--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S C A N S --
+-- --
+-- B o d y --
+-- --
+-- $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. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception 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). --
+-- --
+------------------------------------------------------------------------------
+
+package body Scans is
+
+ ------------------------
+ -- Restore_Scan_State --
+ ------------------------
+
+ procedure Restore_Scan_State (Saved_State : in Saved_Scan_State) is
+ begin
+ Scan_Ptr := Saved_State.Save_Scan_Ptr;
+ Token := Saved_State.Save_Token;
+ Token_Ptr := Saved_State.Save_Token_Ptr;
+ Current_Line_Start := Saved_State.Save_Current_Line_Start;
+ Start_Column := Saved_State.Save_Start_Column;
+ Checksum := Saved_State.Save_Checksum;
+ First_Non_Blank_Location := Saved_State.Save_First_Non_Blank_Location;
+ Token_Node := Saved_State.Save_Token_Node;
+ Token_Name := Saved_State.Save_Token_Name;
+ Prev_Token := Saved_State.Save_Prev_Token;
+ Prev_Token_Ptr := Saved_State.Save_Prev_Token_Ptr;
+ end Restore_Scan_State;
+
+ ---------------------
+ -- Save_Scan_State --
+ ---------------------
+
+ procedure Save_Scan_State (Saved_State : out Saved_Scan_State) is
+ begin
+ Saved_State.Save_Scan_Ptr := Scan_Ptr;
+ Saved_State.Save_Token := Token;
+ Saved_State.Save_Token_Ptr := Token_Ptr;
+ Saved_State.Save_Current_Line_Start := Current_Line_Start;
+ Saved_State.Save_Start_Column := Start_Column;
+ Saved_State.Save_Checksum := Checksum;
+ Saved_State.Save_First_Non_Blank_Location := First_Non_Blank_Location;
+ Saved_State.Save_Token_Node := Token_Node;
+ Saved_State.Save_Token_Name := Token_Name;
+ Saved_State.Save_Prev_Token := Prev_Token;
+ Saved_State.Save_Prev_Token_Ptr := Prev_Token_Ptr;
+ end Save_Scan_State;
+
+end Scans;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S C A N S --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.32 $
+-- --
+-- 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. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception 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). --
+-- --
+------------------------------------------------------------------------------
+
+with Types; use Types;
+package Scans is
+
+-- The scanner maintains a current state in the global variables defined
+-- in this package. The call to the Scan routine advances this state to
+-- the next token. The state is initialized by the call to one of the
+-- initialization routines in Sinput.
+
+ -- The following type is used to identify token types returned by Scan.
+ -- The class column in this table indicates the token classes which
+ -- apply to the token, as defined by subsquent subtype declarations.
+
+ -- Note: the coding in SCN depends on the fact that the first entry in
+ -- this type declaration is *not* for a reserved word. For details on
+ -- why there is this requirement, see Scn.Initialize_Scanner.
+
+ type Token_Type is (
+
+ -- Token name Token type Class(es)
+
+ Tok_Integer_Literal, -- numeric lit Literal, Lit_Or_Name
+
+ Tok_Real_Literal, -- numeric lit Literal, Lit_Or_Name
+
+ Tok_String_Literal, -- string lit Literal. Lit_Or_Name
+
+ Tok_Char_Literal, -- char lit Name, Literal. Lit_Or_Name
+
+ Tok_Operator_Symbol, -- op symbol Name, Literal, Lit_Or_Name, Desig
+
+ Tok_Identifier, -- identifer Name, Lit_Or_Name, Desig
+
+ Tok_Double_Asterisk, -- **
+
+ Tok_Ampersand, -- & Binary_Addop
+ Tok_Minus, -- - Binary_Addop, Unary_Addop
+ Tok_Plus, -- + Binary_Addop, Unary_Addop
+
+ Tok_Asterisk, -- * Mulop
+ Tok_Mod, -- MOD Mulop
+ Tok_Rem, -- REM Mulop
+ Tok_Slash, -- / Mulop
+
+ Tok_New, -- NEW
+
+ Tok_Abs, -- ABS
+ Tok_Others, -- OTHERS
+ Tok_Null, -- NULL
+
+ Tok_Dot, -- . Namext
+ Tok_Apostrophe, -- ' Namext
+
+ Tok_Left_Paren, -- ( Namext, Consk
+
+ Tok_Delta, -- DELTA Atkwd, Sterm, Consk
+ Tok_Digits, -- DIGITS Atkwd, Sterm, Consk
+ Tok_Range, -- RANGE Atkwd, Sterm, Consk
+
+ Tok_Right_Paren, -- ) Sterm
+ Tok_Comma, -- , Sterm
+
+ Tok_And, -- AND Logop, Sterm
+ Tok_Or, -- OR Logop, Sterm
+ Tok_Xor, -- XOR Logop, Sterm
+
+ Tok_Less, -- < Relop, Sterm
+ Tok_Equal, -- = Relop, Sterm
+ Tok_Greater, -- > Relop, Sterm
+ Tok_Not_Equal, -- /= Relop, Sterm
+ Tok_Greater_Equal, -- >= Relop, Sterm
+ Tok_Less_Equal, -- <= Relop, Sterm
+
+ Tok_In, -- IN Relop, Sterm
+ Tok_Not, -- NOT Relop, Sterm
+
+ Tok_Box, -- <> Relop, Eterm, Sterm
+ Tok_Colon_Equal, -- := Eterm, Sterm
+ Tok_Colon, -- : Eterm, Sterm
+ Tok_Greater_Greater, -- >> Eterm, Sterm
+
+ Tok_Abstract, -- ABSTRACT Eterm, Sterm
+ Tok_Access, -- ACCESS Eterm, Sterm
+ Tok_Aliased, -- ALIASED Eterm, Sterm
+ Tok_All, -- ALL Eterm, Sterm
+ Tok_Array, -- ARRAY Eterm, Sterm
+ Tok_At, -- AT Eterm, Sterm
+ Tok_Body, -- BODY Eterm, Sterm
+ Tok_Constant, -- CONSTANT Eterm, Sterm
+ Tok_Do, -- DO Eterm, Sterm
+ Tok_Is, -- IS Eterm, Sterm
+ Tok_Limited, -- LIMITED Eterm, Sterm
+ Tok_Of, -- OF Eterm, Sterm
+ Tok_Out, -- OUT Eterm, Sterm
+ Tok_Record, -- RECORD Eterm, Sterm
+ Tok_Renames, -- RENAMES Eterm, Sterm
+ Tok_Reverse, -- REVERSE Eterm, Sterm
+ Tok_Tagged, -- TAGGED Eterm, Sterm
+ Tok_Then, -- THEN Eterm, Sterm
+
+ Tok_Less_Less, -- << Eterm, Sterm, After_SM
+
+ Tok_Abort, -- ABORT Eterm, Sterm, After_SM
+ Tok_Accept, -- ACCEPT Eterm, Sterm, After_SM
+ Tok_Case, -- CASE Eterm, Sterm, After_SM
+ Tok_Delay, -- DELAY Eterm, Sterm, After_SM
+ Tok_Else, -- ELSE Eterm, Sterm, After_SM
+ Tok_Elsif, -- ELSIF Eterm, Sterm, After_SM
+ Tok_End, -- END Eterm, Sterm, After_SM
+ Tok_Exception, -- EXCEPTION Eterm, Sterm, After_SM
+ Tok_Exit, -- EXIT Eterm, Sterm, After_SM
+ Tok_Goto, -- GOTO Eterm, Sterm, After_SM
+ Tok_If, -- IF Eterm, Sterm, After_SM
+ Tok_Pragma, -- PRAGMA Eterm, Sterm, After_SM
+ Tok_Raise, -- RAISE Eterm, Sterm, After_SM
+ Tok_Requeue, -- REQUEUE Eterm, Sterm, After_SM
+ Tok_Return, -- RETURN Eterm, Sterm, After_SM
+ Tok_Select, -- SELECT Eterm, Sterm, After_SM
+ Tok_Terminate, -- TERMINATE Eterm, Sterm, After_SM
+ Tok_Until, -- UNTIL Eterm, Sterm, After_SM
+ Tok_When, -- WHEN Eterm, Sterm, After_SM
+
+ Tok_Begin, -- BEGIN Eterm, Sterm, After_SM, Labeled_Stmt
+ Tok_Declare, -- DECLARE Eterm, Sterm, After_SM, Labeled_Stmt
+ Tok_For, -- FOR Eterm, Sterm, After_SM, Labeled_Stmt
+ Tok_Loop, -- LOOP Eterm, Sterm, After_SM, Labeled_Stmt
+ Tok_While, -- WHILE Eterm, Sterm, After_SM, Labeled_Stmt
+
+ Tok_Entry, -- ENTRY Eterm, Sterm, Declk, Deckn, After_SM
+ Tok_Protected, -- PROTECTED Eterm, Sterm, Declk, Deckn, After_SM
+ Tok_Task, -- TASK Eterm, Sterm, Declk, Deckn, After_SM
+ Tok_Type, -- TYPE Eterm, Sterm, Declk, Deckn, After_SM
+ Tok_Subtype, -- SUBTYPE Eterm, Sterm, Declk, Deckn, After_SM
+ Tok_Use, -- USE Eterm, Sterm, Declk, Deckn, After_SM
+
+ Tok_Function, -- FUNCTION Eterm, Sterm, Cunit, Declk, After_SM
+ Tok_Generic, -- GENERIC Eterm, Sterm, Cunit, Declk, After_SM
+ Tok_Package, -- PACKAGE Eterm, Sterm, Cunit, Declk, After_SM
+ Tok_Procedure, -- PROCEDURE Eterm, Sterm, Cunit, Declk, After_SM
+
+ Tok_Private, -- PRIVATE Eterm, Sterm, Cunit, After_SM
+ Tok_With, -- WITH Eterm, Sterm, Cunit, After_SM
+ Tok_Separate, -- SEPARATE Eterm, Sterm, Cunit, After_SM
+
+ Tok_EOF, -- End of file Eterm, Sterm, Cterm, After_SM
+
+ Tok_Semicolon, -- ; Eterm, Sterm, Cterm
+
+ Tok_Arrow, -- => Sterm, Cterm, Chtok
+
+ Tok_Vertical_Bar, -- | Cterm, Sterm, Chtok
+
+ Tok_Dot_Dot, -- .. Sterm, Chtok
+
+ -- The following three entries are used only when scanning
+ -- project files.
+
+ Tok_Project,
+ Tok_Modifying,
+ Tok_External,
+
+ No_Token);
+ -- No_Token is used for initializing Token values to indicate that
+ -- no value has been set yet.
+
+ -- Note: in the RM, operator symbol is a special case of string literal.
+ -- We distinguish at the lexical level in this compiler, since there are
+ -- many syntactic situations in which only an operator symbol is allowed.
+
+ -- The following subtype declarations group the token types into classes.
+ -- These are used for class tests in the parser.
+
+ subtype Token_Class_Numeric_Literal is
+ Token_Type range Tok_Integer_Literal .. Tok_Real_Literal;
+ -- Numeric literal
+
+ subtype Token_Class_Literal is
+ Token_Type range Tok_Integer_Literal .. Tok_Operator_Symbol;
+ -- Literal
+
+ subtype Token_Class_Lit_Or_Name is
+ Token_Type range Tok_Integer_Literal .. Tok_Identifier;
+
+ subtype Token_Class_Binary_Addop is
+ Token_Type range Tok_Ampersand .. Tok_Plus;
+ -- Binary adding operator (& + -)
+
+ subtype Token_Class_Unary_Addop is
+ Token_Type range Tok_Minus .. Tok_Plus;
+ -- Unary adding operator (+ -)
+
+ subtype Token_Class_Mulop is
+ Token_Type range Tok_Asterisk .. Tok_Slash;
+ -- Multiplying operator
+
+ subtype Token_Class_Logop is
+ Token_Type range Tok_And .. Tok_Xor;
+ -- Logical operator (and, or, xor)
+
+ subtype Token_Class_Relop is
+ Token_Type range Tok_Less .. Tok_Box;
+ -- Relational operator (= /= < <= > >= not, in plus <> to catch misuse
+ -- of Pascal style not equal operator).
+
+ subtype Token_Class_Name is
+ Token_Type range Tok_Char_Literal .. Tok_Identifier;
+ -- First token of name (4.1),
+ -- (identifier, char literal, operator symbol)
+
+ subtype Token_Class_Desig is
+ Token_Type range Tok_Operator_Symbol .. Tok_Identifier;
+ -- Token which can be a Designator (identifier, operator symbol)
+
+ subtype Token_Class_Namext is
+ Token_Type range Tok_Dot .. Tok_Left_Paren;
+ -- Name extension tokens. These are tokens which can appear immediately
+ -- after a name to extend it recursively (period, quote, left paren)
+
+ subtype Token_Class_Consk is
+ Token_Type range Tok_Left_Paren .. Tok_Range;
+ -- Keywords which can start constraint
+ -- (left paren, delta, digits, range)
+
+ subtype Token_Class_Eterm is
+ Token_Type range Tok_Colon_Equal .. Tok_Semicolon;
+ -- Expression terminators. These tokens can never appear within a simple
+ -- expression. This is used for error recovery purposes (if we encounter
+ -- an error in an expression, we simply scan to the next Eterm token).
+
+ subtype Token_Class_Sterm is
+ Token_Type range Tok_Delta .. Tok_Dot_Dot;
+ -- Simple_Expression terminators. A Simple_Expression must be followed
+ -- by a token in this class, or an error message is issued complaining
+ -- about a missing binary operator.
+
+ subtype Token_Class_Atkwd is
+ Token_Type range Tok_Delta .. Tok_Range;
+ -- Attribute keywords. This class includes keywords which can be used
+ -- as an Attribute_Designator, namely DELTA, DIGITS and RANGE
+
+ subtype Token_Class_Cterm is
+ Token_Type range Tok_EOF .. Tok_Vertical_Bar;
+ -- Choice terminators. These tokens terminate a choice. This is used for
+ -- error recovery purposes (if we encounter an error in a Choice, we
+ -- simply scan to the next Cterm token).
+
+ subtype Token_Class_Chtok is
+ Token_Type range Tok_Arrow .. Tok_Dot_Dot;
+ -- Choice tokens. These tokens signal a choice when used in an Aggregate
+
+ subtype Token_Class_Cunit is
+ Token_Type range Tok_Function .. Tok_Separate;
+ -- Tokens which can begin a compilation unit
+
+ subtype Token_Class_Declk is
+ Token_Type range Tok_Entry .. Tok_Procedure;
+ -- Keywords which start a declaration
+
+ subtype Token_Class_Deckn is
+ Token_Type range Tok_Entry .. Tok_Use;
+ -- Keywords which start a declaration but can't start a compilation unit
+
+ subtype Token_Class_After_SM is
+ Token_Type range Tok_Less_Less .. Tok_EOF;
+ -- Tokens which always, or almost always, appear after a semicolon. Used
+ -- in the Resync_Past_Semicolon routine to avoid gobbling up stuff when
+ -- a semicolon is missing. Of significance only for error recovery.
+
+ subtype Token_Class_Labeled_Stmt is
+ Token_Type range Tok_Begin .. Tok_While;
+ -- Tokens which start labeled statements
+
+ type Token_Flag_Array is array (Token_Type) of Boolean;
+ Is_Reserved_Keyword : constant Token_Flag_Array := Token_Flag_Array'(
+ Tok_Mod .. Tok_Rem => True,
+ Tok_New .. Tok_Null => True,
+ Tok_Delta .. Tok_Range => True,
+ Tok_And .. Tok_Xor => True,
+ Tok_In .. Tok_Not => True,
+ Tok_Abstract .. Tok_Then => True,
+ Tok_Abort .. Tok_Separate => True,
+ others => False);
+ -- Flag array used to test for reserved word
+
+ --------------------------
+ -- Scan State Variables --
+ --------------------------
+
+ -- Note: these variables can only be referenced during the parsing of a
+ -- file. Reference to any of them from Sem or the expander is wrong.
+
+ Scan_Ptr : Source_Ptr;
+ -- Current scan pointer location. After a call to Scan, this points
+ -- just past the end of the token just scanned.
+
+ Token : Token_Type;
+ -- Type of current token
+
+ Token_Ptr : Source_Ptr;
+ -- Pointer to first character of current token
+
+ Current_Line_Start : Source_Ptr;
+ -- Pointer to first character of line containing current token
+
+ Start_Column : Column_Number;
+ -- Starting column number (zero origin) of the first non-blank character
+ -- on the line containing the current token. This is used for error
+ -- recovery circuits which depend on looking at the column line up.
+
+ Checksum : Word;
+ -- Used to accumulate a checksum representing the tokens in the source
+ -- file being compiled. This checksum includes only program tokens, and
+ -- excludes comments.
+
+ First_Non_Blank_Location : Source_Ptr;
+ -- Location of first non-blank character on the line containing the
+ -- current token (i.e. the location of the character whose column number
+ -- is stored in Start_Column).
+
+ Token_Node : Node_Id := Empty;
+ -- Node table Id for the current token. This is set only if the current
+ -- token is one for which the scanner constructs a node (i.e. it is an
+ -- identifier, operator symbol, or literal. For other token types,
+ -- Token_Node is undefined.
+
+ Token_Name : Name_Id := No_Name;
+ -- For identifiers, this is set to the Name_Id of the identifier scanned.
+ -- For all other tokens, Token_Name is set to Error_Name. Note that it
+ -- would be possible for the caller to extract this information from
+ -- Token_Node. We set Token_Name separately for two reasons. First it
+ -- allows a quicker test for a specific identifier. Second, it allows
+ -- a version of the parser to be built that does not build tree nodes,
+ -- usable as a syntax checker.
+
+ Prev_Token : Token_Type := No_Token;
+ -- Type of previous token
+
+ Prev_Token_Ptr : Source_Ptr;
+ -- Pointer to first character of previous token
+
+ Version_To_Be_Found : Boolean;
+ -- This flag is True if the scanner is still looking for an RCS version
+ -- number in a comment. Normally it is initialized to False so that this
+ -- circuit is not activated. If the -dv switch is set, then this flag is
+ -- initialized to True, and then reset when the version number is found.
+ -- We do things this way to minimize the impact on comment scanning.
+
+ --------------------------------------------------------
+ -- Procedures for Saving and Restoring the Scan State --
+ --------------------------------------------------------
+
+ -- The following procedures can be used to save and restore the entire
+ -- scan state. They are used in cases where it is necessary to backup
+ -- the scan during the parse.
+
+ type Saved_Scan_State is private;
+ -- Used for saving and restoring the scan state
+
+ procedure Save_Scan_State (Saved_State : out Saved_Scan_State);
+ pragma Inline (Save_Scan_State);
+ -- Saves the current scan state for possible later restoration. Note that
+ -- there is no harm in saving the state and then never restoring it.
+
+ procedure Restore_Scan_State (Saved_State : in Saved_Scan_State);
+ pragma Inline (Restore_Scan_State);
+ -- Restores a scan state saved by a call to Save_Scan_State.
+ -- The saved scan state must refer to the current source file.
+
+private
+ type Saved_Scan_State is record
+ Save_Scan_Ptr : Source_Ptr;
+ Save_Token : Token_Type;
+ Save_Token_Ptr : Source_Ptr;
+ Save_Current_Line_Start : Source_Ptr;
+ Save_Start_Column : Column_Number;
+ Save_Checksum : Word;
+ Save_First_Non_Blank_Location : Source_Ptr;
+ Save_Token_Node : Node_Id;
+ Save_Token_Name : Name_Id;
+ Save_Prev_Token : Token_Type;
+ Save_Prev_Token_Ptr : Source_Ptr;
+ end record;
+
+end Scans;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S C N . N L I T --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.32 $ --
+-- --
+-- Copyright (C) 1992,1993,1994,1995,1996 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 Uintp; use Uintp;
+with Urealp; use Urealp;
+
+separate (Scn)
+procedure Nlit is
+
+ C : Character;
+ -- Current source program character
+
+ Base_Char : Character;
+ -- Either # or : (character at start of based number)
+
+ Base : Int;
+ -- Value of base
+
+ UI_Base : Uint;
+ -- Value of base in Uint format
+
+ UI_Int_Value : Uint;
+ -- Value of integer scanned by Scan_Integer in Uint format
+
+ UI_Num_Value : Uint;
+ -- Value of integer in numeric value being scanned
+
+ Scale : Int;
+ -- Scale value for real literal
+
+ UI_Scale : Uint;
+ -- Scale in Uint format
+
+ Exponent_Is_Negative : Boolean;
+ -- Set true for negative exponent
+
+ Extended_Digit_Value : Int;
+ -- Extended digit value
+
+ Point_Scanned : Boolean;
+ -- Flag for decimal point scanned in numeric literal
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ procedure Error_Digit_Expected;
+ -- Signal error of bad digit, Scan_Ptr points to the location at which
+ -- the digit was expected on input, and is unchanged on return.
+
+ procedure Scan_Integer;
+ -- Procedure to scan integer literal. On entry, Scan_Ptr points to a
+ -- digit, on exit Scan_Ptr points past the last character of the integer.
+ -- For each digit encountered, UI_Int_Value is multiplied by 10, and the
+ -- value of the digit added to the result. In addition, the value in
+ -- Scale is decremented by one for each actual digit scanned.
+
+ --------------------------
+ -- Error_Digit_Expected --
+ --------------------------
+
+ procedure Error_Digit_Expected is
+ begin
+ Error_Msg_S ("digit expected");
+ end Error_Digit_Expected;
+
+ -------------------
+ -- Scan_Integer --
+ -------------------
+
+ procedure Scan_Integer is
+ C : Character;
+ -- Next character scanned
+
+ begin
+ C := Source (Scan_Ptr);
+
+ -- Loop through digits (allowing underlines)
+
+ loop
+ Accumulate_Checksum (C);
+ UI_Int_Value :=
+ UI_Int_Value * 10 + (Character'Pos (C) - Character'Pos ('0'));
+ Scan_Ptr := Scan_Ptr + 1;
+ Scale := Scale - 1;
+ C := Source (Scan_Ptr);
+
+ if C = '_' then
+ Accumulate_Checksum ('_');
+
+ loop
+ Scan_Ptr := Scan_Ptr + 1;
+ C := Source (Scan_Ptr);
+ exit when C /= '_';
+ Error_No_Double_Underline;
+ end loop;
+
+ if C not in '0' .. '9' then
+ Error_Digit_Expected;
+ exit;
+ end if;
+
+ else
+ exit when C not in '0' .. '9';
+ end if;
+ end loop;
+
+ end Scan_Integer;
+
+----------------------------------
+-- Start of Processing for Nlit --
+----------------------------------
+
+begin
+ Base := 10;
+ UI_Base := Uint_10;
+ UI_Int_Value := Uint_0;
+ Scale := 0;
+ Scan_Integer;
+ Scale := 0;
+ Point_Scanned := False;
+ UI_Num_Value := UI_Int_Value;
+
+ -- Various possibilities now for continuing the literal are
+ -- period, E/e (for exponent), or :/# (for based literal).
+
+ Scale := 0;
+ C := Source (Scan_Ptr);
+
+ if C = '.' then
+
+ -- Scan out point, but do not scan past .. which is a range sequence,
+ -- and must not be eaten up scanning a numeric literal.
+
+ while C = '.' and then Source (Scan_Ptr + 1) /= '.' loop
+ Accumulate_Checksum ('.');
+
+ if Point_Scanned then
+ Error_Msg_S ("duplicate point ignored");
+ end if;
+
+ Point_Scanned := True;
+ Scan_Ptr := Scan_Ptr + 1;
+ C := Source (Scan_Ptr);
+
+ if C not in '0' .. '9' then
+ Error_Msg ("real literal cannot end with point", Scan_Ptr - 1);
+ else
+ Scan_Integer;
+ UI_Num_Value := UI_Int_Value;
+ end if;
+ end loop;
+
+ -- Based literal case. The base is the value we already scanned.
+ -- In the case of colon, we insist that the following character
+ -- is indeed an extended digit or a period. This catches a number
+ -- of common errors, as well as catching the well known tricky
+ -- bug otherwise arising from "x : integer range 1 .. 10:= 6;"
+
+ elsif C = '#'
+ or else (C = ':' and then
+ (Source (Scan_Ptr + 1) = '.'
+ or else
+ Source (Scan_Ptr + 1) in '0' .. '9'
+ or else
+ Source (Scan_Ptr + 1) in 'A' .. 'Z'
+ or else
+ Source (Scan_Ptr + 1) in 'a' .. 'z'))
+ then
+ Accumulate_Checksum (C);
+ Base_Char := C;
+ UI_Base := UI_Int_Value;
+
+ if UI_Base < 2 or else UI_Base > 16 then
+ Error_Msg_SC ("base not 2-16");
+ UI_Base := Uint_16;
+ end if;
+
+ Base := UI_To_Int (UI_Base);
+ Scan_Ptr := Scan_Ptr + 1;
+
+ -- Scan out extended integer [. integer]
+
+ C := Source (Scan_Ptr);
+ UI_Int_Value := Uint_0;
+ Scale := 0;
+
+ loop
+ if C in '0' .. '9' then
+ Accumulate_Checksum (C);
+ Extended_Digit_Value :=
+ Int'(Character'Pos (C)) - Int'(Character'Pos ('0'));
+
+ elsif C in 'A' .. 'F' then
+ Accumulate_Checksum (Character'Val (Character'Pos (C) + 32));
+ Extended_Digit_Value :=
+ Int'(Character'Pos (C)) - Int'(Character'Pos ('A')) + 10;
+
+ elsif C in 'a' .. 'f' then
+ Accumulate_Checksum (C);
+ Extended_Digit_Value :=
+ Int'(Character'Pos (C)) - Int'(Character'Pos ('a')) + 10;
+
+ else
+ Error_Msg_S ("extended digit expected");
+ exit;
+ end if;
+
+ if Extended_Digit_Value >= Base then
+ Error_Msg_S ("digit >= base");
+ end if;
+
+ UI_Int_Value := UI_Int_Value * UI_Base + Extended_Digit_Value;
+ Scale := Scale - 1;
+ Scan_Ptr := Scan_Ptr + 1;
+ C := Source (Scan_Ptr);
+
+ if C = '_' then
+ loop
+ Accumulate_Checksum ('_');
+ Scan_Ptr := Scan_Ptr + 1;
+ C := Source (Scan_Ptr);
+ exit when C /= '_';
+ Error_No_Double_Underline;
+ end loop;
+
+ elsif C = '.' then
+ Accumulate_Checksum ('.');
+
+ if Point_Scanned then
+ Error_Msg_S ("duplicate point ignored");
+ end if;
+
+ Scan_Ptr := Scan_Ptr + 1;
+ C := Source (Scan_Ptr);
+ Point_Scanned := True;
+ Scale := 0;
+
+ elsif C = Base_Char then
+ Accumulate_Checksum (C);
+ Scan_Ptr := Scan_Ptr + 1;
+ exit;
+
+ elsif C = '#' or else C = ':' then
+ Error_Msg_S ("based number delimiters must match");
+ Scan_Ptr := Scan_Ptr + 1;
+ exit;
+
+ elsif not Identifier_Char (C) then
+ if Base_Char = '#' then
+ Error_Msg_S ("missing '#");
+ else
+ Error_Msg_S ("missing ':");
+ end if;
+
+ exit;
+ end if;
+
+ end loop;
+
+ UI_Num_Value := UI_Int_Value;
+ end if;
+
+ -- Scan out exponent
+
+ if not Point_Scanned then
+ Scale := 0;
+ UI_Scale := Uint_0;
+ else
+ UI_Scale := UI_From_Int (Scale);
+ end if;
+
+ if Source (Scan_Ptr) = 'e' or else Source (Scan_Ptr) = 'E' then
+ Accumulate_Checksum ('e');
+ Scan_Ptr := Scan_Ptr + 1;
+ Exponent_Is_Negative := False;
+
+ if Source (Scan_Ptr) = '+' then
+ Accumulate_Checksum ('+');
+ Scan_Ptr := Scan_Ptr + 1;
+
+ elsif Source (Scan_Ptr) = '-' then
+ Accumulate_Checksum ('-');
+
+ if not Point_Scanned then
+ Error_Msg_S ("negative exponent not allowed for integer literal");
+ else
+ Exponent_Is_Negative := True;
+ end if;
+
+ Scan_Ptr := Scan_Ptr + 1;
+ end if;
+
+ UI_Int_Value := Uint_0;
+
+ if Source (Scan_Ptr) in '0' .. '9' then
+ Scan_Integer;
+ else
+ Error_Digit_Expected;
+ end if;
+
+ if Exponent_Is_Negative then
+ UI_Scale := UI_Scale - UI_Int_Value;
+ else
+ UI_Scale := UI_Scale + UI_Int_Value;
+ end if;
+ end if;
+
+ -- Case of real literal to be returned
+
+ if Point_Scanned then
+ Token := Tok_Real_Literal;
+ Token_Node := New_Node (N_Real_Literal, Token_Ptr);
+ Set_Realval (Token_Node,
+ UR_From_Components (
+ Num => UI_Num_Value,
+ Den => -UI_Scale,
+ Rbase => Base));
+
+ -- Case of integer literal to be returned
+
+ else
+ Token := Tok_Integer_Literal;
+ Token_Node := New_Node (N_Integer_Literal, Token_Ptr);
+
+ if UI_Scale = 0 then
+ Set_Intval (Token_Node, UI_Num_Value);
+
+ -- Avoid doing possibly expensive calculations in cases like
+ -- parsing 163E800_000# when semantics will not be done anyway.
+ -- This is especially useful when parsing garbled input.
+
+ elsif Operating_Mode /= Check_Syntax
+ and then (Errors_Detected = 0 or else Try_Semantics)
+ then
+ Set_Intval (Token_Node, UI_Num_Value * UI_Base ** UI_Scale);
+
+ else
+ Set_Intval (Token_Node, No_Uint);
+ end if;
+
+ end if;
+
+ return;
+
+end Nlit;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S C N . S L I T --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.29 $ --
+-- --
+-- Copyright (C) 1992-1999 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 Stringt; use Stringt;
+
+separate (Scn)
+procedure Slit is
+
+ Delimiter : Character;
+ -- Delimiter (first character of string)
+
+ C : Character;
+ -- Current source program character
+
+ Code : Char_Code;
+ -- Current character code value
+
+ Err : Boolean;
+ -- Error flag for Scan_Wide call
+
+ String_Literal_Id : String_Id;
+ -- Id for currently scanned string value
+
+ Wide_Character_Found : Boolean := False;
+ -- Set True if wide character found
+
+ procedure Error_Bad_String_Char;
+ -- Signal bad character in string/character literal. On entry Scan_Ptr
+ -- points to the improper character encountered during the scan. Scan_Ptr
+ -- is not modified, so it still points to the bad character on return.
+
+ procedure Error_Unterminated_String;
+ -- Procedure called if a line terminator character is encountered during
+ -- scanning a string, meaning that the string is not properly terminated.
+
+ procedure Set_String;
+ -- Procedure used to distinguish between string and operator symbol.
+ -- On entry the string has been scanned out, and its characters start
+ -- at Token_Ptr and end one character before Scan_Ptr. On exit Token
+ -- is set to Tok_String_Literal or Tok_Operator_Symbol as appropriate,
+ -- and Token_Node is appropriately initialized. In addition, in the
+ -- operator symbol case, Token_Name is appropriately set.
+
+ ---------------------------
+ -- Error_Bad_String_Char --
+ ---------------------------
+
+ procedure Error_Bad_String_Char is
+ C : constant Character := Source (Scan_Ptr);
+
+ begin
+ if C = HT then
+ Error_Msg_S ("horizontal tab not allowed in string");
+
+ elsif C = VT or else C = FF then
+ Error_Msg_S ("format effector not allowed in string");
+
+ elsif C in Upper_Half_Character then
+ Error_Msg_S ("(Ada 83) upper half character not allowed");
+
+ else
+ Error_Msg_S ("control character not allowed in string");
+ end if;
+ end Error_Bad_String_Char;
+
+ -------------------------------
+ -- Error_Unterminated_String --
+ -------------------------------
+
+ procedure Error_Unterminated_String is
+ begin
+ -- An interesting little refinement. Consider the following examples:
+
+ -- A := "this is an unterminated string;
+ -- A := "this is an unterminated string &
+ -- P(A, "this is a parameter that didn't get terminated);
+
+ -- We fiddle a little to do slightly better placement in these cases
+ -- also if there is white space at the end of the line we place the
+ -- flag at the start of this white space, not at the end. Note that
+ -- we only have to test for blanks, since tabs aren't allowed in
+ -- strings in the first place and would have caused an error message.
+
+ -- Two more cases that we treat specially are:
+
+ -- A := "this string uses the wrong terminator'
+ -- A := "this string uses the wrong terminator' &
+
+ -- In these cases we give a different error message as well
+
+ -- We actually reposition the scan pointer to the point where we
+ -- place the flag in these cases, since it seems a better bet on
+ -- the original intention.
+
+ while Source (Scan_Ptr - 1) = ' '
+ or else Source (Scan_Ptr - 1) = '&'
+ loop
+ Scan_Ptr := Scan_Ptr - 1;
+ Unstore_String_Char;
+ end loop;
+
+ -- Check for case of incorrect string terminator, but single quote is
+ -- not considered incorrect if the opening terminator misused a single
+ -- quote (error message already given).
+
+ if Delimiter /= '''
+ and then Source (Scan_Ptr - 1) = '''
+ then
+ Unstore_String_Char;
+ Error_Msg ("incorrect string terminator character", Scan_Ptr - 1);
+ return;
+ end if;
+
+ if Source (Scan_Ptr - 1) = ';' then
+ Scan_Ptr := Scan_Ptr - 1;
+ Unstore_String_Char;
+
+ if Source (Scan_Ptr - 1) = ')' then
+ Scan_Ptr := Scan_Ptr - 1;
+ Unstore_String_Char;
+ end if;
+ end if;
+
+ Error_Msg_S ("missing string quote");
+ end Error_Unterminated_String;
+
+ ----------------
+ -- Set_String --
+ ----------------
+
+ procedure Set_String is
+ Slen : Int := Int (Scan_Ptr - Token_Ptr - 2);
+ C1 : Character;
+ C2 : Character;
+ C3 : Character;
+
+ begin
+ -- Token_Name is currently set to Error_Name. The following section of
+ -- code resets Token_Name to the proper Name_Op_xx value if the string
+ -- is a valid operator symbol, otherwise it is left set to Error_Name.
+
+ if Slen = 1 then
+ C1 := Source (Token_Ptr + 1);
+
+ case C1 is
+ when '=' =>
+ Token_Name := Name_Op_Eq;
+
+ when '>' =>
+ Token_Name := Name_Op_Gt;
+
+ when '<' =>
+ Token_Name := Name_Op_Lt;
+
+ when '+' =>
+ Token_Name := Name_Op_Add;
+
+ when '-' =>
+ Token_Name := Name_Op_Subtract;
+
+ when '&' =>
+ Token_Name := Name_Op_Concat;
+
+ when '*' =>
+ Token_Name := Name_Op_Multiply;
+
+ when '/' =>
+ Token_Name := Name_Op_Divide;
+
+ when others =>
+ null;
+ end case;
+
+ elsif Slen = 2 then
+ C1 := Source (Token_Ptr + 1);
+ C2 := Source (Token_Ptr + 2);
+
+ if C1 = '*' and then C2 = '*' then
+ Token_Name := Name_Op_Expon;
+
+ elsif C2 = '=' then
+
+ if C1 = '/' then
+ Token_Name := Name_Op_Ne;
+ elsif C1 = '<' then
+ Token_Name := Name_Op_Le;
+ elsif C1 = '>' then
+ Token_Name := Name_Op_Ge;
+ end if;
+
+ elsif (C1 = 'O' or else C1 = 'o') and then -- OR
+ (C2 = 'R' or else C2 = 'r')
+ then
+ Token_Name := Name_Op_Or;
+ end if;
+
+ elsif Slen = 3 then
+ C1 := Source (Token_Ptr + 1);
+ C2 := Source (Token_Ptr + 2);
+ C3 := Source (Token_Ptr + 3);
+
+ if (C1 = 'A' or else C1 = 'a') and then -- AND
+ (C2 = 'N' or else C2 = 'n') and then
+ (C3 = 'D' or else C3 = 'd')
+ then
+ Token_Name := Name_Op_And;
+
+ elsif (C1 = 'A' or else C1 = 'a') and then -- ABS
+ (C2 = 'B' or else C2 = 'b') and then
+ (C3 = 'S' or else C3 = 's')
+ then
+ Token_Name := Name_Op_Abs;
+
+ elsif (C1 = 'M' or else C1 = 'm') and then -- MOD
+ (C2 = 'O' or else C2 = 'o') and then
+ (C3 = 'D' or else C3 = 'd')
+ then
+ Token_Name := Name_Op_Mod;
+
+ elsif (C1 = 'N' or else C1 = 'n') and then -- NOT
+ (C2 = 'O' or else C2 = 'o') and then
+ (C3 = 'T' or else C3 = 't')
+ then
+ Token_Name := Name_Op_Not;
+
+ elsif (C1 = 'R' or else C1 = 'r') and then -- REM
+ (C2 = 'E' or else C2 = 'e') and then
+ (C3 = 'M' or else C3 = 'm')
+ then
+ Token_Name := Name_Op_Rem;
+
+ elsif (C1 = 'X' or else C1 = 'x') and then -- XOR
+ (C2 = 'O' or else C2 = 'o') and then
+ (C3 = 'R' or else C3 = 'r')
+ then
+ Token_Name := Name_Op_Xor;
+ end if;
+
+ end if;
+
+ -- If it is an operator symbol, then Token_Name is set. If it is some
+ -- other string value, then Token_Name still contains Error_Name.
+
+ if Token_Name = Error_Name then
+ Token := Tok_String_Literal;
+ Token_Node := New_Node (N_String_Literal, Token_Ptr);
+ Set_Has_Wide_Character (Token_Node, Wide_Character_Found);
+
+ else
+ Token := Tok_Operator_Symbol;
+ Token_Node := New_Node (N_Operator_Symbol, Token_Ptr);
+ Set_Chars (Token_Node, Token_Name);
+ end if;
+
+ Set_Strval (Token_Node, String_Literal_Id);
+
+ end Set_String;
+
+----------
+-- Slit --
+----------
+
+begin
+ -- On entry, Scan_Ptr points to the opening character of the string which
+ -- is either a percent, double quote, or apostrophe (single quote). The
+ -- latter case is an error detected by the character literal circuit.
+
+ Delimiter := Source (Scan_Ptr);
+ Accumulate_Checksum (Delimiter);
+ Start_String;
+ Scan_Ptr := Scan_Ptr + 1;
+
+ -- Loop to scan out characters of string literal
+
+ loop
+ C := Source (Scan_Ptr);
+
+ if C = Delimiter then
+ Accumulate_Checksum (C);
+ Scan_Ptr := Scan_Ptr + 1;
+ exit when Source (Scan_Ptr) /= Delimiter;
+ Code := Get_Char_Code (C);
+ Accumulate_Checksum (C);
+ Scan_Ptr := Scan_Ptr + 1;
+
+ else
+ if C = '"' and then Delimiter = '%' then
+ Error_Msg_S ("quote not allowed in percent delimited string");
+ Code := Get_Char_Code (C);
+ Scan_Ptr := Scan_Ptr + 1;
+
+ elsif (C = ESC
+ and then
+ Wide_Character_Encoding_Method in WC_ESC_Encoding_Method)
+ or else
+ (C in Upper_Half_Character
+ and then
+ Upper_Half_Encoding)
+ or else
+ (C = '['
+ and then
+ Source (Scan_Ptr + 1) = '"'
+ and then
+ Identifier_Char (Source (Scan_Ptr + 2)))
+ then
+ Scan_Wide (Source, Scan_Ptr, Code, Err);
+ Accumulate_Checksum (Code);
+
+ if Err then
+ Error_Illegal_Wide_Character;
+ Code := Get_Char_Code (' ');
+ end if;
+
+ else
+ Accumulate_Checksum (C);
+
+ if C not in Graphic_Character then
+ if C in Line_Terminator then
+ Error_Unterminated_String;
+ exit;
+
+ elsif C in Upper_Half_Character then
+ if Ada_83 then
+ Error_Bad_String_Char;
+ end if;
+
+ else
+ Error_Bad_String_Char;
+ end if;
+ end if;
+
+ Code := Get_Char_Code (C);
+ Scan_Ptr := Scan_Ptr + 1;
+ end if;
+ end if;
+
+ Store_String_Char (Code);
+
+ if not In_Character_Range (Code) then
+ Wide_Character_Found := True;
+ end if;
+ end loop;
+
+ String_Literal_Id := End_String;
+ Set_String;
+ return;
+
+end Slit;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S C N --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.111 $
+-- --
+-- 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). --
+-- --
+------------------------------------------------------------------------------
+
+with Atree; use Atree;
+with Csets; use Csets;
+with Errout; use Errout;
+with Hostparm; use Hostparm;
+with Namet; use Namet;
+with Opt; use Opt;
+with Scans; use Scans;
+with Sinput; use Sinput;
+with Sinfo; use Sinfo;
+with Snames; use Snames;
+with Style;
+with Widechar; use Widechar;
+
+with System.WCh_Con; use System.WCh_Con;
+
+package body Scn is
+
+ use ASCII;
+ -- Make control characters visible
+
+ Used_As_Identifier : array (Token_Type) of Boolean;
+ -- Flags set True if a given keyword is used as an identifier (used to
+ -- make sure that we only post an error message for incorrect use of a
+ -- keyword as an identifier once for a given keyword).
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ procedure Accumulate_Checksum (C : Character);
+ pragma Inline (Accumulate_Checksum);
+ -- This routine accumulates the checksum given character C. During the
+ -- scanning of a source file, this routine is called with every character
+ -- in the source, excluding blanks, and all control characters (except
+ -- that ESC is included in the checksum). Upper case letters not in string
+ -- literals are folded by the caller. See Sinput spec for the documentation
+ -- of the checksum algorithm. Note: checksum values are only used if we
+ -- generate code, so it is not necessary to worry about making the right
+ -- sequence of calls in any error situation.
+
+ procedure Accumulate_Checksum (C : Char_Code);
+ pragma Inline (Accumulate_Checksum);
+ -- This version is identical, except that the argument, C, is a character
+ -- code value instead of a character. This is used when wide characters
+ -- are scanned. We use the character code rather than the ASCII characters
+ -- so that the checksum is independent of wide character encoding method.
+
+ procedure Check_End_Of_Line;
+ -- Called when end of line encountered. Checks that line is not
+ -- too long, and that other style checks for the end of line are met.
+
+ function Determine_License return License_Type;
+ -- Scan header of file and check that it has an appropriate GNAT-style
+ -- header with a proper license statement. Returns GPL, Unrestricted,
+ -- or Modified_GPL depending on header. If none of these, returns Unknown.
+
+ function Double_Char_Token (C : Character) return Boolean;
+ -- This function is used for double character tokens like := or <>. It
+ -- checks if the character following Source (Scan_Ptr) is C, and if so
+ -- bumps Scan_Ptr past the pair of characters and returns True. A space
+ -- between the two characters is also recognized with an appropriate
+ -- error message being issued. If C is not present, False is returned.
+ -- Note that Double_Char_Token can only be used for tokens defined in
+ -- the Ada syntax (it's use for error cases like && is not appropriate
+ -- since we do not want a junk message for a case like &-space-&).
+
+ procedure Error_Illegal_Character;
+ -- Give illegal character error, Scan_Ptr points to character. On return,
+ -- Scan_Ptr is bumped past the illegal character.
+
+ procedure Error_Illegal_Wide_Character;
+ -- Give illegal wide character message. On return, Scan_Ptr is bumped
+ -- past the illegal character, which may still leave us pointing to
+ -- junk, not much we can do if the escape sequence is messed up!
+
+ procedure Error_Long_Line;
+ -- Signal error of excessively long line
+
+ procedure Error_No_Double_Underline;
+ -- Signal error of double underline character
+
+ procedure Nlit;
+ -- This is the procedure for scanning out numeric literals. On entry,
+ -- Scan_Ptr points to the digit that starts the numeric literal (the
+ -- checksum for this character has not been accumulated yet). On return
+ -- Scan_Ptr points past the last character of the numeric literal, Token
+ -- and Token_Node are set appropriately, and the checksum is updated.
+
+ function Set_Start_Column return Column_Number;
+ -- This routine is called with Scan_Ptr pointing to the first character
+ -- of a line. On exit, Scan_Ptr is advanced to the first non-blank
+ -- character of this line (or to the terminating format effector if the
+ -- line contains no non-blank characters), and the returned result is the
+ -- column number of this non-blank character (zero origin), which is the
+ -- value to be stored in the Start_Column scan variable.
+
+ procedure Slit;
+ -- This is the procedure for scanning out string literals. On entry,
+ -- Scan_Ptr points to the opening string quote (the checksum for this
+ -- character has not been accumulated yet). On return Scan_Ptr points
+ -- past the closing quote of the string literal, Token and Token_Node
+ -- are set appropriately, and the checksum is upated.
+
+ -------------------------
+ -- Accumulate_Checksum --
+ -------------------------
+
+ procedure Accumulate_Checksum (C : Character) is
+ begin
+ Checksum := Checksum + Checksum + Character'Pos (C);
+
+ if Checksum > 16#8000_0000# then
+ Checksum := (Checksum + 1) and 16#7FFF_FFFF#;
+ end if;
+ end Accumulate_Checksum;
+
+ procedure Accumulate_Checksum (C : Char_Code) is
+ begin
+ Checksum := Checksum + Checksum + Char_Code'Pos (C);
+
+ if Checksum > 16#8000_0000# then
+ Checksum := (Checksum + 1) and 16#7FFF_FFFF#;
+ end if;
+ end Accumulate_Checksum;
+
+ -----------------------
+ -- Check_End_Of_Line --
+ -----------------------
+
+ procedure Check_End_Of_Line is
+ Len : constant Int := Int (Scan_Ptr) - Int (Current_Line_Start);
+
+ begin
+ if Len > Hostparm.Max_Line_Length then
+ Error_Long_Line;
+
+ elsif Style_Check then
+ Style.Check_Line_Terminator (Len);
+ end if;
+ end Check_End_Of_Line;
+
+ -----------------------
+ -- Determine_License --
+ -----------------------
+
+ function Determine_License return License_Type is
+ GPL_Found : Boolean := False;
+
+ function Contains (S : String) return Boolean;
+ -- See if current comment contains successive non-blank characters
+ -- matching the contents of S. If so leave Scan_Ptr unchanged and
+ -- return True, otherwise leave Scan_Ptr unchanged and return False.
+
+ procedure Skip_EOL;
+ -- Skip to line terminator character
+
+ --------------
+ -- Contains --
+ --------------
+
+ function Contains (S : String) return Boolean is
+ CP : Natural;
+ SP : Source_Ptr;
+ SS : Source_Ptr;
+
+ begin
+ SP := Scan_Ptr;
+ while Source (SP) /= CR and then Source (SP) /= LF loop
+ if Source (SP) = S (S'First) then
+ SS := SP;
+ CP := S'First;
+
+ loop
+ SS := SS + 1;
+ CP := CP + 1;
+
+ if CP > S'Last then
+ return True;
+ end if;
+
+ while Source (SS) = ' ' loop
+ SS := SS + 1;
+ end loop;
+
+ exit when Source (SS) /= S (CP);
+ end loop;
+ end if;
+
+ SP := SP + 1;
+ end loop;
+
+ return False;
+ end Contains;
+
+ --------------
+ -- Skip_EOL --
+ --------------
+
+ procedure Skip_EOL is
+ begin
+ while Source (Scan_Ptr) /= CR
+ and then Source (Scan_Ptr) /= LF
+ loop
+ Scan_Ptr := Scan_Ptr + 1;
+ end loop;
+ end Skip_EOL;
+
+ -- Start of processing for Determine_License
+
+ begin
+ loop
+ if Source (Scan_Ptr) /= '-'
+ or else Source (Scan_Ptr + 1) /= '-'
+ then
+ if GPL_Found then
+ return GPL;
+ else
+ return Unknown;
+ end if;
+
+ elsif Contains ("Asaspecialexception") then
+ if GPL_Found then
+ return Modified_GPL;
+ end if;
+
+ elsif Contains ("GNUGeneralPublicLicense") then
+ GPL_Found := True;
+
+ elsif
+ Contains
+ ("ThisspecificationisadaptedfromtheAdaSemanticInterface")
+ or else
+ Contains
+ ("ThisspecificationisderivedfromtheAdaReferenceManual")
+ then
+ return Unrestricted;
+ end if;
+
+ Skip_EOL;
+
+ Check_End_Of_Line;
+
+ declare
+ Physical : Boolean;
+
+ begin
+ Skip_Line_Terminators (Scan_Ptr, Physical);
+
+ -- If we are at start of physical line, update scan pointers
+ -- to reflect the start of the new line.
+
+ if Physical then
+ Current_Line_Start := Scan_Ptr;
+ Start_Column := Set_Start_Column;
+ First_Non_Blank_Location := Scan_Ptr;
+ end if;
+ end;
+ end loop;
+ end Determine_License;
+
+ ----------------------------
+ -- Determine_Token_Casing --
+ ----------------------------
+
+ function Determine_Token_Casing return Casing_Type is
+ begin
+ return Determine_Casing (Source (Token_Ptr .. Scan_Ptr - 1));
+ end Determine_Token_Casing;
+
+ -----------------------
+ -- Double_Char_Token --
+ -----------------------
+
+ function Double_Char_Token (C : Character) return Boolean is
+ begin
+ if Source (Scan_Ptr + 1) = C then
+ Accumulate_Checksum (C);
+ Scan_Ptr := Scan_Ptr + 2;
+ return True;
+
+ elsif Source (Scan_Ptr + 1) = ' '
+ and then Source (Scan_Ptr + 2) = C
+ then
+ Scan_Ptr := Scan_Ptr + 1;
+ Error_Msg_S ("no space allowed here");
+ Scan_Ptr := Scan_Ptr + 2;
+ return True;
+
+ else
+ return False;
+ end if;
+ end Double_Char_Token;
+
+ -----------------------------
+ -- Error_Illegal_Character --
+ -----------------------------
+
+ procedure Error_Illegal_Character is
+ begin
+ Error_Msg_S ("illegal character");
+ Scan_Ptr := Scan_Ptr + 1;
+ end Error_Illegal_Character;
+
+ ----------------------------------
+ -- Error_Illegal_Wide_Character --
+ ----------------------------------
+
+ procedure Error_Illegal_Wide_Character is
+ begin
+ if OpenVMS then
+ Error_Msg_S
+ ("illegal wide character, check " &
+ "'/'W'I'D'E'_'C'H'A'R'A'C'T'E'R'_'E'N'C'O'D'I'N'G qualifer");
+ else
+ Error_Msg_S
+ ("illegal wide character, check -gnatW switch");
+ end if;
+
+ Scan_Ptr := Scan_Ptr + 1;
+ end Error_Illegal_Wide_Character;
+
+ ---------------------
+ -- Error_Long_Line --
+ ---------------------
+
+ procedure Error_Long_Line is
+ begin
+ Error_Msg
+ ("this line is too long",
+ Current_Line_Start + Hostparm.Max_Line_Length);
+ end Error_Long_Line;
+
+ -------------------------------
+ -- Error_No_Double_Underline --
+ -------------------------------
+
+ procedure Error_No_Double_Underline is
+ begin
+ Error_Msg_S ("two consecutive underlines not permitted");
+ end Error_No_Double_Underline;
+
+ ------------------------
+ -- Initialize_Scanner --
+ ------------------------
+
+ procedure Initialize_Scanner
+ (Unit : Unit_Number_Type;
+ Index : Source_File_Index)
+ is
+ GNAT_Hedr : constant Text_Buffer (1 .. 78) := (others => '-');
+
+ begin
+ -- Set up Token_Type values in Names Table entries for reserved keywords
+ -- We use the Pos value of the Token_Type value. Note we are relying on
+ -- the fact that Token_Type'Val (0) is not a reserved word!
+
+ Set_Name_Table_Byte (Name_Abort, Token_Type'Pos (Tok_Abort));
+ Set_Name_Table_Byte (Name_Abs, Token_Type'Pos (Tok_Abs));
+ Set_Name_Table_Byte (Name_Abstract, Token_Type'Pos (Tok_Abstract));
+ Set_Name_Table_Byte (Name_Accept, Token_Type'Pos (Tok_Accept));
+ Set_Name_Table_Byte (Name_Access, Token_Type'Pos (Tok_Access));
+ Set_Name_Table_Byte (Name_And, Token_Type'Pos (Tok_And));
+ Set_Name_Table_Byte (Name_Aliased, Token_Type'Pos (Tok_Aliased));
+ Set_Name_Table_Byte (Name_All, Token_Type'Pos (Tok_All));
+ Set_Name_Table_Byte (Name_Array, Token_Type'Pos (Tok_Array));
+ Set_Name_Table_Byte (Name_At, Token_Type'Pos (Tok_At));
+ Set_Name_Table_Byte (Name_Begin, Token_Type'Pos (Tok_Begin));
+ Set_Name_Table_Byte (Name_Body, Token_Type'Pos (Tok_Body));
+ Set_Name_Table_Byte (Name_Case, Token_Type'Pos (Tok_Case));
+ Set_Name_Table_Byte (Name_Constant, Token_Type'Pos (Tok_Constant));
+ Set_Name_Table_Byte (Name_Declare, Token_Type'Pos (Tok_Declare));
+ Set_Name_Table_Byte (Name_Delay, Token_Type'Pos (Tok_Delay));
+ Set_Name_Table_Byte (Name_Delta, Token_Type'Pos (Tok_Delta));
+ Set_Name_Table_Byte (Name_Digits, Token_Type'Pos (Tok_Digits));
+ Set_Name_Table_Byte (Name_Do, Token_Type'Pos (Tok_Do));
+ Set_Name_Table_Byte (Name_Else, Token_Type'Pos (Tok_Else));
+ Set_Name_Table_Byte (Name_Elsif, Token_Type'Pos (Tok_Elsif));
+ Set_Name_Table_Byte (Name_End, Token_Type'Pos (Tok_End));
+ Set_Name_Table_Byte (Name_Entry, Token_Type'Pos (Tok_Entry));
+ Set_Name_Table_Byte (Name_Exception, Token_Type'Pos (Tok_Exception));
+ Set_Name_Table_Byte (Name_Exit, Token_Type'Pos (Tok_Exit));
+ Set_Name_Table_Byte (Name_For, Token_Type'Pos (Tok_For));
+ Set_Name_Table_Byte (Name_Function, Token_Type'Pos (Tok_Function));
+ Set_Name_Table_Byte (Name_Generic, Token_Type'Pos (Tok_Generic));
+ Set_Name_Table_Byte (Name_Goto, Token_Type'Pos (Tok_Goto));
+ Set_Name_Table_Byte (Name_If, Token_Type'Pos (Tok_If));
+ Set_Name_Table_Byte (Name_In, Token_Type'Pos (Tok_In));
+ Set_Name_Table_Byte (Name_Is, Token_Type'Pos (Tok_Is));
+ Set_Name_Table_Byte (Name_Limited, Token_Type'Pos (Tok_Limited));
+ Set_Name_Table_Byte (Name_Loop, Token_Type'Pos (Tok_Loop));
+ Set_Name_Table_Byte (Name_Mod, Token_Type'Pos (Tok_Mod));
+ Set_Name_Table_Byte (Name_New, Token_Type'Pos (Tok_New));
+ Set_Name_Table_Byte (Name_Not, Token_Type'Pos (Tok_Not));
+ Set_Name_Table_Byte (Name_Null, Token_Type'Pos (Tok_Null));
+ Set_Name_Table_Byte (Name_Of, Token_Type'Pos (Tok_Of));
+ Set_Name_Table_Byte (Name_Or, Token_Type'Pos (Tok_Or));
+ Set_Name_Table_Byte (Name_Others, Token_Type'Pos (Tok_Others));
+ Set_Name_Table_Byte (Name_Out, Token_Type'Pos (Tok_Out));
+ Set_Name_Table_Byte (Name_Package, Token_Type'Pos (Tok_Package));
+ Set_Name_Table_Byte (Name_Pragma, Token_Type'Pos (Tok_Pragma));
+ Set_Name_Table_Byte (Name_Private, Token_Type'Pos (Tok_Private));
+ Set_Name_Table_Byte (Name_Procedure, Token_Type'Pos (Tok_Procedure));
+ Set_Name_Table_Byte (Name_Protected, Token_Type'Pos (Tok_Protected));
+ Set_Name_Table_Byte (Name_Raise, Token_Type'Pos (Tok_Raise));
+ Set_Name_Table_Byte (Name_Range, Token_Type'Pos (Tok_Range));
+ Set_Name_Table_Byte (Name_Record, Token_Type'Pos (Tok_Record));
+ Set_Name_Table_Byte (Name_Rem, Token_Type'Pos (Tok_Rem));
+ Set_Name_Table_Byte (Name_Renames, Token_Type'Pos (Tok_Renames));
+ Set_Name_Table_Byte (Name_Requeue, Token_Type'Pos (Tok_Requeue));
+ Set_Name_Table_Byte (Name_Return, Token_Type'Pos (Tok_Return));
+ Set_Name_Table_Byte (Name_Reverse, Token_Type'Pos (Tok_Reverse));
+ Set_Name_Table_Byte (Name_Select, Token_Type'Pos (Tok_Select));
+ Set_Name_Table_Byte (Name_Separate, Token_Type'Pos (Tok_Separate));
+ Set_Name_Table_Byte (Name_Subtype, Token_Type'Pos (Tok_Subtype));
+ Set_Name_Table_Byte (Name_Tagged, Token_Type'Pos (Tok_Tagged));
+ Set_Name_Table_Byte (Name_Task, Token_Type'Pos (Tok_Task));
+ Set_Name_Table_Byte (Name_Terminate, Token_Type'Pos (Tok_Terminate));
+ Set_Name_Table_Byte (Name_Then, Token_Type'Pos (Tok_Then));
+ Set_Name_Table_Byte (Name_Type, Token_Type'Pos (Tok_Type));
+ Set_Name_Table_Byte (Name_Until, Token_Type'Pos (Tok_Until));
+ Set_Name_Table_Byte (Name_Use, Token_Type'Pos (Tok_Use));
+ Set_Name_Table_Byte (Name_When, Token_Type'Pos (Tok_When));
+ Set_Name_Table_Byte (Name_While, Token_Type'Pos (Tok_While));
+ Set_Name_Table_Byte (Name_With, Token_Type'Pos (Tok_With));
+ Set_Name_Table_Byte (Name_Xor, Token_Type'Pos (Tok_Xor));
+
+ -- Initialize scan control variables
+
+ Current_Source_File := Index;
+ Source := Source_Text (Current_Source_File);
+ Current_Source_Unit := Unit;
+ Scan_Ptr := Source_First (Current_Source_File);
+ Token := No_Token;
+ Token_Ptr := Scan_Ptr;
+ Current_Line_Start := Scan_Ptr;
+ Token_Node := Empty;
+ Token_Name := No_Name;
+ Start_Column := Set_Start_Column;
+ First_Non_Blank_Location := Scan_Ptr;
+ Checksum := 0;
+
+ -- Set default for Comes_From_Source. All nodes built now until we
+ -- reenter the analyzer will have Comes_From_Source set to True
+
+ Set_Comes_From_Source_Default (True);
+
+ -- Check license if GNAT type header possibly present
+
+ if Source_Last (Index) - Scan_Ptr > 80
+ and then Source (Scan_Ptr .. Scan_Ptr + 77) = GNAT_Hedr
+ then
+ Set_License (Current_Source_File, Determine_License);
+ end if;
+
+ -- Scan initial token (note this initializes Prev_Token, Prev_Token_Ptr)
+
+ Scan;
+
+ -- Clear flags for reserved words used as indentifiers
+
+ for J in Token_Type loop
+ Used_As_Identifier (J) := False;
+ end loop;
+
+ end Initialize_Scanner;
+
+ ----------
+ -- Nlit --
+ ----------
+
+ procedure Nlit is separate;
+
+ ----------
+ -- Scan --
+ ----------
+
+ procedure Scan is
+ begin
+ Prev_Token := Token;
+ Prev_Token_Ptr := Token_Ptr;
+ Token_Name := Error_Name;
+
+ -- The following loop runs more than once only if a format effector
+ -- (tab, vertical tab, form feed, line feed, carriage return) is
+ -- encountered and skipped, or some error situation, such as an
+ -- illegal character, is encountered.
+
+ loop
+ -- Skip past blanks, loop is opened up for speed
+
+ while Source (Scan_Ptr) = ' ' loop
+
+ if Source (Scan_Ptr + 1) /= ' ' then
+ Scan_Ptr := Scan_Ptr + 1;
+ exit;
+ end if;
+
+ if Source (Scan_Ptr + 2) /= ' ' then
+ Scan_Ptr := Scan_Ptr + 2;
+ exit;
+ end if;
+
+ if Source (Scan_Ptr + 3) /= ' ' then
+ Scan_Ptr := Scan_Ptr + 3;
+ exit;
+ end if;
+
+ if Source (Scan_Ptr + 4) /= ' ' then
+ Scan_Ptr := Scan_Ptr + 4;
+ exit;
+ end if;
+
+ if Source (Scan_Ptr + 5) /= ' ' then
+ Scan_Ptr := Scan_Ptr + 5;
+ exit;
+ end if;
+
+ if Source (Scan_Ptr + 6) /= ' ' then
+ Scan_Ptr := Scan_Ptr + 6;
+ exit;
+ end if;
+
+ if Source (Scan_Ptr + 7) /= ' ' then
+ Scan_Ptr := Scan_Ptr + 7;
+ exit;
+ end if;
+
+ Scan_Ptr := Scan_Ptr + 8;
+ end loop;
+
+ -- We are now at a non-blank character, which is the first character
+ -- of the token we will scan, and hence the value of Token_Ptr.
+
+ Token_Ptr := Scan_Ptr;
+
+ -- Here begins the main case statement which transfers control on
+ -- the basis of the non-blank character we have encountered.
+
+ case Source (Scan_Ptr) is
+
+ -- Line terminator characters
+
+ when CR | LF | FF | VT => Line_Terminator_Case : begin
+
+ -- Check line too long
+
+ Check_End_Of_Line;
+
+ declare
+ Physical : Boolean;
+
+ begin
+ Skip_Line_Terminators (Scan_Ptr, Physical);
+
+ -- If we are at start of physical line, update scan pointers
+ -- to reflect the start of the new line.
+
+ if Physical then
+ Current_Line_Start := Scan_Ptr;
+ Start_Column := Set_Start_Column;
+ First_Non_Blank_Location := Scan_Ptr;
+ end if;
+ end;
+ end Line_Terminator_Case;
+
+ -- Horizontal tab, just skip past it
+
+ when HT =>
+ if Style_Check then Style.Check_HT; end if;
+ Scan_Ptr := Scan_Ptr + 1;
+
+ -- End of file character, treated as an end of file only if it
+ -- is the last character in the buffer, otherwise it is ignored.
+
+ when EOF =>
+ if Scan_Ptr = Source_Last (Current_Source_File) then
+ Check_End_Of_Line;
+ Token := Tok_EOF;
+ return;
+
+ else
+ Scan_Ptr := Scan_Ptr + 1;
+ end if;
+
+ -- Ampersand
+
+ when '&' =>
+ Accumulate_Checksum ('&');
+
+ if Source (Scan_Ptr + 1) = '&' then
+ Error_Msg_S ("'&'& should be `AND THEN`");
+ Scan_Ptr := Scan_Ptr + 2;
+ Token := Tok_And;
+ return;
+
+ else
+ Scan_Ptr := Scan_Ptr + 1;
+ Token := Tok_Ampersand;
+ return;
+ end if;
+
+ -- Asterisk (can be multiplication operator or double asterisk
+ -- which is the exponentiation compound delimtier).
+
+ when '*' =>
+ Accumulate_Checksum ('*');
+
+ if Source (Scan_Ptr + 1) = '*' then
+ Accumulate_Checksum ('*');
+ Scan_Ptr := Scan_Ptr + 2;
+ Token := Tok_Double_Asterisk;
+ return;
+
+ else
+ Scan_Ptr := Scan_Ptr + 1;
+ Token := Tok_Asterisk;
+ return;
+ end if;
+
+ -- Colon, which can either be an isolated colon, or part of an
+ -- assignment compound delimiter.
+
+ when ':' =>
+ Accumulate_Checksum (':');
+
+ if Double_Char_Token ('=') then
+ Token := Tok_Colon_Equal;
+ if Style_Check then Style.Check_Colon_Equal; end if;
+ return;
+
+ elsif Source (Scan_Ptr + 1) = '-'
+ and then Source (Scan_Ptr + 2) /= '-'
+ then
+ Token := Tok_Colon_Equal;
+ Error_Msg (":- should be :=", Scan_Ptr);
+ Scan_Ptr := Scan_Ptr + 2;
+ return;
+
+ else
+ Scan_Ptr := Scan_Ptr + 1;
+ Token := Tok_Colon;
+ if Style_Check then Style.Check_Colon; end if;
+ return;
+ end if;
+
+ -- Left parenthesis
+
+ when '(' =>
+ Accumulate_Checksum ('(');
+ Scan_Ptr := Scan_Ptr + 1;
+ Token := Tok_Left_Paren;
+ if Style_Check then Style.Check_Left_Paren; end if;
+ return;
+
+ -- Left bracket
+
+ when '[' =>
+ if Source (Scan_Ptr + 1) = '"' then
+ Name_Len := 0;
+ goto Scan_Identifier;
+
+ else
+ Error_Msg_S ("illegal character, replaced by ""(""");
+ Scan_Ptr := Scan_Ptr + 1;
+ Token := Tok_Left_Paren;
+ return;
+ end if;
+
+ -- Left brace
+
+ when '{' =>
+ Error_Msg_S ("illegal character, replaced by ""(""");
+ Scan_Ptr := Scan_Ptr + 1;
+ Token := Tok_Left_Paren;
+ return;
+
+ -- Comma
+
+ when ',' =>
+ Accumulate_Checksum (',');
+ Scan_Ptr := Scan_Ptr + 1;
+ Token := Tok_Comma;
+ if Style_Check then Style.Check_Comma; end if;
+ return;
+
+ -- Dot, which is either an isolated period, or part of a double
+ -- dot compound delimiter sequence. We also check for the case of
+ -- a digit following the period, to give a better error message.
+
+ when '.' =>
+ Accumulate_Checksum ('.');
+
+ if Double_Char_Token ('.') then
+ Token := Tok_Dot_Dot;
+ if Style_Check then Style.Check_Dot_Dot; end if;
+ return;
+
+ elsif Source (Scan_Ptr + 1) in '0' .. '9' then
+ Error_Msg_S ("numeric literal cannot start with point");
+ Scan_Ptr := Scan_Ptr + 1;
+
+ else
+ Scan_Ptr := Scan_Ptr + 1;
+ Token := Tok_Dot;
+ return;
+ end if;
+
+ -- Equal, which can either be an equality operator, or part of the
+ -- arrow (=>) compound delimiter.
+
+ when '=' =>
+ Accumulate_Checksum ('=');
+
+ if Double_Char_Token ('>') then
+ Token := Tok_Arrow;
+ if Style_Check then Style.Check_Arrow; end if;
+ return;
+
+ elsif Source (Scan_Ptr + 1) = '=' then
+ Error_Msg_S ("== should be =");
+ Scan_Ptr := Scan_Ptr + 1;
+ end if;
+
+ Scan_Ptr := Scan_Ptr + 1;
+ Token := Tok_Equal;
+ return;
+
+ -- Greater than, which can be a greater than operator, greater than
+ -- or equal operator, or first character of a right label bracket.
+
+ when '>' =>
+ Accumulate_Checksum ('>');
+
+ if Double_Char_Token ('=') then
+ Token := Tok_Greater_Equal;
+ return;
+
+ elsif Double_Char_Token ('>') then
+ Token := Tok_Greater_Greater;
+ return;
+
+ else
+ Scan_Ptr := Scan_Ptr + 1;
+ Token := Tok_Greater;
+ return;
+ end if;
+
+ -- Less than, which can be a less than operator, less than or equal
+ -- operator, or the first character of a left label bracket, or the
+ -- first character of a box (<>) compound delimiter.
+
+ when '<' =>
+ Accumulate_Checksum ('<');
+
+ if Double_Char_Token ('=') then
+ Token := Tok_Less_Equal;
+ return;
+
+ elsif Double_Char_Token ('>') then
+ Token := Tok_Box;
+ if Style_Check then Style.Check_Box; end if;
+ return;
+
+ elsif Double_Char_Token ('<') then
+ Token := Tok_Less_Less;
+ return;
+
+ else
+ Scan_Ptr := Scan_Ptr + 1;
+ Token := Tok_Less;
+ return;
+ end if;
+
+ -- Minus, which is either a subtraction operator, or the first
+ -- character of double minus starting a comment
+
+ when '-' => Minus_Case : begin
+ if Source (Scan_Ptr + 1) = '>' then
+ Error_Msg_S ("invalid token");
+ Scan_Ptr := Scan_Ptr + 2;
+ Token := Tok_Arrow;
+ return;
+
+ elsif Source (Scan_Ptr + 1) /= '-' then
+ Accumulate_Checksum ('-');
+ Scan_Ptr := Scan_Ptr + 1;
+ Token := Tok_Minus;
+ return;
+
+ -- Comment
+
+ else -- Source (Scan_Ptr + 1) = '-' then
+ if Style_Check then Style.Check_Comment; end if;
+ Scan_Ptr := Scan_Ptr + 2;
+
+ -- Loop to scan comment (this loop runs more than once only if
+ -- a horizontal tab or other non-graphic character is scanned)
+
+ loop
+ -- Scan to non graphic character (opened up for speed)
+
+ loop
+ exit when Source (Scan_Ptr) not in Graphic_Character;
+ Scan_Ptr := Scan_Ptr + 1;
+ exit when Source (Scan_Ptr) not in Graphic_Character;
+ Scan_Ptr := Scan_Ptr + 1;
+ exit when Source (Scan_Ptr) not in Graphic_Character;
+ Scan_Ptr := Scan_Ptr + 1;
+ exit when Source (Scan_Ptr) not in Graphic_Character;
+ Scan_Ptr := Scan_Ptr + 1;
+ exit when Source (Scan_Ptr) not in Graphic_Character;
+ Scan_Ptr := Scan_Ptr + 1;
+ end loop;
+
+ -- Keep going if horizontal tab
+
+ if Source (Scan_Ptr) = HT then
+ if Style_Check then Style.Check_HT; end if;
+ Scan_Ptr := Scan_Ptr + 1;
+
+ -- Terminate scan of comment if line terminator
+
+ elsif Source (Scan_Ptr) in Line_Terminator then
+ exit;
+
+ -- Terminate scan of comment if end of file encountered
+ -- (embedded EOF character or real last character in file)
+
+ elsif Source (Scan_Ptr) = EOF then
+ exit;
+
+ -- Keep going if character in 80-FF range, or is ESC. These
+ -- characters are allowed in comments by RM-2.1(1), 2.7(2).
+ -- They are allowed even in Ada 83 mode according to the
+ -- approved AI. ESC was added to the AI in June 93.
+
+ elsif Source (Scan_Ptr) in Upper_Half_Character
+ or else Source (Scan_Ptr) = ESC
+ then
+ Scan_Ptr := Scan_Ptr + 1;
+
+ -- Otherwise we have an illegal comment character
+
+ else
+ Error_Illegal_Character;
+ end if;
+
+ end loop;
+
+ -- Note that we do NOT execute a return here, instead we fall
+ -- through to reexecute the scan loop to look for a token.
+
+ end if;
+ end Minus_Case;
+
+ -- Double quote or percent starting a string literal
+
+ when '"' | '%' =>
+ Slit;
+ return;
+
+ -- Apostrophe. This can either be the start of a character literal,
+ -- or an isolated apostrophe used in a qualified expression or an
+ -- attribute. We treat it as a character literal if it does not
+ -- follow a right parenthesis, identifier, the keyword ALL or
+ -- a literal. This means that we correctly treat constructs like:
+
+ -- A := CHARACTER'('A');
+
+ -- Note that RM-2.2(7) does not require a separator between
+ -- "CHARACTER" and "'" in the above.
+
+ when ''' => Char_Literal_Case : declare
+ Code : Char_Code;
+ Err : Boolean;
+
+ begin
+ Accumulate_Checksum (''');
+ Scan_Ptr := Scan_Ptr + 1;
+
+ -- Here is where we make the test to distinguish the cases. Treat
+ -- as apostrophe if previous token is an identifier, right paren
+ -- or the reserved word "all" (latter case as in A.all'Address)
+ -- Also treat it as apostrophe after a literal (this catches
+ -- some legitimate cases, like A."abs"'Address, and also gives
+ -- better error behavior for impossible cases like 123'xxx).
+
+ if Prev_Token = Tok_Identifier
+ or else Prev_Token = Tok_Right_Paren
+ or else Prev_Token = Tok_All
+ or else Prev_Token in Token_Class_Literal
+ then
+ Token := Tok_Apostrophe;
+ return;
+
+ -- Otherwise the apostrophe starts a character literal
+
+ else
+ -- Case of wide character literal with ESC or [ encoding
+
+ if (Source (Scan_Ptr) = ESC
+ and then
+ Wide_Character_Encoding_Method in WC_ESC_Encoding_Method)
+ or else
+ (Source (Scan_Ptr) in Upper_Half_Character
+ and then
+ Upper_Half_Encoding)
+ or else
+ (Source (Scan_Ptr) = '['
+ and then
+ Source (Scan_Ptr + 1) = '"')
+ then
+ Scan_Wide (Source, Scan_Ptr, Code, Err);
+ Accumulate_Checksum (Code);
+
+ if Err then
+ Error_Illegal_Wide_Character;
+ end if;
+
+ if Source (Scan_Ptr) /= ''' then
+ Error_Msg_S ("missing apostrophe");
+ else
+ Scan_Ptr := Scan_Ptr + 1;
+ end if;
+
+ -- If we do not find a closing quote in the expected place then
+ -- assume that we have a misguided attempt at a string literal.
+
+ -- However, if previous token is RANGE, then we return an
+ -- apostrophe instead since this gives better error recovery
+
+ elsif Source (Scan_Ptr + 1) /= ''' then
+
+ if Prev_Token = Tok_Range then
+ Token := Tok_Apostrophe;
+ return;
+
+ else
+ Scan_Ptr := Scan_Ptr - 1;
+ Error_Msg_S
+ ("strings are delimited by double quote character");
+ Scn.Slit;
+ return;
+ end if;
+
+ -- Otherwise we have a (non-wide) character literal
+
+ else
+ Accumulate_Checksum (Source (Scan_Ptr));
+
+ if Source (Scan_Ptr) not in Graphic_Character then
+ if Source (Scan_Ptr) in Upper_Half_Character then
+ if Ada_83 then
+ Error_Illegal_Character;
+ end if;
+
+ else
+ Error_Illegal_Character;
+ end if;
+ end if;
+
+ Code := Get_Char_Code (Source (Scan_Ptr));
+ Scan_Ptr := Scan_Ptr + 2;
+ end if;
+
+ -- Fall through here with Scan_Ptr updated past the closing
+ -- quote, and Code set to the Char_Code value for the literal
+
+ Accumulate_Checksum (''');
+ Token := Tok_Char_Literal;
+ Token_Node := New_Node (N_Character_Literal, Token_Ptr);
+ Set_Char_Literal_Value (Token_Node, Code);
+ Set_Character_Literal_Name (Code);
+ Token_Name := Name_Find;
+ Set_Chars (Token_Node, Token_Name);
+ return;
+ end if;
+ end Char_Literal_Case;
+
+ -- Right parenthesis
+
+ when ')' =>
+ Accumulate_Checksum (')');
+ Scan_Ptr := Scan_Ptr + 1;
+ Token := Tok_Right_Paren;
+ if Style_Check then Style.Check_Right_Paren; end if;
+ return;
+
+ -- Right bracket or right brace, treated as right paren
+
+ when ']' | '}' =>
+ Error_Msg_S ("illegal character, replaced by "")""");
+ Scan_Ptr := Scan_Ptr + 1;
+ Token := Tok_Right_Paren;
+ return;
+
+ -- Slash (can be division operator or first character of not equal)
+
+ when '/' =>
+ Accumulate_Checksum ('/');
+
+ if Double_Char_Token ('=') then
+ Token := Tok_Not_Equal;
+ return;
+ else
+ Scan_Ptr := Scan_Ptr + 1;
+ Token := Tok_Slash;
+ return;
+ end if;
+
+ -- Semicolon
+
+ when ';' =>
+ Accumulate_Checksum (';');
+ Scan_Ptr := Scan_Ptr + 1;
+ Token := Tok_Semicolon;
+ if Style_Check then Style.Check_Semicolon; end if;
+ return;
+
+ -- Vertical bar
+
+ when '|' => Vertical_Bar_Case : begin
+ Accumulate_Checksum ('|');
+
+ -- Special check for || to give nice message
+
+ if Source (Scan_Ptr + 1) = '|' then
+ Error_Msg_S ("""||"" should be `OR ELSE`");
+ Scan_Ptr := Scan_Ptr + 2;
+ Token := Tok_Or;
+ return;
+
+ else
+ Scan_Ptr := Scan_Ptr + 1;
+ Token := Tok_Vertical_Bar;
+ if Style_Check then Style.Check_Vertical_Bar; end if;
+ return;
+ end if;
+ end Vertical_Bar_Case;
+
+ -- Exclamation, replacement character for vertical bar
+
+ when '!' => Exclamation_Case : begin
+ Accumulate_Checksum ('!');
+
+ if Source (Scan_Ptr + 1) = '=' then
+ Error_Msg_S ("'!= should be /=");
+ Scan_Ptr := Scan_Ptr + 2;
+ Token := Tok_Not_Equal;
+ return;
+
+ else
+ Scan_Ptr := Scan_Ptr + 1;
+ Token := Tok_Vertical_Bar;
+ return;
+ end if;
+
+ end Exclamation_Case;
+
+ -- Plus
+
+ when '+' => Plus_Case : begin
+ Accumulate_Checksum ('+');
+ Scan_Ptr := Scan_Ptr + 1;
+ Token := Tok_Plus;
+ return;
+ end Plus_Case;
+
+ -- Digits starting a numeric literal
+
+ when '0' .. '9' =>
+ Nlit;
+
+ if Identifier_Char (Source (Scan_Ptr)) then
+ Error_Msg_S
+ ("delimiter required between literal and identifier");
+ end if;
+
+ return;
+
+ -- Lower case letters
+
+ when 'a' .. 'z' =>
+ Name_Len := 1;
+ Name_Buffer (1) := Source (Scan_Ptr);
+ Accumulate_Checksum (Name_Buffer (1));
+ Scan_Ptr := Scan_Ptr + 1;
+ goto Scan_Identifier;
+
+ -- Upper case letters
+
+ when 'A' .. 'Z' =>
+ Name_Len := 1;
+ Name_Buffer (1) :=
+ Character'Val (Character'Pos (Source (Scan_Ptr)) + 32);
+ Accumulate_Checksum (Name_Buffer (1));
+ Scan_Ptr := Scan_Ptr + 1;
+ goto Scan_Identifier;
+
+ -- Underline character
+
+ when '_' =>
+ Error_Msg_S ("identifier cannot start with underline");
+ Name_Len := 1;
+ Name_Buffer (1) := '_';
+ Scan_Ptr := Scan_Ptr + 1;
+ goto Scan_Identifier;
+
+ -- Space (not possible, because we scanned past blanks)
+
+ when ' ' =>
+ raise Program_Error;
+
+ -- Characters in top half of ASCII 8-bit chart
+
+ when Upper_Half_Character =>
+
+ -- Wide character case. Note that Scan_Identifier will issue
+ -- an appropriate message if wide characters are not allowed
+ -- in identifiers.
+
+ if Upper_Half_Encoding then
+ Name_Len := 0;
+ goto Scan_Identifier;
+
+ -- Otherwise we have OK Latin-1 character
+
+ else
+ -- Upper half characters may possibly be identifier letters
+ -- but can never be digits, so Identifier_Character can be
+ -- used to test for a valid start of identifier character.
+
+ if Identifier_Char (Source (Scan_Ptr)) then
+ Name_Len := 0;
+ goto Scan_Identifier;
+ else
+ Error_Illegal_Character;
+ end if;
+ end if;
+
+ when ESC =>
+
+ -- ESC character, possible start of identifier if wide characters
+ -- using ESC encoding are allowed in identifiers, which we can
+ -- tell by looking at the Identifier_Char flag for ESC, which is
+ -- only true if these conditions are met.
+
+ if Identifier_Char (ESC) then
+ Name_Len := 0;
+ goto Scan_Identifier;
+ else
+ Error_Illegal_Wide_Character;
+ end if;
+
+ -- Invalid control characters
+
+ when NUL | SOH | STX | ETX | EOT | ENQ | ACK | BEL | BS | SO |
+ SI | DLE | DC1 | DC2 | DC3 | DC4 | NAK | SYN | ETB | CAN |
+ EM | FS | GS | RS | US | DEL
+ =>
+ Error_Illegal_Character;
+
+ -- Invalid graphic characters
+
+ when '#' | '$' | '?' | '@' | '`' | '\' | '^' | '~' =>
+ Error_Illegal_Character;
+
+ -- End switch on non-blank character
+
+ end case;
+
+ -- End loop past format effectors. The exit from this loop is by
+ -- executing a return statement following completion of token scan
+ -- (control never falls out of this loop to the code which follows)
+
+ end loop;
+
+ -- Identifier scanning routine. On entry, some initial characters
+ -- of the identifier may have already been stored in Name_Buffer.
+ -- If so, Name_Len has the number of characters stored. otherwise
+ -- Name_Len is set to zero on entry.
+
+ <<Scan_Identifier>>
+
+ -- This loop scans as fast as possible past lower half letters
+ -- and digits, which we expect to be the most common characters.
+
+ loop
+ if Source (Scan_Ptr) in 'a' .. 'z'
+ or else Source (Scan_Ptr) in '0' .. '9'
+ then
+ Name_Buffer (Name_Len + 1) := Source (Scan_Ptr);
+ Accumulate_Checksum (Source (Scan_Ptr));
+
+ elsif Source (Scan_Ptr) in 'A' .. 'Z' then
+ Name_Buffer (Name_Len + 1) :=
+ Character'Val (Character'Pos (Source (Scan_Ptr)) + 32);
+ Accumulate_Checksum (Name_Buffer (Name_Len + 1));
+ else
+ exit;
+ end if;
+
+ -- Open out the loop a couple of times for speed
+
+ if Source (Scan_Ptr + 1) in 'a' .. 'z'
+ or else Source (Scan_Ptr + 1) in '0' .. '9'
+ then
+ Name_Buffer (Name_Len + 2) := Source (Scan_Ptr + 1);
+ Accumulate_Checksum (Source (Scan_Ptr + 1));
+
+ elsif Source (Scan_Ptr + 1) in 'A' .. 'Z' then
+ Name_Buffer (Name_Len + 2) :=
+ Character'Val (Character'Pos (Source (Scan_Ptr + 1)) + 32);
+ Accumulate_Checksum (Name_Buffer (Name_Len + 2));
+
+ else
+ Scan_Ptr := Scan_Ptr + 1;
+ Name_Len := Name_Len + 1;
+ exit;
+ end if;
+
+ if Source (Scan_Ptr + 2) in 'a' .. 'z'
+ or else Source (Scan_Ptr + 2) in '0' .. '9'
+ then
+ Name_Buffer (Name_Len + 3) := Source (Scan_Ptr + 2);
+ Accumulate_Checksum (Source (Scan_Ptr + 2));
+
+ elsif Source (Scan_Ptr + 2) in 'A' .. 'Z' then
+ Name_Buffer (Name_Len + 3) :=
+ Character'Val (Character'Pos (Source (Scan_Ptr + 2)) + 32);
+ Accumulate_Checksum (Name_Buffer (Name_Len + 3));
+ else
+ Scan_Ptr := Scan_Ptr + 2;
+ Name_Len := Name_Len + 2;
+ exit;
+ end if;
+
+ if Source (Scan_Ptr + 3) in 'a' .. 'z'
+ or else Source (Scan_Ptr + 3) in '0' .. '9'
+ then
+ Name_Buffer (Name_Len + 4) := Source (Scan_Ptr + 3);
+ Accumulate_Checksum (Source (Scan_Ptr + 3));
+
+ elsif Source (Scan_Ptr + 3) in 'A' .. 'Z' then
+ Name_Buffer (Name_Len + 4) :=
+ Character'Val (Character'Pos (Source (Scan_Ptr + 3)) + 32);
+ Accumulate_Checksum (Name_Buffer (Name_Len + 4));
+
+ else
+ Scan_Ptr := Scan_Ptr + 3;
+ Name_Len := Name_Len + 3;
+ exit;
+ end if;
+
+ Scan_Ptr := Scan_Ptr + 4;
+ Name_Len := Name_Len + 4;
+ end loop;
+
+ -- If we fall through, then we have encountered either an underline
+ -- character, or an extended identifier character (i.e. one from the
+ -- upper half), or a wide character, or an identifier terminator.
+ -- The initial test speeds us up in the most common case where we
+ -- have an identifier terminator. Note that ESC is an identifier
+ -- character only if a wide character encoding method that uses
+ -- ESC encoding is active, so if we find an ESC character we know
+ -- that we have a wide character.
+
+ if Identifier_Char (Source (Scan_Ptr)) then
+
+ -- Case of underline, check for error cases of double underline,
+ -- and for a trailing underline character
+
+ if Source (Scan_Ptr) = '_' then
+ Accumulate_Checksum ('_');
+ Name_Len := Name_Len + 1;
+ Name_Buffer (Name_Len) := '_';
+
+ if Identifier_Char (Source (Scan_Ptr + 1)) then
+ Scan_Ptr := Scan_Ptr + 1;
+
+ if Source (Scan_Ptr) = '_' then
+ Error_No_Double_Underline;
+ end if;
+
+ else
+ Error_Msg_S ("identifier cannot end with underline");
+ Scan_Ptr := Scan_Ptr + 1;
+ end if;
+
+ goto Scan_Identifier;
+
+ -- Upper half character
+
+ elsif Source (Scan_Ptr) in Upper_Half_Character
+ and then not Upper_Half_Encoding
+ then
+ Accumulate_Checksum (Source (Scan_Ptr));
+ Store_Encoded_Character
+ (Get_Char_Code (Fold_Lower (Source (Scan_Ptr))));
+ Scan_Ptr := Scan_Ptr + 1;
+ goto Scan_Identifier;
+
+ -- Left bracket not followed by a quote terminates an identifier.
+ -- This is an error, but we don't want to give a junk error msg
+ -- about wide characters in this case!
+
+ elsif Source (Scan_Ptr) = '['
+ and then Source (Scan_Ptr + 1) /= '"'
+ then
+ null;
+
+ -- We know we have a wide character encoding here (the current
+ -- character is either ESC, left bracket, or an upper half
+ -- character depending on the encoding method).
+
+ else
+ -- Scan out the wide character and insert the appropriate
+ -- encoding into the name table entry for the identifier.
+
+ declare
+ Sptr : constant Source_Ptr := Scan_Ptr;
+ Code : Char_Code;
+ Err : Boolean;
+
+ begin
+ Scan_Wide (Source, Scan_Ptr, Code, Err);
+ Accumulate_Checksum (Code);
+
+ if Err then
+ Error_Illegal_Wide_Character;
+ else
+ Store_Encoded_Character (Code);
+ end if;
+
+ -- Make sure we are allowing wide characters in identifiers.
+ -- Note that we allow wide character notation for an OK
+ -- identifier character. This in particular allows bracket
+ -- or other notation to be used for upper half letters.
+
+ if Identifier_Character_Set /= 'w'
+ and then
+ (not In_Character_Range (Code)
+ or else
+ not Identifier_Char (Get_Character (Code)))
+ then
+ Error_Msg
+ ("wide character not allowed in identifier", Sptr);
+ end if;
+ end;
+
+ goto Scan_Identifier;
+ end if;
+ end if;
+
+ -- Scan of identifier is complete. The identifier is stored in
+ -- Name_Buffer, and Scan_Ptr points past the last character.
+
+ Token_Name := Name_Find;
+
+ -- Here is where we check if it was a keyword
+
+ if Get_Name_Table_Byte (Token_Name) /= 0
+ and then (Ada_95 or else Token_Name not in Ada_95_Reserved_Words)
+ then
+ Token := Token_Type'Val (Get_Name_Table_Byte (Token_Name));
+
+ -- Deal with possible style check for non-lower case keyword,
+ -- but we don't treat ACCESS, DELTA, DIGITS, RANGE as keywords
+ -- for this purpose if they appear as attribute designators.
+ -- Actually we only check the first character for speed.
+
+ if Style_Check
+ and then Source (Token_Ptr) <= 'Z'
+ and then (Prev_Token /= Tok_Apostrophe
+ or else
+ (Token /= Tok_Access
+ and then Token /= Tok_Delta
+ and then Token /= Tok_Digits
+ and then Token /= Tok_Range))
+ then
+ Style.Non_Lower_Case_Keyword;
+ end if;
+
+ -- We must reset Token_Name since this is not an identifier
+ -- and if we leave Token_Name set, the parser gets confused
+ -- because it thinks it is dealing with an identifier instead
+ -- of the corresponding keyword.
+
+ Token_Name := No_Name;
+ return;
+
+ -- It is an identifier after all
+
+ else
+ Token_Node := New_Node (N_Identifier, Token_Ptr);
+ Set_Chars (Token_Node, Token_Name);
+ Token := Tok_Identifier;
+ return;
+ end if;
+ end Scan;
+
+ ---------------------
+ -- Scan_First_Char --
+ ---------------------
+
+ function Scan_First_Char return Source_Ptr is
+ Ptr : Source_Ptr := Current_Line_Start;
+
+ begin
+ loop
+ if Source (Ptr) = ' ' then
+ Ptr := Ptr + 1;
+
+ elsif Source (Ptr) = HT then
+ if Style_Check then Style.Check_HT; end if;
+ Ptr := Ptr + 1;
+
+ else
+ return Ptr;
+ end if;
+ end loop;
+ end Scan_First_Char;
+
+ ------------------------------
+ -- Scan_Reserved_Identifier --
+ ------------------------------
+
+ procedure Scan_Reserved_Identifier (Force_Msg : Boolean) is
+ Token_Chars : constant String := Token_Type'Image (Token);
+
+ begin
+ -- We have in Token_Chars the image of the Token name, i.e. Tok_xxx.
+ -- This code extracts the xxx and makes an identifier out of it.
+
+ Name_Len := 0;
+
+ for J in 5 .. Token_Chars'Length loop
+ Name_Len := Name_Len + 1;
+ Name_Buffer (Name_Len) := Fold_Lower (Token_Chars (J));
+ end loop;
+
+ Token_Name := Name_Find;
+
+ if not Used_As_Identifier (Token) or else Force_Msg then
+ Error_Msg_Name_1 := Token_Name;
+ Error_Msg_SC ("reserved word* cannot be used as identifier!");
+ Used_As_Identifier (Token) := True;
+ end if;
+
+ Token := Tok_Identifier;
+ Token_Node := New_Node (N_Identifier, Token_Ptr);
+ Set_Chars (Token_Node, Token_Name);
+ end Scan_Reserved_Identifier;
+
+ ----------------------
+ -- Set_Start_Column --
+ ----------------------
+
+ -- Note: it seems at first glance a little expensive to compute this value
+ -- for every source line (since it is certainly not used for all source
+ -- lines). On the other hand, it doesn't take much more work to skip past
+ -- the initial white space on the line counting the columns than it would
+ -- to scan past the white space using the standard scanning circuits.
+
+ function Set_Start_Column return Column_Number is
+ Start_Column : Column_Number := 0;
+
+ begin
+ -- Outer loop scans past horizontal tab characters
+
+ Tabs_Loop : loop
+
+ -- Inner loop scans past blanks as fast as possible, bumping Scan_Ptr
+ -- past the blanks and adjusting Start_Column to account for them.
+
+ Blanks_Loop : loop
+ if Source (Scan_Ptr) = ' ' then
+ if Source (Scan_Ptr + 1) = ' ' then
+ if Source (Scan_Ptr + 2) = ' ' then
+ if Source (Scan_Ptr + 3) = ' ' then
+ if Source (Scan_Ptr + 4) = ' ' then
+ if Source (Scan_Ptr + 5) = ' ' then
+ if Source (Scan_Ptr + 6) = ' ' then
+ Scan_Ptr := Scan_Ptr + 7;
+ Start_Column := Start_Column + 7;
+ else
+ Scan_Ptr := Scan_Ptr + 6;
+ Start_Column := Start_Column + 6;
+ exit Blanks_Loop;
+ end if;
+ else
+ Scan_Ptr := Scan_Ptr + 5;
+ Start_Column := Start_Column + 5;
+ exit Blanks_Loop;
+ end if;
+ else
+ Scan_Ptr := Scan_Ptr + 4;
+ Start_Column := Start_Column + 4;
+ exit Blanks_Loop;
+ end if;
+ else
+ Scan_Ptr := Scan_Ptr + 3;
+ Start_Column := Start_Column + 3;
+ exit Blanks_Loop;
+ end if;
+ else
+ Scan_Ptr := Scan_Ptr + 2;
+ Start_Column := Start_Column + 2;
+ exit Blanks_Loop;
+ end if;
+ else
+ Scan_Ptr := Scan_Ptr + 1;
+ Start_Column := Start_Column + 1;
+ exit Blanks_Loop;
+ end if;
+ else
+ exit Blanks_Loop;
+ end if;
+ end loop Blanks_Loop;
+
+ -- Outer loop keeps going only if a horizontal tab follows
+
+ if Source (Scan_Ptr) = HT then
+ if Style_Check then Style.Check_HT; end if;
+ Scan_Ptr := Scan_Ptr + 1;
+ Start_Column := (Start_Column / 8) * 8 + 8;
+ else
+ exit Tabs_Loop;
+ end if;
+
+ end loop Tabs_Loop;
+
+ return Start_Column;
+ end Set_Start_Column;
+
+ ----------
+ -- Slit --
+ ----------
+
+ procedure Slit is separate;
+
+end Scn;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S C N --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.19 $
+-- --
+-- 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). --
+-- --
+------------------------------------------------------------------------------
+
+-- This package contains the lexical analyzer routines. This is used both
+-- for scanning Ada source files and also for scanning Ada project files.
+
+with Casing; use Casing;
+with Types; use Types;
+
+package Scn is
+
+ procedure Initialize_Scanner
+ (Unit : Unit_Number_Type;
+ Index : Source_File_Index);
+ -- Initialize lexical scanner for scanning a new file. The caller has
+ -- completed the construction of the Units.Table entry for the specified
+ -- Unit and Index references the corresponding source file. A special
+ -- case is when Unit = No_Unit_Number, and Index corresponds to the
+ -- source index for reading the configuration pragma file.
+
+ procedure Scan;
+ -- Scan scans out the next token, and advances the scan state accordingly
+ -- (see package Scan_State for details). If the scan encounters an illegal
+ -- token, then an error message is issued pointing to the bad character,
+ -- and Scan returns a reasonable substitute token of some kind.
+
+ function Scan_First_Char return Source_Ptr;
+ -- This routine returns the position in Source of the first non-blank
+ -- character on the current line, used for certain error recovery actions.
+
+ procedure Scan_Reserved_Identifier (Force_Msg : Boolean);
+ -- This procedure is called to convert the current token, which the caller
+ -- has checked is for a reserved word, to an equivalent identifier. This is
+ -- of course only used in error situations where the parser can detect that
+ -- a reserved word is being used as an identifier. An appropriate error
+ -- message, pointing to the token, is also issued if either this is the
+ -- first occurrence of misuse of this identifier, or if Force_Msg is True.
+
+ function Determine_Token_Casing return Casing_Type;
+ pragma Inline (Determine_Token_Casing);
+ -- Determines the casing style of the current token, which is
+ -- either a keyword or an identifier. See also package Casing.
+
+end Scn;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S D E F A U L T --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.8 $ --
+-- --
+-- Copyright (C) 1992-1999 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 Types; use Types;
+package Sdefault is
+
+ -- This package contains functions that return the default values for
+ -- the include and object file directories, target name, and the default
+ -- library subdirectory (libsubdir) prefix.
+
+ function Include_Dir_Default_Name return String_Ptr;
+ function Object_Dir_Default_Name return String_Ptr;
+ function Target_Name return String_Ptr;
+ function Search_Dir_Prefix return String_Ptr;
+end Sdefault;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S E M --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.290 $
+-- --
+-- 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). --
+-- --
+------------------------------------------------------------------------------
+
+with Atree; use Atree;
+with Debug; use Debug;
+with Debug_A; use Debug_A;
+with Einfo; use Einfo;
+with Errout; use Errout;
+with Expander; use Expander;
+with Fname; use Fname;
+with HLO; use HLO;
+with Lib; use Lib;
+with Lib.Load; use Lib.Load;
+with Nlists; use Nlists;
+with Opt; use Opt;
+with Sem_Attr; use Sem_Attr;
+with Sem_Ch2; use Sem_Ch2;
+with Sem_Ch3; use Sem_Ch3;
+with Sem_Ch4; use Sem_Ch4;
+with Sem_Ch5; use Sem_Ch5;
+with Sem_Ch6; use Sem_Ch6;
+with Sem_Ch7; use Sem_Ch7;
+with Sem_Ch8; use Sem_Ch8;
+with Sem_Ch9; use Sem_Ch9;
+with Sem_Ch10; use Sem_Ch10;
+with Sem_Ch11; use Sem_Ch11;
+with Sem_Ch12; use Sem_Ch12;
+with Sem_Ch13; use Sem_Ch13;
+with Sem_Prag; use Sem_Prag;
+with Sem_Util; use Sem_Util;
+with Sinfo; use Sinfo;
+with Stand; use Stand;
+with Uintp; use Uintp;
+
+pragma Warnings (Off, Sem_Util);
+-- Suppress warnings of unused with for Sem_Util (used only in asserts)
+
+package body Sem is
+
+ Outer_Generic_Scope : Entity_Id := Empty;
+ -- Global reference to the outer scope that is generic. In a non
+ -- generic context, it is empty. At the moment, it is only used
+ -- for avoiding freezing of external references in generics.
+
+ -------------
+ -- Analyze --
+ -------------
+
+ procedure Analyze (N : Node_Id) is
+ begin
+ Debug_A_Entry ("analyzing ", N);
+
+ -- Immediate return if already analyzed
+
+ if Analyzed (N) then
+ Debug_A_Exit ("analyzing ", N, " (done, analyzed already)");
+ return;
+ end if;
+
+ Current_Error_Node := N;
+
+ -- Otherwise processing depends on the node kind
+
+ case Nkind (N) is
+
+ when N_Abort_Statement =>
+ Analyze_Abort_Statement (N);
+
+ when N_Abstract_Subprogram_Declaration =>
+ Analyze_Abstract_Subprogram_Declaration (N);
+
+ when N_Accept_Alternative =>
+ Analyze_Accept_Alternative (N);
+
+ when N_Accept_Statement =>
+ Analyze_Accept_Statement (N);
+
+ when N_Aggregate =>
+ Analyze_Aggregate (N);
+
+ when N_Allocator =>
+ Analyze_Allocator (N);
+
+ when N_And_Then =>
+ Analyze_Short_Circuit (N);
+
+ when N_Assignment_Statement =>
+ Analyze_Assignment (N);
+
+ when N_Asynchronous_Select =>
+ Analyze_Asynchronous_Select (N);
+
+ when N_At_Clause =>
+ Analyze_At_Clause (N);
+
+ when N_Attribute_Reference =>
+ Analyze_Attribute (N);
+
+ when N_Attribute_Definition_Clause =>
+ Analyze_Attribute_Definition_Clause (N);
+
+ when N_Block_Statement =>
+ Analyze_Block_Statement (N);
+
+ when N_Case_Statement =>
+ Analyze_Case_Statement (N);
+
+ when N_Character_Literal =>
+ Analyze_Character_Literal (N);
+
+ when N_Code_Statement =>
+ Analyze_Code_Statement (N);
+
+ when N_Compilation_Unit =>
+ Analyze_Compilation_Unit (N);
+
+ when N_Component_Declaration =>
+ Analyze_Component_Declaration (N);
+
+ when N_Conditional_Expression =>
+ Analyze_Conditional_Expression (N);
+
+ when N_Conditional_Entry_Call =>
+ Analyze_Conditional_Entry_Call (N);
+
+ when N_Delay_Alternative =>
+ Analyze_Delay_Alternative (N);
+
+ when N_Delay_Relative_Statement =>
+ Analyze_Delay_Relative (N);
+
+ when N_Delay_Until_Statement =>
+ Analyze_Delay_Until (N);
+
+ when N_Entry_Body =>
+ Analyze_Entry_Body (N);
+
+ when N_Entry_Body_Formal_Part =>
+ Analyze_Entry_Body_Formal_Part (N);
+
+ when N_Entry_Call_Alternative =>
+ Analyze_Entry_Call_Alternative (N);
+
+ when N_Entry_Declaration =>
+ Analyze_Entry_Declaration (N);
+
+ when N_Entry_Index_Specification =>
+ Analyze_Entry_Index_Specification (N);
+
+ when N_Enumeration_Representation_Clause =>
+ Analyze_Enumeration_Representation_Clause (N);
+
+ when N_Exception_Declaration =>
+ Analyze_Exception_Declaration (N);
+
+ when N_Exception_Renaming_Declaration =>
+ Analyze_Exception_Renaming (N);
+
+ when N_Exit_Statement =>
+ Analyze_Exit_Statement (N);
+
+ when N_Expanded_Name =>
+ Analyze_Expanded_Name (N);
+
+ when N_Explicit_Dereference =>
+ Analyze_Explicit_Dereference (N);
+
+ when N_Extension_Aggregate =>
+ Analyze_Aggregate (N);
+
+ when N_Formal_Object_Declaration =>
+ Analyze_Formal_Object_Declaration (N);
+
+ when N_Formal_Package_Declaration =>
+ Analyze_Formal_Package (N);
+
+ when N_Formal_Subprogram_Declaration =>
+ Analyze_Formal_Subprogram (N);
+
+ when N_Formal_Type_Declaration =>
+ Analyze_Formal_Type_Declaration (N);
+
+ when N_Free_Statement =>
+ Analyze_Free_Statement (N);
+
+ when N_Freeze_Entity =>
+ null; -- no semantic processing required
+
+ when N_Full_Type_Declaration =>
+ Analyze_Type_Declaration (N);
+
+ when N_Function_Call =>
+ Analyze_Function_Call (N);
+
+ when N_Function_Instantiation =>
+ Analyze_Function_Instantiation (N);
+
+ when N_Generic_Function_Renaming_Declaration =>
+ Analyze_Generic_Function_Renaming (N);
+
+ when N_Generic_Package_Declaration =>
+ Analyze_Generic_Package_Declaration (N);
+
+ when N_Generic_Package_Renaming_Declaration =>
+ Analyze_Generic_Package_Renaming (N);
+
+ when N_Generic_Procedure_Renaming_Declaration =>
+ Analyze_Generic_Procedure_Renaming (N);
+
+ when N_Generic_Subprogram_Declaration =>
+ Analyze_Generic_Subprogram_Declaration (N);
+
+ when N_Goto_Statement =>
+ Analyze_Goto_Statement (N);
+
+ when N_Handled_Sequence_Of_Statements =>
+ Analyze_Handled_Statements (N);
+
+ when N_Identifier =>
+ Analyze_Identifier (N);
+
+ when N_If_Statement =>
+ Analyze_If_Statement (N);
+
+ when N_Implicit_Label_Declaration =>
+ Analyze_Implicit_Label_Declaration (N);
+
+ when N_In =>
+ Analyze_Membership_Op (N);
+
+ when N_Incomplete_Type_Declaration =>
+ Analyze_Incomplete_Type_Decl (N);
+
+ when N_Indexed_Component =>
+ Analyze_Indexed_Component_Form (N);
+
+ when N_Integer_Literal =>
+ Analyze_Integer_Literal (N);
+
+ when N_Itype_Reference =>
+ Analyze_Itype_Reference (N);
+
+ when N_Label =>
+ Analyze_Label (N);
+
+ when N_Loop_Statement =>
+ Analyze_Loop_Statement (N);
+
+ when N_Not_In =>
+ Analyze_Membership_Op (N);
+
+ when N_Null =>
+ Analyze_Null (N);
+
+ when N_Null_Statement =>
+ Analyze_Null_Statement (N);
+
+ when N_Number_Declaration =>
+ Analyze_Number_Declaration (N);
+
+ when N_Object_Declaration =>
+ Analyze_Object_Declaration (N);
+
+ when N_Object_Renaming_Declaration =>
+ Analyze_Object_Renaming (N);
+
+ when N_Operator_Symbol =>
+ Analyze_Operator_Symbol (N);
+
+ when N_Op_Abs =>
+ Analyze_Unary_Op (N);
+
+ when N_Op_Add =>
+ Analyze_Arithmetic_Op (N);
+
+ when N_Op_And =>
+ Analyze_Logical_Op (N);
+
+ when N_Op_Concat =>
+ Analyze_Concatenation (N);
+
+ when N_Op_Divide =>
+ Analyze_Arithmetic_Op (N);
+
+ when N_Op_Eq =>
+ Analyze_Equality_Op (N);
+
+ when N_Op_Expon =>
+ Analyze_Arithmetic_Op (N);
+
+ when N_Op_Ge =>
+ Analyze_Comparison_Op (N);
+
+ when N_Op_Gt =>
+ Analyze_Comparison_Op (N);
+
+ when N_Op_Le =>
+ Analyze_Comparison_Op (N);
+
+ when N_Op_Lt =>
+ Analyze_Comparison_Op (N);
+
+ when N_Op_Minus =>
+ Analyze_Unary_Op (N);
+
+ when N_Op_Mod =>
+ Analyze_Arithmetic_Op (N);
+
+ when N_Op_Multiply =>
+ Analyze_Arithmetic_Op (N);
+
+ when N_Op_Ne =>
+ Analyze_Equality_Op (N);
+
+ when N_Op_Not =>
+ Analyze_Negation (N);
+
+ when N_Op_Or =>
+ Analyze_Logical_Op (N);
+
+ when N_Op_Plus =>
+ Analyze_Unary_Op (N);
+
+ when N_Op_Rem =>
+ Analyze_Arithmetic_Op (N);
+
+ when N_Op_Rotate_Left =>
+ Analyze_Arithmetic_Op (N);
+
+ when N_Op_Rotate_Right =>
+ Analyze_Arithmetic_Op (N);
+
+ when N_Op_Shift_Left =>
+ Analyze_Arithmetic_Op (N);
+
+ when N_Op_Shift_Right =>
+ Analyze_Arithmetic_Op (N);
+
+ when N_Op_Shift_Right_Arithmetic =>
+ Analyze_Arithmetic_Op (N);
+
+ when N_Op_Subtract =>
+ Analyze_Arithmetic_Op (N);
+
+ when N_Op_Xor =>
+ Analyze_Logical_Op (N);
+
+ when N_Or_Else =>
+ Analyze_Short_Circuit (N);
+
+ when N_Others_Choice =>
+ Analyze_Others_Choice (N);
+
+ when N_Package_Body =>
+ Analyze_Package_Body (N);
+
+ when N_Package_Body_Stub =>
+ Analyze_Package_Body_Stub (N);
+
+ when N_Package_Declaration =>
+ Analyze_Package_Declaration (N);
+
+ when N_Package_Instantiation =>
+ Analyze_Package_Instantiation (N);
+
+ when N_Package_Renaming_Declaration =>
+ Analyze_Package_Renaming (N);
+
+ when N_Package_Specification =>
+ Analyze_Package_Specification (N);
+
+ when N_Parameter_Association =>
+ Analyze_Parameter_Association (N);
+
+ when N_Pragma =>
+ Analyze_Pragma (N);
+
+ when N_Private_Extension_Declaration =>
+ Analyze_Private_Extension_Declaration (N);
+
+ when N_Private_Type_Declaration =>
+ Analyze_Private_Type_Declaration (N);
+
+ when N_Procedure_Call_Statement =>
+ Analyze_Procedure_Call (N);
+
+ when N_Procedure_Instantiation =>
+ Analyze_Procedure_Instantiation (N);
+
+ when N_Protected_Body =>
+ Analyze_Protected_Body (N);
+
+ when N_Protected_Body_Stub =>
+ Analyze_Protected_Body_Stub (N);
+
+ when N_Protected_Definition =>
+ Analyze_Protected_Definition (N);
+
+ when N_Protected_Type_Declaration =>
+ Analyze_Protected_Type (N);
+
+ when N_Qualified_Expression =>
+ Analyze_Qualified_Expression (N);
+
+ when N_Raise_Statement =>
+ Analyze_Raise_Statement (N);
+
+ when N_Raise_xxx_Error =>
+ Analyze_Raise_xxx_Error (N);
+
+ when N_Range =>
+ Analyze_Range (N);
+
+ when N_Range_Constraint =>
+ Analyze_Range (Range_Expression (N));
+
+ when N_Real_Literal =>
+ Analyze_Real_Literal (N);
+
+ when N_Record_Representation_Clause =>
+ Analyze_Record_Representation_Clause (N);
+
+ when N_Reference =>
+ Analyze_Reference (N);
+
+ when N_Requeue_Statement =>
+ Analyze_Requeue (N);
+
+ when N_Return_Statement =>
+ Analyze_Return_Statement (N);
+
+ when N_Selected_Component =>
+ Find_Selected_Component (N);
+ -- ??? why not Analyze_Selected_Component, needs comments
+
+ when N_Selective_Accept =>
+ Analyze_Selective_Accept (N);
+
+ when N_Single_Protected_Declaration =>
+ Analyze_Single_Protected (N);
+
+ when N_Single_Task_Declaration =>
+ Analyze_Single_Task (N);
+
+ when N_Slice =>
+ Analyze_Slice (N);
+
+ when N_String_Literal =>
+ Analyze_String_Literal (N);
+
+ when N_Subprogram_Body =>
+ Analyze_Subprogram_Body (N);
+
+ when N_Subprogram_Body_Stub =>
+ Analyze_Subprogram_Body_Stub (N);
+
+ when N_Subprogram_Declaration =>
+ Analyze_Subprogram_Declaration (N);
+
+ when N_Subprogram_Info =>
+ Analyze_Subprogram_Info (N);
+
+ when N_Subprogram_Renaming_Declaration =>
+ Analyze_Subprogram_Renaming (N);
+
+ when N_Subtype_Declaration =>
+ Analyze_Subtype_Declaration (N);
+
+ when N_Subtype_Indication =>
+ Analyze_Subtype_Indication (N);
+
+ when N_Subunit =>
+ Analyze_Subunit (N);
+
+ when N_Task_Body =>
+ Analyze_Task_Body (N);
+
+ when N_Task_Body_Stub =>
+ Analyze_Task_Body_Stub (N);
+
+ when N_Task_Definition =>
+ Analyze_Task_Definition (N);
+
+ when N_Task_Type_Declaration =>
+ Analyze_Task_Type (N);
+
+ when N_Terminate_Alternative =>
+ Analyze_Terminate_Alternative (N);
+
+ when N_Timed_Entry_Call =>
+ Analyze_Timed_Entry_Call (N);
+
+ when N_Triggering_Alternative =>
+ Analyze_Triggering_Alternative (N);
+
+ when N_Type_Conversion =>
+ Analyze_Type_Conversion (N);
+
+ when N_Unchecked_Expression =>
+ Analyze_Unchecked_Expression (N);
+
+ when N_Unchecked_Type_Conversion =>
+ Analyze_Unchecked_Type_Conversion (N);
+
+ when N_Use_Package_Clause =>
+ Analyze_Use_Package (N);
+
+ when N_Use_Type_Clause =>
+ Analyze_Use_Type (N);
+
+ when N_Validate_Unchecked_Conversion =>
+ null;
+
+ when N_Variant_Part =>
+ Analyze_Variant_Part (N);
+
+ when N_With_Clause =>
+ Analyze_With_Clause (N);
+
+ when N_With_Type_Clause =>
+ Analyze_With_Type_Clause (N);
+
+ -- A call to analyze the Empty node is an error, but most likely
+ -- it is an error caused by an attempt to analyze a malformed
+ -- piece of tree caused by some other error, so if there have
+ -- been any other errors, we just ignore it, otherwise it is
+ -- a real internal error which we complain about.
+
+ when N_Empty =>
+ pragma Assert (Errors_Detected /= 0);
+ null;
+
+ -- A call to analyze the error node is simply ignored, to avoid
+ -- causing cascaded errors (happens of course only in error cases)
+
+ when N_Error =>
+ null;
+
+ -- For the remaining node types, we generate compiler abort, because
+ -- these nodes are always analyzed within the Sem_Chn routines and
+ -- there should never be a case of making a call to the main Analyze
+ -- routine for these node kinds. For example, an N_Access_Definition
+ -- node appears only in the context of a type declaration, and is
+ -- processed by the analyze routine for type declarations.
+
+ when
+ N_Abortable_Part |
+ N_Access_Definition |
+ N_Access_Function_Definition |
+ N_Access_Procedure_Definition |
+ N_Access_To_Object_Definition |
+ N_Case_Statement_Alternative |
+ N_Compilation_Unit_Aux |
+ N_Component_Association |
+ N_Component_Clause |
+ N_Component_List |
+ N_Constrained_Array_Definition |
+ N_Decimal_Fixed_Point_Definition |
+ N_Defining_Character_Literal |
+ N_Defining_Identifier |
+ N_Defining_Operator_Symbol |
+ N_Defining_Program_Unit_Name |
+ N_Delta_Constraint |
+ N_Derived_Type_Definition |
+ N_Designator |
+ N_Digits_Constraint |
+ N_Discriminant_Association |
+ N_Discriminant_Specification |
+ N_Elsif_Part |
+ N_Entry_Call_Statement |
+ N_Enumeration_Type_Definition |
+ N_Exception_Handler |
+ N_Floating_Point_Definition |
+ N_Formal_Decimal_Fixed_Point_Definition |
+ N_Formal_Derived_Type_Definition |
+ N_Formal_Discrete_Type_Definition |
+ N_Formal_Floating_Point_Definition |
+ N_Formal_Modular_Type_Definition |
+ N_Formal_Ordinary_Fixed_Point_Definition |
+ N_Formal_Private_Type_Definition |
+ N_Formal_Signed_Integer_Type_Definition |
+ N_Function_Specification |
+ N_Generic_Association |
+ N_Index_Or_Discriminant_Constraint |
+ N_Iteration_Scheme |
+ N_Loop_Parameter_Specification |
+ N_Mod_Clause |
+ N_Modular_Type_Definition |
+ N_Ordinary_Fixed_Point_Definition |
+ N_Parameter_Specification |
+ N_Pragma_Argument_Association |
+ N_Procedure_Specification |
+ N_Real_Range_Specification |
+ N_Record_Definition |
+ N_Signed_Integer_Type_Definition |
+ N_Unconstrained_Array_Definition |
+ N_Unused_At_Start |
+ N_Unused_At_End |
+ N_Variant =>
+
+ raise Program_Error;
+ end case;
+
+ Debug_A_Exit ("analyzing ", N, " (done)");
+
+ -- Now that we have analyzed the node, we call the expander to
+ -- perform possible expansion. This is done only for nodes that
+ -- are not subexpressions, because in the case of subexpressions,
+ -- we don't have the type yet, and the expander will need to know
+ -- the type before it can do its job. For subexpression nodes, the
+ -- call to the expander happens in the Sem_Res.Resolve.
+
+ -- The Analyzed flag is also set at this point for non-subexpression
+ -- nodes (in the case of subexpression nodes, we can't set the flag
+ -- yet, since resolution and expansion have not yet been completed)
+
+ if Nkind (N) not in N_Subexpr then
+ Expand (N);
+ end if;
+
+ end Analyze;
+
+ -- Version with check(s) suppressed
+
+ procedure Analyze (N : Node_Id; Suppress : Check_Id) is
+ begin
+ if Suppress = All_Checks then
+ declare
+ Svg : constant Suppress_Record := Scope_Suppress;
+
+ begin
+ Scope_Suppress := (others => True);
+ Analyze (N);
+ Scope_Suppress := Svg;
+ end;
+
+ else
+ declare
+ Svg : constant Boolean := Get_Scope_Suppress (Suppress);
+
+ begin
+ Set_Scope_Suppress (Suppress, True);
+ Analyze (N);
+ Set_Scope_Suppress (Suppress, Svg);
+ end;
+ end if;
+ end Analyze;
+
+ ------------------
+ -- Analyze_List --
+ ------------------
+
+ procedure Analyze_List (L : List_Id) is
+ Node : Node_Id;
+
+ begin
+ Node := First (L);
+ while Present (Node) loop
+ Analyze (Node);
+ Next (Node);
+ end loop;
+ end Analyze_List;
+
+ -- Version with check(s) suppressed
+
+ procedure Analyze_List (L : List_Id; Suppress : Check_Id) is
+ begin
+ if Suppress = All_Checks then
+ declare
+ Svg : constant Suppress_Record := Scope_Suppress;
+
+ begin
+ Scope_Suppress := (others => True);
+ Analyze_List (L);
+ Scope_Suppress := Svg;
+ end;
+
+ else
+ declare
+ Svg : constant Boolean := Get_Scope_Suppress (Suppress);
+
+ begin
+ Set_Scope_Suppress (Suppress, True);
+ Analyze_List (L);
+ Set_Scope_Suppress (Suppress, Svg);
+ end;
+ end if;
+ end Analyze_List;
+
+ -------------------------
+ -- Enter_Generic_Scope --
+ -------------------------
+
+ procedure Enter_Generic_Scope (S : Entity_Id) is
+ begin
+ if No (Outer_Generic_Scope) then
+ Outer_Generic_Scope := S;
+ end if;
+ end Enter_Generic_Scope;
+
+ ------------------------
+ -- Exit_Generic_Scope --
+ ------------------------
+
+ procedure Exit_Generic_Scope (S : Entity_Id) is
+ begin
+ if S = Outer_Generic_Scope then
+ Outer_Generic_Scope := Empty;
+ end if;
+ end Exit_Generic_Scope;
+
+ -----------------------------
+ -- External_Ref_In_Generic --
+ -----------------------------
+
+ function External_Ref_In_Generic (E : Entity_Id) return Boolean is
+ begin
+
+ -- Entity is global if defined outside of current outer_generic_scope:
+ -- Either the entity has a smaller depth that the outer generic, or it
+ -- is in a different compilation unit.
+
+ return Present (Outer_Generic_Scope)
+ and then (Scope_Depth (Scope (E)) < Scope_Depth (Outer_Generic_Scope)
+ or else not In_Same_Source_Unit (E, Outer_Generic_Scope));
+ end External_Ref_In_Generic;
+
+ ------------------------
+ -- Get_Scope_Suppress --
+ ------------------------
+
+ function Get_Scope_Suppress (C : Check_Id) return Boolean is
+ S : Suppress_Record renames Scope_Suppress;
+
+ begin
+ case C is
+ when Access_Check => return S.Access_Checks;
+ when Accessibility_Check => return S.Accessibility_Checks;
+ when Discriminant_Check => return S.Discriminant_Checks;
+ when Division_Check => return S.Division_Checks;
+ when Elaboration_Check => return S.Discriminant_Checks;
+ when Index_Check => return S.Elaboration_Checks;
+ when Length_Check => return S.Discriminant_Checks;
+ when Overflow_Check => return S.Overflow_Checks;
+ when Range_Check => return S.Range_Checks;
+ when Storage_Check => return S.Storage_Checks;
+ when Tag_Check => return S.Tag_Checks;
+ when All_Checks =>
+ raise Program_Error;
+ end case;
+ end Get_Scope_Suppress;
+
+ ----------------
+ -- Initialize --
+ ----------------
+
+ procedure Initialize is
+ begin
+ Entity_Suppress.Init;
+ Scope_Stack.Init;
+ Unloaded_Subunits := False;
+ end Initialize;
+
+ ------------------------------
+ -- Insert_After_And_Analyze --
+ ------------------------------
+
+ procedure Insert_After_And_Analyze (N : Node_Id; M : Node_Id) is
+ Node : Node_Id;
+
+ begin
+ if Present (M) then
+
+ -- If we are not at the end of the list, then the easiest
+ -- coding is simply to insert before our successor
+
+ if Present (Next (N)) then
+ Insert_Before_And_Analyze (Next (N), M);
+
+ -- Case of inserting at the end of the list
+
+ else
+ -- Capture the Node_Id of the node to be inserted. This Node_Id
+ -- will still be the same after the insert operation.
+
+ Node := M;
+ Insert_After (N, M);
+
+ -- Now just analyze from the inserted node to the end of
+ -- the new list (note that this properly handles the case
+ -- where any of the analyze calls result in the insertion of
+ -- nodes after the analyzed node, expecting analysis).
+
+ while Present (Node) loop
+ Analyze (Node);
+ Mark_Rewrite_Insertion (Node);
+ Next (Node);
+ end loop;
+ end if;
+ end if;
+
+ end Insert_After_And_Analyze;
+
+ -- Version with check(s) suppressed
+
+ procedure Insert_After_And_Analyze
+ (N : Node_Id; M : Node_Id; Suppress : Check_Id)
+ is
+ begin
+ if Suppress = All_Checks then
+ declare
+ Svg : constant Suppress_Record := Scope_Suppress;
+
+ begin
+ Scope_Suppress := (others => True);
+ Insert_After_And_Analyze (N, M);
+ Scope_Suppress := Svg;
+ end;
+
+ else
+ declare
+ Svg : constant Boolean := Get_Scope_Suppress (Suppress);
+
+ begin
+ Set_Scope_Suppress (Suppress, True);
+ Insert_After_And_Analyze (N, M);
+ Set_Scope_Suppress (Suppress, Svg);
+ end;
+ end if;
+ end Insert_After_And_Analyze;
+
+ -------------------------------
+ -- Insert_Before_And_Analyze --
+ -------------------------------
+
+ procedure Insert_Before_And_Analyze (N : Node_Id; M : Node_Id) is
+ Node : Node_Id;
+
+ begin
+ if Present (M) then
+
+ -- Capture the Node_Id of the first list node to be inserted.
+ -- This will still be the first node after the insert operation,
+ -- since Insert_List_After does not modify the Node_Id values.
+
+ Node := M;
+ Insert_Before (N, M);
+
+ -- The insertion does not change the Id's of any of the nodes in
+ -- the list, and they are still linked, so we can simply loop from
+ -- the original first node until we meet the node before which the
+ -- insertion is occurring. Note that this properly handles the case
+ -- where any of the analyzed nodes insert nodes after themselves,
+ -- expecting them to get analyzed.
+
+ while Node /= N loop
+ Analyze (Node);
+ Mark_Rewrite_Insertion (Node);
+ Next (Node);
+ end loop;
+ end if;
+
+ end Insert_Before_And_Analyze;
+
+ -- Version with check(s) suppressed
+
+ procedure Insert_Before_And_Analyze
+ (N : Node_Id; M : Node_Id; Suppress : Check_Id)
+ is
+ begin
+ if Suppress = All_Checks then
+ declare
+ Svg : constant Suppress_Record := Scope_Suppress;
+
+ begin
+ Scope_Suppress := (others => True);
+ Insert_Before_And_Analyze (N, M);
+ Scope_Suppress := Svg;
+ end;
+
+ else
+ declare
+ Svg : constant Boolean := Get_Scope_Suppress (Suppress);
+
+ begin
+ Set_Scope_Suppress (Suppress, True);
+ Insert_Before_And_Analyze (N, M);
+ Set_Scope_Suppress (Suppress, Svg);
+ end;
+ end if;
+ end Insert_Before_And_Analyze;
+
+ -----------------------------------
+ -- Insert_List_After_And_Analyze --
+ -----------------------------------
+
+ procedure Insert_List_After_And_Analyze (N : Node_Id; L : List_Id) is
+ After : constant Node_Id := Next (N);
+ Node : Node_Id;
+
+ begin
+ if Is_Non_Empty_List (L) then
+
+ -- Capture the Node_Id of the first list node to be inserted.
+ -- This will still be the first node after the insert operation,
+ -- since Insert_List_After does not modify the Node_Id values.
+
+ Node := First (L);
+ Insert_List_After (N, L);
+
+ -- Now just analyze from the original first node until we get to
+ -- the successor of the original insertion point (which may be
+ -- Empty if the insertion point was at the end of the list). Note
+ -- that this properly handles the case where any of the analyze
+ -- calls result in the insertion of nodes after the analyzed
+ -- node (possibly calling this routine recursively).
+
+ while Node /= After loop
+ Analyze (Node);
+ Mark_Rewrite_Insertion (Node);
+ Next (Node);
+ end loop;
+ end if;
+
+ end Insert_List_After_And_Analyze;
+
+ -- Version with check(s) suppressed
+
+ procedure Insert_List_After_And_Analyze
+ (N : Node_Id; L : List_Id; Suppress : Check_Id)
+ is
+ begin
+ if Suppress = All_Checks then
+ declare
+ Svg : constant Suppress_Record := Scope_Suppress;
+
+ begin
+ Scope_Suppress := (others => True);
+ Insert_List_After_And_Analyze (N, L);
+ Scope_Suppress := Svg;
+ end;
+
+ else
+ declare
+ Svg : constant Boolean := Get_Scope_Suppress (Suppress);
+
+ begin
+ Set_Scope_Suppress (Suppress, True);
+ Insert_List_After_And_Analyze (N, L);
+ Set_Scope_Suppress (Suppress, Svg);
+ end;
+ end if;
+ end Insert_List_After_And_Analyze;
+
+ ------------------------------------
+ -- Insert_List_Before_And_Analyze --
+ ------------------------------------
+
+ procedure Insert_List_Before_And_Analyze (N : Node_Id; L : List_Id) is
+ Node : Node_Id;
+
+ begin
+ if Is_Non_Empty_List (L) then
+
+ -- Capture the Node_Id of the first list node to be inserted.
+ -- This will still be the first node after the insert operation,
+ -- since Insert_List_After does not modify the Node_Id values.
+
+ Node := First (L);
+ Insert_List_Before (N, L);
+
+ -- The insertion does not change the Id's of any of the nodes in
+ -- the list, and they are still linked, so we can simply loop from
+ -- the original first node until we meet the node before which the
+ -- insertion is occurring. Note that this properly handles the case
+ -- where any of the analyzed nodes insert nodes after themselves,
+ -- expecting them to get analyzed.
+
+ while Node /= N loop
+ Analyze (Node);
+ Mark_Rewrite_Insertion (Node);
+ Next (Node);
+ end loop;
+ end if;
+
+ end Insert_List_Before_And_Analyze;
+
+ -- Version with check(s) suppressed
+
+ procedure Insert_List_Before_And_Analyze
+ (N : Node_Id; L : List_Id; Suppress : Check_Id)
+ is
+ begin
+ if Suppress = All_Checks then
+ declare
+ Svg : constant Suppress_Record := Scope_Suppress;
+
+ begin
+ Scope_Suppress := (others => True);
+ Insert_List_Before_And_Analyze (N, L);
+ Scope_Suppress := Svg;
+ end;
+
+ else
+ declare
+ Svg : constant Boolean := Get_Scope_Suppress (Suppress);
+
+ begin
+ Set_Scope_Suppress (Suppress, True);
+ Insert_List_Before_And_Analyze (N, L);
+ Set_Scope_Suppress (Suppress, Svg);
+ end;
+ end if;
+ end Insert_List_Before_And_Analyze;
+
+ ----------
+ -- Lock --
+ ----------
+
+ procedure Lock is
+ begin
+ Entity_Suppress.Locked := True;
+ Scope_Stack.Locked := True;
+ Entity_Suppress.Release;
+ Scope_Stack.Release;
+ end Lock;
+
+ ---------------
+ -- Semantics --
+ ---------------
+
+ procedure Semantics (Comp_Unit : Node_Id) is
+
+ -- The following locations save the corresponding global flags and
+ -- variables so that they can be restored on completion. This is
+ -- needed so that calls to Rtsfind start with the proper default
+ -- values for these variables, and also that such calls do not
+ -- disturb the settings for units being analyzed at a higher level.
+
+ S_Full_Analysis : constant Boolean := Full_Analysis;
+ S_In_Default_Expr : constant Boolean := In_Default_Expression;
+ S_Inside_A_Generic : constant Boolean := Inside_A_Generic;
+ S_New_Nodes_OK : constant Int := New_Nodes_OK;
+ S_Outer_Gen_Scope : constant Entity_Id := Outer_Generic_Scope;
+ S_Sem_Unit : constant Unit_Number_Type := Current_Sem_Unit;
+
+ Save_Config_Switches : Config_Switches_Type;
+ -- Variable used to save values of config switches while we analyze
+ -- the new unit, to be restored on exit for proper recursive behavior.
+
+ procedure Do_Analyze;
+ -- Procedure to analyze the compilation unit. This is called more
+ -- than once when the high level optimizer is activated.
+
+ procedure Do_Analyze is
+ begin
+ Save_Scope_Stack;
+ New_Scope (Standard_Standard);
+ Scope_Suppress := Suppress_Options;
+ Scope_Stack.Table
+ (Scope_Stack.Last).Component_Alignment_Default := Calign_Default;
+ Scope_Stack.Table
+ (Scope_Stack.Last).Is_Active_Stack_Base := True;
+ Outer_Generic_Scope := Empty;
+
+ -- Now analyze the top level compilation unit node
+
+ Analyze (Comp_Unit);
+
+ -- Check for scope mismatch on exit from compilation
+
+ pragma Assert (Current_Scope = Standard_Standard
+ or else Comp_Unit = Cunit (Main_Unit));
+
+ -- Then pop entry for Standard, and pop implicit types
+
+ Pop_Scope;
+ Restore_Scope_Stack;
+ end Do_Analyze;
+
+ -- Start of processing for Sem
+
+ begin
+ Compiler_State := Analyzing;
+ Current_Sem_Unit := Get_Cunit_Unit_Number (Comp_Unit);
+
+ Expander_Mode_Save_And_Set
+ (Operating_Mode = Generate_Code or Debug_Flag_X);
+
+ Full_Analysis := True;
+ Inside_A_Generic := False;
+ In_Default_Expression := False;
+
+ Set_Comes_From_Source_Default (False);
+ Save_Opt_Config_Switches (Save_Config_Switches);
+ Set_Opt_Config_Switches
+ (Is_Internal_File_Name (Unit_File_Name (Current_Sem_Unit)));
+
+ -- Only do analysis of unit that has not already been analyzed
+
+ if not Analyzed (Comp_Unit) then
+ Initialize_Version (Current_Sem_Unit);
+ if HLO_Active then
+ Expander_Mode_Save_And_Set (False);
+ New_Nodes_OK := 1;
+ Do_Analyze;
+ Reset_Analyzed_Flags (Comp_Unit);
+ Expander_Mode_Restore;
+ High_Level_Optimize (Comp_Unit);
+ New_Nodes_OK := 0;
+ end if;
+
+ Do_Analyze;
+ end if;
+
+ -- Save indication of dynamic elaboration checks for ALI file
+
+ Set_Dynamic_Elab (Current_Sem_Unit, Dynamic_Elaboration_Checks);
+
+ -- Restore settings of saved switches to entry values
+
+ Current_Sem_Unit := S_Sem_Unit;
+ Full_Analysis := S_Full_Analysis;
+ In_Default_Expression := S_In_Default_Expr;
+ Inside_A_Generic := S_Inside_A_Generic;
+ New_Nodes_OK := S_New_Nodes_OK;
+ Outer_Generic_Scope := S_Outer_Gen_Scope;
+
+ Restore_Opt_Config_Switches (Save_Config_Switches);
+ Expander_Mode_Restore;
+
+ end Semantics;
+
+ ------------------------
+ -- Set_Scope_Suppress --
+ ------------------------
+
+ procedure Set_Scope_Suppress (C : Check_Id; B : Boolean) is
+ S : Suppress_Record renames Scope_Suppress;
+
+ begin
+ case C is
+ when Access_Check => S.Access_Checks := B;
+ when Accessibility_Check => S.Accessibility_Checks := B;
+ when Discriminant_Check => S.Discriminant_Checks := B;
+ when Division_Check => S.Division_Checks := B;
+ when Elaboration_Check => S.Discriminant_Checks := B;
+ when Index_Check => S.Elaboration_Checks := B;
+ when Length_Check => S.Discriminant_Checks := B;
+ when Overflow_Check => S.Overflow_Checks := B;
+ when Range_Check => S.Range_Checks := B;
+ when Storage_Check => S.Storage_Checks := B;
+ when Tag_Check => S.Tag_Checks := B;
+ when All_Checks =>
+ raise Program_Error;
+ end case;
+ end Set_Scope_Suppress;
+
+end Sem;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S E M --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.101 $
+-- --
+-- 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). --
+-- --
+------------------------------------------------------------------------------
+
+--------------------------------------
+-- Semantic Analysis: General Model --
+--------------------------------------
+
+-- Semantic processing involves 3 phases which are highly interwined
+-- (ie mutually recursive):
+--
+-- Analysis implements the bulk of semantic analysis such as
+-- name analysis and type resolution for declarations,
+-- instructions and expressions. The main routine
+-- driving this process is procedure Analyze given below.
+-- This analysis phase is really a bottom up pass that is
+-- achieved during the recursive traversal performed by the
+-- Analyze_... procedures implemented in the sem_* packages.
+-- For expressions this phase determines unambiguous types
+-- and collects sets of possible types where the
+-- interpretation is potentially ambiguous.
+--
+-- Resolution is carried out only for expressions to finish type
+-- resolution that was initiated but not necessarily
+-- completed during analysis (because of overloading
+-- ambiguities). Specifically, after completing the bottom
+-- up pass carried out during analysis for expressions, the
+-- Resolve routine (see the spec of sem_res for more info)
+-- is called to perform a top down resolution with
+-- recursive calls to itself to resolve operands.
+--
+-- Expansion if we are not generating code this phase is a no-op.
+-- otherwise this phase expands, ie transforms, original
+-- declaration, expressions or instructions into simpler
+-- structures that can be handled by the back-end. This
+-- phase is also in charge of generating code which is
+-- implicit in the original source (for instance for
+-- default initializations, controlled types, etc.)
+-- There are two separate instances where expansion is
+-- invoked. For declarations and instructions, expansion is
+-- invoked just after analysis since no resolution needs
+-- to be performed. For expressions, expansion is done just
+-- after resolution. In both cases expansion is done from the
+-- bottom up just before the end of Analyze for instructions
+-- and declarations or the call to Resolve for expressions.
+-- The main routine driving expansion is Expand.
+-- See the spec of Expander for more details.
+--
+-- To summarize, in normal code generation mode we recursively traverse the
+-- abstract syntax tree top-down performing semantic analysis bottom
+-- up. For instructions and declarations, before the call to the Analyze
+-- routine completes we perform expansion since at that point we have all
+-- semantic information needed. For expression nodes, after the call to
+-- Analysis terminates we invoke the Resolve routine to transmit top-down
+-- the type that was gathered by Analyze which will resolve possible
+-- ambiguities in the expression. Just before the call to Resolve
+-- terminates, the expression can be expanded since all the semantic
+-- information is available at that point.
+--
+-- If we are not generating code then the expansion phase is a no-op.
+--
+-- When generating code there are a number of exceptions to the basic
+-- Analysis-Resolution-Expansion model for expressions. The most prominent
+-- examples are the handling of default expressions and aggregates.
+
+-------------------------------------
+-- Handling of Default Expressions --
+-------------------------------------
+
+-- The default expressions in component declarations and in procedure
+-- specifications (but not the ones in object declarations) are quite
+-- tricky to handle. The problem is that some processing is required
+-- at the point where the expression appears:
+--
+-- visibility analysis (including user defined operators)
+-- freezing of static expressions
+--
+-- but other processing must be deferred until the enclosing entity
+-- (record or procedure specification) is frozen:
+--
+-- freezing of any other types in the expression
+-- expansion
+--
+-- Expansion has to be deferred since you can't generate code for
+-- expressions that refernce types that have not been frozen yet. As an
+-- example, consider the following:
+--
+-- type x is delta 0.5 range -10.0 .. +10.0;
+-- ...
+-- type q is record
+-- xx : x := y * z;
+-- end record;
+--
+-- for x'small use 0.25
+--
+-- The expander is in charge of dealing with fixed-point, and of course
+-- the small declaration, which is not too late, since the declaration of
+-- type q does *not* freeze type x, definitely affects the expanded code.
+--
+-- Generally our model is to combine analysis resolution and expansion, but
+-- this is the one case where this model falls down. Here is how we patch
+-- it up without causing too much distortion to our basic model.
+--
+-- A switch (sede below) is set to indicate that we are in the initial
+-- occurence of a default expression. The analyzer is then called on this
+-- expression with the switch set true. Analysis and resolution proceed
+-- almost as usual, except that Freeze_Expression will not freeze
+-- non-static expressions if this switch is set, and the call to Expand at
+-- the end of resolution is skipped. This also skips the code that normally
+-- sets the Analyzed flag to True). The result is that when we are done the
+-- tree is still marked as unanalyzed, but all types for static expressions
+-- are frozen as required, and all entities of variables have been
+-- recorded. We then turn off the switch, and later on reanalyze the
+-- expression with the switch off. The effect is that this second analysis
+-- freezes the rest of the types as required, and generates code but
+-- visibility analysis is not repeated since all the entities are marked.
+--
+-- The second analysis (the one that generates code) is in the context
+-- where the code is required. For a record field default, this is in
+-- the initialization procedure for the record and for a subprogram
+-- default parameter, it is at the point the subprogram is frozen.
+
+------------------
+-- Pre-Analysis --
+------------------
+
+-- For certain kind of expressions, such as aggregates, we need to defer
+-- expansion of the aggregate and its inner expressions after the whole
+-- set of expressions appearing inside the aggregate have been analyzed.
+-- Consider, for instance the following example:
+--
+-- (1 .. 100 => new Thing (Function_Call))
+--
+-- The normal Analysis-Resolution-Expansion mechanism where expansion
+-- of the children is performed before expansion of the parent does not
+-- work if the code generated for the children by the expander needs
+-- to be evaluated repeatdly (for instance in the above aggregate
+-- "new Thing (Function_Call)" needs to be called 100 times.)
+-- The reason why this mecanism does not work is that, the expanded code
+-- for the children is typically inserted above the parent and thus
+-- when the father gets expanded no re-evaluation takes place. For instance
+-- in the case of aggregates if "new Thing (Function_Call)" is expanded
+-- before of the aggregate the expanded code will be placed outside
+-- of the aggregate and when expanding the aggregate the loop from 1 to 100
+-- will not surround the expanded code for "new Thing (Function_Call)".
+--
+-- To remedy this situation we introduce a new flag which signals whether
+-- we want a full analysis (ie expansion is enabled) or a pre-analysis
+-- which performs Analysis and Resolution but no expansion.
+--
+-- After the complete pre-analysis of an expression has been carried out
+-- we can transform the expression and then carry out the full
+-- Analyze-Resolve-Expand cycle on the transformed expression top-down
+-- so that the expansion of inner expressions happens inside the newly
+-- generated node for the parent expression.
+--
+-- Note that the difference between processing of default expressions and
+-- pre-analysis of other expressions is that we do carry out freezing in
+-- the latter but not in the former (except for static scalar expressions).
+-- The routine that performs pre-analysis is called Pre_Analyze_And_Resolve
+-- and is in Sem_Res.
+
+with Alloc;
+with Einfo; use Einfo;
+with Opt; use Opt;
+with Snames; use Snames;
+with Table;
+with Types; use Types;
+
+package Sem is
+
+ New_Nodes_OK : Int := 1;
+ -- Temporary flag for use in checking out HLO. Set non-zero if it is
+ -- OK to generate new nodes.
+
+ -----------------------------
+ -- Semantic Analysis Flags --
+ -----------------------------
+
+ Full_Analysis : Boolean := True;
+ -- Switch to indicate whether we are doing a full analysis or a
+ -- pre-analysis. In normal analysis mode (Analysis-Expansion for
+ -- instructions or declarations) or (Analysis-Resolution-Expansion for
+ -- expressions) this flag is set. Note that if we are not generating
+ -- code the expansion phase merely sets the Analyzed flag to True in
+ -- this case. If we are in Pre-Analysis mode (see above) this flag is
+ -- set to False then the expansion phase is skipped.
+ -- When this flag is False the flag Expander_Active is also False
+ -- (the Expander_Activer flag defined in the spec of package Expander
+ -- tells you whether expansion is currently enabled).
+ -- You should really regard this as a read only flag.
+
+ In_Default_Expression : Boolean := False;
+ -- Switch to indicate that we are in a default expression, as described
+ -- above. Note that this must be recursively saved on a Semantics call
+ -- since it is possible for the analysis of an expression to result in
+ -- a recursive call (e.g. to get the entity for System.Address as part
+ -- of the processing of an Address attribute reference).
+ -- When this switch is True then Full_Analysis above must be False.
+ -- You should really regard this as a read only flag.
+
+ In_Inlined_Body : Boolean := False;
+ -- Switch to indicate that we are analyzing and resolving an inlined
+ -- body. Type checking is disabled in this context, because types are
+ -- known to be compatible. This avoids problems with private types whose
+ -- full view is derived from private types.
+
+ Inside_A_Generic : Boolean := False;
+ -- This flag is set if we are processing a generic specification,
+ -- generic definition, or generic body. When this flag is True the
+ -- Expander_Active flag is False to disable any code expansion (see
+ -- package Expander). Only the generic processing can modify the
+ -- status of this flag, any other client should regard it as read-only.
+
+ Unloaded_Subunits : Boolean := False;
+ -- This flag is set True if we have subunits that are not loaded. This
+ -- occurs when the main unit is a subunit, and contains lower level
+ -- subunits that are not loaded. We use this flag to suppress warnings
+ -- about unused variables, since these warnings are unreliable in this
+ -- case. We could perhaps do a more accurate job and retain some of the
+ -- warnings, but it is quite a tricky job. See test 4323-002.
+
+ -----------------
+ -- Scope Stack --
+ -----------------
+
+ Scope_Suppress : Suppress_Record := Suppress_Options;
+ -- This record contains the current scope based settings of the suppress
+ -- switches. It is initialized from the options as shown, and then modified
+ -- by pragma Suppress. On entry to each scope, the current setting is saved
+ -- the scope stack, and then restored on exit from the scope.
+
+ -- The scope stack holds all entries of the scope table. As in the parser,
+ -- we use Last as the stack pointer, so that we can always find the scope
+ -- that is currently open in Scope_Stack.Table (Scope_Stack.Last). The
+ -- oldest entry, at Scope_Stack (0) is Standard. The entries in the table
+ -- include the entity for the referenced scope, together with information
+ -- used to restore the proper setting of check suppressions on scope exit.
+
+ -- There are two kinds of suppress checks, scope based suppress checks
+ -- (from initial command line arguments, or from Suppress pragmas not
+ -- including an entity name). The scope based suppress checks are recorded
+ -- in the Sem.Supress variable, and all that is necessary is to save the
+ -- state of this variable on scope entry, and restore it on scope exit.
+
+ -- The other kind of suppress check is entity based suppress checks, from
+ -- Suppress pragmas giving an Entity_Id. These checks are reflected by the
+ -- appropriate bit being set in the corresponding entity, and restoring the
+ -- setting of these bits is a little trickier. In particular a given pragma
+ -- Suppress may or may not affect the current state. If it sets a check for
+ -- an entity that is already checked, then it is important that this check
+ -- not be restored on scope exit. The situation is made more complicated
+ -- by the fact that a given suppress pragma can specify multiple entities
+ -- (in the overloaded case), and multiple checks (by using All_Checks), so
+ -- that it may be partially effective. On exit only checks that were in
+ -- fact effective must be removed. Logically we could do this by saving
+ -- the entire state of the entity flags on scope entry and restoring them
+ -- on scope exit, but that would be ludicrous, so what we do instead is to
+ -- maintain the following differential structure that shows what checks
+ -- were installed for the current scope.
+
+ -- Note: Suppress pragmas that specify entities defined in a package
+ -- spec do not make entries in this table, since such checks suppress
+ -- requests are valid for the entire life of the entity.
+
+ type Entity_Check_Suppress_Record is record
+ Entity : Entity_Id;
+ -- Entity to which the check applies
+
+ Check : Check_Id;
+ -- Check which is set (note this cannot be All_Checks, if the All_Checks
+ -- case, a sequence of eentries appears for the individual checks.
+ end record;
+
+ -- Entity_Suppress is a stack, to which new entries are added as they
+ -- are processed (see pragma Suppress circuit in Sem_Prag). The scope
+ -- stack entry simply saves the stack pointer on entry, and restores
+ -- it on exit by reversing the checks one by one.
+
+ package Entity_Suppress is new Table.Table (
+ Table_Component_Type => Entity_Check_Suppress_Record,
+ Table_Index_Type => Int,
+ Table_Low_Bound => 0,
+ Table_Initial => Alloc.Entity_Suppress_Initial,
+ Table_Increment => Alloc.Entity_Suppress_Increment,
+ Table_Name => "Entity_Suppress");
+
+ -- Here is the scope stack itself
+
+ type Scope_Stack_Entry is record
+ Entity : Entity_Id;
+ -- Entity representing the scope
+
+ Last_Subprogram_Name : String_Ptr;
+ -- Pointer to name of last subprogram body in this scope. Used for
+ -- testing proper alpha ordering of subprogram bodies in scope.
+
+ Save_Scope_Suppress : Suppress_Record;
+ -- Save contents of Scope_Suppress on entry
+
+ Save_Entity_Suppress : Int;
+ -- Save contents of Entity_Suppress.Last on entry
+
+ Is_Transient : Boolean;
+ -- Marks Transient Scopes (See Exp_Ch7 body for details)
+
+ Previous_Visibility : Boolean;
+ -- Used when installing the parent (s) of the current compilation
+ -- unit. The parent may already be visible because of an ongoing
+ -- compilation, and the proper visibility must be restored on exit.
+
+ Node_To_Be_Wrapped : Node_Id;
+ -- Only used in transient scopes. Records the node which will
+ -- be wrapped by the transient block.
+
+ Actions_To_Be_Wrapped_Before : List_Id;
+ Actions_To_Be_Wrapped_After : List_Id;
+ -- Actions that have to be inserted at the start or at the end of a
+ -- transient block. Used to temporarily hold these actions until the
+ -- block is created, at which time the actions are moved to the
+ -- block.
+
+ Pending_Freeze_Actions : List_Id;
+ -- Used to collect freeze entity nodes and associated actions that
+ -- are generated in a inner context but need to be analyzed outside,
+ -- such as records and initialization procedures. On exit from the
+ -- scope, this list of actions is inserted before the scope construct
+ -- and analyzed to generate the corresponding freeze processing and
+ -- elaboration of other associated actions.
+
+ First_Use_Clause : Node_Id;
+ -- Head of list of Use_Clauses in current scope. The list is built
+ -- when the declarations in the scope are processed. The list is
+ -- traversed on scope exit to undo the effect of the use clauses.
+
+ Component_Alignment_Default : Component_Alignment_Kind;
+ -- Component alignment to be applied to any record or array types
+ -- that are declared for which a specific component alignment pragma
+ -- does not set the alignment.
+
+ Is_Active_Stack_Base : Boolean;
+ -- Set to true only when entering the scope for Standard_Standard from
+ -- from within procedure Semantics. Indicates the base of the current
+ -- active set of scopes. Needed by In_Open_Scopes to handle cases
+ -- where Standard_Standard can be pushed in the middle of the active
+ -- set of scopes (occurs for instantiations of generic child units).
+ end record;
+
+ package Scope_Stack is new Table.Table (
+ Table_Component_Type => Scope_Stack_Entry,
+ Table_Index_Type => Int,
+ Table_Low_Bound => 0,
+ Table_Initial => Alloc.Scope_Stack_Initial,
+ Table_Increment => Alloc.Scope_Stack_Increment,
+ Table_Name => "Sem.Scope_Stack");
+
+ function Get_Scope_Suppress (C : Check_Id) return Boolean;
+ -- Get suppress status of check C for the current scope
+
+ procedure Set_Scope_Suppress (C : Check_Id; B : Boolean);
+ -- Set suppress status of check C for the current scope
+
+ -----------------
+ -- Subprograms --
+ -----------------
+
+ procedure Initialize;
+ -- Initialize internal tables
+
+ procedure Lock;
+ -- Lock internal tables before calling back end
+
+ procedure Semantics (Comp_Unit : Node_Id);
+ -- This procedure is called to perform semantic analysis on the specified
+ -- node which is the N_Compilation_Unit node for the unit.
+
+ procedure Analyze (N : Node_Id);
+ procedure Analyze (N : Node_Id; Suppress : Check_Id);
+ -- This is the recursive procedure which is applied to individual nodes
+ -- of the tree, starting at the top level node (compilation unit node)
+ -- and then moving down the tree in a top down traversal. It calls
+ -- individual routines with names Analyze_xxx to analyze node xxx. Each
+ -- of these routines is responsible for calling Analyze on the components
+ -- of the subtree.
+ --
+ -- Note: In the case of expression components (nodes whose Nkind is in
+ -- N_Subexpr), the call to Analyze does not complete the semantic analysis
+ -- of the node, since the type resolution cannot be completed until the
+ -- complete context is analyzed. The completion of the type analysis occurs
+ -- in the corresponding Resolve routine (see Sem_Res).
+ --
+ -- Note: for integer and real literals, the analyzer sets the flag to
+ -- indicate that the result is a static expression. If the expander
+ -- generates a literal that does NOT correspond to a static expression,
+ -- e.g. by folding an expression whose value is known at compile-time,
+ -- but is not technically static, then the caller should reset the
+ -- Is_Static_Expression flag after analyzing but before resolving.
+ --
+ -- If the Suppress argument is present, then the analysis is done
+ -- with the specified check suppressed (can be All_Checks to suppress
+ -- all checks).
+
+ procedure Analyze_List (L : List_Id);
+ procedure Analyze_List (L : List_Id; Suppress : Check_Id);
+ -- Analyzes each element of a list. If the Suppress argument is present,
+ -- then the analysis is done with the specified check suppressed (can
+ -- be All_Checks to suppress all checks).
+
+ procedure Insert_List_After_And_Analyze
+ (N : Node_Id; L : List_Id);
+ procedure Insert_List_After_And_Analyze
+ (N : Node_Id; L : List_Id; Suppress : Check_Id);
+ -- Inserts list L after node N using Nlists.Insert_List_After, and then,
+ -- after this insertion is complete, analyzes all the nodes in the list,
+ -- including any additional nodes generated by this analysis. If the list
+ -- is empty or be No_List, the call has no effect. If the Suppress
+ -- argument is present, then the analysis is done with the specified
+ -- check suppressed (can be All_Checks to suppress all checks).
+
+ procedure Insert_List_Before_And_Analyze
+ (N : Node_Id; L : List_Id);
+ procedure Insert_List_Before_And_Analyze
+ (N : Node_Id; L : List_Id; Suppress : Check_Id);
+ -- Inserts list L before node N using Nlists.Insert_List_Before, and then,
+ -- after this insertion is complete, analyzes all the nodes in the list,
+ -- including any additional nodes generated by this analysis. If the list
+ -- is empty or be No_List, the call has no effect. If the Suppress
+ -- argument is present, then the analysis is done with the specified
+ -- check suppressed (can be All_Checks to suppress all checks).
+
+ procedure Insert_After_And_Analyze
+ (N : Node_Id; M : Node_Id);
+ procedure Insert_After_And_Analyze
+ (N : Node_Id; M : Node_Id; Suppress : Check_Id);
+ -- Inserts node M after node N and then after the insertion is complete,
+ -- analyzes the inserted node and all nodes that are generated by
+ -- this analysis. If the node is empty, the call has no effect. If the
+ -- Suppress argument is present, then the analysis is done with the
+ -- specified check suppressed (can be All_Checks to suppress all checks).
+
+ procedure Insert_Before_And_Analyze
+ (N : Node_Id; M : Node_Id);
+ procedure Insert_Before_And_Analyze
+ (N : Node_Id; M : Node_Id; Suppress : Check_Id);
+ -- Inserts node M before node N and then after the insertion is complete,
+ -- analyzes the inserted node and all nodes that could be generated by
+ -- this analysis. If the node is empty, the call has no effect. If the
+ -- Suppress argument is present, then the analysis is done with the
+ -- specified check suppressed (can be All_Checks to suppress all checks).
+
+ function External_Ref_In_Generic (E : Entity_Id) return Boolean;
+ -- Return True if we are in the context of a generic and E is
+ -- external (more global) to it.
+
+ procedure Enter_Generic_Scope (S : Entity_Id);
+ -- Shall be called each time a Generic subprogram or package scope is
+ -- entered. S is the entity of the scope.
+ -- ??? At the moment, only called for package specs because this mechanism
+ -- is only used for avoiding freezing of external references in generics
+ -- and this can only be an issue if the outer generic scope is a package
+ -- spec (otherwise all external entities are already frozen)
+
+ procedure Exit_Generic_Scope (S : Entity_Id);
+ -- Shall be called each time a Generic subprogram or package scope is
+ -- exited. S is the entity of the scope.
+ -- ??? At the moment, only called for package specs exit.
+
+end Sem;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S E M _ A G G R --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.232 $
+-- --
+-- 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). --
+-- --
+------------------------------------------------------------------------------
+
+with Atree; use Atree;
+with Checks; use Checks;
+with Einfo; use Einfo;
+with Elists; use Elists;
+with Errout; use Errout;
+with Exp_Util; use Exp_Util;
+with Freeze; use Freeze;
+with Itypes; use Itypes;
+with Namet; use Namet;
+with Nmake; use Nmake;
+with Nlists; use Nlists;
+with Opt; use Opt;
+with Sem; use Sem;
+with Sem_Cat; use Sem_Cat;
+with Sem_Ch8; use Sem_Ch8;
+with Sem_Ch13; use Sem_Ch13;
+with Sem_Eval; use Sem_Eval;
+with Sem_Res; use Sem_Res;
+with Sem_Util; use Sem_Util;
+with Sem_Type; use Sem_Type;
+with Sinfo; use Sinfo;
+with Snames; use Snames;
+with Stringt; use Stringt;
+with Stand; use Stand;
+with Tbuild; use Tbuild;
+with Uintp; use Uintp;
+
+with GNAT.Spelling_Checker; use GNAT.Spelling_Checker;
+
+package body Sem_Aggr is
+
+ type Case_Bounds is record
+ Choice_Lo : Node_Id;
+ Choice_Hi : Node_Id;
+ Choice_Node : Node_Id;
+ end record;
+
+ type Case_Table_Type is array (Nat range <>) of Case_Bounds;
+ -- Table type used by Check_Case_Choices procedure
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ procedure Sort_Case_Table (Case_Table : in out Case_Table_Type);
+ -- Sort the Case Table using the Lower Bound of each Choice as the key.
+ -- A simple insertion sort is used since the number of choices in a case
+ -- statement of variant part will usually be small and probably in near
+ -- sorted order.
+
+ ------------------------------------------------------
+ -- Subprograms used for RECORD AGGREGATE Processing --
+ ------------------------------------------------------
+
+ procedure Resolve_Record_Aggregate (N : Node_Id; Typ : Entity_Id);
+ -- This procedure performs all the semantic checks required for record
+ -- aggregates. Note that for aggregates analysis and resolution go
+ -- hand in hand. Aggregate analysis has been delayed up to here and
+ -- it is done while resolving the aggregate.
+ --
+ -- N is the N_Aggregate node.
+ -- Typ is the record type for the aggregate resolution
+ --
+ -- While performing the semantic checks, this procedure
+ -- builds a new Component_Association_List where each record field
+ -- appears alone in a Component_Choice_List along with its corresponding
+ -- expression. The record fields in the Component_Association_List
+ -- appear in the same order in which they appear in the record type Typ.
+ --
+ -- Once this new Component_Association_List is built and all the
+ -- semantic checks performed, the original aggregate subtree is replaced
+ -- with the new named record aggregate just built. Note that the subtree
+ -- substitution is performed with Rewrite so as to be
+ -- able to retrieve the original aggregate.
+ --
+ -- The aggregate subtree manipulation performed by Resolve_Record_Aggregate
+ -- yields the aggregate format expected by Gigi. Typically, this kind of
+ -- tree manipulations are done in the expander. However, because the
+ -- semantic checks that need to be performed on record aggregates really
+ -- go hand in hand with the record aggreagate normalization, the aggregate
+ -- subtree transformation is performed during resolution rather than
+ -- expansion. Had we decided otherwise we would have had to duplicate
+ -- most of the code in the expansion procedure Expand_Record_Aggregate.
+ -- Note, however, that all the expansion concerning aggegates for tagged
+ -- records is done in Expand_Record_Aggregate.
+ --
+ -- The algorithm of Resolve_Record_Aggregate proceeds as follows:
+ --
+ -- 1. Make sure that the record type against which the record aggregate
+ -- has to be resolved is not abstract. Furthermore if the type is
+ -- a null aggregate make sure the input aggregate N is also null.
+ --
+ -- 2. Verify that the structure of the aggregate is that of a record
+ -- aggregate. Specifically, look for component associations and ensure
+ -- that each choice list only has identifiers or the N_Others_Choice
+ -- node. Also make sure that if present, the N_Others_Choice occurs
+ -- last and by itself.
+ --
+ -- 3. If Typ contains discriminants, the values for each discriminant
+ -- is looked for. If the record type Typ has variants, we check
+ -- that the expressions corresponding to each discriminant ruling
+ -- the (possibly nested) variant parts of Typ, are static. This
+ -- allows us to determine the variant parts to which the rest of
+ -- the aggregate must conform. The names of discriminants with their
+ -- values are saved in a new association list, New_Assoc_List which
+ -- is later augmented with the names and values of the remaining
+ -- components in the record type.
+ --
+ -- During this phase we also make sure that every discriminant is
+ -- assigned exactly one value. Note that when several values
+ -- for a given discriminant are found, semantic processing continues
+ -- looking for further errors. In this case it's the first
+ -- discriminant value found which we will be recorded.
+ --
+ -- IMPORTANT NOTE: For derived tagged types this procedure expects
+ -- First_Discriminant and Next_Discriminant to give the correct list
+ -- of discriminants, in the correct order.
+ --
+ -- 4. After all the discriminant values have been gathered, we can
+ -- set the Etype of the record aggregate. If Typ contains no
+ -- discriminants this is straightforward: the Etype of N is just
+ -- Typ, otherwise a new implicit constrained subtype of Typ is
+ -- built to be the Etype of N.
+ --
+ -- 5. Gather the remaining record components according to the discriminant
+ -- values. This involves recursively traversing the record type
+ -- structure to see what variants are selected by the given discriminant
+ -- values. This processing is a little more convoluted if Typ is a
+ -- derived tagged types since we need to retrieve the record structure
+ -- of all the ancestors of Typ.
+ --
+ -- 6. After gathering the record components we look for their values
+ -- in the record aggregate and emit appropriate error messages
+ -- should we not find such values or should they be duplicated.
+ --
+ -- 7. We then make sure no illegal component names appear in the
+ -- record aggegate and make sure that the type of the record
+ -- components appearing in a same choice list is the same.
+ -- Finally we ensure that the others choice, if present, is
+ -- used to provide the value of at least a record component.
+ --
+ -- 8. The original aggregate node is replaced with the new named
+ -- aggregate built in steps 3 through 6, as explained earlier.
+ --
+ -- Given the complexity of record aggregate resolution, the primary
+ -- goal of this routine is clarity and simplicity rather than execution
+ -- and storage efficiency. If there are only positional components in the
+ -- aggregate the running time is linear. If there are associations
+ -- the running time is still linear as long as the order of the
+ -- associations is not too far off the order of the components in the
+ -- record type. If this is not the case the running time is at worst
+ -- quadratic in the size of the association list.
+
+ procedure Check_Misspelled_Component
+ (Elements : Elist_Id;
+ Component : Node_Id);
+ -- Give possible misspelling diagnostic if Component is likely to be
+ -- a misspelling of one of the components of the Assoc_List.
+ -- This is called by Resolv_Aggr_Expr after producing
+ -- an invalid component error message.
+
+ procedure Check_Static_Discriminated_Subtype (T : Entity_Id; V : Node_Id);
+ -- An optimization: determine whether a discriminated subtype has a
+ -- static constraint, and contains array components whose length is also
+ -- static, either because they are constrained by the discriminant, or
+ -- because the original component bounds are static.
+
+ -----------------------------------------------------
+ -- Subprograms used for ARRAY AGGREGATE Processing --
+ -----------------------------------------------------
+
+ function Resolve_Array_Aggregate
+ (N : Node_Id;
+ Index : Node_Id;
+ Index_Constr : Node_Id;
+ Component_Typ : Entity_Id;
+ Others_Allowed : Boolean)
+ return Boolean;
+ -- This procedure performs the semantic checks for an array aggregate.
+ -- True is returned if the aggregate resolution succeeds.
+ -- The procedure works by recursively checking each nested aggregate.
+ -- Specifically, after checking a sub-aggreate nested at the i-th level
+ -- we recursively check all the subaggregates at the i+1-st level (if any).
+ -- Note that for aggregates analysis and resolution go hand in hand.
+ -- Aggregate analysis has been delayed up to here and it is done while
+ -- resolving the aggregate.
+ --
+ -- N is the current N_Aggregate node to be checked.
+ --
+ -- Index is the index node corresponding to the array sub-aggregate that
+ -- we are currently checking (RM 4.3.3 (8)). Its Etype is the
+ -- corresponding index type (or subtype).
+ --
+ -- Index_Constr is the node giving the applicable index constraint if
+ -- any (RM 4.3.3 (10)). It "is a constraint provided by certain
+ -- contexts [...] that can be used to determine the bounds of the array
+ -- value specified by the aggregate". If Others_Allowed below is False
+ -- there is no applicable index constraint and this node is set to Index.
+ --
+ -- Component_Typ is the array component type.
+ --
+ -- Others_Allowed indicates whether an others choice is allowed
+ -- in the context where the top-level aggregate appeared.
+ --
+ -- The algorithm of Resolve_Array_Aggregate proceeds as follows:
+ --
+ -- 1. Make sure that the others choice, if present, is by itself and
+ -- appears last in the sub-aggregate. Check that we do not have
+ -- positional and named components in the array sub-aggregate (unless
+ -- the named association is an others choice). Finally if an others
+ -- choice is present, make sure it is allowed in the aggregate contex.
+ --
+ -- 2. If the array sub-aggregate contains discrete_choices:
+ --
+ -- (A) Verify their validity. Specifically verify that:
+ --
+ -- (a) If a null range is present it must be the only possible
+ -- choice in the array aggregate.
+ --
+ -- (b) Ditto for a non static range.
+ --
+ -- (c) Ditto for a non static expression.
+ --
+ -- In addition this step analyzes and resolves each discrete_choice,
+ -- making sure that its type is the type of the corresponding Index.
+ -- If we are not at the lowest array aggregate level (in the case of
+ -- multi-dimensional aggregates) then invoke Resolve_Array_Aggregate
+ -- recursively on each component expression. Otherwise, resolve the
+ -- bottom level component expressions against the expected component
+ -- type ONLY IF the component corresponds to a single discrete choice
+ -- which is not an others choice (to see why read the DELAYED
+ -- COMPONENT RESOLUTION below).
+ --
+ -- (B) Determine the bounds of the sub-aggregate and lowest and
+ -- highest choice values.
+ --
+ -- 3. For positional aggregates:
+ --
+ -- (A) Loop over the component expressions either recursively invoking
+ -- Resolve_Array_Aggregate on each of these for multi-dimensional
+ -- array aggregates or resolving the bottom level component
+ -- expressions against the expected component type.
+ --
+ -- (B) Determine the bounds of the positional sub-aggregates.
+ --
+ -- 4. Try to determine statically whether the evaluation of the array
+ -- sub-aggregate raises Constraint_Error. If yes emit proper
+ -- warnings. The precise checks are the following:
+ --
+ -- (A) Check that the index range defined by aggregate bounds is
+ -- compatible with corresponding index subtype.
+ -- We also check against the base type. In fact it could be that
+ -- Low/High bounds of the base type are static whereas those of
+ -- the index subtype are not. Thus if we can statically catch
+ -- a problem with respect to the base type we are guaranteed
+ -- that the same problem will arise with the index subtype
+ --
+ -- (B) If we are dealing with a named aggregate containing an others
+ -- choice and at least one discrete choice then make sure the range
+ -- specified by the discrete choices does not overflow the
+ -- aggregate bounds. We also check against the index type and base
+ -- type bounds for the same reasons given in (A).
+ --
+ -- (C) If we are dealing with a positional aggregate with an others
+ -- choice make sure the number of positional elements specified
+ -- does not overflow the aggregate bounds. We also check against
+ -- the index type and base type bounds as mentioned in (A).
+ --
+ -- Finally construct an N_Range node giving the sub-aggregate bounds.
+ -- Set the Aggregate_Bounds field of the sub-aggregate to be this
+ -- N_Range. The routine Array_Aggr_Subtype below uses such N_Ranges
+ -- to build the appropriate aggregate subtype. Aggregate_Bounds
+ -- information is needed during expansion.
+ --
+ -- DELAYED COMPONENT RESOLUTION: The resolution of bottom level component
+ -- expressions in an array aggregate may call Duplicate_Subexpr or some
+ -- other routine that inserts code just outside the outermost aggregate.
+ -- If the array aggregate contains discrete choices or an others choice,
+ -- this may be wrong. Consider for instance the following example.
+ --
+ -- type Rec is record
+ -- V : Integer := 0;
+ -- end record;
+ --
+ -- type Acc_Rec is access Rec;
+ -- Arr : array (1..3) of Acc_Rec := (1 .. 3 => new Rec);
+ --
+ -- Then the transformation of "new Rec" that occurs during resolution
+ -- entails the following code modifications
+ --
+ -- P7b : constant Acc_Rec := new Rec;
+ -- Rec_init_proc (P7b.all);
+ -- Arr : array (1..3) of Acc_Rec := (1 .. 3 => P7b);
+ --
+ -- This code transformation is clearly wrong, since we need to call
+ -- "new Rec" for each of the 3 array elements. To avoid this problem we
+ -- delay resolution of the components of non positional array aggregates
+ -- to the expansion phase. As an optimization, if the discrete choice
+ -- specifies a single value we do not delay resolution.
+
+ function Array_Aggr_Subtype (N : Node_Id; Typ : Node_Id) return Entity_Id;
+ -- This routine returns the type or subtype of an array aggregate.
+ --
+ -- N is the array aggregate node whose type we return.
+ --
+ -- Typ is the context type in which N occurs.
+ --
+ -- This routine creates an implicit array subtype whose bouds are
+ -- those defined by the aggregate. When this routine is invoked
+ -- Resolve_Array_Aggregate has already processed aggregate N. Thus the
+ -- Aggregate_Bounds of each sub-aggregate, is an N_Range node giving the
+ -- sub-aggregate bounds. When building the aggegate itype, this function
+ -- traverses the array aggregate N collecting such Aggregate_Bounds and
+ -- constructs the proper array aggregate itype.
+ --
+ -- Note that in the case of multidimensional aggregates each inner
+ -- sub-aggregate corresponding to a given array dimension, may provide a
+ -- different bounds. If it is possible to determine statically that
+ -- some sub-aggregates corresponding to the same index do not have the
+ -- same bounds, then a warning is emitted. If such check is not possible
+ -- statically (because some sub-aggregate bounds are dynamic expressions)
+ -- then this job is left to the expander. In all cases the particular
+ -- bounds that this function will chose for a given dimension is the first
+ -- N_Range node for a sub-aggregate corresponding to that dimension.
+ --
+ -- Note that the Raises_Constraint_Error flag of an array aggregate
+ -- whose evaluation is determined to raise CE by Resolve_Array_Aggregate,
+ -- is set in Resolve_Array_Aggregate but the aggregate is not
+ -- immediately replaced with a raise CE. In fact, Array_Aggr_Subtype must
+ -- first construct the proper itype for the aggregate (Gigi needs
+ -- this). After constructing the proper itype we will eventually replace
+ -- the top-level aggregate with a raise CE (done in Resolve_Aggregate).
+ -- Of course in cases such as:
+ --
+ -- type Arr is array (integer range <>) of Integer;
+ -- A : Arr := (positive range -1 .. 2 => 0);
+ --
+ -- The bounds of the aggregate itype are cooked up to look reasonable
+ -- (in this particular case the bounds will be 1 .. 2).
+
+ procedure Aggregate_Constraint_Checks
+ (Exp : Node_Id;
+ Check_Typ : Entity_Id);
+ -- Checks expression Exp against subtype Check_Typ. If Exp is an
+ -- aggregate and Check_Typ a constrained record type with discriminants,
+ -- we generate the appropriate discriminant checks. If Exp is an array
+ -- aggregate then emit the appropriate length checks. If Exp is a scalar
+ -- type, or a string literal, Exp is changed into Check_Typ'(Exp) to
+ -- ensure that range checks are performed at run time.
+
+ procedure Make_String_Into_Aggregate (N : Node_Id);
+ -- A string literal can appear in a context in which a one dimensional
+ -- array of characters is expected. This procedure simply rewrites the
+ -- string as an aggregate, prior to resolution.
+
+ ---------------------------------
+ -- Aggregate_Constraint_Checks --
+ ---------------------------------
+
+ procedure Aggregate_Constraint_Checks
+ (Exp : Node_Id;
+ Check_Typ : Entity_Id)
+ is
+ Exp_Typ : constant Entity_Id := Etype (Exp);
+
+ begin
+ if Raises_Constraint_Error (Exp) then
+ return;
+ end if;
+
+ -- This is really expansion activity, so make sure that expansion
+ -- is on and is allowed.
+
+ if not Expander_Active or else In_Default_Expression then
+ return;
+ end if;
+
+ -- First check if we have to insert discriminant checks
+
+ if Has_Discriminants (Exp_Typ) then
+ Apply_Discriminant_Check (Exp, Check_Typ);
+
+ -- Next emit length checks for array aggregates
+
+ elsif Is_Array_Type (Exp_Typ) then
+ Apply_Length_Check (Exp, Check_Typ);
+
+ -- Finally emit scalar and string checks. If we are dealing with a
+ -- scalar literal we need to check by hand because the Etype of
+ -- literals is not necessarily correct.
+
+ elsif Is_Scalar_Type (Exp_Typ)
+ and then Compile_Time_Known_Value (Exp)
+ then
+ if Is_Out_Of_Range (Exp, Base_Type (Check_Typ)) then
+ Apply_Compile_Time_Constraint_Error
+ (Exp, "value not in range of}?",
+ Ent => Base_Type (Check_Typ),
+ Typ => Base_Type (Check_Typ));
+
+ elsif Is_Out_Of_Range (Exp, Check_Typ) then
+ Apply_Compile_Time_Constraint_Error
+ (Exp, "value not in range of}?",
+ Ent => Check_Typ,
+ Typ => Check_Typ);
+
+ elsif not Range_Checks_Suppressed (Check_Typ) then
+ Apply_Scalar_Range_Check (Exp, Check_Typ);
+ end if;
+
+ elsif (Is_Scalar_Type (Exp_Typ)
+ or else Nkind (Exp) = N_String_Literal)
+ and then Exp_Typ /= Check_Typ
+ then
+ if Is_Entity_Name (Exp)
+ and then Ekind (Entity (Exp)) = E_Constant
+ then
+ -- If expression is a constant, it is worthwhile checking whether
+ -- it is a bound of the type.
+
+ if (Is_Entity_Name (Type_Low_Bound (Check_Typ))
+ and then Entity (Exp) = Entity (Type_Low_Bound (Check_Typ)))
+ or else (Is_Entity_Name (Type_High_Bound (Check_Typ))
+ and then Entity (Exp) = Entity (Type_High_Bound (Check_Typ)))
+ then
+ return;
+
+ else
+ Rewrite (Exp, Convert_To (Check_Typ, Relocate_Node (Exp)));
+ Analyze_And_Resolve (Exp, Check_Typ);
+ end if;
+ else
+ Rewrite (Exp, Convert_To (Check_Typ, Relocate_Node (Exp)));
+ Analyze_And_Resolve (Exp, Check_Typ);
+ end if;
+
+ end if;
+ end Aggregate_Constraint_Checks;
+
+ ------------------------
+ -- Array_Aggr_Subtype --
+ ------------------------
+
+ function Array_Aggr_Subtype
+ (N : Node_Id;
+ Typ : Entity_Id)
+ return Entity_Id
+ is
+ Aggr_Dimension : constant Pos := Number_Dimensions (Typ);
+ -- Number of aggregate index dimensions.
+
+ Aggr_Range : array (1 .. Aggr_Dimension) of Node_Id := (others => Empty);
+ -- Constrained N_Range of each index dimension in our aggregate itype.
+
+ Aggr_Low : array (1 .. Aggr_Dimension) of Node_Id := (others => Empty);
+ Aggr_High : array (1 .. Aggr_Dimension) of Node_Id := (others => Empty);
+ -- Low and High bounds for each index dimension in our aggregate itype.
+
+ Is_Fully_Positional : Boolean := True;
+
+ procedure Collect_Aggr_Bounds (N : Node_Id; Dim : Pos);
+ -- N is an array (sub-)aggregate. Dim is the dimension corresponding to
+ -- (sub-)aggregate N. This procedure collects the constrained N_Range
+ -- nodes corresponding to each index dimension of our aggregate itype.
+ -- These N_Range nodes are collected in Aggr_Range above.
+ -- Likewise collect in Aggr_Low & Aggr_High above the low and high
+ -- bounds of each index dimension. If, when collecting, two bounds
+ -- corresponding to the same dimension are static and found to differ,
+ -- then emit a warning, and mark N as raising Constraint_Error.
+
+ -------------------------
+ -- Collect_Aggr_Bounds --
+ -------------------------
+
+ procedure Collect_Aggr_Bounds (N : Node_Id; Dim : Pos) is
+ This_Range : constant Node_Id := Aggregate_Bounds (N);
+ -- The aggregate range node of this specific sub-aggregate.
+
+ This_Low : constant Node_Id := Low_Bound (Aggregate_Bounds (N));
+ This_High : constant Node_Id := High_Bound (Aggregate_Bounds (N));
+ -- The aggregate bounds of this specific sub-aggregate.
+
+ Assoc : Node_Id;
+ Expr : Node_Id;
+
+ begin
+ -- Collect the first N_Range for a given dimension that you find.
+ -- For a given dimension they must be all equal anyway.
+
+ if No (Aggr_Range (Dim)) then
+ Aggr_Low (Dim) := This_Low;
+ Aggr_High (Dim) := This_High;
+ Aggr_Range (Dim) := This_Range;
+
+ else
+ if Compile_Time_Known_Value (This_Low) then
+ if not Compile_Time_Known_Value (Aggr_Low (Dim)) then
+ Aggr_Low (Dim) := This_Low;
+
+ elsif Expr_Value (This_Low) /= Expr_Value (Aggr_Low (Dim)) then
+ Set_Raises_Constraint_Error (N);
+ Error_Msg_N ("Sub-aggregate low bound mismatch?", N);
+ Error_Msg_N ("Constraint_Error will be raised at run-time?",
+ N);
+ end if;
+ end if;
+
+ if Compile_Time_Known_Value (This_High) then
+ if not Compile_Time_Known_Value (Aggr_High (Dim)) then
+ Aggr_High (Dim) := This_High;
+
+ elsif
+ Expr_Value (This_High) /= Expr_Value (Aggr_High (Dim))
+ then
+ Set_Raises_Constraint_Error (N);
+ Error_Msg_N ("Sub-aggregate high bound mismatch?", N);
+ Error_Msg_N ("Constraint_Error will be raised at run-time?",
+ N);
+ end if;
+ end if;
+ end if;
+
+ if Dim < Aggr_Dimension then
+
+ -- Process positional components
+
+ if Present (Expressions (N)) then
+ Expr := First (Expressions (N));
+ while Present (Expr) loop
+ Collect_Aggr_Bounds (Expr, Dim + 1);
+ Next (Expr);
+ end loop;
+ end if;
+
+ -- Process component associations
+
+ if Present (Component_Associations (N)) then
+ Is_Fully_Positional := False;
+
+ Assoc := First (Component_Associations (N));
+ while Present (Assoc) loop
+ Expr := Expression (Assoc);
+ Collect_Aggr_Bounds (Expr, Dim + 1);
+ Next (Assoc);
+ end loop;
+ end if;
+ end if;
+ end Collect_Aggr_Bounds;
+
+ -- Array_Aggr_Subtype variables
+
+ Itype : Entity_Id;
+ -- the final itype of the overall aggregate
+
+ Index_Constraints : List_Id := New_List;
+ -- The list of index constraints of the aggregate itype.
+
+ -- Start of processing for Array_Aggr_Subtype
+
+ begin
+ -- Make sure that the list of index constraints is properly attached
+ -- to the tree, and then collect the aggregate bounds.
+
+ Set_Parent (Index_Constraints, N);
+ Collect_Aggr_Bounds (N, 1);
+
+ -- Build the list of constrained indices of our aggregate itype.
+
+ for J in 1 .. Aggr_Dimension loop
+ Create_Index : declare
+ Index_Base : Entity_Id := Base_Type (Etype (Aggr_Range (J)));
+ Index_Typ : Entity_Id;
+
+ begin
+ -- Construct the Index subtype
+
+ Index_Typ := Create_Itype (Subtype_Kind (Ekind (Index_Base)), N);
+
+ Set_Etype (Index_Typ, Index_Base);
+
+ if Is_Character_Type (Index_Base) then
+ Set_Is_Character_Type (Index_Typ);
+ end if;
+
+ Set_Size_Info (Index_Typ, (Index_Base));
+ Set_RM_Size (Index_Typ, RM_Size (Index_Base));
+ Set_First_Rep_Item (Index_Typ, First_Rep_Item (Index_Base));
+ Set_Scalar_Range (Index_Typ, Aggr_Range (J));
+
+ if Is_Discrete_Or_Fixed_Point_Type (Index_Typ) then
+ Set_RM_Size (Index_Typ, UI_From_Int (Minimum_Size (Index_Typ)));
+ end if;
+
+ Set_Etype (Aggr_Range (J), Index_Typ);
+
+ Append (Aggr_Range (J), To => Index_Constraints);
+ end Create_Index;
+ end loop;
+
+ -- Now build the Itype
+
+ Itype := Create_Itype (E_Array_Subtype, N);
+
+ Set_First_Rep_Item (Itype, First_Rep_Item (Typ));
+ Set_Component_Type (Itype, Component_Type (Typ));
+ Set_Convention (Itype, Convention (Typ));
+ Set_Depends_On_Private (Itype, Has_Private_Component (Typ));
+ Set_Etype (Itype, Base_Type (Typ));
+ Set_Has_Alignment_Clause (Itype, Has_Alignment_Clause (Typ));
+ Set_Is_Aliased (Itype, Is_Aliased (Typ));
+ Set_Suppress_Index_Checks (Itype, Suppress_Index_Checks (Typ));
+ Set_Suppress_Length_Checks (Itype, Suppress_Length_Checks (Typ));
+ Set_Depends_On_Private (Itype, Depends_On_Private (Typ));
+
+ Set_First_Index (Itype, First (Index_Constraints));
+ Set_Is_Constrained (Itype, True);
+ Set_Is_Internal (Itype, True);
+ Init_Size_Align (Itype);
+
+ -- A simple optimization: purely positional aggregates of static
+ -- components should be passed to gigi unexpanded whenever possible,
+ -- and regardless of the staticness of the bounds themselves. Subse-
+ -- quent checks in exp_aggr verify that type is not packed, etc.
+
+ Set_Size_Known_At_Compile_Time (Itype,
+ Is_Fully_Positional
+ and then Comes_From_Source (N)
+ and then Size_Known_At_Compile_Time (Component_Type (Typ)));
+
+ -- We always need a freeze node for a packed array subtype, so that
+ -- we can build the Packed_Array_Type corresponding to the subtype.
+ -- If expansion is disabled, the packed array subtype is not built,
+ -- and we must not generate a freeze node for the type, or else it
+ -- will appear incomplete to gigi.
+
+ if Is_Packed (Itype) and then not In_Default_Expression
+ and then Expander_Active
+ then
+ Freeze_Itype (Itype, N);
+ end if;
+
+ return Itype;
+ end Array_Aggr_Subtype;
+
+ --------------------------------
+ -- Check_Misspelled_Component --
+ --------------------------------
+
+ procedure Check_Misspelled_Component
+ (Elements : Elist_Id;
+ Component : Node_Id)
+ is
+ Max_Suggestions : constant := 2;
+
+ Nr_Of_Suggestions : Natural := 0;
+ Suggestion_1 : Entity_Id := Empty;
+ Suggestion_2 : Entity_Id := Empty;
+ Component_Elmt : Elmt_Id;
+
+ begin
+ -- All the components of List are matched against Component and
+ -- a count is maintained of possible misspellings. When at the
+ -- end of the analysis there are one or two (not more!) possible
+ -- misspellings, these misspellings will be suggested as
+ -- possible correction.
+
+ Get_Name_String (Chars (Component));
+
+ declare
+ S : constant String (1 .. Name_Len) :=
+ Name_Buffer (1 .. Name_Len);
+
+ begin
+
+ Component_Elmt := First_Elmt (Elements);
+
+ while Nr_Of_Suggestions <= Max_Suggestions
+ and then Present (Component_Elmt)
+ loop
+
+ Get_Name_String (Chars (Node (Component_Elmt)));
+
+ if Is_Bad_Spelling_Of (Name_Buffer (1 .. Name_Len), S) then
+ Nr_Of_Suggestions := Nr_Of_Suggestions + 1;
+
+ case Nr_Of_Suggestions is
+ when 1 => Suggestion_1 := Node (Component_Elmt);
+ when 2 => Suggestion_2 := Node (Component_Elmt);
+ when others => exit;
+ end case;
+ end if;
+
+ Next_Elmt (Component_Elmt);
+ end loop;
+
+ -- Report at most two suggestions
+
+ if Nr_Of_Suggestions = 1 then
+ Error_Msg_NE ("\possible misspelling of&",
+ Component, Suggestion_1);
+
+ elsif Nr_Of_Suggestions = 2 then
+ Error_Msg_Node_2 := Suggestion_2;
+ Error_Msg_NE ("\possible misspelling of& or&",
+ Component, Suggestion_1);
+ end if;
+ end;
+ end Check_Misspelled_Component;
+
+ ----------------------------------------
+ -- Check_Static_Discriminated_Subtype --
+ ----------------------------------------
+
+ procedure Check_Static_Discriminated_Subtype (T : Entity_Id; V : Node_Id) is
+ Disc : constant Entity_Id := First_Discriminant (T);
+ Comp : Entity_Id;
+ Ind : Entity_Id;
+
+ begin
+ if Has_Record_Rep_Clause (Base_Type (T)) then
+ return;
+
+ elsif Present (Next_Discriminant (Disc)) then
+ return;
+
+ elsif Nkind (V) /= N_Integer_Literal then
+ return;
+ end if;
+
+ Comp := First_Component (T);
+
+ while Present (Comp) loop
+
+ if Is_Scalar_Type (Etype (Comp)) then
+ null;
+
+ elsif Is_Private_Type (Etype (Comp))
+ and then Present (Full_View (Etype (Comp)))
+ and then Is_Scalar_Type (Full_View (Etype (Comp)))
+ then
+ null;
+
+ elsif Is_Array_Type (Etype (Comp)) then
+
+ if Is_Bit_Packed_Array (Etype (Comp)) then
+ return;
+ end if;
+
+ Ind := First_Index (Etype (Comp));
+
+ while Present (Ind) loop
+
+ if Nkind (Ind) /= N_Range
+ or else Nkind (Low_Bound (Ind)) /= N_Integer_Literal
+ or else Nkind (High_Bound (Ind)) /= N_Integer_Literal
+ then
+ return;
+ end if;
+
+ Next_Index (Ind);
+ end loop;
+
+ else
+ return;
+ end if;
+
+ Next_Component (Comp);
+ end loop;
+
+ -- On exit, all components have statically known sizes.
+
+ Set_Size_Known_At_Compile_Time (T);
+ end Check_Static_Discriminated_Subtype;
+
+ --------------------------------
+ -- Make_String_Into_Aggregate --
+ --------------------------------
+
+ procedure Make_String_Into_Aggregate (N : Node_Id) is
+ C : Char_Code;
+ C_Node : Node_Id;
+ Exprs : List_Id := New_List;
+ Loc : constant Source_Ptr := Sloc (N);
+ New_N : Node_Id;
+ P : Source_Ptr := Loc + 1;
+ Str : constant String_Id := Strval (N);
+ Strlen : constant Nat := String_Length (Str);
+
+ begin
+ for J in 1 .. Strlen loop
+ C := Get_String_Char (Str, J);
+ Set_Character_Literal_Name (C);
+
+ C_Node := Make_Character_Literal (P, Name_Find, C);
+ Set_Etype (C_Node, Any_Character);
+ Set_Analyzed (C_Node);
+ Append_To (Exprs, C_Node);
+
+ P := P + 1;
+ -- something special for wide strings ?
+ end loop;
+
+ New_N := Make_Aggregate (Loc, Expressions => Exprs);
+ Set_Analyzed (New_N);
+ Set_Etype (New_N, Any_Composite);
+
+ Rewrite (N, New_N);
+ end Make_String_Into_Aggregate;
+
+ -----------------------
+ -- Resolve_Aggregate --
+ -----------------------
+
+ procedure Resolve_Aggregate (N : Node_Id; Typ : Entity_Id) is
+ Pkind : constant Node_Kind := Nkind (Parent (N));
+
+ Aggr_Subtyp : Entity_Id;
+ -- The actual aggregate subtype. This is not necessarily the same as Typ
+ -- which is the subtype of the context in which the aggregate was found.
+
+ begin
+ if Is_Limited_Type (Typ) then
+ Error_Msg_N ("aggregate type cannot be limited", N);
+
+ elsif Is_Limited_Composite (Typ) then
+ Error_Msg_N ("aggregate type cannot have limited component", N);
+
+ elsif Is_Class_Wide_Type (Typ) then
+ Error_Msg_N ("type of aggregate cannot be class-wide", N);
+
+ elsif Typ = Any_String
+ or else Typ = Any_Composite
+ then
+ Error_Msg_N ("no unique type for aggregate", N);
+ Set_Etype (N, Any_Composite);
+
+ elsif Is_Array_Type (Typ) and then Null_Record_Present (N) then
+ Error_Msg_N ("null record forbidden in array aggregate", N);
+
+ elsif Is_Record_Type (Typ) then
+ Resolve_Record_Aggregate (N, Typ);
+
+ elsif Is_Array_Type (Typ) then
+
+ -- First a special test, for the case of a positional aggregate
+ -- of characters which can be replaced by a string literal.
+ -- Do not perform this transformation if this was a string literal
+ -- to start with, whose components needed constraint checks, or if
+ -- the component type is non-static, because it will require those
+ -- checks and be transformed back into an aggregate.
+
+ if Number_Dimensions (Typ) = 1
+ and then
+ (Root_Type (Component_Type (Typ)) = Standard_Character
+ or else
+ Root_Type (Component_Type (Typ)) = Standard_Wide_Character)
+ and then No (Component_Associations (N))
+ and then not Is_Limited_Composite (Typ)
+ and then not Is_Private_Composite (Typ)
+ and then not Is_Bit_Packed_Array (Typ)
+ and then Nkind (Original_Node (Parent (N))) /= N_String_Literal
+ and then Is_Static_Subtype (Component_Type (Typ))
+ then
+ declare
+ Expr : Node_Id;
+
+ begin
+ Expr := First (Expressions (N));
+ while Present (Expr) loop
+ exit when Nkind (Expr) /= N_Character_Literal;
+ Next (Expr);
+ end loop;
+
+ if No (Expr) then
+ Start_String;
+
+ Expr := First (Expressions (N));
+ while Present (Expr) loop
+ Store_String_Char (Char_Literal_Value (Expr));
+ Next (Expr);
+ end loop;
+
+ Rewrite (N,
+ Make_String_Literal (Sloc (N), End_String));
+
+ Analyze_And_Resolve (N, Typ);
+ return;
+ end if;
+ end;
+ end if;
+
+ -- Here if we have a real aggregate to deal with
+
+ Array_Aggregate : declare
+ Aggr_Resolved : Boolean;
+ Aggr_Typ : Entity_Id := Etype (Typ);
+ -- This is the unconstrained array type, which is the type
+ -- against which the aggregate is to be resoved. Typ itself
+ -- is the array type of the context which may not be the same
+ -- subtype as the subtype for the final aggregate.
+
+ begin
+ -- In the following we determine whether an others choice is
+ -- allowed inside the array aggregate. The test checks the context
+ -- in which the array aggregate occurs. If the context does not
+ -- permit it, or the aggregate type is unconstrained, an others
+ -- choice is not allowed.
+ --
+ -- Note that there is no node for Explicit_Actual_Parameter.
+ -- To test for this context we therefore have to test for node
+ -- N_Parameter_Association which itself appears only if there is a
+ -- formal parameter. Consequently we also need to test for
+ -- N_Procedure_Call_Statement or N_Function_Call.
+
+ if Is_Constrained (Typ) and then
+ (Pkind = N_Assignment_Statement or else
+ Pkind = N_Parameter_Association or else
+ Pkind = N_Function_Call or else
+ Pkind = N_Procedure_Call_Statement or else
+ Pkind = N_Generic_Association or else
+ Pkind = N_Formal_Object_Declaration or else
+ Pkind = N_Return_Statement or else
+ Pkind = N_Object_Declaration or else
+ Pkind = N_Component_Declaration or else
+ Pkind = N_Parameter_Specification or else
+ Pkind = N_Qualified_Expression or else
+ Pkind = N_Aggregate or else
+ Pkind = N_Extension_Aggregate or else
+ Pkind = N_Component_Association)
+ then
+ Aggr_Resolved :=
+ Resolve_Array_Aggregate
+ (N,
+ Index => First_Index (Aggr_Typ),
+ Index_Constr => First_Index (Typ),
+ Component_Typ => Component_Type (Typ),
+ Others_Allowed => True);
+
+ else
+ Aggr_Resolved :=
+ Resolve_Array_Aggregate
+ (N,
+ Index => First_Index (Aggr_Typ),
+ Index_Constr => First_Index (Aggr_Typ),
+ Component_Typ => Component_Type (Typ),
+ Others_Allowed => False);
+ end if;
+
+ if not Aggr_Resolved then
+ Aggr_Subtyp := Any_Composite;
+ else
+ Aggr_Subtyp := Array_Aggr_Subtype (N, Typ);
+ end if;
+
+ Set_Etype (N, Aggr_Subtyp);
+ end Array_Aggregate;
+
+ else
+ Error_Msg_N ("illegal context for aggregate", N);
+
+ end if;
+
+ -- If we can determine statically that the evaluation of the
+ -- aggregate raises Constraint_Error, then replace the
+ -- aggregate with an N_Raise_Constraint_Error node, but set the
+ -- Etype to the right aggregate subtype. Gigi needs this.
+
+ if Raises_Constraint_Error (N) then
+ Aggr_Subtyp := Etype (N);
+ Rewrite (N, Make_Raise_Constraint_Error (Sloc (N)));
+ Set_Raises_Constraint_Error (N);
+ Set_Etype (N, Aggr_Subtyp);
+ Set_Analyzed (N);
+ end if;
+
+ end Resolve_Aggregate;
+
+ -----------------------------
+ -- Resolve_Array_Aggregate --
+ -----------------------------
+
+ function Resolve_Array_Aggregate
+ (N : Node_Id;
+ Index : Node_Id;
+ Index_Constr : Node_Id;
+ Component_Typ : Entity_Id;
+ Others_Allowed : Boolean)
+ return Boolean
+ is
+ Loc : constant Source_Ptr := Sloc (N);
+
+ Failure : constant Boolean := False;
+ Success : constant Boolean := True;
+
+ Index_Typ : constant Entity_Id := Etype (Index);
+ Index_Typ_Low : constant Node_Id := Type_Low_Bound (Index_Typ);
+ Index_Typ_High : constant Node_Id := Type_High_Bound (Index_Typ);
+ -- The type of the index corresponding to the array sub-aggregate
+ -- along with its low and upper bounds
+
+ Index_Base : constant Entity_Id := Base_Type (Index_Typ);
+ Index_Base_Low : constant Node_Id := Type_Low_Bound (Index_Base);
+ Index_Base_High : constant Node_Id := Type_High_Bound (Index_Base);
+ -- ditto for the base type
+
+ function Add (Val : Uint; To : Node_Id) return Node_Id;
+ -- Creates a new expression node where Val is added to expression To.
+ -- Tries to constant fold whenever possible. To must be an already
+ -- analyzed expression.
+
+ procedure Check_Bound (BH : Node_Id; AH : in out Node_Id);
+ -- Checks that AH (the upper bound of an array aggregate) is <= BH
+ -- (the upper bound of the index base type). If the check fails a
+ -- warning is emitted, the Raises_Constraint_Error Flag of N is set,
+ -- and AH is replaced with a duplicate of BH.
+
+ procedure Check_Bounds (L, H : Node_Id; AL, AH : Node_Id);
+ -- Checks that range AL .. AH is compatible with range L .. H. Emits a
+ -- warning if not and sets the Raises_Constraint_Error Flag in N.
+
+ procedure Check_Length (L, H : Node_Id; Len : Uint);
+ -- Checks that range L .. H contains at least Len elements. Emits a
+ -- warning if not and sets the Raises_Constraint_Error Flag in N.
+
+ function Dynamic_Or_Null_Range (L, H : Node_Id) return Boolean;
+ -- Returns True if range L .. H is dynamic or null.
+
+ procedure Get (Value : out Uint; From : Node_Id; OK : out Boolean);
+ -- Given expression node From, this routine sets OK to False if it
+ -- cannot statically evaluate From. Otherwise it stores this static
+ -- value into Value.
+
+ function Resolve_Aggr_Expr
+ (Expr : Node_Id;
+ Single_Elmt : Boolean)
+ return Boolean;
+ -- Resolves aggregate expression Expr. Returs False if resolution
+ -- fails. If Single_Elmt is set to False, the expression Expr may be
+ -- used to initialize several array aggregate elements (this can
+ -- happen for discrete choices such as "L .. H => Expr" or the others
+ -- choice). In this event we do not resolve Expr unless expansion is
+ -- disabled. To know why, see the DELAYED COMPONENT RESOLUTION
+ -- note above.
+
+ ---------
+ -- Add --
+ ---------
+
+ function Add (Val : Uint; To : Node_Id) return Node_Id is
+ Expr_Pos : Node_Id;
+ Expr : Node_Id;
+ To_Pos : Node_Id;
+
+ begin
+ if Raises_Constraint_Error (To) then
+ return To;
+ end if;
+
+ -- First test if we can do constant folding
+
+ if Compile_Time_Known_Value (To)
+ or else Nkind (To) = N_Integer_Literal
+ then
+ Expr_Pos := Make_Integer_Literal (Loc, Expr_Value (To) + Val);
+ Set_Is_Static_Expression (Expr_Pos);
+ Set_Etype (Expr_Pos, Etype (To));
+ Set_Analyzed (Expr_Pos, Analyzed (To));
+
+ if not Is_Enumeration_Type (Index_Typ) then
+ Expr := Expr_Pos;
+
+ -- If we are dealing with enumeration return
+ -- Index_Typ'Val (Expr_Pos)
+
+ else
+ Expr :=
+ Make_Attribute_Reference
+ (Loc,
+ Prefix => New_Reference_To (Index_Typ, Loc),
+ Attribute_Name => Name_Val,
+ Expressions => New_List (Expr_Pos));
+ end if;
+
+ return Expr;
+ end if;
+
+ -- If we are here no constant folding possible
+
+ if not Is_Enumeration_Type (Index_Base) then
+ Expr :=
+ Make_Op_Add (Loc,
+ Left_Opnd => Duplicate_Subexpr (To),
+ Right_Opnd => Make_Integer_Literal (Loc, Val));
+
+ -- If we are dealing with enumeration return
+ -- Index_Typ'Val (Index_Typ'Pos (To) + Val)
+
+ else
+ To_Pos :=
+ Make_Attribute_Reference
+ (Loc,
+ Prefix => New_Reference_To (Index_Typ, Loc),
+ Attribute_Name => Name_Pos,
+ Expressions => New_List (Duplicate_Subexpr (To)));
+
+ Expr_Pos :=
+ Make_Op_Add (Loc,
+ Left_Opnd => To_Pos,
+ Right_Opnd => Make_Integer_Literal (Loc, Val));
+
+ Expr :=
+ Make_Attribute_Reference
+ (Loc,
+ Prefix => New_Reference_To (Index_Typ, Loc),
+ Attribute_Name => Name_Val,
+ Expressions => New_List (Expr_Pos));
+ end if;
+
+ return Expr;
+ end Add;
+
+ -----------------
+ -- Check_Bound --
+ -----------------
+
+ procedure Check_Bound (BH : Node_Id; AH : in out Node_Id) is
+ Val_BH : Uint;
+ Val_AH : Uint;
+
+ OK_BH : Boolean;
+ OK_AH : Boolean;
+
+ begin
+ Get (Value => Val_BH, From => BH, OK => OK_BH);
+ Get (Value => Val_AH, From => AH, OK => OK_AH);
+
+ if OK_BH and then OK_AH and then Val_BH < Val_AH then
+ Set_Raises_Constraint_Error (N);
+ Error_Msg_N ("upper bound out of range?", AH);
+ Error_Msg_N ("Constraint_Error will be raised at run-time?", AH);
+
+ -- You need to set AH to BH or else in the case of enumerations
+ -- indices we will not be able to resolve the aggregate bounds.
+
+ AH := Duplicate_Subexpr (BH);
+ end if;
+ end Check_Bound;
+
+ ------------------
+ -- Check_Bounds --
+ ------------------
+
+ procedure Check_Bounds (L, H : Node_Id; AL, AH : Node_Id) is
+ Val_L : Uint;
+ Val_H : Uint;
+ Val_AL : Uint;
+ Val_AH : Uint;
+
+ OK_L : Boolean;
+ OK_H : Boolean;
+ OK_AL : Boolean;
+ OK_AH : Boolean;
+
+ begin
+ if Raises_Constraint_Error (N)
+ or else Dynamic_Or_Null_Range (AL, AH)
+ then
+ return;
+ end if;
+
+ Get (Value => Val_L, From => L, OK => OK_L);
+ Get (Value => Val_H, From => H, OK => OK_H);
+
+ Get (Value => Val_AL, From => AL, OK => OK_AL);
+ Get (Value => Val_AH, From => AH, OK => OK_AH);
+
+ if OK_L and then Val_L > Val_AL then
+ Set_Raises_Constraint_Error (N);
+ Error_Msg_N ("lower bound of aggregate out of range?", N);
+ Error_Msg_N ("Constraint_Error will be raised at run-time?", N);
+ end if;
+
+ if OK_H and then Val_H < Val_AH then
+ Set_Raises_Constraint_Error (N);
+ Error_Msg_N ("upper bound of aggregate out of range?", N);
+ Error_Msg_N ("Constraint_Error will be raised at run-time?", N);
+ end if;
+ end Check_Bounds;
+
+ ------------------
+ -- Check_Length --
+ ------------------
+
+ procedure Check_Length (L, H : Node_Id; Len : Uint) is
+ Val_L : Uint;
+ Val_H : Uint;
+
+ OK_L : Boolean;
+ OK_H : Boolean;
+
+ Range_Len : Uint;
+
+ begin
+ if Raises_Constraint_Error (N) then
+ return;
+ end if;
+
+ Get (Value => Val_L, From => L, OK => OK_L);
+ Get (Value => Val_H, From => H, OK => OK_H);
+
+ if not OK_L or else not OK_H then
+ return;
+ end if;
+
+ -- If null range length is zero
+
+ if Val_L > Val_H then
+ Range_Len := Uint_0;
+ else
+ Range_Len := Val_H - Val_L + 1;
+ end if;
+
+ if Range_Len < Len then
+ Set_Raises_Constraint_Error (N);
+ Error_Msg_N ("Too many elements?", N);
+ Error_Msg_N ("Constraint_Error will be raised at run-time?", N);
+ end if;
+ end Check_Length;
+
+ ---------------------------
+ -- Dynamic_Or_Null_Range --
+ ---------------------------
+
+ function Dynamic_Or_Null_Range (L, H : Node_Id) return Boolean is
+ Val_L : Uint;
+ Val_H : Uint;
+
+ OK_L : Boolean;
+ OK_H : Boolean;
+
+ begin
+ Get (Value => Val_L, From => L, OK => OK_L);
+ Get (Value => Val_H, From => H, OK => OK_H);
+
+ return not OK_L or else not OK_H
+ or else not Is_OK_Static_Expression (L)
+ or else not Is_OK_Static_Expression (H)
+ or else Val_L > Val_H;
+ end Dynamic_Or_Null_Range;
+
+ ---------
+ -- Get --
+ ---------
+
+ procedure Get (Value : out Uint; From : Node_Id; OK : out Boolean) is
+ begin
+ OK := True;
+
+ if Compile_Time_Known_Value (From) then
+ Value := Expr_Value (From);
+
+ -- If expression From is something like Some_Type'Val (10) then
+ -- Value = 10
+
+ elsif Nkind (From) = N_Attribute_Reference
+ and then Attribute_Name (From) = Name_Val
+ and then Compile_Time_Known_Value (First (Expressions (From)))
+ then
+ Value := Expr_Value (First (Expressions (From)));
+
+ else
+ Value := Uint_0;
+ OK := False;
+ end if;
+ end Get;
+
+ -----------------------
+ -- Resolve_Aggr_Expr --
+ -----------------------
+
+ function Resolve_Aggr_Expr
+ (Expr : Node_Id;
+ Single_Elmt : Boolean)
+ return Boolean
+ is
+ Nxt_Ind : Node_Id := Next_Index (Index);
+ Nxt_Ind_Constr : Node_Id := Next_Index (Index_Constr);
+ -- Index is the current index corresponding to the expresion.
+
+ Resolution_OK : Boolean := True;
+ -- Set to False if resolution of the expression failed.
+
+ begin
+ -- If the array type against which we are resolving the aggregate
+ -- has several dimensions, the expressions nested inside the
+ -- aggregate must be further aggregates (or strings).
+
+ if Present (Nxt_Ind) then
+ if Nkind (Expr) /= N_Aggregate then
+
+ -- A string literal can appear where a one-dimensional array
+ -- of characters is expected. If the literal looks like an
+ -- operator, it is still an operator symbol, which will be
+ -- transformed into a string when analyzed.
+
+ if Is_Character_Type (Component_Typ)
+ and then No (Next_Index (Nxt_Ind))
+ and then (Nkind (Expr) = N_String_Literal
+ or else Nkind (Expr) = N_Operator_Symbol)
+ then
+ -- A string literal used in a multidimensional array
+ -- aggregate in place of the final one-dimensional
+ -- aggregate must not be enclosed in parentheses.
+
+ if Paren_Count (Expr) /= 0 then
+ Error_Msg_N ("No parenthesis allowed here", Expr);
+ end if;
+
+ Make_String_Into_Aggregate (Expr);
+
+ else
+ Error_Msg_N ("nested array aggregate expected", Expr);
+ return Failure;
+ end if;
+ end if;
+
+ Resolution_OK := Resolve_Array_Aggregate
+ (Expr, Nxt_Ind, Nxt_Ind_Constr, Component_Typ, Others_Allowed);
+
+ -- Do not resolve the expressions of discrete or others choices
+ -- unless the expression covers a single component, or the expander
+ -- is inactive.
+
+ elsif Single_Elmt
+ or else not Expander_Active
+ or else In_Default_Expression
+ then
+ Analyze_And_Resolve (Expr, Component_Typ);
+ Check_Non_Static_Context (Expr);
+ Aggregate_Constraint_Checks (Expr, Component_Typ);
+ end if;
+
+ if Raises_Constraint_Error (Expr)
+ and then Nkind (Parent (Expr)) /= N_Component_Association
+ then
+ Set_Raises_Constraint_Error (N);
+ end if;
+
+ return Resolution_OK;
+ end Resolve_Aggr_Expr;
+
+ -- Variables local to Resolve_Array_Aggregate
+
+ Assoc : Node_Id;
+ Choice : Node_Id;
+ Expr : Node_Id;
+
+ Who_Cares : Node_Id;
+
+ Aggr_Low : Node_Id := Empty;
+ Aggr_High : Node_Id := Empty;
+ -- The actual low and high bounds of this sub-aggegate
+
+ Choices_Low : Node_Id := Empty;
+ Choices_High : Node_Id := Empty;
+ -- The lowest and highest discrete choices values for a named aggregate
+
+ Nb_Elements : Uint := Uint_0;
+ -- The number of elements in a positional aggegate
+
+ Others_Present : Boolean := False;
+
+ Nb_Choices : Nat := 0;
+ -- Contains the overall number of named choices in this sub-aggregate
+
+ Nb_Discrete_Choices : Nat := 0;
+ -- The overall number of discrete choices (not counting others choice)
+
+ Case_Table_Size : Nat;
+ -- Contains the size of the case table needed to sort aggregate choices
+
+ -- Start of processing for Resolve_Array_Aggregate
+
+ begin
+ -- STEP 1: make sure the aggregate is correctly formatted
+
+ if Present (Component_Associations (N)) then
+ Assoc := First (Component_Associations (N));
+ while Present (Assoc) loop
+ Choice := First (Choices (Assoc));
+ while Present (Choice) loop
+ if Nkind (Choice) = N_Others_Choice then
+ Others_Present := True;
+
+ if Choice /= First (Choices (Assoc))
+ or else Present (Next (Choice))
+ then
+ Error_Msg_N
+ ("OTHERS must appear alone in a choice list", Choice);
+ return Failure;
+ end if;
+
+ if Present (Next (Assoc)) then
+ Error_Msg_N
+ ("OTHERS must appear last in an aggregate", Choice);
+ return Failure;
+ end if;
+
+ if Ada_83
+ and then Assoc /= First (Component_Associations (N))
+ and then (Nkind (Parent (N)) = N_Assignment_Statement
+ or else
+ Nkind (Parent (N)) = N_Object_Declaration)
+ then
+ Error_Msg_N
+ ("(Ada 83) illegal context for OTHERS choice", N);
+ end if;
+ end if;
+
+ Nb_Choices := Nb_Choices + 1;
+ Next (Choice);
+ end loop;
+
+ Next (Assoc);
+ end loop;
+ end if;
+
+ -- At this point we know that the others choice, if present, is by
+ -- itself and appears last in the aggregate. Check if we have mixed
+ -- positional and discrete associations (other than the others choice).
+
+ if Present (Expressions (N))
+ and then (Nb_Choices > 1
+ or else (Nb_Choices = 1 and then not Others_Present))
+ then
+ Error_Msg_N
+ ("named association cannot follow positional association",
+ First (Choices (First (Component_Associations (N)))));
+ return Failure;
+ end if;
+
+ -- Test for the validity of an others choice if present
+
+ if Others_Present and then not Others_Allowed then
+ Error_Msg_N
+ ("OTHERS choice not allowed here",
+ First (Choices (First (Component_Associations (N)))));
+ return Failure;
+ end if;
+
+ -- STEP 2: Process named components
+
+ if No (Expressions (N)) then
+
+ if Others_Present then
+ Case_Table_Size := Nb_Choices - 1;
+ else
+ Case_Table_Size := Nb_Choices;
+ end if;
+
+ Step_2 : declare
+ Low : Node_Id;
+ High : Node_Id;
+ -- Denote the lowest and highest values in an aggregate choice
+
+ Hi_Val : Uint;
+ Lo_Val : Uint;
+ -- High end of one range and Low end of the next. Should be
+ -- contiguous if there is no hole in the list of values.
+
+ Missing_Values : Boolean;
+ -- Set True if missing index values
+
+ S_Low : Node_Id := Empty;
+ S_High : Node_Id := Empty;
+ -- if a choice in an aggregate is a subtype indication these
+ -- denote the lowest and highest values of the subtype
+
+ Table : Case_Table_Type (1 .. Case_Table_Size);
+ -- Used to sort all the different choice values
+
+ Single_Choice : Boolean;
+ -- Set to true every time there is a single discrete choice in a
+ -- discrete association
+
+ Prev_Nb_Discrete_Choices : Nat;
+ -- Used to keep track of the number of discrete choices
+ -- in the current association.
+
+ begin
+ -- STEP 2 (A): Check discrete choices validity.
+
+ Assoc := First (Component_Associations (N));
+ while Present (Assoc) loop
+
+ Prev_Nb_Discrete_Choices := Nb_Discrete_Choices;
+ Choice := First (Choices (Assoc));
+ loop
+ Analyze (Choice);
+
+ if Nkind (Choice) = N_Others_Choice then
+ Single_Choice := False;
+ exit;
+
+ -- Test for subtype mark without constraint
+
+ elsif Is_Entity_Name (Choice) and then
+ Is_Type (Entity (Choice))
+ then
+ if Base_Type (Entity (Choice)) /= Index_Base then
+ Error_Msg_N
+ ("invalid subtype mark in aggregate choice",
+ Choice);
+ return Failure;
+ end if;
+
+ elsif Nkind (Choice) = N_Subtype_Indication then
+ Resolve_Discrete_Subtype_Indication (Choice, Index_Base);
+
+ -- Does the subtype indication evaluation raise CE ?
+
+ Get_Index_Bounds (Subtype_Mark (Choice), S_Low, S_High);
+ Get_Index_Bounds (Choice, Low, High);
+ Check_Bounds (S_Low, S_High, Low, High);
+
+ else -- Choice is a range or an expression
+ Resolve (Choice, Index_Base);
+ Check_Non_Static_Context (Choice);
+
+ -- Do not range check a choice. This check is redundant
+ -- since this test is already performed when we check
+ -- that the bounds of the array aggregate are within
+ -- range.
+
+ Set_Do_Range_Check (Choice, False);
+ end if;
+
+ -- If we could not resolve the discrete choice stop here
+
+ if Etype (Choice) = Any_Type then
+ return Failure;
+
+ -- If the discrete choice raises CE get its original bounds.
+
+ elsif Nkind (Choice) = N_Raise_Constraint_Error then
+ Set_Raises_Constraint_Error (N);
+ Get_Index_Bounds (Original_Node (Choice), Low, High);
+
+ -- Otherwise get its bounds as usual
+
+ else
+ Get_Index_Bounds (Choice, Low, High);
+ end if;
+
+ if (Dynamic_Or_Null_Range (Low, High)
+ or else (Nkind (Choice) = N_Subtype_Indication
+ and then
+ Dynamic_Or_Null_Range (S_Low, S_High)))
+ and then Nb_Choices /= 1
+ then
+ Error_Msg_N
+ ("dynamic or empty choice in aggregate " &
+ "must be the only choice", Choice);
+ return Failure;
+ end if;
+
+ Nb_Discrete_Choices := Nb_Discrete_Choices + 1;
+ Table (Nb_Discrete_Choices).Choice_Lo := Low;
+ Table (Nb_Discrete_Choices).Choice_Hi := High;
+
+ Next (Choice);
+
+ if No (Choice) then
+ -- Check if we have a single discrete choice and whether
+ -- this discrete choice specifies a single value.
+
+ Single_Choice :=
+ (Nb_Discrete_Choices = Prev_Nb_Discrete_Choices + 1)
+ and then (Low = High);
+
+ exit;
+ end if;
+ end loop;
+
+ if not
+ Resolve_Aggr_Expr
+ (Expression (Assoc), Single_Elmt => Single_Choice)
+ then
+ return Failure;
+ end if;
+
+ Next (Assoc);
+ end loop;
+
+ -- If aggregate contains more than one choice then these must be
+ -- static. Sort them and check that they are contiguous
+
+ if Nb_Discrete_Choices > 1 then
+ Sort_Case_Table (Table);
+ Missing_Values := False;
+
+ Outer : for J in 1 .. Nb_Discrete_Choices - 1 loop
+ if Expr_Value (Table (J).Choice_Hi) >=
+ Expr_Value (Table (J + 1).Choice_Lo)
+ then
+ Error_Msg_N
+ ("duplicate choice values in array aggregate",
+ Table (J).Choice_Hi);
+ return Failure;
+
+ elsif not Others_Present then
+
+ Hi_Val := Expr_Value (Table (J).Choice_Hi);
+ Lo_Val := Expr_Value (Table (J + 1).Choice_Lo);
+
+ -- If missing values, output error messages
+
+ if Lo_Val - Hi_Val > 1 then
+
+ -- Header message if not first missing value
+
+ if not Missing_Values then
+ Error_Msg_N
+ ("missing index value(s) in array aggregate", N);
+ Missing_Values := True;
+ end if;
+
+ -- Output values of missing indexes
+
+ Lo_Val := Lo_Val - 1;
+ Hi_Val := Hi_Val + 1;
+
+ -- Enumeration type case
+
+ if Is_Enumeration_Type (Index_Typ) then
+ Error_Msg_Name_1 :=
+ Chars
+ (Get_Enum_Lit_From_Pos
+ (Index_Typ, Hi_Val, Loc));
+
+ if Lo_Val = Hi_Val then
+ Error_Msg_N ("\ %", N);
+ else
+ Error_Msg_Name_2 :=
+ Chars
+ (Get_Enum_Lit_From_Pos
+ (Index_Typ, Lo_Val, Loc));
+ Error_Msg_N ("\ % .. %", N);
+ end if;
+
+ -- Integer types case
+
+ else
+ Error_Msg_Uint_1 := Hi_Val;
+
+ if Lo_Val = Hi_Val then
+ Error_Msg_N ("\ ^", N);
+ else
+ Error_Msg_Uint_2 := Lo_Val;
+ Error_Msg_N ("\ ^ .. ^", N);
+ end if;
+ end if;
+ end if;
+ end if;
+ end loop Outer;
+
+ if Missing_Values then
+ Set_Etype (N, Any_Composite);
+ return Failure;
+ end if;
+ end if;
+
+ -- STEP 2 (B): Compute aggregate bounds and min/max choices values
+
+ if Nb_Discrete_Choices > 0 then
+ Choices_Low := Table (1).Choice_Lo;
+ Choices_High := Table (Nb_Discrete_Choices).Choice_Hi;
+ end if;
+
+ if Others_Present then
+ Get_Index_Bounds (Index_Constr, Aggr_Low, Aggr_High);
+
+ else
+ Aggr_Low := Choices_Low;
+ Aggr_High := Choices_High;
+ end if;
+ end Step_2;
+
+ -- STEP 3: Process positional components
+
+ else
+ -- STEP 3 (A): Process positional elements
+
+ Expr := First (Expressions (N));
+ Nb_Elements := Uint_0;
+ while Present (Expr) loop
+ Nb_Elements := Nb_Elements + 1;
+
+ if not Resolve_Aggr_Expr (Expr, Single_Elmt => True) then
+ return Failure;
+ end if;
+
+ Next (Expr);
+ end loop;
+
+ if Others_Present then
+ Assoc := Last (Component_Associations (N));
+ if not Resolve_Aggr_Expr (Expression (Assoc),
+ Single_Elmt => False)
+ then
+ return Failure;
+ end if;
+ end if;
+
+ -- STEP 3 (B): Compute the aggregate bounds
+
+ if Others_Present then
+ Get_Index_Bounds (Index_Constr, Aggr_Low, Aggr_High);
+
+ else
+ if Others_Allowed then
+ Get_Index_Bounds (Index_Constr, Aggr_Low, Who_Cares);
+ else
+ Aggr_Low := Index_Typ_Low;
+ end if;
+
+ Aggr_High := Add (Nb_Elements - 1, To => Aggr_Low);
+ Check_Bound (Index_Base_High, Aggr_High);
+ end if;
+ end if;
+
+ -- STEP 4: Perform static aggregate checks and save the bounds
+
+ -- Check (A)
+
+ Check_Bounds (Index_Typ_Low, Index_Typ_High, Aggr_Low, Aggr_High);
+ Check_Bounds (Index_Base_Low, Index_Base_High, Aggr_Low, Aggr_High);
+
+ -- Check (B)
+
+ if Others_Present and then Nb_Discrete_Choices > 0 then
+ Check_Bounds (Aggr_Low, Aggr_High, Choices_Low, Choices_High);
+ Check_Bounds (Index_Typ_Low, Index_Typ_High,
+ Choices_Low, Choices_High);
+ Check_Bounds (Index_Base_Low, Index_Base_High,
+ Choices_Low, Choices_High);
+
+ -- Check (C)
+
+ elsif Others_Present and then Nb_Elements > 0 then
+ Check_Length (Aggr_Low, Aggr_High, Nb_Elements);
+ Check_Length (Index_Typ_Low, Index_Typ_High, Nb_Elements);
+ Check_Length (Index_Base_Low, Index_Base_High, Nb_Elements);
+
+ end if;
+
+ if Raises_Constraint_Error (Aggr_Low)
+ or else Raises_Constraint_Error (Aggr_High)
+ then
+ Set_Raises_Constraint_Error (N);
+ end if;
+
+ Aggr_Low := Duplicate_Subexpr (Aggr_Low);
+
+ -- Do not duplicate Aggr_High if Aggr_High = Aggr_Low + Nb_Elements
+ -- since the addition node returned by Add is not yet analyzed. Attach
+ -- to tree and analyze first. Reset analyzed flag to insure it will get
+ -- analyzed when it is a literal bound whose type must be properly
+ -- set.
+
+ if Others_Present or else Nb_Discrete_Choices > 0 then
+ Aggr_High := Duplicate_Subexpr (Aggr_High);
+
+ if Etype (Aggr_High) = Universal_Integer then
+ Set_Analyzed (Aggr_High, False);
+ end if;
+ end if;
+
+ Set_Aggregate_Bounds
+ (N, Make_Range (Loc, Low_Bound => Aggr_Low, High_Bound => Aggr_High));
+
+ -- The bounds may contain expressions that must be inserted upwards.
+ -- Attach them fully to the tree. After analysis, remove side effects
+ -- from upper bound, if still needed.
+
+ Set_Parent (Aggregate_Bounds (N), N);
+ Analyze_And_Resolve (Aggregate_Bounds (N), Index_Typ);
+
+ if not Others_Present and then Nb_Discrete_Choices = 0 then
+ Set_High_Bound (Aggregate_Bounds (N),
+ Duplicate_Subexpr (High_Bound (Aggregate_Bounds (N))));
+ end if;
+
+ return Success;
+ end Resolve_Array_Aggregate;
+
+ ---------------------------------
+ -- Resolve_Extension_Aggregate --
+ ---------------------------------
+
+ -- There are two cases to consider:
+
+ -- a) If the ancestor part is a type mark, the components needed are
+ -- the difference between the components of the expected type and the
+ -- components of the given type mark.
+
+ -- b) If the ancestor part is an expression, it must be unambiguous,
+ -- and once we have its type we can also compute the needed components
+ -- as in the previous case. In both cases, if the ancestor type is not
+ -- the immediate ancestor, we have to build this ancestor recursively.
+
+ -- In both cases discriminants of the ancestor type do not play a
+ -- role in the resolution of the needed components, because inherited
+ -- discriminants cannot be used in a type extension. As a result we can
+ -- compute independently the list of components of the ancestor type and
+ -- of the expected type.
+
+ procedure Resolve_Extension_Aggregate (N : Node_Id; Typ : Entity_Id) is
+ A : constant Node_Id := Ancestor_Part (N);
+ A_Type : Entity_Id;
+ I : Interp_Index;
+ It : Interp;
+ Imm_Type : Entity_Id;
+
+ function Valid_Ancestor_Type return Boolean;
+ -- Verify that the type of the ancestor part is a non-private ancestor
+ -- of the expected type.
+
+ function Valid_Ancestor_Type return Boolean is
+ Imm_Type : Entity_Id;
+
+ begin
+ Imm_Type := Base_Type (Typ);
+ while Is_Derived_Type (Imm_Type)
+ and then Etype (Imm_Type) /= Base_Type (A_Type)
+ loop
+ Imm_Type := Etype (Base_Type (Imm_Type));
+ end loop;
+
+ if Etype (Imm_Type) /= Base_Type (A_Type) then
+ Error_Msg_NE ("expect ancestor type of &", A, Typ);
+ return False;
+ else
+ return True;
+ end if;
+ end Valid_Ancestor_Type;
+
+ -- Start of processing for Resolve_Extension_Aggregate
+
+ begin
+ Analyze (A);
+
+ if not Is_Tagged_Type (Typ) then
+ Error_Msg_N ("type of extension aggregate must be tagged", N);
+ return;
+
+ elsif Is_Limited_Type (Typ) then
+ Error_Msg_N ("aggregate type cannot be limited", N);
+ return;
+
+ elsif Is_Class_Wide_Type (Typ) then
+ Error_Msg_N ("aggregate cannot be of a class-wide type", N);
+ return;
+ end if;
+
+ if Is_Entity_Name (A)
+ and then Is_Type (Entity (A))
+ then
+ A_Type := Get_Full_View (Entity (A));
+ Imm_Type := Base_Type (Typ);
+
+ if Valid_Ancestor_Type then
+ Set_Entity (A, A_Type);
+ Set_Etype (A, A_Type);
+
+ Validate_Ancestor_Part (N);
+ Resolve_Record_Aggregate (N, Typ);
+ end if;
+
+ elsif Nkind (A) /= N_Aggregate then
+ if Is_Overloaded (A) then
+ A_Type := Any_Type;
+ Get_First_Interp (A, I, It);
+
+ while Present (It.Typ) loop
+
+ if Is_Tagged_Type (It.Typ)
+ and then not Is_Limited_Type (It.Typ)
+ then
+ if A_Type /= Any_Type then
+ Error_Msg_N ("cannot resolve expression", A);
+ return;
+ else
+ A_Type := It.Typ;
+ end if;
+ end if;
+
+ Get_Next_Interp (I, It);
+ end loop;
+
+ if A_Type = Any_Type then
+ Error_Msg_N
+ ("ancestor part must be non-limited tagged type", A);
+ return;
+ end if;
+
+ else
+ A_Type := Etype (A);
+ end if;
+
+ if Valid_Ancestor_Type then
+ Resolve (A, A_Type);
+ Check_Non_Static_Context (A);
+ Resolve_Record_Aggregate (N, Typ);
+ end if;
+
+ else
+ Error_Msg_N (" No unique type for this aggregate", A);
+ end if;
+
+ end Resolve_Extension_Aggregate;
+
+ ------------------------------
+ -- Resolve_Record_Aggregate --
+ ------------------------------
+
+ procedure Resolve_Record_Aggregate (N : Node_Id; Typ : Entity_Id) is
+ Regular_Aggr : constant Boolean := Nkind (N) /= N_Extension_Aggregate;
+
+ New_Assoc_List : List_Id := New_List;
+ New_Assoc : Node_Id;
+ -- New_Assoc_List is the newly built list of N_Component_Association
+ -- nodes. New_Assoc is one such N_Component_Association node in it.
+ -- Please note that while Assoc and New_Assoc contain the same
+ -- kind of nodes, they are used to iterate over two different
+ -- N_Component_Association lists.
+
+ Others_Etype : Entity_Id := Empty;
+ -- This variable is used to save the Etype of the last record component
+ -- that takes its value from the others choice. Its purpose is:
+ --
+ -- (a) make sure the others choice is useful
+ --
+ -- (b) make sure the type of all the components whose value is
+ -- subsumed by the others choice are the same.
+ --
+ -- This variable is updated as a side effect of function Get_Value
+
+ procedure Add_Association (Component : Entity_Id; Expr : Node_Id);
+ -- Builds a new N_Component_Association node which associates
+ -- Component to expression Expr and adds it to the new association
+ -- list New_Assoc_List being built.
+
+ function Discr_Present (Discr : Entity_Id) return Boolean;
+ -- If aggregate N is a regular aggregate this routine will return True.
+ -- Otherwise, if N is an extension aggreagte, Discr is a discriminant
+ -- whose value may already have been specified by N's ancestor part,
+ -- this routine checks whether this is indeed the case and if so
+ -- returns False, signaling that no value for Discr should appear in the
+ -- N's aggregate part. Also, in this case, the routine appends to
+ -- New_Assoc_List Discr the discriminant value specified in the ancestor
+ -- part.
+
+ function Get_Value
+ (Compon : Node_Id;
+ From : List_Id;
+ Consider_Others_Choice : Boolean := False)
+ return Node_Id;
+ -- Given a record component stored in parameter Compon, the
+ -- following function returns its value as it appears in the list
+ -- From, which is a list of N_Component_Association nodes. If no
+ -- component association has a choice for the searched component,
+ -- the value provided by the others choice is returned, if there
+ -- is one and Consider_Others_Choice is set to true. Otherwise
+ -- Empty is returned. If there is more than one component association
+ -- giving a value for the searched record component, an error message
+ -- is emitted and the first found value is returned.
+ --
+ -- If Consider_Others_Choice is set and the returned expression comes
+ -- from the others choice, then Others_Etype is set as a side effect.
+ -- An error message is emitted if the components taking their value
+ -- from the others choice do not have same type.
+
+ procedure Resolve_Aggr_Expr (Expr : Node_Id; Component : Node_Id);
+ -- Analyzes and resolves expression Expr against the Etype of the
+ -- Component. This routine also applies all appropiate checks to Expr.
+ -- It finally saves a Expr in the newly created association list that
+ -- will be attached to the final record aggregate. Note that if the
+ -- Parent pointer of Expr is not set then Expr was produced with a
+ -- New_copy_Tree or some such.
+
+ ---------------------
+ -- Add_Association --
+ ---------------------
+
+ procedure Add_Association (Component : Entity_Id; Expr : Node_Id) is
+ New_Assoc : Node_Id;
+ Choice_List : List_Id := New_List;
+
+ begin
+ Append (New_Occurrence_Of (Component, Sloc (Expr)), Choice_List);
+ New_Assoc :=
+ Make_Component_Association (Sloc (Expr),
+ Choices => Choice_List,
+ Expression => Expr);
+ Append (New_Assoc, New_Assoc_List);
+ end Add_Association;
+
+ -------------------
+ -- Discr_Present --
+ -------------------
+
+ function Discr_Present (Discr : Entity_Id) return Boolean is
+ Loc : Source_Ptr;
+
+ Ancestor : Node_Id;
+ Discr_Expr : Node_Id;
+
+ Ancestor_Typ : Entity_Id;
+ Orig_Discr : Entity_Id;
+ D : Entity_Id;
+ D_Val : Elmt_Id := No_Elmt; -- stop junk warning
+
+ Ancestor_Is_Subtyp : Boolean;
+
+ begin
+ if Regular_Aggr then
+ return True;
+ end if;
+
+ Ancestor := Ancestor_Part (N);
+ Ancestor_Typ := Etype (Ancestor);
+ Loc := Sloc (Ancestor);
+
+ Ancestor_Is_Subtyp :=
+ Is_Entity_Name (Ancestor) and then Is_Type (Entity (Ancestor));
+
+ -- If the ancestor part has no discriminants clearly N's aggregate
+ -- part must provide a value for Discr.
+
+ if not Has_Discriminants (Ancestor_Typ) then
+ return True;
+
+ -- If the ancestor part is an unconstrained subtype mark then the
+ -- Discr must be present in N's aggregate part.
+
+ elsif Ancestor_Is_Subtyp
+ and then not Is_Constrained (Entity (Ancestor))
+ then
+ return True;
+ end if;
+
+ -- Now look to see if Discr was specified in the ancestor part.
+
+ Orig_Discr := Original_Record_Component (Discr);
+ D := First_Discriminant (Ancestor_Typ);
+
+ if Ancestor_Is_Subtyp then
+ D_Val := First_Elmt (Discriminant_Constraint (Entity (Ancestor)));
+ end if;
+
+ while Present (D) loop
+ -- If Ancestor has already specified Disc value than
+ -- insert its value in the final aggregate.
+
+ if Original_Record_Component (D) = Orig_Discr then
+ if Ancestor_Is_Subtyp then
+ Discr_Expr := New_Copy_Tree (Node (D_Val));
+ else
+ Discr_Expr :=
+ Make_Selected_Component (Loc,
+ Prefix => Duplicate_Subexpr (Ancestor),
+ Selector_Name => New_Occurrence_Of (Discr, Loc));
+ end if;
+
+ Resolve_Aggr_Expr (Discr_Expr, Discr);
+ return False;
+ end if;
+
+ Next_Discriminant (D);
+
+ if Ancestor_Is_Subtyp then
+ Next_Elmt (D_Val);
+ end if;
+ end loop;
+
+ return True;
+ end Discr_Present;
+
+ ---------------
+ -- Get_Value --
+ ---------------
+
+ function Get_Value
+ (Compon : Node_Id;
+ From : List_Id;
+ Consider_Others_Choice : Boolean := False)
+ return Node_Id
+ is
+ Assoc : Node_Id;
+ Expr : Node_Id := Empty;
+ Selector_Name : Node_Id;
+
+ begin
+ if Present (From) then
+ Assoc := First (From);
+ else
+ return Empty;
+ end if;
+
+ while Present (Assoc) loop
+ Selector_Name := First (Choices (Assoc));
+ while Present (Selector_Name) loop
+ if Nkind (Selector_Name) = N_Others_Choice then
+ if Consider_Others_Choice and then No (Expr) then
+ if Present (Others_Etype) and then
+ Base_Type (Others_Etype) /= Base_Type (Etype (Compon))
+ then
+ Error_Msg_N ("components in OTHERS choice must " &
+ "have same type", Selector_Name);
+ end if;
+
+ Others_Etype := Etype (Compon);
+
+ -- We need to duplicate the expression for each
+ -- successive component covered by the others choice.
+ -- If the expression is itself an array aggregate with
+ -- "others", its subtype must be obtained from the
+ -- current component, and therefore it must be (at least
+ -- partly) reanalyzed.
+
+ if Analyzed (Expression (Assoc)) then
+ Expr := New_Copy_Tree (Expression (Assoc));
+
+ if Nkind (Expr) = N_Aggregate
+ and then Is_Array_Type (Etype (Expr))
+ and then No (Expressions (Expr))
+ and then
+ Nkind (First (Choices
+ (First (Component_Associations (Expr)))))
+ = N_Others_Choice
+ then
+ Set_Analyzed (Expr, False);
+ end if;
+
+ return Expr;
+
+ else
+ return Expression (Assoc);
+ end if;
+ end if;
+
+ elsif Chars (Compon) = Chars (Selector_Name) then
+ if No (Expr) then
+ -- We need to duplicate the expression when several
+ -- components are grouped together with a "|" choice.
+ -- For instance "filed1 | filed2 => Expr"
+
+ if Present (Next (Selector_Name)) then
+ Expr := New_Copy_Tree (Expression (Assoc));
+ else
+ Expr := Expression (Assoc);
+ end if;
+
+ else
+ Error_Msg_NE
+ ("more than one value supplied for &",
+ Selector_Name, Compon);
+
+ end if;
+ end if;
+
+ Next (Selector_Name);
+ end loop;
+
+ Next (Assoc);
+ end loop;
+
+ return Expr;
+ end Get_Value;
+
+ -----------------------
+ -- Resolve_Aggr_Expr --
+ -----------------------
+
+ procedure Resolve_Aggr_Expr (Expr : Node_Id; Component : Node_Id) is
+ New_C : Entity_Id := Component;
+ Expr_Type : Entity_Id := Empty;
+
+ function Has_Expansion_Delayed (Expr : Node_Id) return Boolean;
+ -- If the expression is an aggregate (possibly qualified) then its
+ -- expansion is delayed until the enclosing aggregate is expanded
+ -- into assignments. In that case, do not generate checks on the
+ -- expression, because they will be generated later, and will other-
+ -- wise force a copy (to remove side-effects) that would leave a
+ -- dynamic-sized aggregate in the code, something that gigi cannot
+ -- handle.
+
+ Relocate : Boolean;
+ -- Set to True if the resolved Expr node needs to be relocated
+ -- when attached to the newly created association list. This node
+ -- need not be relocated if its parent pointer is not set.
+ -- In fact in this case Expr is the output of a New_Copy_Tree call.
+ -- if Relocate is True then we have analyzed the expression node
+ -- in the original aggregate and hence it needs to be relocated
+ -- when moved over the new association list.
+
+ function Has_Expansion_Delayed (Expr : Node_Id) return Boolean is
+ Kind : constant Node_Kind := Nkind (Expr);
+
+ begin
+ return ((Kind = N_Aggregate
+ or else Kind = N_Extension_Aggregate)
+ and then Present (Etype (Expr))
+ and then Is_Record_Type (Etype (Expr))
+ and then Expansion_Delayed (Expr))
+
+ or else (Kind = N_Qualified_Expression
+ and then Has_Expansion_Delayed (Expression (Expr)));
+ end Has_Expansion_Delayed;
+
+ -- Start of processing for Resolve_Aggr_Expr
+
+ begin
+ -- If the type of the component is elementary or the type of the
+ -- aggregate does not contain discriminants, use the type of the
+ -- component to resolve Expr.
+
+ if Is_Elementary_Type (Etype (Component))
+ or else not Has_Discriminants (Etype (N))
+ then
+ Expr_Type := Etype (Component);
+
+ -- Otherwise we have to pick up the new type of the component from
+ -- the new costrained subtype of the aggregate. In fact components
+ -- which are of a composite type might be constrained by a
+ -- discriminant, and we want to resolve Expr against the subtype were
+ -- all discriminant occurrences are replaced with their actual value.
+
+ else
+ New_C := First_Component (Etype (N));
+ while Present (New_C) loop
+ if Chars (New_C) = Chars (Component) then
+ Expr_Type := Etype (New_C);
+ exit;
+ end if;
+
+ Next_Component (New_C);
+ end loop;
+
+ pragma Assert (Present (Expr_Type));
+
+ -- For each range in an array type where a discriminant has been
+ -- replaced with the constraint, check that this range is within
+ -- the range of the base type. This checks is done in the
+ -- _init_proc for regular objects, but has to be done here for
+ -- aggregates since no _init_proc is called for them.
+
+ if Is_Array_Type (Expr_Type) then
+ declare
+ Index : Node_Id := First_Index (Expr_Type);
+ -- Range of the current constrained index in the array.
+
+ Orig_Index : Node_Id := First_Index (Etype (Component));
+ -- Range corresponding to the range Index above in the
+ -- original unconstrained record type. The bounds of this
+ -- range may be governed by discriminants.
+
+ Unconstr_Index : Node_Id := First_Index (Etype (Expr_Type));
+ -- Range corresponding to the range Index above for the
+ -- unconstrained array type. This range is needed to apply
+ -- range checks.
+
+ begin
+ while Present (Index) loop
+ if Depends_On_Discriminant (Orig_Index) then
+ Apply_Range_Check (Index, Etype (Unconstr_Index));
+ end if;
+
+ Next_Index (Index);
+ Next_Index (Orig_Index);
+ Next_Index (Unconstr_Index);
+ end loop;
+ end;
+ end if;
+ end if;
+
+ -- If the Parent pointer of Expr is not set, Expr is an expression
+ -- duplicated by New_Tree_Copy (this happens for record aggregates
+ -- that look like (Field1 | Filed2 => Expr) or (others => Expr)).
+ -- Such a duplicated expression must be attached to the tree
+ -- before analysis and resolution to enforce the rule that a tree
+ -- fragment should never be analyzed or resolved unless it is
+ -- attached to the current compilation unit.
+
+ if No (Parent (Expr)) then
+ Set_Parent (Expr, N);
+ Relocate := False;
+ else
+ Relocate := True;
+ end if;
+
+ Analyze_And_Resolve (Expr, Expr_Type);
+ Check_Non_Static_Context (Expr);
+
+ if not Has_Expansion_Delayed (Expr) then
+ Aggregate_Constraint_Checks (Expr, Expr_Type);
+ end if;
+
+ if Raises_Constraint_Error (Expr) then
+ Set_Raises_Constraint_Error (N);
+ end if;
+
+ if Relocate then
+ Add_Association (New_C, Relocate_Node (Expr));
+ else
+ Add_Association (New_C, Expr);
+ end if;
+
+ end Resolve_Aggr_Expr;
+
+ -- Resolve_Record_Aggregate local variables
+
+ Assoc : Node_Id;
+ -- N_Component_Association node belonging to the input aggregate N
+
+ Expr : Node_Id;
+ Positional_Expr : Node_Id;
+
+ Component : Entity_Id;
+ Component_Elmt : Elmt_Id;
+ Components : Elist_Id := New_Elmt_List;
+ -- Components is the list of the record components whose value must
+ -- be provided in the aggregate. This list does include discriminants.
+
+ -- Start of processing for Resolve_Record_Aggregate
+
+ begin
+ -- We may end up calling Duplicate_Subexpr on expressions that are
+ -- attached to New_Assoc_List. For this reason we need to attach it
+ -- to the tree by setting its parent pointer to N. This parent point
+ -- will change in STEP 8 below.
+
+ Set_Parent (New_Assoc_List, N);
+
+ -- STEP 1: abstract type and null record verification
+
+ if Is_Abstract (Typ) then
+ Error_Msg_N ("type of aggregate cannot be abstract", N);
+ end if;
+
+ if No (First_Entity (Typ)) and then Null_Record_Present (N) then
+ Set_Etype (N, Typ);
+ return;
+
+ elsif Present (First_Entity (Typ))
+ and then Null_Record_Present (N)
+ and then not Is_Tagged_Type (Typ)
+ then
+ Error_Msg_N ("record aggregate cannot be null", N);
+ return;
+
+ elsif No (First_Entity (Typ)) then
+ Error_Msg_N ("record aggregate must be null", N);
+ return;
+ end if;
+
+ -- STEP 2: Verify aggregate structure
+
+ Step_2 : declare
+ Selector_Name : Node_Id;
+ Bad_Aggregate : Boolean := False;
+
+ begin
+ if Present (Component_Associations (N)) then
+ Assoc := First (Component_Associations (N));
+ else
+ Assoc := Empty;
+ end if;
+
+ while Present (Assoc) loop
+ Selector_Name := First (Choices (Assoc));
+ while Present (Selector_Name) loop
+ if Nkind (Selector_Name) = N_Identifier then
+ null;
+
+ elsif Nkind (Selector_Name) = N_Others_Choice then
+ if Selector_Name /= First (Choices (Assoc))
+ or else Present (Next (Selector_Name))
+ then
+ Error_Msg_N ("OTHERS must appear alone in a choice list",
+ Selector_Name);
+ return;
+
+ elsif Present (Next (Assoc)) then
+ Error_Msg_N ("OTHERS must appear last in an aggregate",
+ Selector_Name);
+ return;
+ end if;
+
+ else
+ Error_Msg_N
+ ("selector name should be identifier or OTHERS",
+ Selector_Name);
+ Bad_Aggregate := True;
+ end if;
+
+ Next (Selector_Name);
+ end loop;
+
+ Next (Assoc);
+ end loop;
+
+ if Bad_Aggregate then
+ return;
+ end if;
+ end Step_2;
+
+ -- STEP 3: Find discriminant Values
+
+ Step_3 : declare
+ Discrim : Entity_Id;
+ Missing_Discriminants : Boolean := False;
+
+ begin
+ if Present (Expressions (N)) then
+ Positional_Expr := First (Expressions (N));
+ else
+ Positional_Expr := Empty;
+ end if;
+
+ if Has_Discriminants (Typ) then
+ Discrim := First_Discriminant (Typ);
+ else
+ Discrim := Empty;
+ end if;
+
+ -- First find the discriminant values in the positional components
+
+ while Present (Discrim) and then Present (Positional_Expr) loop
+ if Discr_Present (Discrim) then
+ Resolve_Aggr_Expr (Positional_Expr, Discrim);
+ Next (Positional_Expr);
+ end if;
+
+ if Present (Get_Value (Discrim, Component_Associations (N))) then
+ Error_Msg_NE
+ ("more than one value supplied for discriminant&",
+ N, Discrim);
+ end if;
+
+ Next_Discriminant (Discrim);
+ end loop;
+
+ -- Find remaining discriminant values, if any, among named components
+
+ while Present (Discrim) loop
+ Expr := Get_Value (Discrim, Component_Associations (N), True);
+
+ if not Discr_Present (Discrim) then
+ if Present (Expr) then
+ Error_Msg_NE
+ ("more than one value supplied for discriminant&",
+ N, Discrim);
+ end if;
+
+ elsif No (Expr) then
+ Error_Msg_NE
+ ("no value supplied for discriminant &", N, Discrim);
+ Missing_Discriminants := True;
+
+ else
+ Resolve_Aggr_Expr (Expr, Discrim);
+ end if;
+
+ Next_Discriminant (Discrim);
+ end loop;
+
+ if Missing_Discriminants then
+ return;
+ end if;
+
+ -- At this point and until the beginning of STEP 6, New_Assoc_List
+ -- contains only the discriminants and their values.
+
+ end Step_3;
+
+ -- STEP 4: Set the Etype of the record aggregate
+
+ -- ??? This code is pretty much a copy of Sem_Ch3.Build_Subtype. That
+ -- routine should really be exported in sem_util or some such and used
+ -- in sem_ch3 and here rather than have a copy of the code which is a
+ -- maintenance nightmare.
+
+ -- ??? Performace WARNING. The current implementation creates a new
+ -- itype for all aggregates whose base type is discriminated.
+ -- This means that for record aggregates nested inside an array
+ -- aggregate we will create a new itype for each record aggregate
+ -- if the array cmponent type has discriminants. For large aggregates
+ -- this may be a problem. What should be done in this case is
+ -- to reuse itypes as much as possible.
+
+ if Has_Discriminants (Typ) then
+ Build_Constrained_Itype : declare
+ Loc : constant Source_Ptr := Sloc (N);
+ Indic : Node_Id;
+ Subtyp_Decl : Node_Id;
+ Def_Id : Entity_Id;
+
+ C : List_Id := New_List;
+
+ begin
+ New_Assoc := First (New_Assoc_List);
+ while Present (New_Assoc) loop
+ Append (Duplicate_Subexpr (Expression (New_Assoc)), To => C);
+ Next (New_Assoc);
+ end loop;
+
+ Indic :=
+ Make_Subtype_Indication (Loc,
+ Subtype_Mark => New_Occurrence_Of (Base_Type (Typ), Loc),
+ Constraint => Make_Index_Or_Discriminant_Constraint (Loc, C));
+
+ Def_Id := Create_Itype (Ekind (Typ), N);
+
+ Subtyp_Decl :=
+ Make_Subtype_Declaration (Loc,
+ Defining_Identifier => Def_Id,
+ Subtype_Indication => Indic);
+ Set_Parent (Subtyp_Decl, Parent (N));
+
+ -- Itypes must be analyzed with checks off (see itypes.ads).
+
+ Analyze (Subtyp_Decl, Suppress => All_Checks);
+
+ Set_Etype (N, Def_Id);
+ Check_Static_Discriminated_Subtype
+ (Def_Id, Expression (First (New_Assoc_List)));
+ end Build_Constrained_Itype;
+
+ else
+ Set_Etype (N, Typ);
+ end if;
+
+ -- STEP 5: Get remaining components according to discriminant values
+
+ Step_5 : declare
+ Record_Def : Node_Id;
+ Parent_Typ : Entity_Id;
+ Root_Typ : Entity_Id;
+ Parent_Typ_List : Elist_Id;
+ Parent_Elmt : Elmt_Id;
+ Errors_Found : Boolean := False;
+ Dnode : Node_Id;
+
+ begin
+ if Is_Derived_Type (Typ) and then Is_Tagged_Type (Typ) then
+ Parent_Typ_List := New_Elmt_List;
+
+ -- If this is an extension aggregate, the component list must
+ -- include all components that are not in the given ancestor
+ -- type. Otherwise, the component list must include components
+ -- of all ancestors.
+
+ if Nkind (N) = N_Extension_Aggregate then
+ Root_Typ := Base_Type (Etype (Ancestor_Part (N)));
+ else
+ Root_Typ := Root_Type (Typ);
+
+ if Nkind (Parent (Base_Type (Root_Typ)))
+ = N_Private_Type_Declaration
+ then
+ Error_Msg_NE
+ ("type of aggregate has private ancestor&!",
+ N, Root_Typ);
+ Error_Msg_N ("must use extension aggregate!", N);
+ return;
+ end if;
+
+ Dnode := Declaration_Node (Base_Type (Root_Typ));
+
+ -- If we don't get a full declaration, then we have some
+ -- error which will get signalled later so skip this part.
+
+ if Nkind (Dnode) = N_Full_Type_Declaration then
+ Record_Def := Type_Definition (Dnode);
+ Gather_Components (Typ,
+ Component_List (Record_Def),
+ Governed_By => New_Assoc_List,
+ Into => Components,
+ Report_Errors => Errors_Found);
+ end if;
+ end if;
+
+ Parent_Typ := Base_Type (Typ);
+ while Parent_Typ /= Root_Typ loop
+
+ Prepend_Elmt (Parent_Typ, To => Parent_Typ_List);
+ Parent_Typ := Etype (Parent_Typ);
+
+ if (Nkind (Parent (Base_Type (Parent_Typ))) =
+ N_Private_Type_Declaration
+ or else Nkind (Parent (Base_Type (Parent_Typ))) =
+ N_Private_Extension_Declaration)
+ then
+ if Nkind (N) /= N_Extension_Aggregate then
+ Error_Msg_NE
+ ("type of aggregate has private ancestor&!",
+ N, Parent_Typ);
+ Error_Msg_N ("must use extension aggregate!", N);
+ return;
+
+ elsif Parent_Typ /= Root_Typ then
+ Error_Msg_NE
+ ("ancestor part of aggregate must be private type&",
+ Ancestor_Part (N), Parent_Typ);
+ return;
+ end if;
+ end if;
+ end loop;
+
+ -- Now collect components from all other ancestors.
+
+ Parent_Elmt := First_Elmt (Parent_Typ_List);
+ while Present (Parent_Elmt) loop
+ Parent_Typ := Node (Parent_Elmt);
+ Record_Def := Type_Definition (Parent (Base_Type (Parent_Typ)));
+ Gather_Components (Empty,
+ Component_List (Record_Extension_Part (Record_Def)),
+ Governed_By => New_Assoc_List,
+ Into => Components,
+ Report_Errors => Errors_Found);
+
+ Next_Elmt (Parent_Elmt);
+ end loop;
+
+ else
+ Record_Def := Type_Definition (Parent (Base_Type (Typ)));
+
+ if Null_Present (Record_Def) then
+ null;
+ else
+ Gather_Components (Typ,
+ Component_List (Record_Def),
+ Governed_By => New_Assoc_List,
+ Into => Components,
+ Report_Errors => Errors_Found);
+ end if;
+ end if;
+
+ if Errors_Found then
+ return;
+ end if;
+ end Step_5;
+
+ -- STEP 6: Find component Values
+
+ Component := Empty;
+ Component_Elmt := First_Elmt (Components);
+
+ -- First scan the remaining positional associations in the aggregate.
+ -- Remember that at this point Positional_Expr contains the current
+ -- positional association if any is left after looking for discriminant
+ -- values in step 3.
+
+ while Present (Positional_Expr) and then Present (Component_Elmt) loop
+ Component := Node (Component_Elmt);
+ Resolve_Aggr_Expr (Positional_Expr, Component);
+
+ if Present (Get_Value (Component, Component_Associations (N))) then
+ Error_Msg_NE
+ ("more than one value supplied for Component &", N, Component);
+ end if;
+
+ Next (Positional_Expr);
+ Next_Elmt (Component_Elmt);
+ end loop;
+
+ if Present (Positional_Expr) then
+ Error_Msg_N
+ ("too many components for record aggregate", Positional_Expr);
+ end if;
+
+ -- Now scan for the named arguments of the aggregate
+
+ while Present (Component_Elmt) loop
+ Component := Node (Component_Elmt);
+ Expr := Get_Value (Component, Component_Associations (N), True);
+
+ if No (Expr) then
+ Error_Msg_NE ("no value supplied for component &!", N, Component);
+ else
+ Resolve_Aggr_Expr (Expr, Component);
+ end if;
+
+ Next_Elmt (Component_Elmt);
+ end loop;
+
+ -- STEP 7: check for invalid components + check type in choice list
+
+ Step_7 : declare
+ Selectr : Node_Id;
+ -- Selector name
+
+ Typech : Entity_Id;
+ -- Type of first component in choice list
+
+ begin
+ if Present (Component_Associations (N)) then
+ Assoc := First (Component_Associations (N));
+ else
+ Assoc := Empty;
+ end if;
+
+ Verification : while Present (Assoc) loop
+ Selectr := First (Choices (Assoc));
+ Typech := Empty;
+
+ if Nkind (Selectr) = N_Others_Choice then
+ if No (Others_Etype) then
+ Error_Msg_N
+ ("OTHERS must represent at least one component", Selectr);
+ end if;
+
+ exit Verification;
+ end if;
+
+ while Present (Selectr) loop
+ New_Assoc := First (New_Assoc_List);
+ while Present (New_Assoc) loop
+ Component := First (Choices (New_Assoc));
+ exit when Chars (Selectr) = Chars (Component);
+ Next (New_Assoc);
+ end loop;
+
+ -- If no association, this is not a legal component of
+ -- of the type in question, except if this is an internal
+ -- component supplied by a previous expansion.
+
+ if No (New_Assoc) then
+
+ if Chars (Selectr) /= Name_uTag
+ and then Chars (Selectr) /= Name_uParent
+ and then Chars (Selectr) /= Name_uController
+ then
+ if not Has_Discriminants (Typ) then
+ Error_Msg_Node_2 := Typ;
+ Error_Msg_N
+ ("& is not a component of}",
+ Selectr);
+ else
+ Error_Msg_N
+ ("& is not a component of the aggregate subtype",
+ Selectr);
+ end if;
+
+ Check_Misspelled_Component (Components, Selectr);
+ end if;
+
+ elsif No (Typech) then
+ Typech := Base_Type (Etype (Component));
+
+ elsif Typech /= Base_Type (Etype (Component)) then
+ Error_Msg_N
+ ("components in choice list must have same type", Selectr);
+ end if;
+
+ Next (Selectr);
+ end loop;
+
+ Next (Assoc);
+ end loop Verification;
+ end Step_7;
+
+ -- STEP 8: replace the original aggregate
+
+ Step_8 : declare
+ New_Aggregate : Node_Id := New_Copy (N);
+
+ begin
+ Set_Expressions (New_Aggregate, No_List);
+ Set_Etype (New_Aggregate, Etype (N));
+ Set_Component_Associations (New_Aggregate, New_Assoc_List);
+
+ Rewrite (N, New_Aggregate);
+ end Step_8;
+ end Resolve_Record_Aggregate;
+
+ ---------------------
+ -- Sort_Case_Table --
+ ---------------------
+
+ procedure Sort_Case_Table (Case_Table : in out Case_Table_Type) is
+ L : Int := Case_Table'First;
+ U : Int := Case_Table'Last;
+ K : Int;
+ J : Int;
+ T : Case_Bounds;
+
+ begin
+ K := L;
+
+ while K /= U loop
+ T := Case_Table (K + 1);
+ J := K + 1;
+
+ while J /= L
+ and then Expr_Value (Case_Table (J - 1).Choice_Lo) >
+ Expr_Value (T.Choice_Lo)
+ loop
+ Case_Table (J) := Case_Table (J - 1);
+ J := J - 1;
+ end loop;
+
+ Case_Table (J) := T;
+ K := K + 1;
+ end loop;
+ end Sort_Case_Table;
+
+end Sem_Aggr;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S E M _ A G G R --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.3 $ --
+-- --
+-- Copyright (C) 1992,1993,1994 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 contains the resolution code for aggregates. It is logically
+-- part of Sem_Res, but is split off since the aggregate code is so complex.
+
+with Types; use Types;
+
+package Sem_Aggr is
+
+ procedure Resolve_Aggregate (N : Node_Id; Typ : Entity_Id);
+ procedure Resolve_Extension_Aggregate (N : Node_Id; Typ : Entity_Id);
+
+end Sem_Aggr;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S E M _ A T T R --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.552 $
+-- --
+-- 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). --
+-- --
+------------------------------------------------------------------------------
+
+with Ada.Characters.Latin_1; use Ada.Characters.Latin_1;
+
+with Atree; use Atree;
+with Checks; use Checks;
+with Einfo; use Einfo;
+with Errout; use Errout;
+with Eval_Fat;
+with Exp_Tss; use Exp_Tss;
+with Exp_Util; use Exp_Util;
+with Expander; use Expander;
+with Freeze; use Freeze;
+with Lib.Xref; use Lib.Xref;
+with Namet; use Namet;
+with Nlists; use Nlists;
+with Nmake; use Nmake;
+with Opt; use Opt;
+with Restrict; use Restrict;
+with Rtsfind; use Rtsfind;
+with Sem; use Sem;
+with Sem_Cat; use Sem_Cat;
+with Sem_Ch6; use Sem_Ch6;
+with Sem_Ch8; use Sem_Ch8;
+with Sem_Ch13; use Sem_Ch13;
+with Sem_Dist; use Sem_Dist;
+with Sem_Eval; use Sem_Eval;
+with Sem_Res; use Sem_Res;
+with Sem_Type; use Sem_Type;
+with Sem_Util; use Sem_Util;
+with Stand; use Stand;
+with Sinfo; use Sinfo;
+with Sinput; use Sinput;
+with Snames; use Snames;
+with Stand;
+with Stringt; use Stringt;
+with Targparm; use Targparm;
+with Ttypes; use Ttypes;
+with Ttypef; use Ttypef;
+with Tbuild; use Tbuild;
+with Uintp; use Uintp;
+with Urealp; use Urealp;
+with Widechar; use Widechar;
+
+package body Sem_Attr is
+
+ True_Value : constant Uint := Uint_1;
+ False_Value : constant Uint := Uint_0;
+ -- Synonyms to be used when these constants are used as Boolean values
+
+ Bad_Attribute : exception;
+ -- Exception raised if an error is detected during attribute processing,
+ -- used so that we can abandon the processing so we don't run into
+ -- trouble with cascaded errors.
+
+ -- The following array is the list of attributes defined in the Ada 83 RM
+
+ Attribute_83 : Attribute_Class_Array := Attribute_Class_Array'(
+ Attribute_Address |
+ Attribute_Aft |
+ Attribute_Alignment |
+ Attribute_Base |
+ Attribute_Callable |
+ Attribute_Constrained |
+ Attribute_Count |
+ Attribute_Delta |
+ Attribute_Digits |
+ Attribute_Emax |
+ Attribute_Epsilon |
+ Attribute_First |
+ Attribute_First_Bit |
+ Attribute_Fore |
+ Attribute_Image |
+ Attribute_Large |
+ Attribute_Last |
+ Attribute_Last_Bit |
+ Attribute_Leading_Part |
+ Attribute_Length |
+ Attribute_Machine_Emax |
+ Attribute_Machine_Emin |
+ Attribute_Machine_Mantissa |
+ Attribute_Machine_Overflows |
+ Attribute_Machine_Radix |
+ Attribute_Machine_Rounds |
+ Attribute_Mantissa |
+ Attribute_Pos |
+ Attribute_Position |
+ Attribute_Pred |
+ Attribute_Range |
+ Attribute_Safe_Emax |
+ Attribute_Safe_Large |
+ Attribute_Safe_Small |
+ Attribute_Size |
+ Attribute_Small |
+ Attribute_Storage_Size |
+ Attribute_Succ |
+ Attribute_Terminated |
+ Attribute_Val |
+ Attribute_Value |
+ Attribute_Width => True,
+ others => False);
+
+ -----------------------
+ -- Local_Subprograms --
+ -----------------------
+
+ procedure Eval_Attribute (N : Node_Id);
+ -- Performs compile time evaluation of attributes where possible, leaving
+ -- the Is_Static_Expression/Raises_Constraint_Error flags appropriately
+ -- set, and replacing the node with a literal node if the value can be
+ -- computed at compile time. All static attribute references are folded,
+ -- as well as a number of cases of non-static attributes that can always
+ -- be computed at compile time (e.g. floating-point model attributes that
+ -- are applied to non-static subtypes). Of course in such cases, the
+ -- Is_Static_Expression flag will not be set on the resulting literal.
+ -- Note that the only required action of this procedure is to catch the
+ -- static expression cases as described in the RM. Folding of other cases
+ -- is done where convenient, but some additional non-static folding is in
+ -- N_Expand_Attribute_Reference in cases where this is more convenient.
+
+ function Is_Anonymous_Tagged_Base
+ (Anon : Entity_Id;
+ Typ : Entity_Id)
+ return Boolean;
+ -- For derived tagged types that constrain parent discriminants we build
+ -- an anonymous unconstrained base type. We need to recognize the relation
+ -- between the two when analyzing an access attribute for a constrained
+ -- component, before the full declaration for Typ has been analyzed, and
+ -- where therefore the prefix of the attribute does not match the enclosing
+ -- scope.
+
+ -----------------------
+ -- Analyze_Attribute --
+ -----------------------
+
+ procedure Analyze_Attribute (N : Node_Id) is
+ Loc : constant Source_Ptr := Sloc (N);
+ Aname : constant Name_Id := Attribute_Name (N);
+ P : constant Node_Id := Prefix (N);
+ Exprs : constant List_Id := Expressions (N);
+ Attr_Id : constant Attribute_Id := Get_Attribute_Id (Aname);
+ E1 : Node_Id;
+ E2 : Node_Id;
+
+ P_Type : Entity_Id;
+ -- Type of prefix after analysis
+
+ P_Base_Type : Entity_Id;
+ -- Base type of prefix after analysis
+
+ P_Root_Type : Entity_Id;
+ -- Root type of prefix after analysis
+
+ Unanalyzed : Node_Id;
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ procedure Access_Attribute;
+ -- Used for Access, Unchecked_Access, Unrestricted_Access attributes.
+ -- Internally, Id distinguishes which of the three cases is involved.
+
+ procedure Check_Array_Or_Scalar_Type;
+ -- Common procedure used by First, Last, Range attribute to check
+ -- that the prefix is a constrained array or scalar type, or a name
+ -- of an array object, and that an argument appears only if appropriate
+ -- (i.e. only in the array case).
+
+ procedure Check_Array_Type;
+ -- Common semantic checks for all array attributes. Checks that the
+ -- prefix is a constrained array type or the name of an array object.
+ -- The error message for non-arrays is specialized appropriately.
+
+ procedure Check_Asm_Attribute;
+ -- Common semantic checks for Asm_Input and Asm_Output attributes
+
+ procedure Check_Component;
+ -- Common processing for Bit_Position, First_Bit, Last_Bit, and
+ -- Position. Checks prefix is an appropriate selected component.
+
+ procedure Check_Decimal_Fixed_Point_Type;
+ -- Check that prefix of attribute N is a decimal fixed-point type
+
+ procedure Check_Dereference;
+ -- If the prefix of attribute is an object of an access type, then
+ -- introduce an explicit deference, and adjust P_Type accordingly.
+
+ procedure Check_Discrete_Type;
+ -- Verify that prefix of attribute N is a discrete type
+
+ procedure Check_E0;
+ -- Check that no attribute arguments are present
+
+ procedure Check_Either_E0_Or_E1;
+ -- Check that there are zero or one attribute arguments present
+
+ procedure Check_E1;
+ -- Check that exactly one attribute argument is present
+
+ procedure Check_E2;
+ -- Check that two attribute arguments are present
+
+ procedure Check_Enum_Image;
+ -- If the prefix type is an enumeration type, set all its literals
+ -- as referenced, since the image function could possibly end up
+ -- referencing any of the literals indirectly.
+
+ procedure Check_Enumeration_Type;
+ -- Verify that prefix of attribute N is an enumeration type
+
+ procedure Check_Fixed_Point_Type;
+ -- Verify that prefix of attribute N is a fixed type
+
+ procedure Check_Fixed_Point_Type_0;
+ -- Verify that prefix of attribute N is a fixed type and that
+ -- no attribute expressions are present
+
+ procedure Check_Floating_Point_Type;
+ -- Verify that prefix of attribute N is a float type
+
+ procedure Check_Floating_Point_Type_0;
+ -- Verify that prefix of attribute N is a float type and that
+ -- no attribute expressions are present
+
+ procedure Check_Floating_Point_Type_1;
+ -- Verify that prefix of attribute N is a float type and that
+ -- exactly one attribute expression is present
+
+ procedure Check_Floating_Point_Type_2;
+ -- Verify that prefix of attribute N is a float type and that
+ -- two attribute expressions are present
+
+ procedure Legal_Formal_Attribute;
+ -- Common processing for attributes Definite, and Has_Discriminants
+
+ procedure Check_Integer_Type;
+ -- Verify that prefix of attribute N is an integer type
+
+ procedure Check_Library_Unit;
+ -- Verify that prefix of attribute N is a library unit
+
+ procedure Check_Not_Incomplete_Type;
+ -- Check that P (the prefix of the attribute) is not an incomplete
+ -- type or a private type for which no full view has been given.
+
+ procedure Check_Object_Reference (P : Node_Id);
+ -- Check that P (the prefix of the attribute) is an object reference
+
+ procedure Check_Program_Unit;
+ -- Verify that prefix of attribute N is a program unit
+
+ procedure Check_Real_Type;
+ -- Verify that prefix of attribute N is fixed or float type
+
+ procedure Check_Scalar_Type;
+ -- Verify that prefix of attribute N is a scalar type
+
+ procedure Check_Standard_Prefix;
+ -- Verify that prefix of attribute N is package Standard
+
+ procedure Check_Stream_Attribute (Nam : Name_Id);
+ -- Validity checking for stream attribute. Nam is the name of the
+ -- corresponding possible defined attribute function (e.g. for the
+ -- Read attribute, Nam will be Name_uRead).
+
+ procedure Check_Task_Prefix;
+ -- Verify that prefix of attribute N is a task or task type
+
+ procedure Check_Type;
+ -- Verify that the prefix of attribute N is a type
+
+ procedure Check_Unit_Name (Nod : Node_Id);
+ -- Check that Nod is of the form of a library unit name, i.e that
+ -- it is an identifier, or a selected component whose prefix is
+ -- itself of the form of a library unit name. Note that this is
+ -- quite different from Check_Program_Unit, since it only checks
+ -- the syntactic form of the name, not the semantic identity. This
+ -- is because it is used with attributes (Elab_Body, Elab_Spec, and
+ -- UET_Address) which can refer to non-visible unit.
+
+ procedure Error_Attr (Msg : String; Error_Node : Node_Id);
+ pragma No_Return (Error_Attr);
+ -- Posts error using Error_Msg_N at given node, sets type of attribute
+ -- node to Any_Type, and then raises Bad_Attribute to avoid any further
+ -- semantic processing. The message typically contains a % insertion
+ -- character which is replaced by the attribute name.
+
+ procedure Standard_Attribute (Val : Int);
+ -- Used to process attributes whose prefix is package Standard which
+ -- yield values of type Universal_Integer. The attribute reference
+ -- node is rewritten with an integer literal of the given value.
+
+ procedure Unexpected_Argument (En : Node_Id);
+ -- Signal unexpected attribute argument (En is the argument)
+
+ procedure Validate_Non_Static_Attribute_Function_Call;
+ -- Called when processing an attribute that is a function call to a
+ -- non-static function, i.e. an attribute function that either takes
+ -- non-scalar arguments or returns a non-scalar result. Verifies that
+ -- such a call does not appear in a preelaborable context.
+
+ ----------------------
+ -- Access_Attribute --
+ ----------------------
+
+ procedure Access_Attribute is
+ Acc_Type : Entity_Id;
+
+ Scop : Entity_Id;
+ Typ : Entity_Id;
+
+ function Build_Access_Object_Type (DT : Entity_Id) return Entity_Id;
+ -- Build an access-to-object type whose designated type is DT,
+ -- and whose Ekind is appropriate to the attribute type. The
+ -- type that is constructed is returned as the result.
+
+ procedure Build_Access_Subprogram_Type (P : Node_Id);
+ -- Build an access to subprogram whose designated type is
+ -- the type of the prefix. If prefix is overloaded, so it the
+ -- node itself. The result is stored in Acc_Type.
+
+ ------------------------------
+ -- Build_Access_Object_Type --
+ ------------------------------
+
+ function Build_Access_Object_Type (DT : Entity_Id) return Entity_Id is
+ Typ : Entity_Id;
+
+ begin
+ if Aname = Name_Unrestricted_Access then
+ Typ :=
+ New_Internal_Entity
+ (E_Allocator_Type, Current_Scope, Loc, 'A');
+ else
+ Typ :=
+ New_Internal_Entity
+ (E_Access_Attribute_Type, Current_Scope, Loc, 'A');
+ end if;
+
+ Set_Etype (Typ, Typ);
+ Init_Size_Align (Typ);
+ Set_Is_Itype (Typ);
+ Set_Associated_Node_For_Itype (Typ, N);
+ Set_Directly_Designated_Type (Typ, DT);
+ return Typ;
+ end Build_Access_Object_Type;
+
+ ----------------------------------
+ -- Build_Access_Subprogram_Type --
+ ----------------------------------
+
+ procedure Build_Access_Subprogram_Type (P : Node_Id) is
+ Index : Interp_Index;
+ It : Interp;
+
+ function Get_Kind (E : Entity_Id) return Entity_Kind;
+ -- Distinguish between access to regular and protected
+ -- subprograms.
+
+ function Get_Kind (E : Entity_Id) return Entity_Kind is
+ begin
+ if Convention (E) = Convention_Protected then
+ return E_Access_Protected_Subprogram_Type;
+ else
+ return E_Access_Subprogram_Type;
+ end if;
+ end Get_Kind;
+
+ -- Start of processing for Build_Access_Subprogram_Type
+
+ begin
+ if not Is_Overloaded (P) then
+ Acc_Type :=
+ New_Internal_Entity
+ (Get_Kind (Entity (P)), Current_Scope, Loc, 'A');
+ Set_Etype (Acc_Type, Acc_Type);
+ Set_Directly_Designated_Type (Acc_Type, Entity (P));
+ Set_Etype (N, Acc_Type);
+
+ else
+ Get_First_Interp (P, Index, It);
+ Set_Etype (N, Any_Type);
+
+ while Present (It.Nam) loop
+
+ if not Is_Intrinsic_Subprogram (It.Nam) then
+ Acc_Type :=
+ New_Internal_Entity
+ (Get_Kind (It.Nam), Current_Scope, Loc, 'A');
+ Set_Etype (Acc_Type, Acc_Type);
+ Set_Directly_Designated_Type (Acc_Type, It.Nam);
+ Add_One_Interp (N, Acc_Type, Acc_Type);
+ end if;
+
+ Get_Next_Interp (Index, It);
+ end loop;
+
+ if Etype (N) = Any_Type then
+ Error_Attr ("prefix of % attribute cannot be intrinsic", P);
+ end if;
+ end if;
+ end Build_Access_Subprogram_Type;
+
+ -- Start of processing for Access_Attribute
+
+ begin
+ Check_E0;
+
+ if Nkind (P) = N_Character_Literal then
+ Error_Attr
+ ("prefix of % attribute cannot be enumeration literal", P);
+
+ -- In the case of an access to subprogram, use the name of the
+ -- subprogram itself as the designated type. Type-checking in
+ -- this case compares the signatures of the designated types.
+
+ elsif Is_Entity_Name (P)
+ and then Is_Overloadable (Entity (P))
+ then
+ Build_Access_Subprogram_Type (P);
+ return;
+
+ -- Component is an operation of a protected type.
+
+ elsif (Nkind (P) = N_Selected_Component
+ and then Is_Overloadable (Entity (Selector_Name (P))))
+ then
+ if Ekind (Entity (Selector_Name (P))) = E_Entry then
+ Error_Attr ("Prefix of % attribute must be subprogram", P);
+ end if;
+
+ Build_Access_Subprogram_Type (Selector_Name (P));
+ return;
+ end if;
+
+ -- Deal with incorrect reference to a type, but note that some
+ -- accesses are allowed (references to the current type instance).
+
+ if Is_Entity_Name (P) then
+ Scop := Current_Scope;
+ Typ := Entity (P);
+
+ if Is_Type (Typ) then
+
+ -- OK if we are within the scope of a limited type
+ -- let's mark the component as having per object constraint
+
+ if Is_Anonymous_Tagged_Base (Scop, Typ) then
+ Typ := Scop;
+ Set_Entity (P, Typ);
+ Set_Etype (P, Typ);
+ end if;
+
+ if Typ = Scop then
+ declare
+ Q : Node_Id := Parent (N);
+
+ begin
+ while Present (Q)
+ and then Nkind (Q) /= N_Component_Declaration
+ loop
+ Q := Parent (Q);
+ end loop;
+ if Present (Q) then
+ Set_Has_Per_Object_Constraint (
+ Defining_Identifier (Q), True);
+ end if;
+ end;
+
+ if Nkind (P) = N_Expanded_Name then
+ Error_Msg_N
+ ("current instance prefix must be a direct name", P);
+ end if;
+
+ -- If a current instance attribute appears within a
+ -- a component constraint it must appear alone; other
+ -- contexts (default expressions, within a task body)
+ -- are not subject to this restriction.
+
+ if not In_Default_Expression
+ and then not Has_Completion (Scop)
+ and then
+ Nkind (Parent (N)) /= N_Discriminant_Association
+ and then
+ Nkind (Parent (N)) /= N_Index_Or_Discriminant_Constraint
+ then
+ Error_Msg_N
+ ("current instance attribute must appear alone", N);
+ end if;
+
+ -- OK if we are in initialization procedure for the type
+ -- in question, in which case the reference to the type
+ -- is rewritten as a reference to the current object.
+
+ elsif Ekind (Scop) = E_Procedure
+ and then Chars (Scop) = Name_uInit_Proc
+ and then Etype (First_Formal (Scop)) = Typ
+ then
+ Rewrite (N,
+ Make_Attribute_Reference (Loc,
+ Prefix => Make_Identifier (Loc, Name_uInit),
+ Attribute_Name => Name_Unrestricted_Access));
+ Analyze (N);
+ return;
+
+ -- OK if a task type, this test needs sharpening up ???
+
+ elsif Is_Task_Type (Typ) then
+ null;
+
+ -- Otherwise we have an error case
+
+ else
+ Error_Attr ("% attribute cannot be applied to type", P);
+ return;
+ end if;
+ end if;
+ end if;
+
+ -- If we fall through, we have a normal access to object case.
+ -- Unrestricted_Access is legal wherever an allocator would be
+ -- legal, so its Etype is set to E_Allocator. The expected type
+ -- of the other attributes is a general access type, and therefore
+ -- we label them with E_Access_Attribute_Type.
+
+ if not Is_Overloaded (P) then
+ Acc_Type := Build_Access_Object_Type (P_Type);
+ Set_Etype (N, Acc_Type);
+ else
+ declare
+ Index : Interp_Index;
+ It : Interp;
+
+ begin
+ Set_Etype (N, Any_Type);
+ Get_First_Interp (P, Index, It);
+
+ while Present (It.Typ) loop
+ Acc_Type := Build_Access_Object_Type (It.Typ);
+ Add_One_Interp (N, Acc_Type, Acc_Type);
+ Get_Next_Interp (Index, It);
+ end loop;
+ end;
+ end if;
+
+ -- Check for aliased view unless unrestricted case. We allow
+ -- a nonaliased prefix when within an instance because the
+ -- prefix may have been a tagged formal object, which is
+ -- defined to be aliased even when the actual might not be
+ -- (other instance cases will have been caught in the generic).
+
+ if Aname /= Name_Unrestricted_Access
+ and then not Is_Aliased_View (P)
+ and then not In_Instance
+ then
+ Error_Attr ("prefix of % attribute must be aliased", P);
+ end if;
+
+ end Access_Attribute;
+
+ --------------------------------
+ -- Check_Array_Or_Scalar_Type --
+ --------------------------------
+
+ procedure Check_Array_Or_Scalar_Type is
+ Index : Entity_Id;
+
+ D : Int;
+ -- Dimension number for array attributes.
+
+ begin
+ -- Case of string literal or string literal subtype. These cases
+ -- cannot arise from legal Ada code, but the expander is allowed
+ -- to generate them. They require special handling because string
+ -- literal subtypes do not have standard bounds (the whole idea
+ -- of these subtypes is to avoid having to generate the bounds)
+
+ if Ekind (P_Type) = E_String_Literal_Subtype then
+ Set_Etype (N, Etype (First_Index (P_Base_Type)));
+ return;
+
+ -- Scalar types
+
+ elsif Is_Scalar_Type (P_Type) then
+ Check_Type;
+
+ if Present (E1) then
+ Error_Attr ("invalid argument in % attribute", E1);
+ else
+ Set_Etype (N, P_Base_Type);
+ return;
+ end if;
+
+ -- The following is a special test to allow 'First to apply to
+ -- private scalar types if the attribute comes from generated
+ -- code. This occurs in the case of Normalize_Scalars code.
+
+ elsif Is_Private_Type (P_Type)
+ and then Present (Full_View (P_Type))
+ and then Is_Scalar_Type (Full_View (P_Type))
+ and then not Comes_From_Source (N)
+ then
+ Set_Etype (N, Implementation_Base_Type (P_Type));
+
+ -- Array types other than string literal subtypes handled above
+
+ else
+ Check_Array_Type;
+
+ -- We know prefix is an array type, or the name of an array
+ -- object, and that the expression, if present, is static
+ -- and within the range of the dimensions of the type.
+
+ if Is_Array_Type (P_Type) then
+ Index := First_Index (P_Base_Type);
+
+ else pragma Assert (Is_Access_Type (P_Type));
+ Index := First_Index (Base_Type (Designated_Type (P_Type)));
+ end if;
+
+ if No (E1) then
+
+ -- First dimension assumed
+
+ Set_Etype (N, Base_Type (Etype (Index)));
+
+ else
+ D := UI_To_Int (Intval (E1));
+
+ for J in 1 .. D - 1 loop
+ Next_Index (Index);
+ end loop;
+
+ Set_Etype (N, Base_Type (Etype (Index)));
+ Set_Etype (E1, Standard_Integer);
+ end if;
+ end if;
+ end Check_Array_Or_Scalar_Type;
+
+ ----------------------
+ -- Check_Array_Type --
+ ----------------------
+
+ procedure Check_Array_Type is
+ D : Int;
+ -- Dimension number for array attributes.
+
+ begin
+ -- If the type is a string literal type, then this must be generated
+ -- internally, and no further check is required on its legality.
+
+ if Ekind (P_Type) = E_String_Literal_Subtype then
+ return;
+
+ -- If the type is a composite, it is an illegal aggregate, no point
+ -- in going on.
+
+ elsif P_Type = Any_Composite then
+ raise Bad_Attribute;
+ end if;
+
+ -- Normal case of array type or subtype
+
+ Check_Either_E0_Or_E1;
+
+ if Is_Array_Type (P_Type) then
+ if not Is_Constrained (P_Type)
+ and then Is_Entity_Name (P)
+ and then Is_Type (Entity (P))
+ then
+ -- Note: we do not call Error_Attr here, since we prefer to
+ -- continue, using the relevant index type of the array,
+ -- even though it is unconstrained. This gives better error
+ -- recovery behavior.
+
+ Error_Msg_Name_1 := Aname;
+ Error_Msg_N
+ ("prefix for % attribute must be constrained array", P);
+ end if;
+
+ D := Number_Dimensions (P_Type);
+
+ elsif Is_Access_Type (P_Type)
+ and then Is_Array_Type (Designated_Type (P_Type))
+ then
+ if Is_Entity_Name (P) and then Is_Type (Entity (P)) then
+ Error_Attr ("prefix of % attribute cannot be access type", P);
+ end if;
+
+ D := Number_Dimensions (Designated_Type (P_Type));
+
+ -- If there is an implicit dereference, then we must freeze
+ -- the designated type of the access type, since the type of
+ -- the referenced array is this type (see AI95-00106).
+
+ Freeze_Before (N, Designated_Type (P_Type));
+
+ else
+ if Is_Private_Type (P_Type) then
+ Error_Attr
+ ("prefix for % attribute may not be private type", P);
+
+ elsif Attr_Id = Attribute_First
+ or else
+ Attr_Id = Attribute_Last
+ then
+ Error_Attr ("invalid prefix for % attribute", P);
+
+ else
+ Error_Attr ("prefix for % attribute must be array", P);
+ end if;
+ end if;
+
+ if Present (E1) then
+ Resolve (E1, Any_Integer);
+ Set_Etype (E1, Standard_Integer);
+
+ if not Is_Static_Expression (E1)
+ or else Raises_Constraint_Error (E1)
+ then
+ Error_Attr ("expression for dimension must be static", E1);
+
+ elsif UI_To_Int (Expr_Value (E1)) > D
+ or else UI_To_Int (Expr_Value (E1)) < 1
+ then
+ Error_Attr ("invalid dimension number for array type", E1);
+ end if;
+ end if;
+ end Check_Array_Type;
+
+ -------------------------
+ -- Check_Asm_Attribute --
+ -------------------------
+
+ procedure Check_Asm_Attribute is
+ begin
+ Check_Type;
+ Check_E2;
+
+ -- Check first argument is static string expression
+
+ Analyze_And_Resolve (E1, Standard_String);
+
+ if Etype (E1) = Any_Type then
+ return;
+
+ elsif not Is_OK_Static_Expression (E1) then
+ Error_Attr
+ ("constraint argument must be static string expression", E1);
+ end if;
+
+ -- Check second argument is right type
+
+ Analyze_And_Resolve (E2, Entity (P));
+
+ -- Note: that is all we need to do, we don't need to check
+ -- that it appears in a correct context. The Ada type system
+ -- will do that for us.
+
+ end Check_Asm_Attribute;
+
+ ---------------------
+ -- Check_Component --
+ ---------------------
+
+ procedure Check_Component is
+ begin
+ Check_E0;
+
+ if Nkind (P) /= N_Selected_Component
+ or else
+ (Ekind (Entity (Selector_Name (P))) /= E_Component
+ and then
+ Ekind (Entity (Selector_Name (P))) /= E_Discriminant)
+ then
+ Error_Attr
+ ("prefix for % attribute must be selected component", P);
+ end if;
+ end Check_Component;
+
+ ------------------------------------
+ -- Check_Decimal_Fixed_Point_Type --
+ ------------------------------------
+
+ procedure Check_Decimal_Fixed_Point_Type is
+ begin
+ Check_Type;
+
+ if not Is_Decimal_Fixed_Point_Type (P_Type) then
+ Error_Attr
+ ("prefix of % attribute must be decimal type", P);
+ end if;
+ end Check_Decimal_Fixed_Point_Type;
+
+ -----------------------
+ -- Check_Dereference --
+ -----------------------
+
+ procedure Check_Dereference is
+ begin
+ if Is_Object_Reference (P)
+ and then Is_Access_Type (P_Type)
+ then
+ Rewrite (P,
+ Make_Explicit_Dereference (Sloc (P),
+ Prefix => Relocate_Node (P)));
+
+ Analyze_And_Resolve (P);
+ P_Type := Etype (P);
+
+ if P_Type = Any_Type then
+ raise Bad_Attribute;
+ end if;
+
+ P_Base_Type := Base_Type (P_Type);
+ P_Root_Type := Root_Type (P_Base_Type);
+ end if;
+ end Check_Dereference;
+
+ -------------------------
+ -- Check_Discrete_Type --
+ -------------------------
+
+ procedure Check_Discrete_Type is
+ begin
+ Check_Type;
+
+ if not Is_Discrete_Type (P_Type) then
+ Error_Attr ("prefix of % attribute must be discrete type", P);
+ end if;
+ end Check_Discrete_Type;
+
+ --------------
+ -- Check_E0 --
+ --------------
+
+ procedure Check_E0 is
+ begin
+ if Present (E1) then
+ Unexpected_Argument (E1);
+ end if;
+ end Check_E0;
+
+ --------------
+ -- Check_E1 --
+ --------------
+
+ procedure Check_E1 is
+ begin
+ Check_Either_E0_Or_E1;
+
+ if No (E1) then
+
+ -- Special-case attributes that are functions and that appear as
+ -- the prefix of another attribute. Error is posted on parent.
+
+ if Nkind (Parent (N)) = N_Attribute_Reference
+ and then (Attribute_Name (Parent (N)) = Name_Address
+ or else
+ Attribute_Name (Parent (N)) = Name_Code_Address
+ or else
+ Attribute_Name (Parent (N)) = Name_Access)
+ then
+ Error_Msg_Name_1 := Attribute_Name (Parent (N));
+ Error_Msg_N ("illegal prefix for % attribute", Parent (N));
+ Set_Etype (Parent (N), Any_Type);
+ Set_Entity (Parent (N), Any_Type);
+ raise Bad_Attribute;
+
+ else
+ Error_Attr ("missing argument for % attribute", N);
+ end if;
+ end if;
+ end Check_E1;
+
+ --------------
+ -- Check_E2 --
+ --------------
+
+ procedure Check_E2 is
+ begin
+ if No (E1) then
+ Error_Attr ("missing arguments for % attribute (2 required)", N);
+ elsif No (E2) then
+ Error_Attr ("missing argument for % attribute (2 required)", N);
+ end if;
+ end Check_E2;
+
+ ---------------------------
+ -- Check_Either_E0_Or_E1 --
+ ---------------------------
+
+ procedure Check_Either_E0_Or_E1 is
+ begin
+ if Present (E2) then
+ Unexpected_Argument (E2);
+ end if;
+ end Check_Either_E0_Or_E1;
+
+ ----------------------
+ -- Check_Enum_Image --
+ ----------------------
+
+ procedure Check_Enum_Image is
+ Lit : Entity_Id;
+
+ begin
+ if Is_Enumeration_Type (P_Base_Type) then
+ Lit := First_Literal (P_Base_Type);
+ while Present (Lit) loop
+ Set_Referenced (Lit);
+ Next_Literal (Lit);
+ end loop;
+ end if;
+ end Check_Enum_Image;
+
+ ----------------------------
+ -- Check_Enumeration_Type --
+ ----------------------------
+
+ procedure Check_Enumeration_Type is
+ begin
+ Check_Type;
+
+ if not Is_Enumeration_Type (P_Type) then
+ Error_Attr ("prefix of % attribute must be enumeration type", P);
+ end if;
+ end Check_Enumeration_Type;
+
+ ----------------------------
+ -- Check_Fixed_Point_Type --
+ ----------------------------
+
+ procedure Check_Fixed_Point_Type is
+ begin
+ Check_Type;
+
+ if not Is_Fixed_Point_Type (P_Type) then
+ Error_Attr ("prefix of % attribute must be fixed point type", P);
+ end if;
+ end Check_Fixed_Point_Type;
+
+ ------------------------------
+ -- Check_Fixed_Point_Type_0 --
+ ------------------------------
+
+ procedure Check_Fixed_Point_Type_0 is
+ begin
+ Check_Fixed_Point_Type;
+ Check_E0;
+ end Check_Fixed_Point_Type_0;
+
+ -------------------------------
+ -- Check_Floating_Point_Type --
+ -------------------------------
+
+ procedure Check_Floating_Point_Type is
+ begin
+ Check_Type;
+
+ if not Is_Floating_Point_Type (P_Type) then
+ Error_Attr ("prefix of % attribute must be float type", P);
+ end if;
+ end Check_Floating_Point_Type;
+
+ ---------------------------------
+ -- Check_Floating_Point_Type_0 --
+ ---------------------------------
+
+ procedure Check_Floating_Point_Type_0 is
+ begin
+ Check_Floating_Point_Type;
+ Check_E0;
+ end Check_Floating_Point_Type_0;
+
+ ---------------------------------
+ -- Check_Floating_Point_Type_1 --
+ ---------------------------------
+
+ procedure Check_Floating_Point_Type_1 is
+ begin
+ Check_Floating_Point_Type;
+ Check_E1;
+ end Check_Floating_Point_Type_1;
+
+ ---------------------------------
+ -- Check_Floating_Point_Type_2 --
+ ---------------------------------
+
+ procedure Check_Floating_Point_Type_2 is
+ begin
+ Check_Floating_Point_Type;
+ Check_E2;
+ end Check_Floating_Point_Type_2;
+
+ ------------------------
+ -- Check_Integer_Type --
+ ------------------------
+
+ procedure Check_Integer_Type is
+ begin
+ Check_Type;
+
+ if not Is_Integer_Type (P_Type) then
+ Error_Attr ("prefix of % attribute must be integer type", P);
+ end if;
+ end Check_Integer_Type;
+
+ ------------------------
+ -- Check_Library_Unit --
+ ------------------------
+
+ procedure Check_Library_Unit is
+ begin
+ if not Is_Compilation_Unit (Entity (P)) then
+ Error_Attr ("prefix of % attribute must be library unit", P);
+ end if;
+ end Check_Library_Unit;
+
+ -------------------------------
+ -- Check_Not_Incomplete_Type --
+ -------------------------------
+
+ procedure Check_Not_Incomplete_Type is
+ begin
+ if not Is_Entity_Name (P)
+ or else not Is_Type (Entity (P))
+ or else In_Default_Expression
+ then
+ return;
+
+ else
+ Check_Fully_Declared (P_Type, P);
+ end if;
+ end Check_Not_Incomplete_Type;
+
+ ----------------------------
+ -- Check_Object_Reference --
+ ----------------------------
+
+ procedure Check_Object_Reference (P : Node_Id) is
+ Rtyp : Entity_Id;
+
+ begin
+ -- If we need an object, and we have a prefix that is the name of
+ -- a function entity, convert it into a function call.
+
+ if Is_Entity_Name (P)
+ and then Ekind (Entity (P)) = E_Function
+ then
+ Rtyp := Etype (Entity (P));
+
+ Rewrite (P,
+ Make_Function_Call (Sloc (P),
+ Name => Relocate_Node (P)));
+
+ Analyze_And_Resolve (P, Rtyp);
+
+ -- Otherwise we must have an object reference
+
+ elsif not Is_Object_Reference (P) then
+ Error_Attr ("prefix of % attribute must be object", P);
+ end if;
+ end Check_Object_Reference;
+
+ ------------------------
+ -- Check_Program_Unit --
+ ------------------------
+
+ procedure Check_Program_Unit is
+ begin
+ if Is_Entity_Name (P) then
+ declare
+ K : constant Entity_Kind := Ekind (Entity (P));
+ T : constant Entity_Id := Etype (Entity (P));
+
+ begin
+ if K in Subprogram_Kind
+ or else K in Task_Kind
+ or else K in Protected_Kind
+ or else K = E_Package
+ or else K in Generic_Unit_Kind
+ or else (K = E_Variable
+ and then
+ (Is_Task_Type (T)
+ or else
+ Is_Protected_Type (T)))
+ then
+ return;
+ end if;
+ end;
+ end if;
+
+ Error_Attr ("prefix of % attribute must be program unit", P);
+ end Check_Program_Unit;
+
+ ---------------------
+ -- Check_Real_Type --
+ ---------------------
+
+ procedure Check_Real_Type is
+ begin
+ Check_Type;
+
+ if not Is_Real_Type (P_Type) then
+ Error_Attr ("prefix of % attribute must be real type", P);
+ end if;
+ end Check_Real_Type;
+
+ -----------------------
+ -- Check_Scalar_Type --
+ -----------------------
+
+ procedure Check_Scalar_Type is
+ begin
+ Check_Type;
+
+ if not Is_Scalar_Type (P_Type) then
+ Error_Attr ("prefix of % attribute must be scalar type", P);
+ end if;
+ end Check_Scalar_Type;
+
+ ---------------------------
+ -- Check_Standard_Prefix --
+ ---------------------------
+
+ procedure Check_Standard_Prefix is
+ begin
+ Check_E0;
+
+ if Nkind (P) /= N_Identifier
+ or else Chars (P) /= Name_Standard
+ then
+ Error_Attr ("only allowed prefix for % attribute is Standard", P);
+ end if;
+
+ end Check_Standard_Prefix;
+
+ ----------------------------
+ -- Check_Stream_Attribute --
+ ----------------------------
+
+ procedure Check_Stream_Attribute (Nam : Name_Id) is
+ Etyp : Entity_Id;
+ Btyp : Entity_Id;
+
+ begin
+ Validate_Non_Static_Attribute_Function_Call;
+
+ -- With the exception of 'Input, Stream attributes are procedures,
+ -- and can only appear at the position of procedure calls. We check
+ -- for this here, before they are rewritten, to give a more precise
+ -- diagnostic.
+
+ if Nam = Name_uInput then
+ null;
+
+ elsif Is_List_Member (N)
+ and then Nkind (Parent (N)) /= N_Procedure_Call_Statement
+ and then Nkind (Parent (N)) /= N_Aggregate
+ then
+ null;
+
+ else
+ Error_Attr
+ ("invalid context for attribute %, which is a procedure", N);
+ end if;
+
+ Check_Type;
+ Btyp := Implementation_Base_Type (P_Type);
+
+ -- Stream attributes not allowed on limited types unless the
+ -- special OK_For_Stream flag is set.
+
+ if Is_Limited_Type (P_Type)
+ and then Comes_From_Source (N)
+ and then not Present (TSS (Btyp, Nam))
+ and then No (Get_Rep_Pragma (Btyp, Name_Stream_Convert))
+ then
+ -- Special case the message if we are compiling the stub version
+ -- of a remote operation. One error on the type is sufficient.
+
+ if (Is_Remote_Types (Current_Scope)
+ or else Is_Remote_Call_Interface (Current_Scope))
+ and then not Error_Posted (Btyp)
+ then
+ Error_Msg_Node_2 := Current_Scope;
+ Error_Msg_NE
+ ("limited type& used in& has no stream attributes", P, Btyp);
+ Set_Error_Posted (Btyp);
+
+ elsif not Error_Posted (Btyp) then
+ Error_Msg_NE
+ ("limited type& has no stream attributes", P, Btyp);
+ end if;
+ end if;
+
+ -- Here we must check that the first argument is an access type
+ -- that is compatible with Ada.Streams.Root_Stream_Type'Class.
+
+ Analyze_And_Resolve (E1);
+ Etyp := Etype (E1);
+
+ -- Note: the double call to Root_Type here is needed because the
+ -- root type of a class-wide type is the corresponding type (e.g.
+ -- X for X'Class, and we really want to go to the root.
+
+ if not Is_Access_Type (Etyp)
+ or else Root_Type (Root_Type (Designated_Type (Etyp))) /=
+ RTE (RE_Root_Stream_Type)
+ then
+ Error_Attr
+ ("expected access to Ada.Streams.Root_Stream_Type''Class", E1);
+ end if;
+
+ -- Check that the second argument is of the right type if there is
+ -- one (the Input attribute has only one argument so this is skipped)
+
+ if Present (E2) then
+ Analyze (E2);
+
+ if Nam = Name_uRead
+ and then not Is_OK_Variable_For_Out_Formal (E2)
+ then
+ Error_Attr
+ ("second argument of % attribute must be a variable", E2);
+ end if;
+
+ Resolve (E2, P_Type);
+ end if;
+ end Check_Stream_Attribute;
+
+ -----------------------
+ -- Check_Task_Prefix --
+ -----------------------
+
+ procedure Check_Task_Prefix is
+ begin
+ Analyze (P);
+
+ if Is_Task_Type (Etype (P))
+ or else (Is_Access_Type (Etype (P))
+ and then Is_Task_Type (Designated_Type (Etype (P))))
+ then
+ Resolve (P, Etype (P));
+ else
+ Error_Attr ("prefix of % attribute must be a task", P);
+ end if;
+ end Check_Task_Prefix;
+
+ ----------------
+ -- Check_Type --
+ ----------------
+
+ -- The possibilities are an entity name denoting a type, or an
+ -- attribute reference that denotes a type (Base or Class). If
+ -- the type is incomplete, replace it with its full view.
+
+ procedure Check_Type is
+ begin
+ if not Is_Entity_Name (P)
+ or else not Is_Type (Entity (P))
+ then
+ Error_Attr ("prefix of % attribute must be a type", P);
+
+ elsif Ekind (Entity (P)) = E_Incomplete_Type
+ and then Present (Full_View (Entity (P)))
+ then
+ P_Type := Full_View (Entity (P));
+ Set_Entity (P, P_Type);
+ end if;
+ end Check_Type;
+
+ ---------------------
+ -- Check_Unit_Name --
+ ---------------------
+
+ procedure Check_Unit_Name (Nod : Node_Id) is
+ begin
+ if Nkind (Nod) = N_Identifier then
+ return;
+
+ elsif Nkind (Nod) = N_Selected_Component then
+ Check_Unit_Name (Prefix (Nod));
+
+ if Nkind (Selector_Name (Nod)) = N_Identifier then
+ return;
+ end if;
+ end if;
+
+ Error_Attr ("argument for % attribute must be unit name", P);
+ end Check_Unit_Name;
+
+ ----------------
+ -- Error_Attr --
+ ----------------
+
+ procedure Error_Attr (Msg : String; Error_Node : Node_Id) is
+ begin
+ Error_Msg_Name_1 := Aname;
+ Error_Msg_N (Msg, Error_Node);
+ Set_Etype (N, Any_Type);
+ Set_Entity (N, Any_Type);
+ raise Bad_Attribute;
+ end Error_Attr;
+
+ ----------------------------
+ -- Legal_Formal_Attribute --
+ ----------------------------
+
+ procedure Legal_Formal_Attribute is
+ begin
+ Check_E0;
+
+ if not Is_Entity_Name (P)
+ or else not Is_Type (Entity (P))
+ then
+ Error_Attr (" prefix of % attribute must be generic type", N);
+
+ elsif Is_Generic_Actual_Type (Entity (P))
+ or In_Instance
+ then
+ null;
+
+ elsif Is_Generic_Type (Entity (P)) then
+ if not Is_Indefinite_Subtype (Entity (P)) then
+ Error_Attr
+ (" prefix of % attribute must be indefinite generic type", N);
+ end if;
+
+ else
+ Error_Attr
+ (" prefix of % attribute must be indefinite generic type", N);
+ end if;
+
+ Set_Etype (N, Standard_Boolean);
+ end Legal_Formal_Attribute;
+
+ ------------------------
+ -- Standard_Attribute --
+ ------------------------
+
+ procedure Standard_Attribute (Val : Int) is
+ begin
+ Check_Standard_Prefix;
+ Rewrite (N,
+ Make_Integer_Literal (Loc, Val));
+ Analyze (N);
+ end Standard_Attribute;
+
+ -------------------------
+ -- Unexpected Argument --
+ -------------------------
+
+ procedure Unexpected_Argument (En : Node_Id) is
+ begin
+ Error_Attr ("unexpected argument for % attribute", En);
+ end Unexpected_Argument;
+
+ -------------------------------------------------
+ -- Validate_Non_Static_Attribute_Function_Call --
+ -------------------------------------------------
+
+ -- This function should be moved to Sem_Dist ???
+
+ procedure Validate_Non_Static_Attribute_Function_Call is
+ begin
+ if In_Preelaborated_Unit
+ and then not In_Subprogram_Or_Concurrent_Unit
+ then
+ Error_Msg_N ("non-static function call in preelaborated unit", N);
+ end if;
+ end Validate_Non_Static_Attribute_Function_Call;
+
+ -----------------------------------------------
+ -- Start of Processing for Analyze_Attribute --
+ -----------------------------------------------
+
+ begin
+ -- Immediate return if unrecognized attribute (already diagnosed
+ -- by parser, so there is nothing more that we need to do)
+
+ if not Is_Attribute_Name (Aname) then
+ raise Bad_Attribute;
+ end if;
+
+ -- Deal with Ada 83 and Features issues
+
+ if not Attribute_83 (Attr_Id) then
+ if Ada_83 and then Comes_From_Source (N) then
+ Error_Msg_Name_1 := Aname;
+ Error_Msg_N ("(Ada 83) attribute% is not standard?", N);
+ end if;
+
+ if Attribute_Impl_Def (Attr_Id) then
+ Check_Restriction (No_Implementation_Attributes, N);
+ end if;
+ end if;
+
+ -- Remote access to subprogram type access attribute reference needs
+ -- unanalyzed copy for tree transformation. The analyzed copy is used
+ -- for its semantic information (whether prefix is a remote subprogram
+ -- name), the unanalyzed copy is used to construct new subtree rooted
+ -- with N_aggregate which represents a fat pointer aggregate.
+
+ if Aname = Name_Access then
+ Unanalyzed := Copy_Separate_Tree (N);
+ end if;
+
+ -- Analyze prefix and exit if error in analysis. If the prefix is an
+ -- incomplete type, use full view if available. A special case is
+ -- that we never analyze the prefix of an Elab_Body or Elab_Spec
+ -- or UET_Address attribute.
+
+ if Aname /= Name_Elab_Body
+ and then
+ Aname /= Name_Elab_Spec
+ and then
+ Aname /= Name_UET_Address
+ then
+ Analyze (P);
+ P_Type := Etype (P);
+
+ if Is_Entity_Name (P)
+ and then Present (Entity (P))
+ and then Is_Type (Entity (P))
+ and then Ekind (Entity (P)) = E_Incomplete_Type
+ then
+ P_Type := Get_Full_View (P_Type);
+ Set_Entity (P, P_Type);
+ Set_Etype (P, P_Type);
+ end if;
+
+ if P_Type = Any_Type then
+ raise Bad_Attribute;
+ end if;
+
+ P_Base_Type := Base_Type (P_Type);
+ P_Root_Type := Root_Type (P_Base_Type);
+ end if;
+
+ -- Analyze expressions that may be present, exiting if an error occurs
+
+ if No (Exprs) then
+ E1 := Empty;
+ E2 := Empty;
+
+ else
+ E1 := First (Exprs);
+ Analyze (E1);
+
+ if Etype (E1) = Any_Type then
+ raise Bad_Attribute;
+ end if;
+
+ E2 := Next (E1);
+
+ if Present (E2) then
+ Analyze (E2);
+
+ if Etype (E2) = Any_Type then
+ raise Bad_Attribute;
+ end if;
+
+ if Present (Next (E2)) then
+ Unexpected_Argument (Next (E2));
+ end if;
+ end if;
+ end if;
+
+ if Is_Overloaded (P)
+ and then Aname /= Name_Access
+ and then Aname /= Name_Address
+ and then Aname /= Name_Code_Address
+ and then Aname /= Name_Count
+ and then Aname /= Name_Unchecked_Access
+ then
+ Error_Attr ("ambiguous prefix for % attribute", P);
+ end if;
+
+ -- Remaining processing depends on attribute
+
+ case Attr_Id is
+
+ ------------------
+ -- Abort_Signal --
+ ------------------
+
+ when Attribute_Abort_Signal =>
+ Check_Standard_Prefix;
+ Rewrite (N,
+ New_Reference_To (Stand.Abort_Signal, Loc));
+ Analyze (N);
+
+ ------------
+ -- Access --
+ ------------
+
+ when Attribute_Access =>
+ Access_Attribute;
+
+ -------------
+ -- Address --
+ -------------
+
+ when Attribute_Address =>
+ Check_E0;
+
+ -- Check for some junk cases, where we have to allow the address
+ -- attribute but it does not make much sense, so at least for now
+ -- just replace with Null_Address.
+
+ -- We also do this if the prefix is a reference to the AST_Entry
+ -- attribute. If expansion is active, the attribute will be
+ -- replaced by a function call, and address will work fine and
+ -- get the proper value, but if expansion is not active, then
+ -- the check here allows proper semantic analysis of the reference.
+
+ if (Is_Entity_Name (P)
+ and then
+ (((Ekind (Entity (P)) = E_Task_Type
+ or else Ekind (Entity (P)) = E_Protected_Type)
+ and then Etype (Entity (P)) = Base_Type (Entity (P)))
+ or else Ekind (Entity (P)) = E_Package
+ or else Is_Generic_Unit (Entity (P))))
+ or else
+ (Nkind (P) = N_Attribute_Reference
+ and then
+ Attribute_Name (P) = Name_AST_Entry)
+ then
+ Rewrite (N,
+ New_Occurrence_Of (RTE (RE_Null_Address), Sloc (N)));
+
+ -- The following logic is obscure, needs explanation ???
+
+ elsif Nkind (P) = N_Attribute_Reference
+ or else (Is_Entity_Name (P)
+ and then not Is_Subprogram (Entity (P))
+ and then not Is_Object (Entity (P))
+ and then Ekind (Entity (P)) /= E_Label)
+ then
+ Error_Attr ("invalid prefix for % attribute", P);
+
+ elsif Is_Entity_Name (P) then
+ Set_Address_Taken (Entity (P));
+ end if;
+
+ Set_Etype (N, RTE (RE_Address));
+
+ ------------------
+ -- Address_Size --
+ ------------------
+
+ when Attribute_Address_Size =>
+ Standard_Attribute (System_Address_Size);
+
+ --------------
+ -- Adjacent --
+ --------------
+
+ when Attribute_Adjacent =>
+ Check_Floating_Point_Type_2;
+ Set_Etype (N, P_Base_Type);
+ Resolve (E1, P_Base_Type);
+ Resolve (E2, P_Base_Type);
+
+ ---------
+ -- Aft --
+ ---------
+
+ when Attribute_Aft =>
+ Check_Fixed_Point_Type_0;
+ Set_Etype (N, Universal_Integer);
+
+ ---------------
+ -- Alignment --
+ ---------------
+
+ when Attribute_Alignment =>
+
+ -- Don't we need more checking here, cf Size ???
+
+ Check_E0;
+ Check_Not_Incomplete_Type;
+ Set_Etype (N, Universal_Integer);
+
+ ---------------
+ -- Asm_Input --
+ ---------------
+
+ when Attribute_Asm_Input =>
+ Check_Asm_Attribute;
+ Set_Etype (N, RTE (RE_Asm_Input_Operand));
+
+ ----------------
+ -- Asm_Output --
+ ----------------
+
+ when Attribute_Asm_Output =>
+ Check_Asm_Attribute;
+
+ if Etype (E2) = Any_Type then
+ return;
+
+ elsif Aname = Name_Asm_Output then
+ if not Is_Variable (E2) then
+ Error_Attr
+ ("second argument for Asm_Output is not variable", E2);
+ end if;
+ end if;
+
+ Note_Possible_Modification (E2);
+ Set_Etype (N, RTE (RE_Asm_Output_Operand));
+
+ ---------------
+ -- AST_Entry --
+ ---------------
+
+ when Attribute_AST_Entry => AST_Entry : declare
+ Ent : Entity_Id;
+ Pref : Node_Id;
+ Ptyp : Entity_Id;
+
+ Indexed : Boolean;
+ -- Indicates if entry family index is present. Note the coding
+ -- here handles the entry family case, but in fact it cannot be
+ -- executed currently, because pragma AST_Entry does not permit
+ -- the specification of an entry family.
+
+ procedure Bad_AST_Entry;
+ -- Signal a bad AST_Entry pragma
+
+ function OK_Entry (E : Entity_Id) return Boolean;
+ -- Checks that E is of an appropriate entity kind for an entry
+ -- (i.e. E_Entry if Index is False, or E_Entry_Family if Index
+ -- is set True for the entry family case). In the True case,
+ -- makes sure that Is_AST_Entry is set on the entry.
+
+ procedure Bad_AST_Entry is
+ begin
+ Error_Attr ("prefix for % attribute must be task entry", P);
+ end Bad_AST_Entry;
+
+ function OK_Entry (E : Entity_Id) return Boolean is
+ Result : Boolean;
+
+ begin
+ if Indexed then
+ Result := (Ekind (E) = E_Entry_Family);
+ else
+ Result := (Ekind (E) = E_Entry);
+ end if;
+
+ if Result then
+ if not Is_AST_Entry (E) then
+ Error_Msg_Name_2 := Aname;
+ Error_Attr
+ ("% attribute requires previous % pragma", P);
+ end if;
+ end if;
+
+ return Result;
+ end OK_Entry;
+
+ -- Start of processing for AST_Entry
+
+ begin
+ Check_VMS (N);
+ Check_E0;
+
+ -- Deal with entry family case
+
+ if Nkind (P) = N_Indexed_Component then
+ Pref := Prefix (P);
+ Indexed := True;
+ else
+ Pref := P;
+ Indexed := False;
+ end if;
+
+ Ptyp := Etype (Pref);
+
+ if Ptyp = Any_Type or else Error_Posted (Pref) then
+ return;
+ end if;
+
+ -- If the prefix is a selected component whose prefix is of an
+ -- access type, then introduce an explicit dereference.
+
+ if Nkind (Pref) = N_Selected_Component
+ and then Is_Access_Type (Ptyp)
+ then
+ Rewrite (Pref,
+ Make_Explicit_Dereference (Sloc (Pref),
+ Relocate_Node (Pref)));
+ Analyze_And_Resolve (Pref, Designated_Type (Ptyp));
+ end if;
+
+ -- Prefix can be of the form a.b, where a is a task object
+ -- and b is one of the entries of the corresponding task type.
+
+ if Nkind (Pref) = N_Selected_Component
+ and then OK_Entry (Entity (Selector_Name (Pref)))
+ and then Is_Object_Reference (Prefix (Pref))
+ and then Is_Task_Type (Etype (Prefix (Pref)))
+ then
+ null;
+
+ -- Otherwise the prefix must be an entry of a containing task,
+ -- or of a variable of the enclosing task type.
+
+ else
+ if Nkind (Pref) = N_Identifier
+ or else Nkind (Pref) = N_Expanded_Name
+ then
+ Ent := Entity (Pref);
+
+ if not OK_Entry (Ent)
+ or else not In_Open_Scopes (Scope (Ent))
+ then
+ Bad_AST_Entry;
+ end if;
+
+ else
+ Bad_AST_Entry;
+ end if;
+ end if;
+
+ Set_Etype (N, RTE (RE_AST_Handler));
+ end AST_Entry;
+
+ ----------
+ -- Base --
+ ----------
+
+ when Attribute_Base => Base : declare
+ Typ : Entity_Id;
+
+ begin
+ Check_Either_E0_Or_E1;
+ Find_Type (P);
+ Typ := Entity (P);
+
+ if Sloc (Typ) = Standard_Location
+ and then Base_Type (Typ) = Typ
+ and then Warn_On_Redundant_Constructs
+ then
+ Error_Msg_NE
+ ("?redudant attribute, & is its own base type", N, Typ);
+ end if;
+
+ Set_Etype (N, Base_Type (Entity (P)));
+
+ -- If we have an expression present, then really this is a conversion
+ -- and the tree must be reformed. Note that this is one of the cases
+ -- in which we do a replace rather than a rewrite, because the
+ -- original tree is junk.
+
+ if Present (E1) then
+ Replace (N,
+ Make_Type_Conversion (Loc,
+ Subtype_Mark =>
+ Make_Attribute_Reference (Loc,
+ Prefix => Prefix (N),
+ Attribute_Name => Name_Base),
+ Expression => Relocate_Node (E1)));
+
+ -- E1 may be overloaded, and its interpretations preserved.
+
+ Save_Interps (E1, Expression (N));
+ Analyze (N);
+
+ -- For other cases, set the proper type as the entity of the
+ -- attribute reference, and then rewrite the node to be an
+ -- occurrence of the referenced base type. This way, no one
+ -- else in the compiler has to worry about the base attribute.
+
+ else
+ Set_Entity (N, Base_Type (Entity (P)));
+ Rewrite (N,
+ New_Reference_To (Entity (N), Loc));
+ Analyze (N);
+ end if;
+ end Base;
+
+ ---------
+ -- Bit --
+ ---------
+
+ when Attribute_Bit => Bit :
+ begin
+ Check_E0;
+
+ if not Is_Object_Reference (P) then
+ Error_Attr ("prefix for % attribute must be object", P);
+
+ -- What about the access object cases ???
+
+ else
+ null;
+ end if;
+
+ Set_Etype (N, Universal_Integer);
+ end Bit;
+
+ ---------------
+ -- Bit_Order --
+ ---------------
+
+ when Attribute_Bit_Order => Bit_Order :
+ begin
+ Check_E0;
+ Check_Type;
+
+ if not Is_Record_Type (P_Type) then
+ Error_Attr ("prefix of % attribute must be record type", P);
+ end if;
+
+ if Bytes_Big_Endian xor Reverse_Bit_Order (P_Type) then
+ Rewrite (N,
+ New_Occurrence_Of (RTE (RE_High_Order_First), Loc));
+ else
+ Rewrite (N,
+ New_Occurrence_Of (RTE (RE_Low_Order_First), Loc));
+ end if;
+
+ Set_Etype (N, RTE (RE_Bit_Order));
+ Resolve (N, Etype (N));
+
+ -- Reset incorrect indication of staticness
+
+ Set_Is_Static_Expression (N, False);
+ end Bit_Order;
+
+ ------------------
+ -- Bit_Position --
+ ------------------
+
+ -- Note: in generated code, we can have a Bit_Position attribute
+ -- applied to a (naked) record component (i.e. the prefix is an
+ -- identifier that references an E_Component or E_Discriminant
+ -- entity directly, and this is interpreted as expected by Gigi.
+ -- The following code will not tolerate such usage, but when the
+ -- expander creates this special case, it marks it as analyzed
+ -- immediately and sets an appropriate type.
+
+ when Attribute_Bit_Position =>
+
+ if Comes_From_Source (N) then
+ Check_Component;
+ end if;
+
+ Set_Etype (N, Universal_Integer);
+
+ ------------------
+ -- Body_Version --
+ ------------------
+
+ when Attribute_Body_Version =>
+ Check_E0;
+ Check_Program_Unit;
+ Set_Etype (N, RTE (RE_Version_String));
+
+ --------------
+ -- Callable --
+ --------------
+
+ when Attribute_Callable =>
+ Check_E0;
+ Set_Etype (N, Standard_Boolean);
+ Check_Task_Prefix;
+
+ ------------
+ -- Caller --
+ ------------
+
+ when Attribute_Caller => Caller : declare
+ Ent : Entity_Id;
+ S : Entity_Id;
+
+ begin
+ Check_E0;
+
+ if Nkind (P) = N_Identifier
+ or else Nkind (P) = N_Expanded_Name
+ then
+ Ent := Entity (P);
+
+ if not Is_Entry (Ent) then
+ Error_Attr ("invalid entry name", N);
+ end if;
+
+ else
+ Error_Attr ("invalid entry name", N);
+ return;
+ end if;
+
+ for J in reverse 0 .. Scope_Stack.Last loop
+ S := Scope_Stack.Table (J).Entity;
+
+ if S = Scope (Ent) then
+ Error_Attr ("Caller must appear in matching accept or body", N);
+ elsif S = Ent then
+ exit;
+ end if;
+ end loop;
+
+ Set_Etype (N, RTE (RO_AT_Task_ID));
+ end Caller;
+
+ -------------
+ -- Ceiling --
+ -------------
+
+ when Attribute_Ceiling =>
+ Check_Floating_Point_Type_1;
+ Set_Etype (N, P_Base_Type);
+ Resolve (E1, P_Base_Type);
+
+ -----------
+ -- Class --
+ -----------
+
+ when Attribute_Class => Class : declare
+ begin
+ Check_Restriction (No_Dispatch, N);
+ Check_Either_E0_Or_E1;
+
+ -- If we have an expression present, then really this is a conversion
+ -- and the tree must be reformed into a proper conversion. This is a
+ -- Replace rather than a Rewrite, because the original tree is junk.
+ -- If expression is overloaded, propagate interpretations to new one.
+
+ if Present (E1) then
+ Replace (N,
+ Make_Type_Conversion (Loc,
+ Subtype_Mark =>
+ Make_Attribute_Reference (Loc,
+ Prefix => Prefix (N),
+ Attribute_Name => Name_Class),
+ Expression => Relocate_Node (E1)));
+
+ Save_Interps (E1, Expression (N));
+ Analyze (N);
+
+ -- Otherwise we just need to find the proper type
+
+ else
+ Find_Type (N);
+ end if;
+
+ end Class;
+
+ ------------------
+ -- Code_Address --
+ ------------------
+
+ when Attribute_Code_Address =>
+ Check_E0;
+
+ if Nkind (P) = N_Attribute_Reference
+ and then (Attribute_Name (P) = Name_Elab_Body
+ or else
+ Attribute_Name (P) = Name_Elab_Spec)
+ then
+ null;
+
+ elsif not Is_Entity_Name (P)
+ or else (Ekind (Entity (P)) /= E_Function
+ and then
+ Ekind (Entity (P)) /= E_Procedure)
+ then
+ Error_Attr ("invalid prefix for % attribute", P);
+ Set_Address_Taken (Entity (P));
+ end if;
+
+ Set_Etype (N, RTE (RE_Address));
+
+ --------------------
+ -- Component_Size --
+ --------------------
+
+ when Attribute_Component_Size =>
+ Check_E0;
+ Set_Etype (N, Universal_Integer);
+
+ -- Note: unlike other array attributes, unconstrained arrays are OK
+
+ if Is_Array_Type (P_Type) and then not Is_Constrained (P_Type) then
+ null;
+ else
+ Check_Array_Type;
+ end if;
+
+ -------------
+ -- Compose --
+ -------------
+
+ when Attribute_Compose =>
+ Check_Floating_Point_Type_2;
+ Set_Etype (N, P_Base_Type);
+ Resolve (E1, P_Base_Type);
+ Resolve (E2, Any_Integer);
+
+ -----------------
+ -- Constrained --
+ -----------------
+
+ when Attribute_Constrained =>
+ Check_E0;
+ Set_Etype (N, Standard_Boolean);
+
+ -- Case from RM J.4(2) of constrained applied to private type
+
+ if Is_Entity_Name (P) and then Is_Type (Entity (P)) then
+
+ -- If we are within an instance, the attribute must be legal
+ -- because it was valid in the generic unit.
+
+ if In_Instance then
+ return;
+
+ -- For sure OK if we have a real private type itself, but must
+ -- be completed, cannot apply Constrained to incomplete type.
+
+ elsif Is_Private_Type (Entity (P)) then
+ Check_Not_Incomplete_Type;
+ return;
+ end if;
+
+ else
+ Check_Object_Reference (P);
+
+ -- If N does not come from source, then we allow the
+ -- the attribute prefix to be of a private type whose
+ -- full type has discriminants. This occurs in cases
+ -- involving expanded calls to stream attributes.
+
+ if not Comes_From_Source (N) then
+ P_Type := Underlying_Type (P_Type);
+ end if;
+
+ -- Must have discriminants or be an access type designating
+ -- a type with discriminants. If it is a classwide type is
+ -- has unknown discriminants.
+
+ if Has_Discriminants (P_Type)
+ or else Has_Unknown_Discriminants (P_Type)
+ or else
+ (Is_Access_Type (P_Type)
+ and then Has_Discriminants (Designated_Type (P_Type)))
+ then
+ return;
+
+ -- Also allow an object of a generic type if extensions allowed
+ -- and allow this for any type at all.
+
+ elsif (Is_Generic_Type (P_Type)
+ or else Is_Generic_Actual_Type (P_Type))
+ and then Extensions_Allowed
+ then
+ return;
+ end if;
+ end if;
+
+ -- Fall through if bad prefix
+
+ Error_Attr
+ ("prefix of % attribute must be object of discriminated type", P);
+
+ ---------------
+ -- Copy_Sign --
+ ---------------
+
+ when Attribute_Copy_Sign =>
+ Check_Floating_Point_Type_2;
+ Set_Etype (N, P_Base_Type);
+ Resolve (E1, P_Base_Type);
+ Resolve (E2, P_Base_Type);
+
+ -----------
+ -- Count --
+ -----------
+
+ when Attribute_Count => Count :
+ declare
+ Ent : Entity_Id;
+ S : Entity_Id;
+ Tsk : Entity_Id;
+
+ begin
+ Check_E0;
+
+ if Nkind (P) = N_Identifier
+ or else Nkind (P) = N_Expanded_Name
+ then
+ Ent := Entity (P);
+
+ if Ekind (Ent) /= E_Entry then
+ Error_Attr ("invalid entry name", N);
+ end if;
+
+ elsif Nkind (P) = N_Indexed_Component then
+ Ent := Entity (Prefix (P));
+
+ if Ekind (Ent) /= E_Entry_Family then
+ Error_Attr ("invalid entry family name", P);
+ return;
+ end if;
+
+ else
+ Error_Attr ("invalid entry name", N);
+ return;
+ end if;
+
+ for J in reverse 0 .. Scope_Stack.Last loop
+ S := Scope_Stack.Table (J).Entity;
+
+ if S = Scope (Ent) then
+ if Nkind (P) = N_Expanded_Name then
+ Tsk := Entity (Prefix (P));
+
+ -- The prefix denotes either the task type, or else a
+ -- single task whose task type is being analyzed.
+
+ if (Is_Type (Tsk)
+ and then Tsk = S)
+
+ or else (not Is_Type (Tsk)
+ and then Etype (Tsk) = S
+ and then not (Comes_From_Source (S)))
+ then
+ null;
+ else
+ Error_Msg_N
+ ("Count must apply to entry of current task", N);
+ end if;
+ end if;
+
+ exit;
+
+ elsif Ekind (Scope (Ent)) in Task_Kind
+ and then Ekind (S) /= E_Loop
+ and then Ekind (S) /= E_Block
+ and then Ekind (S) /= E_Entry
+ and then Ekind (S) /= E_Entry_Family
+ then
+ Error_Attr ("Count cannot appear in inner unit", N);
+
+ elsif Ekind (Scope (Ent)) = E_Protected_Type
+ and then not Has_Completion (Scope (Ent))
+ then
+ Error_Attr ("attribute % can only be used inside body", N);
+ end if;
+ end loop;
+
+ if Is_Overloaded (P) then
+ declare
+ Index : Interp_Index;
+ It : Interp;
+
+ begin
+ Get_First_Interp (P, Index, It);
+
+ while Present (It.Nam) loop
+ if It.Nam = Ent then
+ null;
+
+ elsif Scope (It.Nam) = Scope (Ent) then
+ Error_Attr ("ambiguous entry name", N);
+
+ else
+ -- For now make this into a warning. Will become an
+ -- error after the 3.15 release.
+
+ Error_Msg_N
+ ("ambiguous name, resolved to entry?", N);
+ Error_Msg_N
+ ("\(this will become an error in a later release)?", N);
+ end if;
+
+ Get_Next_Interp (Index, It);
+ end loop;
+ end;
+ end if;
+
+ Set_Etype (N, Universal_Integer);
+ end Count;
+
+ -----------------------
+ -- Default_Bit_Order --
+ -----------------------
+
+ when Attribute_Default_Bit_Order => Default_Bit_Order :
+ begin
+ Check_Standard_Prefix;
+ Check_E0;
+
+ if Bytes_Big_Endian then
+ Rewrite (N,
+ Make_Integer_Literal (Loc, False_Value));
+ else
+ Rewrite (N,
+ Make_Integer_Literal (Loc, True_Value));
+ end if;
+
+ Set_Etype (N, Universal_Integer);
+ Set_Is_Static_Expression (N);
+ end Default_Bit_Order;
+
+ --------------
+ -- Definite --
+ --------------
+
+ when Attribute_Definite =>
+ Legal_Formal_Attribute;
+
+ -----------
+ -- Delta --
+ -----------
+
+ when Attribute_Delta =>
+ Check_Fixed_Point_Type_0;
+ Set_Etype (N, Universal_Real);
+
+ ------------
+ -- Denorm --
+ ------------
+
+ when Attribute_Denorm =>
+ Check_Floating_Point_Type_0;
+ Set_Etype (N, Standard_Boolean);
+
+ ------------
+ -- Digits --
+ ------------
+
+ when Attribute_Digits =>
+ Check_E0;
+ Check_Type;
+
+ if not Is_Floating_Point_Type (P_Type)
+ and then not Is_Decimal_Fixed_Point_Type (P_Type)
+ then
+ Error_Attr
+ ("prefix of % attribute must be float or decimal type", P);
+ end if;
+
+ Set_Etype (N, Universal_Integer);
+
+ ---------------
+ -- Elab_Body --
+ ---------------
+
+ -- Also handles processing for Elab_Spec
+
+ when Attribute_Elab_Body | Attribute_Elab_Spec =>
+ Check_E0;
+ Check_Unit_Name (P);
+ Set_Etype (N, Standard_Void_Type);
+
+ -- We have to manually call the expander in this case to get
+ -- the necessary expansion (normally attributes that return
+ -- entities are not expanded).
+
+ Expand (N);
+
+ ---------------
+ -- Elab_Spec --
+ ---------------
+
+ -- Shares processing with Elab_Body
+
+ ----------------
+ -- Elaborated --
+ ----------------
+
+ when Attribute_Elaborated =>
+ Check_E0;
+ Check_Library_Unit;
+ Set_Etype (N, Standard_Boolean);
+
+ ----------
+ -- Emax --
+ ----------
+
+ when Attribute_Emax =>
+ Check_Floating_Point_Type_0;
+ Set_Etype (N, Universal_Integer);
+
+ --------------
+ -- Enum_Rep --
+ --------------
+
+ when Attribute_Enum_Rep => Enum_Rep : declare
+ begin
+ if Present (E1) then
+ Check_E1;
+ Check_Discrete_Type;
+ Resolve (E1, P_Base_Type);
+
+ else
+ if not Is_Entity_Name (P)
+ or else (not Is_Object (Entity (P))
+ and then
+ Ekind (Entity (P)) /= E_Enumeration_Literal)
+ then
+ Error_Attr
+ ("prefix of %attribute must be " &
+ "discrete type/object or enum literal", P);
+ end if;
+ end if;
+
+ Set_Etype (N, Universal_Integer);
+ end Enum_Rep;
+
+ -------------
+ -- Epsilon --
+ -------------
+
+ when Attribute_Epsilon =>
+ Check_Floating_Point_Type_0;
+ Set_Etype (N, Universal_Real);
+
+ --------------
+ -- Exponent --
+ --------------
+
+ when Attribute_Exponent =>
+ Check_Floating_Point_Type_1;
+ Set_Etype (N, Universal_Integer);
+ Resolve (E1, P_Base_Type);
+
+ ------------------
+ -- External_Tag --
+ ------------------
+
+ when Attribute_External_Tag =>
+ Check_E0;
+ Check_Type;
+
+ Set_Etype (N, Standard_String);
+
+ if not Is_Tagged_Type (P_Type) then
+ Error_Attr ("prefix of % attribute must be tagged", P);
+ end if;
+
+ -----------
+ -- First --
+ -----------
+
+ when Attribute_First =>
+ Check_Array_Or_Scalar_Type;
+
+ ---------------
+ -- First_Bit --
+ ---------------
+
+ when Attribute_First_Bit =>
+ Check_Component;
+ Set_Etype (N, Universal_Integer);
+
+ -----------------
+ -- Fixed_Value --
+ -----------------
+
+ when Attribute_Fixed_Value =>
+ Check_E1;
+ Check_Fixed_Point_Type;
+ Resolve (E1, Any_Integer);
+ Set_Etype (N, P_Base_Type);
+
+ -----------
+ -- Floor --
+ -----------
+
+ when Attribute_Floor =>
+ Check_Floating_Point_Type_1;
+ Set_Etype (N, P_Base_Type);
+ Resolve (E1, P_Base_Type);
+
+ ----------
+ -- Fore --
+ ----------
+
+ when Attribute_Fore =>
+ Check_Fixed_Point_Type_0;
+ Set_Etype (N, Universal_Integer);
+
+ --------------
+ -- Fraction --
+ --------------
+
+ when Attribute_Fraction =>
+ Check_Floating_Point_Type_1;
+ Set_Etype (N, P_Base_Type);
+ Resolve (E1, P_Base_Type);
+
+ -----------------------
+ -- Has_Discriminants --
+ -----------------------
+
+ when Attribute_Has_Discriminants =>
+ Legal_Formal_Attribute;
+
+ --------------
+ -- Identity --
+ --------------
+
+ when Attribute_Identity =>
+ Check_E0;
+ Analyze (P);
+
+ if Etype (P) = Standard_Exception_Type then
+ Set_Etype (N, RTE (RE_Exception_Id));
+
+ elsif Is_Task_Type (Etype (P))
+ or else (Is_Access_Type (Etype (P))
+ and then Is_Task_Type (Designated_Type (Etype (P))))
+ then
+ Resolve (P, Etype (P));
+ Set_Etype (N, RTE (RO_AT_Task_ID));
+
+ else
+ Error_Attr ("prefix of % attribute must be a task or an "
+ & "exception", P);
+ end if;
+
+ -----------
+ -- Image --
+ -----------
+
+ when Attribute_Image => Image :
+ begin
+ Set_Etype (N, Standard_String);
+ Check_Scalar_Type;
+
+ if Is_Real_Type (P_Type) then
+ if Ada_83 and then Comes_From_Source (N) then
+ Error_Msg_Name_1 := Aname;
+ Error_Msg_N
+ ("(Ada 83) % attribute not allowed for real types", N);
+ end if;
+ end if;
+
+ if Is_Enumeration_Type (P_Type) then
+ Check_Restriction (No_Enumeration_Maps, N);
+ end if;
+
+ Check_E1;
+ Resolve (E1, P_Base_Type);
+ Check_Enum_Image;
+ Validate_Non_Static_Attribute_Function_Call;
+ end Image;
+
+ ---------
+ -- Img --
+ ---------
+
+ when Attribute_Img => Img :
+ begin
+ Set_Etype (N, Standard_String);
+
+ if not Is_Scalar_Type (P_Type)
+ or else (Is_Entity_Name (P) and then Is_Type (Entity (P)))
+ then
+ Error_Attr
+ ("prefix of % attribute must be scalar object name", N);
+ end if;
+
+ Check_Enum_Image;
+ end Img;
+
+ -----------
+ -- Input --
+ -----------
+
+ when Attribute_Input =>
+ Check_E1;
+ Check_Stream_Attribute (Name_uInput);
+ Disallow_In_No_Run_Time_Mode (N);
+ Set_Etype (N, P_Base_Type);
+
+ -------------------
+ -- Integer_Value --
+ -------------------
+
+ when Attribute_Integer_Value =>
+ Check_E1;
+ Check_Integer_Type;
+ Resolve (E1, Any_Fixed);
+ Set_Etype (N, P_Base_Type);
+
+ -----------
+ -- Large --
+ -----------
+
+ when Attribute_Large =>
+ Check_E0;
+ Check_Real_Type;
+ Set_Etype (N, Universal_Real);
+
+ ----------
+ -- Last --
+ ----------
+
+ when Attribute_Last =>
+ Check_Array_Or_Scalar_Type;
+
+ --------------
+ -- Last_Bit --
+ --------------
+
+ when Attribute_Last_Bit =>
+ Check_Component;
+ Set_Etype (N, Universal_Integer);
+
+ ------------------
+ -- Leading_Part --
+ ------------------
+
+ when Attribute_Leading_Part =>
+ Check_Floating_Point_Type_2;
+ Set_Etype (N, P_Base_Type);
+ Resolve (E1, P_Base_Type);
+ Resolve (E2, Any_Integer);
+
+ ------------
+ -- Length --
+ ------------
+
+ when Attribute_Length =>
+ Check_Array_Type;
+ Set_Etype (N, Universal_Integer);
+
+ -------------
+ -- Machine --
+ -------------
+
+ when Attribute_Machine =>
+ Check_Floating_Point_Type_1;
+ Set_Etype (N, P_Base_Type);
+ Resolve (E1, P_Base_Type);
+
+ ------------------
+ -- Machine_Emax --
+ ------------------
+
+ when Attribute_Machine_Emax =>
+ Check_Floating_Point_Type_0;
+ Set_Etype (N, Universal_Integer);
+
+ ------------------
+ -- Machine_Emin --
+ ------------------
+
+ when Attribute_Machine_Emin =>
+ Check_Floating_Point_Type_0;
+ Set_Etype (N, Universal_Integer);
+
+ ----------------------
+ -- Machine_Mantissa --
+ ----------------------
+
+ when Attribute_Machine_Mantissa =>
+ Check_Floating_Point_Type_0;
+ Set_Etype (N, Universal_Integer);
+
+ -----------------------
+ -- Machine_Overflows --
+ -----------------------
+
+ when Attribute_Machine_Overflows =>
+ Check_Real_Type;
+ Check_E0;
+ Set_Etype (N, Standard_Boolean);
+
+ -------------------
+ -- Machine_Radix --
+ -------------------
+
+ when Attribute_Machine_Radix =>
+ Check_Real_Type;
+ Check_E0;
+ Set_Etype (N, Universal_Integer);
+
+ --------------------
+ -- Machine_Rounds --
+ --------------------
+
+ when Attribute_Machine_Rounds =>
+ Check_Real_Type;
+ Check_E0;
+ Set_Etype (N, Standard_Boolean);
+
+ ------------------
+ -- Machine_Size --
+ ------------------
+
+ when Attribute_Machine_Size =>
+ Check_E0;
+ Check_Type;
+ Check_Not_Incomplete_Type;
+ Set_Etype (N, Universal_Integer);
+
+ --------------
+ -- Mantissa --
+ --------------
+
+ when Attribute_Mantissa =>
+ Check_E0;
+ Check_Real_Type;
+ Set_Etype (N, Universal_Integer);
+
+ ---------
+ -- Max --
+ ---------
+
+ when Attribute_Max =>
+ Check_E2;
+ Check_Scalar_Type;
+ Resolve (E1, P_Base_Type);
+ Resolve (E2, P_Base_Type);
+ Set_Etype (N, P_Base_Type);
+
+ ----------------------------
+ -- Max_Interrupt_Priority --
+ ----------------------------
+
+ when Attribute_Max_Interrupt_Priority =>
+ Standard_Attribute
+ (UI_To_Int
+ (Expr_Value
+ (Expression
+ (Parent (RTE (RE_Max_Interrupt_Priority))))));
+
+ ------------------
+ -- Max_Priority --
+ ------------------
+
+ when Attribute_Max_Priority =>
+ Standard_Attribute
+ (UI_To_Int
+ (Expr_Value
+ (Expression
+ (Parent (RTE (RE_Max_Priority))))));
+
+ ----------------------------------
+ -- Max_Size_In_Storage_Elements --
+ ----------------------------------
+
+ when Attribute_Max_Size_In_Storage_Elements =>
+ Check_E0;
+ Check_Type;
+ Check_Not_Incomplete_Type;
+ Set_Etype (N, Universal_Integer);
+
+ -----------------------
+ -- Maximum_Alignment --
+ -----------------------
+
+ when Attribute_Maximum_Alignment =>
+ Standard_Attribute (Ttypes.Maximum_Alignment);
+
+ --------------------
+ -- Mechanism_Code --
+ --------------------
+
+ when Attribute_Mechanism_Code =>
+
+ if not Is_Entity_Name (P)
+ or else not Is_Subprogram (Entity (P))
+ then
+ Error_Attr ("prefix of % attribute must be subprogram", P);
+ end if;
+
+ Check_Either_E0_Or_E1;
+
+ if Present (E1) then
+ Resolve (E1, Any_Integer);
+ Set_Etype (E1, Standard_Integer);
+
+ if not Is_Static_Expression (E1) then
+ Error_Attr
+ ("expression for parameter number must be static", E1);
+
+ elsif UI_To_Int (Intval (E1)) > Number_Formals (Entity (P))
+ or else UI_To_Int (Intval (E1)) < 0
+ then
+ Error_Attr ("invalid parameter number for %attribute", E1);
+ end if;
+ end if;
+
+ Set_Etype (N, Universal_Integer);
+
+ ---------
+ -- Min --
+ ---------
+
+ when Attribute_Min =>
+ Check_E2;
+ Check_Scalar_Type;
+ Resolve (E1, P_Base_Type);
+ Resolve (E2, P_Base_Type);
+ Set_Etype (N, P_Base_Type);
+
+ -----------
+ -- Model --
+ -----------
+
+ when Attribute_Model =>
+ Check_Floating_Point_Type_1;
+ Set_Etype (N, P_Base_Type);
+ Resolve (E1, P_Base_Type);
+
+ ----------------
+ -- Model_Emin --
+ ----------------
+
+ when Attribute_Model_Emin =>
+ Check_Floating_Point_Type_0;
+ Set_Etype (N, Universal_Integer);
+
+ -------------------
+ -- Model_Epsilon --
+ -------------------
+
+ when Attribute_Model_Epsilon =>
+ Check_Floating_Point_Type_0;
+ Set_Etype (N, Universal_Real);
+
+ --------------------
+ -- Model_Mantissa --
+ --------------------
+
+ when Attribute_Model_Mantissa =>
+ Check_Floating_Point_Type_0;
+ Set_Etype (N, Universal_Integer);
+
+ -----------------
+ -- Model_Small --
+ -----------------
+
+ when Attribute_Model_Small =>
+ Check_Floating_Point_Type_0;
+ Set_Etype (N, Universal_Real);
+
+ -------------
+ -- Modulus --
+ -------------
+
+ when Attribute_Modulus =>
+ Check_E0;
+ Check_Type;
+
+ if not Is_Modular_Integer_Type (P_Type) then
+ Error_Attr ("prefix of % attribute must be modular type", P);
+ end if;
+
+ Set_Etype (N, Universal_Integer);
+
+ --------------------
+ -- Null_Parameter --
+ --------------------
+
+ when Attribute_Null_Parameter => Null_Parameter : declare
+ Parnt : constant Node_Id := Parent (N);
+ GParnt : constant Node_Id := Parent (Parnt);
+
+ procedure Bad_Null_Parameter (Msg : String);
+ -- Used if bad Null parameter attribute node is found. Issues
+ -- given error message, and also sets the type to Any_Type to
+ -- avoid blowups later on from dealing with a junk node.
+
+ procedure Must_Be_Imported (Proc_Ent : Entity_Id);
+ -- Called to check that Proc_Ent is imported subprogram
+
+ ------------------------
+ -- Bad_Null_Parameter --
+ ------------------------
+
+ procedure Bad_Null_Parameter (Msg : String) is
+ begin
+ Error_Msg_N (Msg, N);
+ Set_Etype (N, Any_Type);
+ end Bad_Null_Parameter;
+
+ ----------------------
+ -- Must_Be_Imported --
+ ----------------------
+
+ procedure Must_Be_Imported (Proc_Ent : Entity_Id) is
+ Pent : Entity_Id := Proc_Ent;
+
+ begin
+ while Present (Alias (Pent)) loop
+ Pent := Alias (Pent);
+ end loop;
+
+ -- Ignore check if procedure not frozen yet (we will get
+ -- another chance when the default parameter is reanalyzed)
+
+ if not Is_Frozen (Pent) then
+ return;
+
+ elsif not Is_Imported (Pent) then
+ Bad_Null_Parameter
+ ("Null_Parameter can only be used with imported subprogram");
+
+ else
+ return;
+ end if;
+ end Must_Be_Imported;
+
+ -- Start of processing for Null_Parameter
+
+ begin
+ Check_Type;
+ Check_E0;
+ Set_Etype (N, P_Type);
+
+ -- Case of attribute used as default expression
+
+ if Nkind (Parnt) = N_Parameter_Specification then
+ Must_Be_Imported (Defining_Entity (GParnt));
+
+ -- Case of attribute used as actual for subprogram (positional)
+
+ elsif (Nkind (Parnt) = N_Procedure_Call_Statement
+ or else
+ Nkind (Parnt) = N_Function_Call)
+ and then Is_Entity_Name (Name (Parnt))
+ then
+ Must_Be_Imported (Entity (Name (Parnt)));
+
+ -- Case of attribute used as actual for subprogram (named)
+
+ elsif Nkind (Parnt) = N_Parameter_Association
+ and then (Nkind (GParnt) = N_Procedure_Call_Statement
+ or else
+ Nkind (GParnt) = N_Function_Call)
+ and then Is_Entity_Name (Name (GParnt))
+ then
+ Must_Be_Imported (Entity (Name (GParnt)));
+
+ -- Not an allowed case
+
+ else
+ Bad_Null_Parameter
+ ("Null_Parameter must be actual or default parameter");
+ end if;
+
+ end Null_Parameter;
+
+ -----------------
+ -- Object_Size --
+ -----------------
+
+ when Attribute_Object_Size =>
+ Check_E0;
+ Check_Type;
+ Check_Not_Incomplete_Type;
+ Set_Etype (N, Universal_Integer);
+
+ ------------
+ -- Output --
+ ------------
+
+ when Attribute_Output =>
+ Check_E2;
+ Check_Stream_Attribute (Name_uInput);
+ Set_Etype (N, Standard_Void_Type);
+ Disallow_In_No_Run_Time_Mode (N);
+ Resolve (N, Standard_Void_Type);
+
+ ------------------
+ -- Partition_ID --
+ ------------------
+
+ when Attribute_Partition_ID =>
+ Check_E0;
+
+ if P_Type /= Any_Type then
+ if not Is_Library_Level_Entity (Entity (P)) then
+ Error_Attr
+ ("prefix of % attribute must be library-level entity", P);
+
+ -- The defining entity of prefix should not be declared inside
+ -- a Pure unit. RM E.1(8).
+ -- The Is_Pure flag has been set during declaration.
+
+ elsif Is_Entity_Name (P)
+ and then Is_Pure (Entity (P))
+ then
+ Error_Attr
+ ("prefix of % attribute must not be declared pure", P);
+ end if;
+ end if;
+
+ Set_Etype (N, Universal_Integer);
+
+ -------------------------
+ -- Passed_By_Reference --
+ -------------------------
+
+ when Attribute_Passed_By_Reference =>
+ Check_E0;
+ Check_Type;
+ Set_Etype (N, Standard_Boolean);
+
+ ---------
+ -- Pos --
+ ---------
+
+ when Attribute_Pos =>
+ Check_Discrete_Type;
+ Check_E1;
+ Resolve (E1, P_Base_Type);
+ Set_Etype (N, Universal_Integer);
+
+ --------------
+ -- Position --
+ --------------
+
+ when Attribute_Position =>
+ Check_Component;
+ Set_Etype (N, Universal_Integer);
+
+ ----------
+ -- Pred --
+ ----------
+
+ when Attribute_Pred =>
+ Check_Scalar_Type;
+ Check_E1;
+ Resolve (E1, P_Base_Type);
+ Set_Etype (N, P_Base_Type);
+
+ -- Nothing to do for real type case
+
+ if Is_Real_Type (P_Type) then
+ null;
+
+ -- If not modular type, test for overflow check required
+
+ else
+ if not Is_Modular_Integer_Type (P_Type)
+ and then not Range_Checks_Suppressed (P_Base_Type)
+ then
+ Enable_Range_Check (E1);
+ end if;
+ end if;
+
+ -----------
+ -- Range --
+ -----------
+
+ when Attribute_Range =>
+ Check_Array_Or_Scalar_Type;
+
+ if Ada_83
+ and then Is_Scalar_Type (P_Type)
+ and then Comes_From_Source (N)
+ then
+ Error_Attr
+ ("(Ada 83) % attribute not allowed for scalar type", P);
+ end if;
+
+ ------------------
+ -- Range_Length --
+ ------------------
+
+ when Attribute_Range_Length =>
+ Check_Discrete_Type;
+ Set_Etype (N, Universal_Integer);
+
+ ----------
+ -- Read --
+ ----------
+
+ when Attribute_Read =>
+ Check_E2;
+ Check_Stream_Attribute (Name_uRead);
+ Set_Etype (N, Standard_Void_Type);
+ Resolve (N, Standard_Void_Type);
+ Disallow_In_No_Run_Time_Mode (N);
+ Note_Possible_Modification (E2);
+
+ ---------------
+ -- Remainder --
+ ---------------
+
+ when Attribute_Remainder =>
+ Check_Floating_Point_Type_2;
+ Set_Etype (N, P_Base_Type);
+ Resolve (E1, P_Base_Type);
+ Resolve (E2, P_Base_Type);
+
+ -----------
+ -- Round --
+ -----------
+
+ when Attribute_Round =>
+ Check_E1;
+ Check_Decimal_Fixed_Point_Type;
+ Set_Etype (N, P_Base_Type);
+
+ -- Because the context is universal_real (3.5.10(12)) it is a legal
+ -- context for a universal fixed expression. This is the only
+ -- attribute whose functional description involves U_R.
+
+ if Etype (E1) = Universal_Fixed then
+ declare
+ Conv : constant Node_Id := Make_Type_Conversion (Loc,
+ Subtype_Mark => New_Occurrence_Of (Universal_Real, Loc),
+ Expression => Relocate_Node (E1));
+
+ begin
+ Rewrite (E1, Conv);
+ Analyze (E1);
+ end;
+ end if;
+
+ Resolve (E1, Any_Real);
+
+ --------------
+ -- Rounding --
+ --------------
+
+ when Attribute_Rounding =>
+ Check_Floating_Point_Type_1;
+ Set_Etype (N, P_Base_Type);
+ Resolve (E1, P_Base_Type);
+
+ ---------------
+ -- Safe_Emax --
+ ---------------
+
+ when Attribute_Safe_Emax =>
+ Check_Floating_Point_Type_0;
+ Set_Etype (N, Universal_Integer);
+
+ ----------------
+ -- Safe_First --
+ ----------------
+
+ when Attribute_Safe_First =>
+ Check_Floating_Point_Type_0;
+ Set_Etype (N, Universal_Real);
+
+ ----------------
+ -- Safe_Large --
+ ----------------
+
+ when Attribute_Safe_Large =>
+ Check_E0;
+ Check_Real_Type;
+ Set_Etype (N, Universal_Real);
+
+ ---------------
+ -- Safe_Last --
+ ---------------
+
+ when Attribute_Safe_Last =>
+ Check_Floating_Point_Type_0;
+ Set_Etype (N, Universal_Real);
+
+ ----------------
+ -- Safe_Small --
+ ----------------
+
+ when Attribute_Safe_Small =>
+ Check_E0;
+ Check_Real_Type;
+ Set_Etype (N, Universal_Real);
+
+ -----------
+ -- Scale --
+ -----------
+
+ when Attribute_Scale =>
+ Check_E0;
+ Check_Decimal_Fixed_Point_Type;
+ Set_Etype (N, Universal_Integer);
+
+ -------------
+ -- Scaling --
+ -------------
+
+ when Attribute_Scaling =>
+ Check_Floating_Point_Type_2;
+ Set_Etype (N, P_Base_Type);
+ Resolve (E1, P_Base_Type);
+
+ ------------------
+ -- Signed_Zeros --
+ ------------------
+
+ when Attribute_Signed_Zeros =>
+ Check_Floating_Point_Type_0;
+ Set_Etype (N, Standard_Boolean);
+
+ ----------
+ -- Size --
+ ----------
+
+ when Attribute_Size | Attribute_VADS_Size =>
+ Check_E0;
+
+ if Is_Object_Reference (P)
+ or else (Is_Entity_Name (P)
+ and then
+ Ekind (Entity (P)) = E_Function)
+ then
+ Check_Object_Reference (P);
+
+ elsif Nkind (P) = N_Attribute_Reference
+ or else
+ (Nkind (P) = N_Selected_Component
+ and then (Is_Entry (Entity (Selector_Name (P)))
+ or else
+ Is_Subprogram (Entity (Selector_Name (P)))))
+ or else
+ (Is_Entity_Name (P)
+ and then not Is_Type (Entity (P))
+ and then not Is_Object (Entity (P)))
+ then
+ Error_Attr ("invalid prefix for % attribute", P);
+ end if;
+
+ Check_Not_Incomplete_Type;
+ Set_Etype (N, Universal_Integer);
+
+ -----------
+ -- Small --
+ -----------
+
+ when Attribute_Small =>
+ Check_E0;
+ Check_Real_Type;
+ Set_Etype (N, Universal_Real);
+
+ ------------------
+ -- Storage_Pool --
+ ------------------
+
+ when Attribute_Storage_Pool =>
+ if Is_Access_Type (P_Type) then
+ Check_E0;
+
+ -- Set appropriate entity
+
+ if Present (Associated_Storage_Pool (Root_Type (P_Type))) then
+ Set_Entity (N, Associated_Storage_Pool (Root_Type (P_Type)));
+ else
+ Set_Entity (N, RTE (RE_Global_Pool_Object));
+ end if;
+
+ Set_Etype (N, Class_Wide_Type (RTE (RE_Root_Storage_Pool)));
+
+ -- Validate_Remote_Access_To_Class_Wide_Type for attribute
+ -- Storage_Pool since this attribute is not defined for such
+ -- types (RM E.2.3(22)).
+
+ Validate_Remote_Access_To_Class_Wide_Type (N);
+
+ else
+ Error_Attr ("prefix of % attribute must be access type", P);
+ end if;
+
+ ------------------
+ -- Storage_Size --
+ ------------------
+
+ when Attribute_Storage_Size =>
+
+ if Is_Task_Type (P_Type) then
+ Check_E0;
+ Set_Etype (N, Universal_Integer);
+
+ elsif Is_Access_Type (P_Type) then
+ if Is_Entity_Name (P)
+ and then Is_Type (Entity (P))
+ then
+ Check_E0;
+ Check_Type;
+ Set_Etype (N, Universal_Integer);
+
+ -- Validate_Remote_Access_To_Class_Wide_Type for attribute
+ -- Storage_Size since this attribute is not defined for
+ -- such types (RM E.2.3(22)).
+
+ Validate_Remote_Access_To_Class_Wide_Type (N);
+
+ -- The prefix is allowed to be an implicit dereference
+ -- of an access value designating a task.
+
+ else
+ Check_E0;
+ Check_Task_Prefix;
+ Set_Etype (N, Universal_Integer);
+ end if;
+
+ else
+ Error_Attr
+ ("prefix of % attribute must be access or task type", P);
+ end if;
+
+ ------------------
+ -- Storage_Unit --
+ ------------------
+
+ when Attribute_Storage_Unit =>
+ Standard_Attribute (Ttypes.System_Storage_Unit);
+
+ ----------
+ -- Succ --
+ ----------
+
+ when Attribute_Succ =>
+ Check_Scalar_Type;
+ Check_E1;
+ Resolve (E1, P_Base_Type);
+ Set_Etype (N, P_Base_Type);
+
+ -- Nothing to do for real type case
+
+ if Is_Real_Type (P_Type) then
+ null;
+
+ -- If not modular type, test for overflow check required.
+
+ else
+ if not Is_Modular_Integer_Type (P_Type)
+ and then not Range_Checks_Suppressed (P_Base_Type)
+ then
+ Enable_Range_Check (E1);
+ end if;
+ end if;
+
+ ---------
+ -- Tag --
+ ---------
+
+ when Attribute_Tag =>
+ Check_E0;
+ Check_Dereference;
+
+ if not Is_Tagged_Type (P_Type) then
+ Error_Attr ("prefix of % attribute must be tagged", P);
+
+ -- Next test does not apply to generated code
+ -- why not, and what does the illegal reference mean???
+
+ elsif Is_Object_Reference (P)
+ and then not Is_Class_Wide_Type (P_Type)
+ and then Comes_From_Source (N)
+ then
+ Error_Attr
+ ("% attribute can only be applied to objects of class-wide type",
+ P);
+ end if;
+
+ Set_Etype (N, RTE (RE_Tag));
+
+ ----------------
+ -- Terminated --
+ ----------------
+
+ when Attribute_Terminated =>
+ Check_E0;
+ Set_Etype (N, Standard_Boolean);
+ Check_Task_Prefix;
+
+ ----------
+ -- Tick --
+ ----------
+
+ when Attribute_Tick =>
+ Check_Standard_Prefix;
+ Rewrite (N,
+ Make_Real_Literal (Loc,
+ UR_From_Components (
+ Num => UI_From_Int (Ttypes.System_Tick_Nanoseconds),
+ Den => UI_From_Int (9),
+ Rbase => 10)));
+ Analyze (N);
+
+ ----------------
+ -- To_Address --
+ ----------------
+
+ when Attribute_To_Address =>
+ Check_E1;
+ Analyze (P);
+
+ if Nkind (P) /= N_Identifier
+ or else Chars (P) /= Name_System
+ then
+ Error_Attr ("prefix of %attribute must be System", P);
+ end if;
+
+ Generate_Reference (RTE (RE_Address), P);
+ Analyze_And_Resolve (E1, Any_Integer);
+ Set_Etype (N, RTE (RE_Address));
+
+ ----------------
+ -- Truncation --
+ ----------------
+
+ when Attribute_Truncation =>
+ Check_Floating_Point_Type_1;
+ Resolve (E1, P_Base_Type);
+ Set_Etype (N, P_Base_Type);
+
+ ----------------
+ -- Type_Class --
+ ----------------
+
+ when Attribute_Type_Class =>
+ Check_E0;
+ Check_Type;
+ Check_Not_Incomplete_Type;
+ Set_Etype (N, RTE (RE_Type_Class));
+
+ -----------------
+ -- UET_Address --
+ -----------------
+
+ when Attribute_UET_Address =>
+ Check_E0;
+ Check_Unit_Name (P);
+ Set_Etype (N, RTE (RE_Address));
+
+ -----------------------
+ -- Unbiased_Rounding --
+ -----------------------
+
+ when Attribute_Unbiased_Rounding =>
+ Check_Floating_Point_Type_1;
+ Set_Etype (N, P_Base_Type);
+ Resolve (E1, P_Base_Type);
+
+ ----------------------
+ -- Unchecked_Access --
+ ----------------------
+
+ when Attribute_Unchecked_Access =>
+ if Comes_From_Source (N) then
+ Check_Restriction (No_Unchecked_Access, N);
+ end if;
+
+ Access_Attribute;
+
+ ------------------------------
+ -- Universal_Literal_String --
+ ------------------------------
+
+ -- This is a GNAT specific attribute whose prefix must be a named
+ -- number where the expression is either a single numeric literal,
+ -- or a numeric literal immediately preceded by a minus sign. The
+ -- result is equivalent to a string literal containing the text of
+ -- the literal as it appeared in the source program with a possible
+ -- leading minus sign.
+
+ when Attribute_Universal_Literal_String => Universal_Literal_String :
+ begin
+ Check_E0;
+
+ if not Is_Entity_Name (P)
+ or else Ekind (Entity (P)) not in Named_Kind
+ then
+ Error_Attr ("prefix for % attribute must be named number", P);
+
+ else
+ declare
+ Expr : Node_Id;
+ Negative : Boolean;
+ S : Source_Ptr;
+ Src : Source_Buffer_Ptr;
+
+ begin
+ Expr := Original_Node (Expression (Parent (Entity (P))));
+
+ if Nkind (Expr) = N_Op_Minus then
+ Negative := True;
+ Expr := Original_Node (Right_Opnd (Expr));
+ else
+ Negative := False;
+ end if;
+
+ if Nkind (Expr) /= N_Integer_Literal
+ and then Nkind (Expr) /= N_Real_Literal
+ then
+ Error_Attr
+ ("named number for % attribute must be simple literal", N);
+ end if;
+
+ -- Build string literal corresponding to source literal text
+
+ Start_String;
+
+ if Negative then
+ Store_String_Char (Get_Char_Code ('-'));
+ end if;
+
+ S := Sloc (Expr);
+ Src := Source_Text (Get_Source_File_Index (S));
+
+ while Src (S) /= ';' and then Src (S) /= ' ' loop
+ Store_String_Char (Get_Char_Code (Src (S)));
+ S := S + 1;
+ end loop;
+
+ -- Now we rewrite the attribute with the string literal
+
+ Rewrite (N,
+ Make_String_Literal (Loc, End_String));
+ Analyze (N);
+ end;
+ end if;
+ end Universal_Literal_String;
+
+ -------------------------
+ -- Unrestricted_Access --
+ -------------------------
+
+ -- This is a GNAT specific attribute which is like Access except that
+ -- all scope checks and checks for aliased views are omitted.
+
+ when Attribute_Unrestricted_Access =>
+ if Comes_From_Source (N) then
+ Check_Restriction (No_Unchecked_Access, N);
+ end if;
+
+ if Is_Entity_Name (P) then
+ Set_Address_Taken (Entity (P));
+ end if;
+
+ Access_Attribute;
+
+ ---------
+ -- Val --
+ ---------
+
+ when Attribute_Val => Val : declare
+ begin
+ Check_E1;
+ Check_Discrete_Type;
+ Resolve (E1, Any_Integer);
+ Set_Etype (N, P_Base_Type);
+
+ -- Note, we need a range check in general, but we wait for the
+ -- Resolve call to do this, since we want to let Eval_Attribute
+ -- have a chance to find an static illegality first!
+ end Val;
+
+ -----------
+ -- Valid --
+ -----------
+
+ when Attribute_Valid =>
+ Check_E0;
+
+ -- Ignore check for object if we have a 'Valid reference generated
+ -- by the expanded code, since in some cases valid checks can occur
+ -- on items that are names, but are not objects (e.g. attributes).
+
+ if Comes_From_Source (N) then
+ Check_Object_Reference (P);
+ end if;
+
+ if not Is_Scalar_Type (P_Type) then
+ Error_Attr ("object for % attribute must be of scalar type", P);
+ end if;
+
+ Set_Etype (N, Standard_Boolean);
+
+ -----------
+ -- Value --
+ -----------
+
+ when Attribute_Value => Value :
+ begin
+ Check_E1;
+ Check_Scalar_Type;
+
+ if Is_Enumeration_Type (P_Type) then
+ Check_Restriction (No_Enumeration_Maps, N);
+ end if;
+
+ -- Set Etype before resolving expression because expansion
+ -- of expression may require enclosing type.
+
+ Set_Etype (N, P_Type);
+ Validate_Non_Static_Attribute_Function_Call;
+ end Value;
+
+ ----------------
+ -- Value_Size --
+ ----------------
+
+ when Attribute_Value_Size =>
+ Check_E0;
+ Check_Type;
+ Check_Not_Incomplete_Type;
+ Set_Etype (N, Universal_Integer);
+
+ -------------
+ -- Version --
+ -------------
+
+ when Attribute_Version =>
+ Check_E0;
+ Check_Program_Unit;
+ Set_Etype (N, RTE (RE_Version_String));
+
+ ------------------
+ -- Wchar_T_Size --
+ ------------------
+
+ when Attribute_Wchar_T_Size =>
+ Standard_Attribute (Interfaces_Wchar_T_Size);
+
+ ----------------
+ -- Wide_Image --
+ ----------------
+
+ when Attribute_Wide_Image => Wide_Image :
+ begin
+ Check_Scalar_Type;
+ Set_Etype (N, Standard_Wide_String);
+ Check_E1;
+ Resolve (E1, P_Base_Type);
+ Validate_Non_Static_Attribute_Function_Call;
+ end Wide_Image;
+
+ ----------------
+ -- Wide_Value --
+ ----------------
+
+ when Attribute_Wide_Value => Wide_Value :
+ begin
+ Check_E1;
+ Check_Scalar_Type;
+
+ -- Set Etype before resolving expression because expansion
+ -- of expression may require enclosing type.
+
+ Set_Etype (N, P_Type);
+ Validate_Non_Static_Attribute_Function_Call;
+ end Wide_Value;
+
+ ----------------
+ -- Wide_Width --
+ ----------------
+
+ when Attribute_Wide_Width =>
+ Check_E0;
+ Check_Scalar_Type;
+ Set_Etype (N, Universal_Integer);
+
+ -----------
+ -- Width --
+ -----------
+
+ when Attribute_Width =>
+ Check_E0;
+ Check_Scalar_Type;
+ Set_Etype (N, Universal_Integer);
+
+ ---------------
+ -- Word_Size --
+ ---------------
+
+ when Attribute_Word_Size =>
+ Standard_Attribute (System_Word_Size);
+
+ -----------
+ -- Write --
+ -----------
+
+ when Attribute_Write =>
+ Check_E2;
+ Check_Stream_Attribute (Name_uWrite);
+ Set_Etype (N, Standard_Void_Type);
+ Disallow_In_No_Run_Time_Mode (N);
+ Resolve (N, Standard_Void_Type);
+
+ end case;
+
+ -- All errors raise Bad_Attribute, so that we get out before any further
+ -- damage occurs when an error is detected (for example, if we check for
+ -- one attribute expression, and the check succeeds, we want to be able
+ -- to proceed securely assuming that an expression is in fact present.
+
+ exception
+ when Bad_Attribute =>
+ Set_Etype (N, Any_Type);
+ return;
+
+ end Analyze_Attribute;
+
+ --------------------
+ -- Eval_Attribute --
+ --------------------
+
+ procedure Eval_Attribute (N : Node_Id) is
+ Loc : constant Source_Ptr := Sloc (N);
+ Aname : constant Name_Id := Attribute_Name (N);
+ Id : constant Attribute_Id := Get_Attribute_Id (Aname);
+ P : constant Node_Id := Prefix (N);
+
+ C_Type : constant Entity_Id := Etype (N);
+ -- The type imposed by the context.
+
+ E1 : Node_Id;
+ -- First expression, or Empty if none
+
+ E2 : Node_Id;
+ -- Second expression, or Empty if none
+
+ P_Entity : Entity_Id;
+ -- Entity denoted by prefix
+
+ P_Type : Entity_Id;
+ -- The type of the prefix
+
+ P_Base_Type : Entity_Id;
+ -- The base type of the prefix type
+
+ P_Root_Type : Entity_Id;
+ -- The root type of the prefix type
+
+ Static : Boolean;
+ -- True if prefix type is static
+
+ Lo_Bound, Hi_Bound : Node_Id;
+ -- Expressions for low and high bounds of type or array index referenced
+ -- by First, Last, or Length attribute for array, set by Set_Bounds.
+
+ CE_Node : Node_Id;
+ -- Constraint error node used if we have an attribute reference has
+ -- an argument that raises a constraint error. In this case we replace
+ -- the attribute with a raise constraint_error node. This is important
+ -- processing, since otherwise gigi might see an attribute which it is
+ -- unprepared to deal with.
+
+ function Aft_Value return Nat;
+ -- Computes Aft value for current attribute prefix (used by Aft itself
+ -- and also by Width for computing the Width of a fixed point type).
+
+ procedure Check_Expressions;
+ -- In case where the attribute is not foldable, the expressions, if
+ -- any, of the attribute, are in a non-static context. This procedure
+ -- performs the required additional checks.
+
+ procedure Float_Attribute_Universal_Integer
+ (IEEES_Val : Int;
+ IEEEL_Val : Int;
+ IEEEX_Val : Int;
+ VAXFF_Val : Int;
+ VAXDF_Val : Int;
+ VAXGF_Val : Int);
+ -- This procedure evaluates a float attribute with no arguments that
+ -- returns a universal integer result. The parameters give the values
+ -- for the possible floating-point root types. See ttypef for details.
+ -- The prefix type is a float type (and is thus not a generic type).
+
+ procedure Float_Attribute_Universal_Real
+ (IEEES_Val : String;
+ IEEEL_Val : String;
+ IEEEX_Val : String;
+ VAXFF_Val : String;
+ VAXDF_Val : String;
+ VAXGF_Val : String);
+ -- This procedure evaluates a float attribute with no arguments that
+ -- returns a universal real result. The parameters give the values
+ -- required for the possible floating-point root types in string
+ -- format as real literals with a possible leading minus sign.
+ -- The prefix type is a float type (and is thus not a generic type).
+
+ function Fore_Value return Nat;
+ -- Computes the Fore value for the current attribute prefix, which is
+ -- known to be a static fixed-point type. Used by Fore and Width.
+
+ function Mantissa return Uint;
+ -- Returns the Mantissa value for the prefix type
+
+ procedure Set_Bounds;
+ -- Used for First, Last and Length attributes applied to an array or
+ -- array subtype. Sets the variables Index_Lo and Index_Hi to the low
+ -- and high bound expressions for the index referenced by the attribute
+ -- designator (i.e. the first index if no expression is present, and
+ -- the N'th index if the value N is present as an expression).
+
+ ---------------
+ -- Aft_Value --
+ ---------------
+
+ function Aft_Value return Nat is
+ Result : Nat;
+ Delta_Val : Ureal;
+
+ begin
+ Result := 1;
+ Delta_Val := Delta_Value (P_Type);
+
+ while Delta_Val < Ureal_Tenth loop
+ Delta_Val := Delta_Val * Ureal_10;
+ Result := Result + 1;
+ end loop;
+
+ return Result;
+ end Aft_Value;
+
+ -----------------------
+ -- Check_Expressions --
+ -----------------------
+
+ procedure Check_Expressions is
+ E : Node_Id := E1;
+
+ begin
+ while Present (E) loop
+ Check_Non_Static_Context (E);
+ Next (E);
+ end loop;
+ end Check_Expressions;
+
+ ---------------------------------------
+ -- Float_Attribute_Universal_Integer --
+ ---------------------------------------
+
+ procedure Float_Attribute_Universal_Integer
+ (IEEES_Val : Int;
+ IEEEL_Val : Int;
+ IEEEX_Val : Int;
+ VAXFF_Val : Int;
+ VAXDF_Val : Int;
+ VAXGF_Val : Int)
+ is
+ Val : Int;
+ Digs : constant Nat := UI_To_Int (Digits_Value (P_Base_Type));
+
+ begin
+ if not Vax_Float (P_Base_Type) then
+ if Digs = IEEES_Digits then
+ Val := IEEES_Val;
+ elsif Digs = IEEEL_Digits then
+ Val := IEEEL_Val;
+ else pragma Assert (Digs = IEEEX_Digits);
+ Val := IEEEX_Val;
+ end if;
+
+ else
+ if Digs = VAXFF_Digits then
+ Val := VAXFF_Val;
+ elsif Digs = VAXDF_Digits then
+ Val := VAXDF_Val;
+ else pragma Assert (Digs = VAXGF_Digits);
+ Val := VAXGF_Val;
+ end if;
+ end if;
+
+ Fold_Uint (N, UI_From_Int (Val));
+ end Float_Attribute_Universal_Integer;
+
+ ------------------------------------
+ -- Float_Attribute_Universal_Real --
+ ------------------------------------
+
+ procedure Float_Attribute_Universal_Real
+ (IEEES_Val : String;
+ IEEEL_Val : String;
+ IEEEX_Val : String;
+ VAXFF_Val : String;
+ VAXDF_Val : String;
+ VAXGF_Val : String)
+ is
+ Val : Node_Id;
+ Digs : constant Nat := UI_To_Int (Digits_Value (P_Base_Type));
+
+ begin
+ if not Vax_Float (P_Base_Type) then
+ if Digs = IEEES_Digits then
+ Val := Real_Convert (IEEES_Val);
+ elsif Digs = IEEEL_Digits then
+ Val := Real_Convert (IEEEL_Val);
+ else pragma Assert (Digs = IEEEX_Digits);
+ Val := Real_Convert (IEEEX_Val);
+ end if;
+
+ else
+ if Digs = VAXFF_Digits then
+ Val := Real_Convert (VAXFF_Val);
+ elsif Digs = VAXDF_Digits then
+ Val := Real_Convert (VAXDF_Val);
+ else pragma Assert (Digs = VAXGF_Digits);
+ Val := Real_Convert (VAXGF_Val);
+ end if;
+ end if;
+
+ Set_Sloc (Val, Loc);
+ Rewrite (N, Val);
+ Analyze_And_Resolve (N, C_Type);
+ end Float_Attribute_Universal_Real;
+
+ ----------------
+ -- Fore_Value --
+ ----------------
+
+ -- Note that the Fore calculation is based on the actual values
+ -- of the bounds, and does not take into account possible rounding.
+
+ function Fore_Value return Nat is
+ Lo : constant Uint := Expr_Value (Type_Low_Bound (P_Type));
+ Hi : constant Uint := Expr_Value (Type_High_Bound (P_Type));
+ Small : constant Ureal := Small_Value (P_Type);
+ Lo_Real : constant Ureal := Lo * Small;
+ Hi_Real : constant Ureal := Hi * Small;
+ T : Ureal;
+ R : Nat;
+
+ begin
+ -- Bounds are given in terms of small units, so first compute
+ -- proper values as reals.
+
+ T := UR_Max (abs Lo_Real, abs Hi_Real);
+ R := 2;
+
+ -- Loop to compute proper value if more than one digit required
+
+ while T >= Ureal_10 loop
+ R := R + 1;
+ T := T / Ureal_10;
+ end loop;
+
+ return R;
+ end Fore_Value;
+
+ --------------
+ -- Mantissa --
+ --------------
+
+ -- Table of mantissa values accessed by function Computed using
+ -- the relation:
+
+ -- T'Mantissa = integer next above (D * log(10)/log(2)) + 1)
+
+ -- where D is T'Digits (RM83 3.5.7)
+
+ Mantissa_Value : constant array (Nat range 1 .. 40) of Nat := (
+ 1 => 5,
+ 2 => 8,
+ 3 => 11,
+ 4 => 15,
+ 5 => 18,
+ 6 => 21,
+ 7 => 25,
+ 8 => 28,
+ 9 => 31,
+ 10 => 35,
+ 11 => 38,
+ 12 => 41,
+ 13 => 45,
+ 14 => 48,
+ 15 => 51,
+ 16 => 55,
+ 17 => 58,
+ 18 => 61,
+ 19 => 65,
+ 20 => 68,
+ 21 => 71,
+ 22 => 75,
+ 23 => 78,
+ 24 => 81,
+ 25 => 85,
+ 26 => 88,
+ 27 => 91,
+ 28 => 95,
+ 29 => 98,
+ 30 => 101,
+ 31 => 104,
+ 32 => 108,
+ 33 => 111,
+ 34 => 114,
+ 35 => 118,
+ 36 => 121,
+ 37 => 124,
+ 38 => 128,
+ 39 => 131,
+ 40 => 134);
+
+ function Mantissa return Uint is
+ begin
+ return
+ UI_From_Int (Mantissa_Value (UI_To_Int (Digits_Value (P_Type))));
+ end Mantissa;
+
+ ----------------
+ -- Set_Bounds --
+ ----------------
+
+ procedure Set_Bounds is
+ Ndim : Nat;
+ Indx : Node_Id;
+ Ityp : Entity_Id;
+
+ begin
+ -- For a string literal subtype, we have to construct the bounds.
+ -- Valid Ada code never applies attributes to string literals, but
+ -- it is convenient to allow the expander to generate attribute
+ -- references of this type (e.g. First and Last applied to a string
+ -- literal).
+
+ -- Note that the whole point of the E_String_Literal_Subtype is to
+ -- avoid this construction of bounds, but the cases in which we
+ -- have to materialize them are rare enough that we don't worry!
+
+ -- The low bound is simply the low bound of the base type. The
+ -- high bound is computed from the length of the string and this
+ -- low bound.
+
+ if Ekind (P_Type) = E_String_Literal_Subtype then
+ Lo_Bound :=
+ Type_Low_Bound (Etype (First_Index (Base_Type (P_Type))));
+
+ Hi_Bound :=
+ Make_Integer_Literal (Sloc (P),
+ Intval =>
+ Expr_Value (Lo_Bound) + String_Literal_Length (P_Type) - 1);
+
+ Set_Parent (Hi_Bound, P);
+ Analyze_And_Resolve (Hi_Bound, Etype (Lo_Bound));
+ return;
+
+ -- For non-array case, just get bounds of scalar type
+
+ elsif Is_Scalar_Type (P_Type) then
+ Ityp := P_Type;
+
+ -- For array case, get type of proper index
+
+ else
+ if No (E1) then
+ Ndim := 1;
+ else
+ Ndim := UI_To_Int (Expr_Value (E1));
+ end if;
+
+ Indx := First_Index (P_Type);
+ for J in 1 .. Ndim - 1 loop
+ Next_Index (Indx);
+ end loop;
+
+ -- If no index type, get out (some other error occurred, and
+ -- we don't have enough information to complete the job!)
+
+ if No (Indx) then
+ Lo_Bound := Error;
+ Hi_Bound := Error;
+ return;
+ end if;
+
+ Ityp := Etype (Indx);
+ end if;
+
+ -- A discrete range in an index constraint is allowed to be a
+ -- subtype indication. This is syntactically a pain, but should
+ -- not propagate to the entity for the corresponding index subtype.
+ -- After checking that the subtype indication is legal, the range
+ -- of the subtype indication should be transfered to the entity.
+ -- The attributes for the bounds should remain the simple retrievals
+ -- that they are now.
+
+ Lo_Bound := Type_Low_Bound (Ityp);
+ Hi_Bound := Type_High_Bound (Ityp);
+
+ end Set_Bounds;
+
+ -- Start of processing for Eval_Attribute
+
+ begin
+ -- Acquire first two expressions (at the moment, no attributes
+ -- take more than two expressions in any case).
+
+ if Present (Expressions (N)) then
+ E1 := First (Expressions (N));
+ E2 := Next (E1);
+ else
+ E1 := Empty;
+ E2 := Empty;
+ end if;
+
+ -- Special processing for cases where the prefix is an object
+
+ if Is_Object_Reference (P) then
+
+ -- For Component_Size, the prefix is an array object, and we apply
+ -- the attribute to the type of the object. This is allowed for
+ -- both unconstrained and constrained arrays, since the bounds
+ -- have no influence on the value of this attribute.
+
+ if Id = Attribute_Component_Size then
+ P_Entity := Etype (P);
+
+ -- For First and Last, the prefix is an array object, and we apply
+ -- the attribute to the type of the array, but we need a constrained
+ -- type for this, so we use the actual subtype if available.
+
+ elsif Id = Attribute_First
+ or else
+ Id = Attribute_Last
+ or else
+ Id = Attribute_Length
+ then
+ declare
+ AS : constant Entity_Id := Get_Actual_Subtype_If_Available (P);
+
+ begin
+ if Present (AS) then
+ P_Entity := AS;
+
+ -- If no actual subtype, cannot fold
+
+ else
+ Check_Expressions;
+ return;
+ end if;
+ end;
+
+ -- For Size, give size of object if available, otherwise we
+ -- cannot fold Size.
+
+ elsif Id = Attribute_Size then
+
+ if Is_Entity_Name (P)
+ and then Known_Esize (Entity (P))
+ then
+ Fold_Uint (N, Esize (Entity (P)));
+ Set_Is_Static_Expression (N, False);
+ return;
+
+ else
+ Check_Expressions;
+ return;
+ end if;
+
+ -- For Alignment, give size of object if available, otherwise we
+ -- cannot fold Alignment.
+
+ elsif Id = Attribute_Alignment then
+
+ if Is_Entity_Name (P)
+ and then Known_Alignment (Entity (P))
+ then
+ Fold_Uint (N, Alignment (Entity (P)));
+ Set_Is_Static_Expression (N, False);
+ return;
+
+ else
+ Check_Expressions;
+ return;
+ end if;
+
+ -- No other attributes for objects are folded
+
+ else
+ Check_Expressions;
+ return;
+ end if;
+
+ -- Cases where P is not an object. Cannot do anything if P is
+ -- not the name of an entity.
+
+ elsif not Is_Entity_Name (P) then
+ Check_Expressions;
+ return;
+
+ -- Otherwise get prefix entity
+
+ else
+ P_Entity := Entity (P);
+ end if;
+
+ -- At this stage P_Entity is the entity to which the attribute
+ -- is to be applied. This is usually simply the entity of the
+ -- prefix, except in some cases of attributes for objects, where
+ -- as described above, we apply the attribute to the object type.
+
+ -- First foldable possibility is a scalar or array type (RM 4.9(7))
+ -- that is not generic (generic types are eliminated by RM 4.9(25)).
+ -- Note we allow non-static non-generic types at this stage as further
+ -- described below.
+
+ if Is_Type (P_Entity)
+ and then (Is_Scalar_Type (P_Entity) or Is_Array_Type (P_Entity))
+ and then (not Is_Generic_Type (P_Entity))
+ then
+ P_Type := P_Entity;
+
+ -- Second foldable possibility is an array object (RM 4.9(8))
+
+ elsif (Ekind (P_Entity) = E_Variable
+ or else
+ Ekind (P_Entity) = E_Constant)
+ and then Is_Array_Type (Etype (P_Entity))
+ and then (not Is_Generic_Type (Etype (P_Entity)))
+ then
+ P_Type := Etype (P_Entity);
+
+ -- If the entity is an array constant with an unconstrained
+ -- nominal subtype then get the type from the initial value.
+ -- If the value has been expanded into assignments, the expression
+ -- is not present and the attribute reference remains dynamic.
+ -- We could do better here and retrieve the type ???
+
+ if Ekind (P_Entity) = E_Constant
+ and then not Is_Constrained (P_Type)
+ then
+ if No (Constant_Value (P_Entity)) then
+ return;
+ else
+ P_Type := Etype (Constant_Value (P_Entity));
+ end if;
+ end if;
+
+ -- Definite must be folded if the prefix is not a generic type,
+ -- that is to say if we are within an instantiation. Same processing
+ -- applies to the GNAT attributes Has_Discriminants and Type_Class
+
+ elsif (Id = Attribute_Definite
+ or else
+ Id = Attribute_Has_Discriminants
+ or else
+ Id = Attribute_Type_Class)
+ and then not Is_Generic_Type (P_Entity)
+ then
+ P_Type := P_Entity;
+
+ -- We can fold 'Size applied to a type if the size is known
+ -- (as happens for a size from an attribute definition clause).
+ -- At this stage, this can happen only for types (e.g. record
+ -- types) for which the size is always non-static. We exclude
+ -- generic types from consideration (since they have bogus
+ -- sizes set within templates).
+
+ elsif Id = Attribute_Size
+ and then Is_Type (P_Entity)
+ and then (not Is_Generic_Type (P_Entity))
+ and then Known_Static_RM_Size (P_Entity)
+ then
+ Fold_Uint (N, RM_Size (P_Entity));
+ Set_Is_Static_Expression (N, False);
+ return;
+
+ -- No other cases are foldable (they certainly aren't static, and at
+ -- the moment we don't try to fold any cases other than the two above)
+
+ else
+ Check_Expressions;
+ return;
+ end if;
+
+ -- If either attribute or the prefix is Any_Type, then propagate
+ -- Any_Type to the result and don't do anything else at all.
+
+ if P_Type = Any_Type
+ or else (Present (E1) and then Etype (E1) = Any_Type)
+ or else (Present (E2) and then Etype (E2) = Any_Type)
+ then
+ Set_Etype (N, Any_Type);
+ return;
+ end if;
+
+ -- Scalar subtype case. We have not yet enforced the static requirement
+ -- of (RM 4.9(7)) and we don't intend to just yet, since there are cases
+ -- of non-static attribute references (e.g. S'Digits for a non-static
+ -- floating-point type, which we can compute at compile time).
+
+ -- Note: this folding of non-static attributes is not simply a case of
+ -- optimization. For many of the attributes affected, Gigi cannot handle
+ -- the attribute and depends on the front end having folded them away.
+
+ -- Note: although we don't require staticness at this stage, we do set
+ -- the Static variable to record the staticness, for easy reference by
+ -- those attributes where it matters (e.g. Succ and Pred), and also to
+ -- be used to ensure that non-static folded things are not marked as
+ -- being static (a check that is done right at the end).
+
+ P_Root_Type := Root_Type (P_Type);
+ P_Base_Type := Base_Type (P_Type);
+
+ -- If the root type or base type is generic, then we cannot fold. This
+ -- test is needed because subtypes of generic types are not always
+ -- marked as being generic themselves (which seems odd???)
+
+ if Is_Generic_Type (P_Root_Type)
+ or else Is_Generic_Type (P_Base_Type)
+ then
+ return;
+ end if;
+
+ if Is_Scalar_Type (P_Type) then
+ Static := Is_OK_Static_Subtype (P_Type);
+
+ -- Array case. We enforce the constrained requirement of (RM 4.9(7-8))
+ -- since we can't do anything with unconstrained arrays. In addition,
+ -- only the First, Last and Length attributes are possibly static.
+ -- In addition Component_Size is possibly foldable, even though it
+ -- can never be static.
+
+ -- Definite, Has_Discriminants and Type_Class are again exceptions,
+ -- because they apply as well to unconstrained types.
+
+ elsif Id = Attribute_Definite
+ or else
+ Id = Attribute_Has_Discriminants
+ or else
+ Id = Attribute_Type_Class
+ then
+ Static := False;
+
+ else
+ if not Is_Constrained (P_Type)
+ or else (Id /= Attribute_Component_Size and then
+ Id /= Attribute_First and then
+ Id /= Attribute_Last and then
+ Id /= Attribute_Length)
+ then
+ Check_Expressions;
+ return;
+ end if;
+
+ -- The rules in (RM 4.9(7,8)) require a static array, but as in the
+ -- scalar case, we hold off on enforcing staticness, since there are
+ -- cases which we can fold at compile time even though they are not
+ -- static (e.g. 'Length applied to a static index, even though other
+ -- non-static indexes make the array type non-static). This is only
+ -- ab optimization, but it falls out essentially free, so why not.
+ -- Again we compute the variable Static for easy reference later
+ -- (note that no array attributes are static in Ada 83).
+
+ Static := Ada_95;
+
+ declare
+ N : Node_Id;
+
+ begin
+ N := First_Index (P_Type);
+ while Present (N) loop
+ Static := Static and Is_Static_Subtype (Etype (N));
+ Next_Index (N);
+ end loop;
+ end;
+ end if;
+
+ -- Check any expressions that are present. Note that these expressions,
+ -- depending on the particular attribute type, are either part of the
+ -- attribute designator, or they are arguments in a case where the
+ -- attribute reference returns a function. In the latter case, the
+ -- rule in (RM 4.9(22)) applies and in particular requires the type
+ -- of the expressions to be scalar in order for the attribute to be
+ -- considered to be static.
+
+ declare
+ E : Node_Id;
+
+ begin
+ E := E1;
+ while Present (E) loop
+
+ -- If expression is not static, then the attribute reference
+ -- certainly is neither foldable nor static, so we can quit
+ -- after calling Apply_Range_Check for 'Pos attributes.
+
+ -- We can also quit if the expression is not of a scalar type
+ -- as noted above.
+
+ if not Is_Static_Expression (E)
+ or else not Is_Scalar_Type (Etype (E))
+ then
+ if Id = Attribute_Pos then
+ if Is_Integer_Type (Etype (E)) then
+ Apply_Range_Check (E, Etype (N));
+ end if;
+ end if;
+
+ Check_Expressions;
+ return;
+
+ -- If the expression raises a constraint error, then so does
+ -- the attribute reference. We keep going in this case because
+ -- we are still interested in whether the attribute reference
+ -- is static even if it is not static.
+
+ elsif Raises_Constraint_Error (E) then
+ Set_Raises_Constraint_Error (N);
+ end if;
+
+ Next (E);
+ end loop;
+
+ if Raises_Constraint_Error (Prefix (N)) then
+ return;
+ end if;
+ end;
+
+ -- Deal with the case of a static attribute reference that raises
+ -- constraint error. The Raises_Constraint_Error flag will already
+ -- have been set, and the Static flag shows whether the attribute
+ -- reference is static. In any case we certainly can't fold such an
+ -- attribute reference.
+
+ -- Note that the rewriting of the attribute node with the constraint
+ -- error node is essential in this case, because otherwise Gigi might
+ -- blow up on one of the attributes it never expects to see.
+
+ -- The constraint_error node must have the type imposed by the context,
+ -- to avoid spurious errors in the enclosing expression.
+
+ if Raises_Constraint_Error (N) then
+ CE_Node :=
+ Make_Raise_Constraint_Error (Sloc (N));
+ Set_Etype (CE_Node, Etype (N));
+ Set_Raises_Constraint_Error (CE_Node);
+ Check_Expressions;
+ Rewrite (N, Relocate_Node (CE_Node));
+ Set_Is_Static_Expression (N, Static);
+ return;
+ end if;
+
+ -- At this point we have a potentially foldable attribute reference.
+ -- If Static is set, then the attribute reference definitely obeys
+ -- the requirements in (RM 4.9(7,8,22)), and it definitely can be
+ -- folded. If Static is not set, then the attribute may or may not
+ -- be foldable, and the individual attribute processing routines
+ -- test Static as required in cases where it makes a difference.
+
+ case Id is
+
+ --------------
+ -- Adjacent --
+ --------------
+
+ when Attribute_Adjacent =>
+ if Static then
+ Fold_Ureal (N,
+ Eval_Fat.Adjacent
+ (P_Root_Type, Expr_Value_R (E1), Expr_Value_R (E2)));
+ end if;
+
+ ---------
+ -- Aft --
+ ---------
+
+ when Attribute_Aft =>
+ Fold_Uint (N, UI_From_Int (Aft_Value));
+
+ ---------------
+ -- Alignment --
+ ---------------
+
+ when Attribute_Alignment => Alignment_Block : declare
+ P_TypeA : constant Entity_Id := Underlying_Type (P_Type);
+
+ begin
+ -- Fold if alignment is set and not otherwise
+
+ if Known_Alignment (P_TypeA) then
+ Fold_Uint (N, Alignment (P_TypeA));
+ end if;
+ end Alignment_Block;
+
+ ---------------
+ -- AST_Entry --
+ ---------------
+
+ -- Can only be folded in No_Ast_Handler case
+
+ when Attribute_AST_Entry =>
+ if not Is_AST_Entry (P_Entity) then
+ Rewrite (N,
+ New_Occurrence_Of (RTE (RE_No_AST_Handler), Loc));
+ else
+ null;
+ end if;
+
+ ---------
+ -- Bit --
+ ---------
+
+ -- Bit can never be folded
+
+ when Attribute_Bit =>
+ null;
+
+ ------------------
+ -- Body_Version --
+ ------------------
+
+ -- Body_version can never be static
+
+ when Attribute_Body_Version =>
+ null;
+
+ -------------
+ -- Ceiling --
+ -------------
+
+ when Attribute_Ceiling =>
+ if Static then
+ Fold_Ureal (N,
+ Eval_Fat.Ceiling (P_Root_Type, Expr_Value_R (E1)));
+ end if;
+
+ --------------------
+ -- Component_Size --
+ --------------------
+
+ when Attribute_Component_Size =>
+ if Component_Size (P_Type) /= 0 then
+ Fold_Uint (N, Component_Size (P_Type));
+ end if;
+
+ -------------
+ -- Compose --
+ -------------
+
+ when Attribute_Compose =>
+ if Static then
+ Fold_Ureal (N,
+ Eval_Fat.Compose
+ (P_Root_Type, Expr_Value_R (E1), Expr_Value (E2)));
+ end if;
+
+ -----------------
+ -- Constrained --
+ -----------------
+
+ -- Constrained is never folded for now, there may be cases that
+ -- could be handled at compile time. to be looked at later.
+
+ when Attribute_Constrained =>
+ null;
+
+ ---------------
+ -- Copy_Sign --
+ ---------------
+
+ when Attribute_Copy_Sign =>
+ if Static then
+ Fold_Ureal (N,
+ Eval_Fat.Copy_Sign
+ (P_Root_Type, Expr_Value_R (E1), Expr_Value_R (E2)));
+ end if;
+
+ -----------
+ -- Delta --
+ -----------
+
+ when Attribute_Delta =>
+ Fold_Ureal (N, Delta_Value (P_Type));
+
+ --------------
+ -- Definite --
+ --------------
+
+ when Attribute_Definite =>
+ declare
+ Result : Node_Id;
+
+ begin
+ if Is_Indefinite_Subtype (P_Entity) then
+ Result := New_Occurrence_Of (Standard_False, Loc);
+ else
+ Result := New_Occurrence_Of (Standard_True, Loc);
+ end if;
+
+ Rewrite (N, Result);
+ Analyze_And_Resolve (N, Standard_Boolean);
+ end;
+
+ ------------
+ -- Denorm --
+ ------------
+
+ when Attribute_Denorm =>
+ Fold_Uint
+ (N, UI_From_Int (Boolean'Pos (Denorm_On_Target)));
+
+ ------------
+ -- Digits --
+ ------------
+
+ when Attribute_Digits =>
+ Fold_Uint (N, Digits_Value (P_Type));
+
+ ----------
+ -- Emax --
+ ----------
+
+ when Attribute_Emax =>
+
+ -- Ada 83 attribute is defined as (RM83 3.5.8)
+
+ -- T'Emax = 4 * T'Mantissa
+
+ Fold_Uint (N, 4 * Mantissa);
+
+ --------------
+ -- Enum_Rep --
+ --------------
+
+ when Attribute_Enum_Rep =>
+ if Static then
+
+ -- For an enumeration type with a non-standard representation
+ -- use the Enumeration_Rep field of the proper constant. Note
+ -- that this would not work for types Character/Wide_Character,
+ -- since no real entities are created for the enumeration
+ -- literals, but that does not matter since these two types
+ -- do not have non-standard representations anyway.
+
+ if Is_Enumeration_Type (P_Type)
+ and then Has_Non_Standard_Rep (P_Type)
+ then
+ Fold_Uint (N, Enumeration_Rep (Expr_Value_E (E1)));
+
+ -- For enumeration types with standard representations and all
+ -- other cases (i.e. all integer and modular types), Enum_Rep
+ -- is equivalent to Pos.
+
+ else
+ Fold_Uint (N, Expr_Value (E1));
+ end if;
+ end if;
+
+ -------------
+ -- Epsilon --
+ -------------
+
+ when Attribute_Epsilon =>
+
+ -- Ada 83 attribute is defined as (RM83 3.5.8)
+
+ -- T'Epsilon = 2.0**(1 - T'Mantissa)
+
+ Fold_Ureal (N, Ureal_2 ** (1 - Mantissa));
+
+ --------------
+ -- Exponent --
+ --------------
+
+ when Attribute_Exponent =>
+ if Static then
+ Fold_Uint (N,
+ Eval_Fat.Exponent (P_Root_Type, Expr_Value_R (E1)));
+ end if;
+
+ -----------
+ -- First --
+ -----------
+
+ when Attribute_First => First_Attr :
+ begin
+ Set_Bounds;
+
+ if Compile_Time_Known_Value (Lo_Bound) then
+ if Is_Real_Type (P_Type) then
+ Fold_Ureal (N, Expr_Value_R (Lo_Bound));
+ else
+ Fold_Uint (N, Expr_Value (Lo_Bound));
+ end if;
+ end if;
+ end First_Attr;
+
+ -----------------
+ -- Fixed_Value --
+ -----------------
+
+ when Attribute_Fixed_Value =>
+ null;
+
+ -----------
+ -- Floor --
+ -----------
+
+ when Attribute_Floor =>
+ if Static then
+ Fold_Ureal (N,
+ Eval_Fat.Floor (P_Root_Type, Expr_Value_R (E1)));
+ end if;
+
+ ----------
+ -- Fore --
+ ----------
+
+ when Attribute_Fore =>
+ if Static then
+ Fold_Uint (N, UI_From_Int (Fore_Value));
+ end if;
+
+ --------------
+ -- Fraction --
+ --------------
+
+ when Attribute_Fraction =>
+ if Static then
+ Fold_Ureal (N,
+ Eval_Fat.Fraction (P_Root_Type, Expr_Value_R (E1)));
+ end if;
+
+ -----------------------
+ -- Has_Discriminants --
+ -----------------------
+
+ when Attribute_Has_Discriminants =>
+ declare
+ Result : Node_Id;
+
+ begin
+ if Has_Discriminants (P_Entity) then
+ Result := New_Occurrence_Of (Standard_True, Loc);
+ else
+ Result := New_Occurrence_Of (Standard_False, Loc);
+ end if;
+
+ Rewrite (N, Result);
+ Analyze_And_Resolve (N, Standard_Boolean);
+ end;
+
+ --------------
+ -- Identity --
+ --------------
+
+ when Attribute_Identity =>
+ null;
+
+ -----------
+ -- Image --
+ -----------
+
+ -- Image is a scalar attribute, but is never static, because it is
+ -- not a static function (having a non-scalar argument (RM 4.9(22))
+
+ when Attribute_Image =>
+ null;
+
+ ---------
+ -- Img --
+ ---------
+
+ -- Img is a scalar attribute, but is never static, because it is
+ -- not a static function (having a non-scalar argument (RM 4.9(22))
+
+ when Attribute_Img =>
+ null;
+
+ -------------------
+ -- Integer_Value --
+ -------------------
+
+ when Attribute_Integer_Value =>
+ null;
+
+ -----------
+ -- Large --
+ -----------
+
+ when Attribute_Large =>
+
+ -- For fixed-point, we use the identity:
+
+ -- T'Large = (2.0**T'Mantissa - 1.0) * T'Small
+
+ if Is_Fixed_Point_Type (P_Type) then
+ Rewrite (N,
+ Make_Op_Multiply (Loc,
+ Left_Opnd =>
+ Make_Op_Subtract (Loc,
+ Left_Opnd =>
+ Make_Op_Expon (Loc,
+ Left_Opnd =>
+ Make_Real_Literal (Loc, Ureal_2),
+ Right_Opnd =>
+ Make_Attribute_Reference (Loc,
+ Prefix => P,
+ Attribute_Name => Name_Mantissa)),
+ Right_Opnd => Make_Real_Literal (Loc, Ureal_1)),
+
+ Right_Opnd =>
+ Make_Real_Literal (Loc, Small_Value (Entity (P)))));
+
+ Analyze_And_Resolve (N, C_Type);
+
+ -- Floating-point (Ada 83 compatibility)
+
+ else
+ -- Ada 83 attribute is defined as (RM83 3.5.8)
+
+ -- T'Large = 2.0**T'Emax * (1.0 - 2.0**(-T'Mantissa))
+
+ -- where
+
+ -- T'Emax = 4 * T'Mantissa
+
+ Fold_Ureal (N,
+ Ureal_2 ** (4 * Mantissa) *
+ (Ureal_1 - Ureal_2 ** (-Mantissa)));
+ end if;
+
+ ----------
+ -- Last --
+ ----------
+
+ when Attribute_Last => Last :
+ begin
+ Set_Bounds;
+
+ if Compile_Time_Known_Value (Hi_Bound) then
+ if Is_Real_Type (P_Type) then
+ Fold_Ureal (N, Expr_Value_R (Hi_Bound));
+ else
+ Fold_Uint (N, Expr_Value (Hi_Bound));
+ end if;
+ end if;
+ end Last;
+
+ ------------------
+ -- Leading_Part --
+ ------------------
+
+ when Attribute_Leading_Part =>
+ if Static then
+ Fold_Ureal (N,
+ Eval_Fat.Leading_Part
+ (P_Root_Type, Expr_Value_R (E1), Expr_Value (E2)));
+ end if;
+
+ ------------
+ -- Length --
+ ------------
+
+ when Attribute_Length => Length :
+ begin
+ Set_Bounds;
+
+ if Compile_Time_Known_Value (Lo_Bound)
+ and then Compile_Time_Known_Value (Hi_Bound)
+ then
+ Fold_Uint (N,
+ UI_Max (0, 1 + (Expr_Value (Hi_Bound) - Expr_Value (Lo_Bound))));
+ end if;
+ end Length;
+
+ -------------
+ -- Machine --
+ -------------
+
+ when Attribute_Machine =>
+ if Static then
+ Fold_Ureal (N,
+ Eval_Fat.Machine (P_Root_Type, Expr_Value_R (E1),
+ Eval_Fat.Round));
+ end if;
+
+ ------------------
+ -- Machine_Emax --
+ ------------------
+
+ when Attribute_Machine_Emax =>
+ Float_Attribute_Universal_Integer (
+ IEEES_Machine_Emax,
+ IEEEL_Machine_Emax,
+ IEEEX_Machine_Emax,
+ VAXFF_Machine_Emax,
+ VAXDF_Machine_Emax,
+ VAXGF_Machine_Emax);
+
+ ------------------
+ -- Machine_Emin --
+ ------------------
+
+ when Attribute_Machine_Emin =>
+ Float_Attribute_Universal_Integer (
+ IEEES_Machine_Emin,
+ IEEEL_Machine_Emin,
+ IEEEX_Machine_Emin,
+ VAXFF_Machine_Emin,
+ VAXDF_Machine_Emin,
+ VAXGF_Machine_Emin);
+
+ ----------------------
+ -- Machine_Mantissa --
+ ----------------------
+
+ when Attribute_Machine_Mantissa =>
+ Float_Attribute_Universal_Integer (
+ IEEES_Machine_Mantissa,
+ IEEEL_Machine_Mantissa,
+ IEEEX_Machine_Mantissa,
+ VAXFF_Machine_Mantissa,
+ VAXDF_Machine_Mantissa,
+ VAXGF_Machine_Mantissa);
+
+ -----------------------
+ -- Machine_Overflows --
+ -----------------------
+
+ when Attribute_Machine_Overflows =>
+
+ -- Always true for fixed-point
+
+ if Is_Fixed_Point_Type (P_Type) then
+ Fold_Uint (N, True_Value);
+
+ -- Floating point case
+
+ else
+ Fold_Uint
+ (N, UI_From_Int (Boolean'Pos (Machine_Overflows_On_Target)));
+ end if;
+
+ -------------------
+ -- Machine_Radix --
+ -------------------
+
+ when Attribute_Machine_Radix =>
+ if Is_Fixed_Point_Type (P_Type) then
+ if Is_Decimal_Fixed_Point_Type (P_Type)
+ and then Machine_Radix_10 (P_Type)
+ then
+ Fold_Uint (N, Uint_10);
+ else
+ Fold_Uint (N, Uint_2);
+ end if;
+
+ -- All floating-point type always have radix 2
+
+ else
+ Fold_Uint (N, Uint_2);
+ end if;
+
+ --------------------
+ -- Machine_Rounds --
+ --------------------
+
+ when Attribute_Machine_Rounds =>
+
+ -- Always False for fixed-point
+
+ if Is_Fixed_Point_Type (P_Type) then
+ Fold_Uint (N, False_Value);
+
+ -- Else yield proper floating-point result
+
+ else
+ Fold_Uint
+ (N, UI_From_Int (Boolean'Pos (Machine_Rounds_On_Target)));
+ end if;
+
+ ------------------
+ -- Machine_Size --
+ ------------------
+
+ -- Note: Machine_Size is identical to Object_Size
+
+ when Attribute_Machine_Size => Machine_Size : declare
+ P_TypeA : constant Entity_Id := Underlying_Type (P_Type);
+
+ begin
+ if Known_Esize (P_TypeA) then
+ Fold_Uint (N, Esize (P_TypeA));
+ end if;
+ end Machine_Size;
+
+ --------------
+ -- Mantissa --
+ --------------
+
+ when Attribute_Mantissa =>
+
+ -- Fixed-point mantissa
+
+ if Is_Fixed_Point_Type (P_Type) then
+
+ -- Compile time foldable case
+
+ if Compile_Time_Known_Value (Type_Low_Bound (P_Type))
+ and then
+ Compile_Time_Known_Value (Type_High_Bound (P_Type))
+ then
+ -- The calculation of the obsolete Ada 83 attribute Mantissa
+ -- is annoying, because of AI00143, quoted here:
+
+ -- !question 84-01-10
+
+ -- Consider the model numbers for F:
+
+ -- type F is delta 1.0 range -7.0 .. 8.0;
+
+ -- The wording requires that F'MANTISSA be the SMALLEST
+ -- integer number for which each bound of the specified
+ -- range is either a model number or lies at most small
+ -- distant from a model number. This means F'MANTISSA
+ -- is required to be 3 since the range -7.0 .. 7.0 fits
+ -- in 3 signed bits, and 8 is "at most" 1.0 from a model
+ -- number, namely, 7. Is this analysis correct? Note that
+ -- this implies the upper bound of the range is not
+ -- represented as a model number.
+
+ -- !response 84-03-17
+
+ -- The analysis is correct. The upper and lower bounds for
+ -- a fixed point type can lie outside the range of model
+ -- numbers.
+
+ declare
+ Siz : Uint;
+ LBound : Ureal;
+ UBound : Ureal;
+ Bound : Ureal;
+ Max_Man : Uint;
+
+ begin
+ LBound := Expr_Value_R (Type_Low_Bound (P_Type));
+ UBound := Expr_Value_R (Type_High_Bound (P_Type));
+ Bound := UR_Max (UR_Abs (LBound), UR_Abs (UBound));
+ Max_Man := UR_Trunc (Bound / Small_Value (P_Type));
+
+ -- If the Bound is exactly a model number, i.e. a multiple
+ -- of Small, then we back it off by one to get the integer
+ -- value that must be representable.
+
+ if Small_Value (P_Type) * Max_Man = Bound then
+ Max_Man := Max_Man - 1;
+ end if;
+
+ -- Now find corresponding size = Mantissa value
+
+ Siz := Uint_0;
+ while 2 ** Siz < Max_Man loop
+ Siz := Siz + 1;
+ end loop;
+
+ Fold_Uint (N, Siz);
+ end;
+
+ else
+ -- The case of dynamic bounds cannot be evaluated at compile
+ -- time. Instead we use a runtime routine (see Exp_Attr).
+
+ null;
+ end if;
+
+ -- Floating-point Mantissa
+
+ else
+ Fold_Uint (N, Mantissa);
+ end if;
+
+ ---------
+ -- Max --
+ ---------
+
+ when Attribute_Max => Max :
+ begin
+ if Is_Real_Type (P_Type) then
+ Fold_Ureal (N, UR_Max (Expr_Value_R (E1), Expr_Value_R (E2)));
+ else
+ Fold_Uint (N, UI_Max (Expr_Value (E1), Expr_Value (E2)));
+ end if;
+ end Max;
+
+ ----------------------------------
+ -- Max_Size_In_Storage_Elements --
+ ----------------------------------
+
+ -- Max_Size_In_Storage_Elements is simply the Size rounded up to a
+ -- Storage_Unit boundary. We can fold any cases for which the size
+ -- is known by the front end.
+
+ when Attribute_Max_Size_In_Storage_Elements =>
+ if Known_Esize (P_Type) then
+ Fold_Uint (N,
+ (Esize (P_Type) + System_Storage_Unit - 1) /
+ System_Storage_Unit);
+ end if;
+
+ --------------------
+ -- Mechanism_Code --
+ --------------------
+
+ when Attribute_Mechanism_Code =>
+ declare
+ Val : Int;
+ Formal : Entity_Id;
+ Mech : Mechanism_Type;
+
+ begin
+ if No (E1) then
+ Mech := Mechanism (P_Entity);
+
+ else
+ Val := UI_To_Int (Expr_Value (E1));
+
+ Formal := First_Formal (P_Entity);
+ for J in 1 .. Val - 1 loop
+ Next_Formal (Formal);
+ end loop;
+ Mech := Mechanism (Formal);
+ end if;
+
+ if Mech < 0 then
+ Fold_Uint (N, UI_From_Int (Int (-Mech)));
+ end if;
+ end;
+
+ ---------
+ -- Min --
+ ---------
+
+ when Attribute_Min => Min :
+ begin
+ if Is_Real_Type (P_Type) then
+ Fold_Ureal (N, UR_Min (Expr_Value_R (E1), Expr_Value_R (E2)));
+ else
+ Fold_Uint (N, UI_Min (Expr_Value (E1), Expr_Value (E2)));
+ end if;
+ end Min;
+
+ -----------
+ -- Model --
+ -----------
+
+ when Attribute_Model =>
+ if Static then
+ Fold_Ureal (N,
+ Eval_Fat.Model (P_Root_Type, Expr_Value_R (E1)));
+ end if;
+
+ ----------------
+ -- Model_Emin --
+ ----------------
+
+ when Attribute_Model_Emin =>
+ Float_Attribute_Universal_Integer (
+ IEEES_Model_Emin,
+ IEEEL_Model_Emin,
+ IEEEX_Model_Emin,
+ VAXFF_Model_Emin,
+ VAXDF_Model_Emin,
+ VAXGF_Model_Emin);
+
+ -------------------
+ -- Model_Epsilon --
+ -------------------
+
+ when Attribute_Model_Epsilon =>
+ Float_Attribute_Universal_Real (
+ IEEES_Model_Epsilon'Universal_Literal_String,
+ IEEEL_Model_Epsilon'Universal_Literal_String,
+ IEEEX_Model_Epsilon'Universal_Literal_String,
+ VAXFF_Model_Epsilon'Universal_Literal_String,
+ VAXDF_Model_Epsilon'Universal_Literal_String,
+ VAXGF_Model_Epsilon'Universal_Literal_String);
+
+ --------------------
+ -- Model_Mantissa --
+ --------------------
+
+ when Attribute_Model_Mantissa =>
+ Float_Attribute_Universal_Integer (
+ IEEES_Model_Mantissa,
+ IEEEL_Model_Mantissa,
+ IEEEX_Model_Mantissa,
+ VAXFF_Model_Mantissa,
+ VAXDF_Model_Mantissa,
+ VAXGF_Model_Mantissa);
+
+ -----------------
+ -- Model_Small --
+ -----------------
+
+ when Attribute_Model_Small =>
+ Float_Attribute_Universal_Real (
+ IEEES_Model_Small'Universal_Literal_String,
+ IEEEL_Model_Small'Universal_Literal_String,
+ IEEEX_Model_Small'Universal_Literal_String,
+ VAXFF_Model_Small'Universal_Literal_String,
+ VAXDF_Model_Small'Universal_Literal_String,
+ VAXGF_Model_Small'Universal_Literal_String);
+
+ -------------
+ -- Modulus --
+ -------------
+
+ when Attribute_Modulus =>
+ Fold_Uint (N, Modulus (P_Type));
+
+ --------------------
+ -- Null_Parameter --
+ --------------------
+
+ -- Cannot fold, we know the value sort of, but the whole point is
+ -- that there is no way to talk about this imaginary value except
+ -- by using the attribute, so we leave it the way it is.
+
+ when Attribute_Null_Parameter =>
+ null;
+
+ -----------------
+ -- Object_Size --
+ -----------------
+
+ -- The Object_Size attribute for a type returns the Esize of the
+ -- type and can be folded if this value is known.
+
+ when Attribute_Object_Size => Object_Size : declare
+ P_TypeA : constant Entity_Id := Underlying_Type (P_Type);
+
+ begin
+ if Known_Esize (P_TypeA) then
+ Fold_Uint (N, Esize (P_TypeA));
+ end if;
+ end Object_Size;
+
+ -------------------------
+ -- Passed_By_Reference --
+ -------------------------
+
+ -- Scalar types are never passed by reference
+
+ when Attribute_Passed_By_Reference =>
+ Fold_Uint (N, False_Value);
+
+ ---------
+ -- Pos --
+ ---------
+
+ when Attribute_Pos =>
+ Fold_Uint (N, Expr_Value (E1));
+
+ ----------
+ -- Pred --
+ ----------
+
+ when Attribute_Pred => Pred :
+ begin
+ if Static then
+
+ -- Floating-point case. For now, do not fold this, since we
+ -- don't know how to do it right (see fixed bug 3512-001 ???)
+
+ if Is_Floating_Point_Type (P_Type) then
+ Fold_Ureal (N,
+ Eval_Fat.Pred (P_Root_Type, Expr_Value_R (E1)));
+
+ -- Fixed-point case
+
+ elsif Is_Fixed_Point_Type (P_Type) then
+ Fold_Ureal (N,
+ Expr_Value_R (E1) - Small_Value (P_Type));
+
+ -- Modular integer case (wraps)
+
+ elsif Is_Modular_Integer_Type (P_Type) then
+ Fold_Uint (N, (Expr_Value (E1) - 1) mod Modulus (P_Type));
+
+ -- Other scalar cases
+
+ else
+ pragma Assert (Is_Scalar_Type (P_Type));
+
+ if Is_Enumeration_Type (P_Type)
+ and then Expr_Value (E1) =
+ Expr_Value (Type_Low_Bound (P_Base_Type))
+ then
+ Apply_Compile_Time_Constraint_Error
+ (N, "Pred of type''First");
+ Check_Expressions;
+ return;
+ end if;
+
+ Fold_Uint (N, Expr_Value (E1) - 1);
+ end if;
+ end if;
+ end Pred;
+
+ -----------
+ -- Range --
+ -----------
+
+ -- No processing required, because by this stage, Range has been
+ -- replaced by First .. Last, so this branch can never be taken.
+
+ when Attribute_Range =>
+ raise Program_Error;
+
+ ------------------
+ -- Range_Length --
+ ------------------
+
+ when Attribute_Range_Length =>
+ Set_Bounds;
+
+ if Compile_Time_Known_Value (Hi_Bound)
+ and then Compile_Time_Known_Value (Lo_Bound)
+ then
+ Fold_Uint (N,
+ UI_Max
+ (0, Expr_Value (Hi_Bound) - Expr_Value (Lo_Bound) + 1));
+ end if;
+
+ ---------------
+ -- Remainder --
+ ---------------
+
+ when Attribute_Remainder =>
+ if Static then
+ Fold_Ureal (N,
+ Eval_Fat.Remainder
+ (P_Root_Type, Expr_Value_R (E1), Expr_Value_R (E2)));
+ end if;
+
+ -----------
+ -- Round --
+ -----------
+
+ when Attribute_Round => Round :
+ declare
+ Sr : Ureal;
+ Si : Uint;
+
+ begin
+ if Static then
+ -- First we get the (exact result) in units of small
+
+ Sr := Expr_Value_R (E1) / Small_Value (C_Type);
+
+ -- Now round that exactly to an integer
+
+ Si := UR_To_Uint (Sr);
+
+ -- Finally the result is obtained by converting back to real
+
+ Fold_Ureal (N, Si * Small_Value (C_Type));
+ end if;
+ end Round;
+
+ --------------
+ -- Rounding --
+ --------------
+
+ when Attribute_Rounding =>
+ if Static then
+ Fold_Ureal (N,
+ Eval_Fat.Rounding (P_Root_Type, Expr_Value_R (E1)));
+ end if;
+
+ ---------------
+ -- Safe_Emax --
+ ---------------
+
+ when Attribute_Safe_Emax =>
+ Float_Attribute_Universal_Integer (
+ IEEES_Safe_Emax,
+ IEEEL_Safe_Emax,
+ IEEEX_Safe_Emax,
+ VAXFF_Safe_Emax,
+ VAXDF_Safe_Emax,
+ VAXGF_Safe_Emax);
+
+ ----------------
+ -- Safe_First --
+ ----------------
+
+ when Attribute_Safe_First =>
+ Float_Attribute_Universal_Real (
+ IEEES_Safe_First'Universal_Literal_String,
+ IEEEL_Safe_First'Universal_Literal_String,
+ IEEEX_Safe_First'Universal_Literal_String,
+ VAXFF_Safe_First'Universal_Literal_String,
+ VAXDF_Safe_First'Universal_Literal_String,
+ VAXGF_Safe_First'Universal_Literal_String);
+
+ ----------------
+ -- Safe_Large --
+ ----------------
+
+ when Attribute_Safe_Large =>
+ if Is_Fixed_Point_Type (P_Type) then
+ Fold_Ureal (N, Expr_Value_R (Type_High_Bound (P_Base_Type)));
+ else
+ Float_Attribute_Universal_Real (
+ IEEES_Safe_Large'Universal_Literal_String,
+ IEEEL_Safe_Large'Universal_Literal_String,
+ IEEEX_Safe_Large'Universal_Literal_String,
+ VAXFF_Safe_Large'Universal_Literal_String,
+ VAXDF_Safe_Large'Universal_Literal_String,
+ VAXGF_Safe_Large'Universal_Literal_String);
+ end if;
+
+ ---------------
+ -- Safe_Last --
+ ---------------
+
+ when Attribute_Safe_Last =>
+ Float_Attribute_Universal_Real (
+ IEEES_Safe_Last'Universal_Literal_String,
+ IEEEL_Safe_Last'Universal_Literal_String,
+ IEEEX_Safe_Last'Universal_Literal_String,
+ VAXFF_Safe_Last'Universal_Literal_String,
+ VAXDF_Safe_Last'Universal_Literal_String,
+ VAXGF_Safe_Last'Universal_Literal_String);
+
+ ----------------
+ -- Safe_Small --
+ ----------------
+
+ when Attribute_Safe_Small =>
+
+ -- In Ada 95, the old Ada 83 attribute Safe_Small is redundant
+ -- for fixed-point, since is the same as Small, but we implement
+ -- it for backwards compatibility.
+
+ if Is_Fixed_Point_Type (P_Type) then
+ Fold_Ureal (N, Small_Value (P_Type));
+
+ -- Ada 83 Safe_Small for floating-point cases
+
+ else
+ Float_Attribute_Universal_Real (
+ IEEES_Safe_Small'Universal_Literal_String,
+ IEEEL_Safe_Small'Universal_Literal_String,
+ IEEEX_Safe_Small'Universal_Literal_String,
+ VAXFF_Safe_Small'Universal_Literal_String,
+ VAXDF_Safe_Small'Universal_Literal_String,
+ VAXGF_Safe_Small'Universal_Literal_String);
+ end if;
+
+ -----------
+ -- Scale --
+ -----------
+
+ when Attribute_Scale =>
+ Fold_Uint (N, Scale_Value (P_Type));
+
+ -------------
+ -- Scaling --
+ -------------
+
+ when Attribute_Scaling =>
+ if Static then
+ Fold_Ureal (N,
+ Eval_Fat.Scaling
+ (P_Root_Type, Expr_Value_R (E1), Expr_Value (E2)));
+ end if;
+
+ ------------------
+ -- Signed_Zeros --
+ ------------------
+
+ when Attribute_Signed_Zeros =>
+ Fold_Uint
+ (N, UI_From_Int (Boolean'Pos (Signed_Zeros_On_Target)));
+
+ ----------
+ -- Size --
+ ----------
+
+ -- Size attribute returns the RM size. All scalar types can be folded,
+ -- as well as any types for which the size is known by the front end,
+ -- including any type for which a size attribute is specified.
+
+ when Attribute_Size | Attribute_VADS_Size => Size : declare
+ P_TypeA : constant Entity_Id := Underlying_Type (P_Type);
+
+ begin
+ if RM_Size (P_TypeA) /= Uint_0 then
+
+ -- VADS_Size case
+
+ if (Id = Attribute_VADS_Size or else Use_VADS_Size) then
+
+ declare
+ S : constant Node_Id := Size_Clause (P_TypeA);
+
+ begin
+ -- If a size clause applies, then use the size from it.
+ -- This is one of the rare cases where we can use the
+ -- Size_Clause field for a subtype when Has_Size_Clause
+ -- is False. Consider:
+
+ -- type x is range 1 .. 64;
+ -- for x'size use 12;
+ -- subtype y is x range 0 .. 3;
+
+ -- Here y has a size clause inherited from x, but normally
+ -- it does not apply, and y'size is 2. However, y'VADS_Size
+ -- is indeed 12 and not 2.
+
+ if Present (S)
+ and then Is_OK_Static_Expression (Expression (S))
+ then
+ Fold_Uint (N, Expr_Value (Expression (S)));
+
+ -- If no size is specified, then we simply use the object
+ -- size in the VADS_Size case (e.g. Natural'Size is equal
+ -- to Integer'Size, not one less).
+
+ else
+ Fold_Uint (N, Esize (P_TypeA));
+ end if;
+ end;
+
+ -- Normal case (Size) in which case we want the RM_Size
+
+ else
+ Fold_Uint (N, RM_Size (P_TypeA));
+ end if;
+ end if;
+ end Size;
+
+ -----------
+ -- Small --
+ -----------
+
+ when Attribute_Small =>
+
+ -- The floating-point case is present only for Ada 83 compatability.
+ -- Note that strictly this is an illegal addition, since we are
+ -- extending an Ada 95 defined attribute, but we anticipate an
+ -- ARG ruling that will permit this.
+
+ if Is_Floating_Point_Type (P_Type) then
+
+ -- Ada 83 attribute is defined as (RM83 3.5.8)
+
+ -- T'Small = 2.0**(-T'Emax - 1)
+
+ -- where
+
+ -- T'Emax = 4 * T'Mantissa
+
+ Fold_Ureal (N, Ureal_2 ** ((-(4 * Mantissa)) - 1));
+
+ -- Normal Ada 95 fixed-point case
+
+ else
+ Fold_Ureal (N, Small_Value (P_Type));
+ end if;
+
+ ----------
+ -- Succ --
+ ----------
+
+ when Attribute_Succ => Succ :
+ begin
+ if Static then
+
+ -- Floating-point case. For now, do not fold this, since we
+ -- don't know how to do it right (see fixed bug 3512-001 ???)
+
+ if Is_Floating_Point_Type (P_Type) then
+ Fold_Ureal (N,
+ Eval_Fat.Succ (P_Root_Type, Expr_Value_R (E1)));
+
+ -- Fixed-point case
+
+ elsif Is_Fixed_Point_Type (P_Type) then
+ Fold_Ureal (N,
+ Expr_Value_R (E1) + Small_Value (P_Type));
+
+ -- Modular integer case (wraps)
+
+ elsif Is_Modular_Integer_Type (P_Type) then
+ Fold_Uint (N, (Expr_Value (E1) + 1) mod Modulus (P_Type));
+
+ -- Other scalar cases
+
+ else
+ pragma Assert (Is_Scalar_Type (P_Type));
+
+ if Is_Enumeration_Type (P_Type)
+ and then Expr_Value (E1) =
+ Expr_Value (Type_High_Bound (P_Base_Type))
+ then
+ Apply_Compile_Time_Constraint_Error
+ (N, "Succ of type''Last");
+ Check_Expressions;
+ return;
+ else
+ Fold_Uint (N, Expr_Value (E1) + 1);
+ end if;
+ end if;
+ end if;
+ end Succ;
+
+ ----------------
+ -- Truncation --
+ ----------------
+
+ when Attribute_Truncation =>
+ if Static then
+ Fold_Ureal (N,
+ Eval_Fat.Truncation (P_Root_Type, Expr_Value_R (E1)));
+ end if;
+
+ ----------------
+ -- Type_Class --
+ ----------------
+
+ when Attribute_Type_Class => Type_Class : declare
+ Typ : constant Entity_Id := Underlying_Type (P_Base_Type);
+ Id : RE_Id;
+
+ begin
+ if Is_RTE (P_Root_Type, RE_Address) then
+ Id := RE_Type_Class_Address;
+
+ elsif Is_Enumeration_Type (Typ) then
+ Id := RE_Type_Class_Enumeration;
+
+ elsif Is_Integer_Type (Typ) then
+ Id := RE_Type_Class_Integer;
+
+ elsif Is_Fixed_Point_Type (Typ) then
+ Id := RE_Type_Class_Fixed_Point;
+
+ elsif Is_Floating_Point_Type (Typ) then
+ Id := RE_Type_Class_Floating_Point;
+
+ elsif Is_Array_Type (Typ) then
+ Id := RE_Type_Class_Array;
+
+ elsif Is_Record_Type (Typ) then
+ Id := RE_Type_Class_Record;
+
+ elsif Is_Access_Type (Typ) then
+ Id := RE_Type_Class_Access;
+
+ elsif Is_Enumeration_Type (Typ) then
+ Id := RE_Type_Class_Enumeration;
+
+ elsif Is_Task_Type (Typ) then
+ Id := RE_Type_Class_Task;
+
+ -- We treat protected types like task types. It would make more
+ -- sense to have another enumeration value, but after all the
+ -- whole point of this feature is to be exactly DEC compatible,
+ -- and changing the type Type_Clas would not meet this requirement.
+
+ elsif Is_Protected_Type (Typ) then
+ Id := RE_Type_Class_Task;
+
+ -- Not clear if there are any other possibilities, but if there
+ -- are, then we will treat them as the address case.
+
+ else
+ Id := RE_Type_Class_Address;
+ end if;
+
+ Rewrite (N, New_Occurrence_Of (RTE (Id), Loc));
+
+ end Type_Class;
+
+ -----------------------
+ -- Unbiased_Rounding --
+ -----------------------
+
+ when Attribute_Unbiased_Rounding =>
+ if Static then
+ Fold_Ureal (N,
+ Eval_Fat.Unbiased_Rounding (P_Root_Type, Expr_Value_R (E1)));
+ end if;
+
+ ---------------
+ -- VADS_Size --
+ ---------------
+
+ -- Processing is shared with Size
+
+ ---------
+ -- Val --
+ ---------
+
+ when Attribute_Val => Val :
+ begin
+ if Static then
+ if Expr_Value (E1) < Expr_Value (Type_Low_Bound (P_Base_Type))
+ or else
+ Expr_Value (E1) > Expr_Value (Type_High_Bound (P_Base_Type))
+ then
+ Apply_Compile_Time_Constraint_Error
+ (N, "Val expression out of range");
+ Check_Expressions;
+ return;
+ else
+ Fold_Uint (N, Expr_Value (E1));
+ end if;
+ end if;
+ end Val;
+
+ ----------------
+ -- Value_Size --
+ ----------------
+
+ -- The Value_Size attribute for a type returns the RM size of the
+ -- type. This an always be folded for scalar types, and can also
+ -- be folded for non-scalar types if the size is set.
+
+ when Attribute_Value_Size => Value_Size : declare
+ P_TypeA : constant Entity_Id := Underlying_Type (P_Type);
+
+ begin
+ if RM_Size (P_TypeA) /= Uint_0 then
+ Fold_Uint (N, RM_Size (P_TypeA));
+ end if;
+
+ end Value_Size;
+
+ -------------
+ -- Version --
+ -------------
+
+ -- Version can never be static
+
+ when Attribute_Version =>
+ null;
+
+ ----------------
+ -- Wide_Image --
+ ----------------
+
+ -- Wide_Image is a scalar attribute, but is never static, because it
+ -- is not a static function (having a non-scalar argument (RM 4.9(22))
+
+ when Attribute_Wide_Image =>
+ null;
+
+ ----------------
+ -- Wide_Width --
+ ----------------
+
+ -- Processing for Wide_Width is combined with Width
+
+ -----------
+ -- Width --
+ -----------
+
+ -- This processing also handles the case of Wide_Width
+
+ when Attribute_Width | Attribute_Wide_Width => Width :
+ begin
+ if Static then
+
+ -- Floating-point types
+
+ if Is_Floating_Point_Type (P_Type) then
+
+ -- Width is zero for a null range (RM 3.5 (38))
+
+ if Expr_Value_R (Type_High_Bound (P_Type)) <
+ Expr_Value_R (Type_Low_Bound (P_Type))
+ then
+ Fold_Uint (N, Uint_0);
+
+ else
+ -- For floating-point, we have +N.dddE+nnn where length
+ -- of ddd is determined by type'Digits - 1, but is one
+ -- if Digits is one (RM 3.5 (33)).
+
+ -- nnn is set to 2 for Short_Float and Float (32 bit
+ -- floats), and 3 for Long_Float and Long_Long_Float.
+ -- This is not quite right, but is good enough.
+
+ declare
+ Len : Int :=
+ Int'Max (2, UI_To_Int (Digits_Value (P_Type)));
+
+ begin
+ if Esize (P_Type) <= 32 then
+ Len := Len + 6;
+ else
+ Len := Len + 7;
+ end if;
+
+ Fold_Uint (N, UI_From_Int (Len));
+ end;
+ end if;
+
+ -- Fixed-point types
+
+ elsif Is_Fixed_Point_Type (P_Type) then
+
+ -- Width is zero for a null range (RM 3.5 (38))
+
+ if Expr_Value (Type_High_Bound (P_Type)) <
+ Expr_Value (Type_Low_Bound (P_Type))
+ then
+ Fold_Uint (N, Uint_0);
+
+ -- The non-null case depends on the specific real type
+
+ else
+ -- For fixed-point type width is Fore + 1 + Aft (RM 3.5(34))
+
+ Fold_Uint (N, UI_From_Int (Fore_Value + 1 + Aft_Value));
+ end if;
+
+ -- Discrete types
+
+ else
+ declare
+ R : constant Entity_Id := Root_Type (P_Type);
+ Lo : constant Uint :=
+ Expr_Value (Type_Low_Bound (P_Type));
+ Hi : constant Uint :=
+ Expr_Value (Type_High_Bound (P_Type));
+ W : Nat;
+ Wt : Nat;
+ T : Uint;
+ L : Node_Id;
+ C : Character;
+
+ begin
+ -- Empty ranges
+
+ if Lo > Hi then
+ W := 0;
+
+ -- Width for types derived from Standard.Character
+ -- and Standard.Wide_Character.
+
+ elsif R = Standard_Character
+ or else R = Standard_Wide_Character
+ then
+ W := 0;
+
+ -- Set W larger if needed
+
+ for J in UI_To_Int (Lo) .. UI_To_Int (Hi) loop
+
+ -- Assume all wide-character escape sequences are
+ -- same length, so we can quit when we reach one.
+
+ if J > 255 then
+ if Id = Attribute_Wide_Width then
+ W := Int'Max (W, 3);
+ exit;
+ else
+ W := Int'Max (W, Length_Wide);
+ exit;
+ end if;
+
+ else
+ C := Character'Val (J);
+
+ -- Test for all cases where Character'Image
+ -- yields an image that is longer than three
+ -- characters. First the cases of Reserved_xxx
+ -- names (length = 12).
+
+ case C is
+ when Reserved_128 | Reserved_129 |
+ Reserved_132 | Reserved_153
+
+ => Wt := 12;
+
+ when BS | HT | LF | VT | FF | CR |
+ SO | SI | EM | FS | GS | RS |
+ US | RI | MW | ST | PM
+
+ => Wt := 2;
+
+ when NUL | SOH | STX | ETX | EOT |
+ ENQ | ACK | BEL | DLE | DC1 |
+ DC2 | DC3 | DC4 | NAK | SYN |
+ ETB | CAN | SUB | ESC | DEL |
+ BPH | NBH | NEL | SSA | ESA |
+ HTS | HTJ | VTS | PLD | PLU |
+ SS2 | SS3 | DCS | PU1 | PU2 |
+ STS | CCH | SPA | EPA | SOS |
+ SCI | CSI | OSC | APC
+
+ => Wt := 3;
+
+ when Space .. Tilde |
+ No_Break_Space .. LC_Y_Diaeresis
+
+ => Wt := 3;
+
+ end case;
+
+ W := Int'Max (W, Wt);
+ end if;
+ end loop;
+
+ -- Width for types derived from Standard.Boolean
+
+ elsif R = Standard_Boolean then
+ if Lo = 0 then
+ W := 5; -- FALSE
+ else
+ W := 4; -- TRUE
+ end if;
+
+ -- Width for integer types
+
+ elsif Is_Integer_Type (P_Type) then
+ T := UI_Max (abs Lo, abs Hi);
+
+ W := 2;
+ while T >= 10 loop
+ W := W + 1;
+ T := T / 10;
+ end loop;
+
+ -- Only remaining possibility is user declared enum type
+
+ else
+ pragma Assert (Is_Enumeration_Type (P_Type));
+
+ W := 0;
+ L := First_Literal (P_Type);
+
+ while Present (L) loop
+
+ -- Only pay attention to in range characters
+
+ if Lo <= Enumeration_Pos (L)
+ and then Enumeration_Pos (L) <= Hi
+ then
+ -- For Width case, use decoded name
+
+ if Id = Attribute_Width then
+ Get_Decoded_Name_String (Chars (L));
+ Wt := Nat (Name_Len);
+
+ -- For Wide_Width, use encoded name, and then
+ -- adjust for the encoding.
+
+ else
+ Get_Name_String (Chars (L));
+
+ -- Character literals are always of length 3
+
+ if Name_Buffer (1) = 'Q' then
+ Wt := 3;
+
+ -- Otherwise loop to adjust for upper/wide chars
+
+ else
+ Wt := Nat (Name_Len);
+
+ for J in 1 .. Name_Len loop
+ if Name_Buffer (J) = 'U' then
+ Wt := Wt - 2;
+ elsif Name_Buffer (J) = 'W' then
+ Wt := Wt - 4;
+ end if;
+ end loop;
+ end if;
+ end if;
+
+ W := Int'Max (W, Wt);
+ end if;
+
+ Next_Literal (L);
+ end loop;
+ end if;
+
+ Fold_Uint (N, UI_From_Int (W));
+ end;
+ end if;
+ end if;
+ end Width;
+
+ -- The following attributes can never be folded, and furthermore we
+ -- should not even have entered the case statement for any of these.
+ -- Note that in some cases, the values have already been folded as
+ -- a result of the processing in Analyze_Attribute.
+
+ when Attribute_Abort_Signal |
+ Attribute_Access |
+ Attribute_Address |
+ Attribute_Address_Size |
+ Attribute_Asm_Input |
+ Attribute_Asm_Output |
+ Attribute_Base |
+ Attribute_Bit_Order |
+ Attribute_Bit_Position |
+ Attribute_Callable |
+ Attribute_Caller |
+ Attribute_Class |
+ Attribute_Code_Address |
+ Attribute_Count |
+ Attribute_Default_Bit_Order |
+ Attribute_Elaborated |
+ Attribute_Elab_Body |
+ Attribute_Elab_Spec |
+ Attribute_External_Tag |
+ Attribute_First_Bit |
+ Attribute_Input |
+ Attribute_Last_Bit |
+ Attribute_Max_Interrupt_Priority |
+ Attribute_Max_Priority |
+ Attribute_Maximum_Alignment |
+ Attribute_Output |
+ Attribute_Partition_ID |
+ Attribute_Position |
+ Attribute_Read |
+ Attribute_Storage_Pool |
+ Attribute_Storage_Size |
+ Attribute_Storage_Unit |
+ Attribute_Tag |
+ Attribute_Terminated |
+ Attribute_Tick |
+ Attribute_To_Address |
+ Attribute_UET_Address |
+ Attribute_Unchecked_Access |
+ Attribute_Universal_Literal_String |
+ Attribute_Unrestricted_Access |
+ Attribute_Valid |
+ Attribute_Value |
+ Attribute_Wchar_T_Size |
+ Attribute_Wide_Value |
+ Attribute_Word_Size |
+ Attribute_Write =>
+
+ raise Program_Error;
+
+ end case;
+
+ -- At the end of the case, one more check. If we did a static evaluation
+ -- so that the result is now a literal, then set Is_Static_Expression
+ -- in the constant only if the prefix type is a static subtype. For
+ -- non-static subtypes, the folding is still OK, but not static.
+
+ if Nkind (N) = N_Integer_Literal
+ or else Nkind (N) = N_Real_Literal
+ or else Nkind (N) = N_Character_Literal
+ or else Nkind (N) = N_String_Literal
+ or else (Is_Entity_Name (N)
+ and then Ekind (Entity (N)) = E_Enumeration_Literal)
+ then
+ Set_Is_Static_Expression (N, Static);
+
+ -- If this is still an attribute reference, then it has not been folded
+ -- and that means that its expressions are in a non-static context.
+
+ elsif Nkind (N) = N_Attribute_Reference then
+ Check_Expressions;
+
+ -- Note: the else case not covered here are odd cases where the
+ -- processing has transformed the attribute into something other
+ -- than a constant. Nothing more to do in such cases.
+
+ else
+ null;
+ end if;
+
+ end Eval_Attribute;
+
+ ------------------------------
+ -- Is_Anonymous_Tagged_Base --
+ ------------------------------
+
+ function Is_Anonymous_Tagged_Base
+ (Anon : Entity_Id;
+ Typ : Entity_Id)
+ return Boolean
+ is
+ begin
+ return
+ Anon = Current_Scope
+ and then Is_Itype (Anon)
+ and then Associated_Node_For_Itype (Anon) = Parent (Typ);
+ end Is_Anonymous_Tagged_Base;
+
+ -----------------------
+ -- Resolve_Attribute --
+ -----------------------
+
+ procedure Resolve_Attribute (N : Node_Id; Typ : Entity_Id) is
+ Loc : constant Source_Ptr := Sloc (N);
+ P : constant Node_Id := Prefix (N);
+ Aname : constant Name_Id := Attribute_Name (N);
+ Attr_Id : constant Attribute_Id := Get_Attribute_Id (Aname);
+ Index : Interp_Index;
+ It : Interp;
+ Btyp : Entity_Id := Base_Type (Typ);
+ Nom_Subt : Entity_Id;
+
+ begin
+ -- If error during analysis, no point in continuing, except for
+ -- array types, where we get better recovery by using unconstrained
+ -- indices than nothing at all (see Check_Array_Type).
+
+ if Error_Posted (N)
+ and then Attr_Id /= Attribute_First
+ and then Attr_Id /= Attribute_Last
+ and then Attr_Id /= Attribute_Length
+ and then Attr_Id /= Attribute_Range
+ then
+ return;
+ end if;
+
+ -- If attribute was universal type, reset to actual type
+
+ if Etype (N) = Universal_Integer
+ or else Etype (N) = Universal_Real
+ then
+ Set_Etype (N, Typ);
+ end if;
+
+ -- Remaining processing depends on attribute
+
+ case Attr_Id is
+
+ ------------
+ -- Access --
+ ------------
+
+ -- For access attributes, if the prefix denotes an entity, it is
+ -- interpreted as a name, never as a call. It may be overloaded,
+ -- in which case resolution uses the profile of the context type.
+ -- Otherwise prefix must be resolved.
+
+ when Attribute_Access
+ | Attribute_Unchecked_Access
+ | Attribute_Unrestricted_Access =>
+
+ if Is_Variable (P) then
+ Note_Possible_Modification (P);
+ end if;
+
+ if Is_Entity_Name (P) then
+
+ if Is_Overloaded (P) then
+ Get_First_Interp (P, Index, It);
+
+ while Present (It.Nam) loop
+
+ if Type_Conformant (Designated_Type (Typ), It.Nam) then
+ Set_Entity (P, It.Nam);
+
+ -- The prefix is definitely NOT overloaded anymore
+ -- at this point, so we reset the Is_Overloaded
+ -- flag to avoid any confusion when reanalyzing
+ -- the node.
+
+ Set_Is_Overloaded (P, False);
+ Generate_Reference (Entity (P), P);
+ exit;
+ end if;
+
+ Get_Next_Interp (Index, It);
+ end loop;
+
+ -- If it is a subprogram name or a type, there is nothing
+ -- to resolve.
+
+ elsif not Is_Overloadable (Entity (P))
+ and then not Is_Type (Entity (P))
+ then
+ Resolve (P, Etype (P));
+ end if;
+
+ if not Is_Entity_Name (P) then
+ null;
+
+ elsif Is_Abstract (Entity (P))
+ and then Is_Overloadable (Entity (P))
+ then
+ Error_Msg_Name_1 := Aname;
+ Error_Msg_N ("prefix of % attribute cannot be abstract", P);
+ Set_Etype (N, Any_Type);
+
+ elsif Convention (Entity (P)) = Convention_Intrinsic then
+ Error_Msg_Name_1 := Aname;
+
+ if Ekind (Entity (P)) = E_Enumeration_Literal then
+ Error_Msg_N
+ ("prefix of % attribute cannot be enumeration literal",
+ P);
+ else
+ Error_Msg_N
+ ("prefix of % attribute cannot be intrinsic", P);
+ end if;
+
+ Set_Etype (N, Any_Type);
+ end if;
+
+ -- Assignments, return statements, components of aggregates,
+ -- generic instantiations will require convention checks if
+ -- the type is an access to subprogram. Given that there will
+ -- also be accessibility checks on those, this is where the
+ -- checks can eventually be centralized ???
+
+ if Ekind (Btyp) = E_Access_Subprogram_Type then
+ if Convention (Btyp) /= Convention (Entity (P)) then
+ Error_Msg_N
+ ("subprogram has invalid convention for context", P);
+
+ else
+ Check_Subtype_Conformant
+ (New_Id => Entity (P),
+ Old_Id => Designated_Type (Btyp),
+ Err_Loc => P);
+ end if;
+
+ if Attr_Id = Attribute_Unchecked_Access then
+ Error_Msg_Name_1 := Aname;
+ Error_Msg_N
+ ("attribute% cannot be applied to a subprogram", P);
+
+ elsif Aname = Name_Unrestricted_Access then
+ null; -- Nothing to check
+
+ -- Check the static accessibility rule of 3.10.2(32)
+
+ elsif Attr_Id = Attribute_Access
+ and then Subprogram_Access_Level (Entity (P))
+ > Type_Access_Level (Btyp)
+ then
+ if not In_Instance_Body then
+ Error_Msg_N
+ ("subprogram must not be deeper than access type",
+ P);
+ else
+ Warn_On_Instance := True;
+ Error_Msg_N
+ ("subprogram must not be deeper than access type?",
+ P);
+ Error_Msg_N
+ ("Constraint_Error will be raised ?", P);
+ Set_Raises_Constraint_Error (N);
+ Warn_On_Instance := False;
+ end if;
+
+ -- Check the restriction of 3.10.2(32) that disallows
+ -- the type of the access attribute to be declared
+ -- outside a generic body when the attribute occurs
+ -- within that generic body.
+
+ elsif Enclosing_Generic_Body (Entity (P))
+ /= Enclosing_Generic_Body (Btyp)
+ then
+ Error_Msg_N
+ ("access type must not be outside generic body", P);
+ end if;
+ end if;
+
+ -- if this is a renaming, an inherited operation, or a
+ -- subprogram instance, use the original entity.
+
+ if Is_Entity_Name (P)
+ and then Is_Overloadable (Entity (P))
+ and then Present (Alias (Entity (P)))
+ then
+ Rewrite (P,
+ New_Occurrence_Of (Alias (Entity (P)), Sloc (P)));
+ end if;
+
+ elsif Nkind (P) = N_Selected_Component
+ and then Is_Overloadable (Entity (Selector_Name (P)))
+ then
+ -- Protected operation. If operation is overloaded, must
+ -- disambiguate. Prefix that denotes protected object itself
+ -- is resolved with its own type.
+
+ if Attr_Id = Attribute_Unchecked_Access then
+ Error_Msg_Name_1 := Aname;
+ Error_Msg_N
+ ("attribute% cannot be applied to protected operation", P);
+ end if;
+
+ Resolve (Prefix (P), Etype (Prefix (P)));
+
+ elsif Is_Overloaded (P) then
+
+ -- Use the designated type of the context to disambiguate.
+ declare
+ Index : Interp_Index;
+ It : Interp;
+ begin
+ Get_First_Interp (P, Index, It);
+
+ while Present (It.Typ) loop
+ if Covers (Designated_Type (Typ), It.Typ) then
+ Resolve (P, It.Typ);
+ exit;
+ end if;
+
+ Get_Next_Interp (Index, It);
+ end loop;
+ end;
+ else
+ Resolve (P, Etype (P));
+ end if;
+
+ -- X'Access is illegal if X denotes a constant and the access
+ -- type is access-to-variable. Same for 'Unchecked_Access.
+ -- The rule does not apply to 'Unrestricted_Access.
+
+ if not (Ekind (Btyp) = E_Access_Subprogram_Type
+ or else (Is_Record_Type (Btyp) and then
+ Present (Corresponding_Remote_Type (Btyp)))
+ or else Ekind (Btyp) = E_Access_Protected_Subprogram_Type
+ or else Is_Access_Constant (Btyp)
+ or else Is_Variable (P)
+ or else Attr_Id = Attribute_Unrestricted_Access)
+ then
+ if Comes_From_Source (N) then
+ Error_Msg_N ("access-to-variable designates constant", P);
+ end if;
+ end if;
+
+ if (Attr_Id = Attribute_Access
+ or else
+ Attr_Id = Attribute_Unchecked_Access)
+ and then (Ekind (Btyp) = E_General_Access_Type
+ or else Ekind (Btyp) = E_Anonymous_Access_Type)
+ then
+ if Is_Dependent_Component_Of_Mutable_Object (P) then
+ Error_Msg_N
+ ("illegal attribute for discriminant-dependent component",
+ P);
+ end if;
+
+ -- Check the static matching rule of 3.10.2(27). The
+ -- nominal subtype of the prefix must statically
+ -- match the designated type.
+
+ Nom_Subt := Etype (P);
+
+ if Is_Constr_Subt_For_U_Nominal (Nom_Subt) then
+ Nom_Subt := Etype (Nom_Subt);
+ end if;
+
+ if Is_Tagged_Type (Designated_Type (Typ)) then
+ -- If the attribute is in the context of an access
+ -- parameter, then the prefix is allowed to be of
+ -- the class-wide type (by AI-127).
+
+ if Ekind (Typ) = E_Anonymous_Access_Type then
+ if not Covers (Designated_Type (Typ), Nom_Subt)
+ and then not Covers (Nom_Subt, Designated_Type (Typ))
+ then
+ if Is_Anonymous_Tagged_Base
+ (Nom_Subt, Etype (Designated_Type (Typ)))
+ then
+ null;
+
+ else
+ Error_Msg_NE
+ ("type of prefix: & not compatible", P, Nom_Subt);
+ Error_Msg_NE
+ ("\with &, the expected designated type",
+ P, Designated_Type (Typ));
+ end if;
+ end if;
+
+ elsif not Covers (Designated_Type (Typ), Nom_Subt)
+ or else
+ (not Is_Class_Wide_Type (Designated_Type (Typ))
+ and then Is_Class_Wide_Type (Nom_Subt))
+ then
+ Error_Msg_NE
+ ("type of prefix: & is not covered", P, Nom_Subt);
+ Error_Msg_NE
+ ("\by &, the expected designated type" &
+ " ('R'M 3.10.2 (27))", P, Designated_Type (Typ));
+ end if;
+
+ if Is_Class_Wide_Type (Designated_Type (Typ))
+ and then Has_Discriminants (Etype (Designated_Type (Typ)))
+ and then Is_Constrained (Etype (Designated_Type (Typ)))
+ and then Designated_Type (Typ) /= Nom_Subt
+ then
+ Apply_Discriminant_Check
+ (N, Etype (Designated_Type (Typ)));
+ end if;
+
+ elsif not Subtypes_Statically_Match
+ (Designated_Type (Typ), Nom_Subt)
+ and then
+ not (Has_Discriminants (Designated_Type (Typ))
+ and then not Is_Constrained (Designated_Type (Typ)))
+ then
+ Error_Msg_N
+ ("object subtype must statically match "
+ & "designated subtype", P);
+
+ if Is_Entity_Name (P)
+ and then Is_Array_Type (Designated_Type (Typ))
+ then
+
+ declare
+ D : constant Node_Id := Declaration_Node (Entity (P));
+
+ begin
+ Error_Msg_N ("aliased object has explicit bounds?",
+ D);
+ Error_Msg_N ("\declare without bounds"
+ & " (and with explicit initialization)?", D);
+ Error_Msg_N ("\for use with unconstrained access?", D);
+ end;
+ end if;
+ end if;
+
+ -- Check the static accessibility rule of 3.10.2(28).
+ -- Note that this check is not performed for the
+ -- case of an anonymous access type, since the access
+ -- attribute is always legal in such a context.
+
+ if Attr_Id /= Attribute_Unchecked_Access
+ and then Object_Access_Level (P) > Type_Access_Level (Btyp)
+ and then Ekind (Btyp) = E_General_Access_Type
+ then
+ -- In an instance, this is a runtime check, but one we
+ -- know will fail, so generate an appropriate warning.
+
+ if In_Instance_Body then
+ Error_Msg_N
+ ("?non-local pointer cannot point to local object", P);
+ Error_Msg_N
+ ("?Program_Error will be raised at run time", P);
+ Rewrite (N, Make_Raise_Program_Error (Loc));
+ Set_Etype (N, Typ);
+ return;
+
+ else
+ Error_Msg_N
+ ("non-local pointer cannot point to local object", P);
+
+ if Is_Record_Type (Current_Scope)
+ and then (Nkind (Parent (N)) =
+ N_Discriminant_Association
+ or else
+ Nkind (Parent (N)) =
+ N_Index_Or_Discriminant_Constraint)
+ then
+ declare
+ Indic : Node_Id := Parent (Parent (N));
+
+ begin
+ while Present (Indic)
+ and then Nkind (Indic) /= N_Subtype_Indication
+ loop
+ Indic := Parent (Indic);
+ end loop;
+
+ if Present (Indic) then
+ Error_Msg_NE
+ ("\use an access definition for" &
+ " the access discriminant of&", N,
+ Entity (Subtype_Mark (Indic)));
+ end if;
+ end;
+ end if;
+ end if;
+ end if;
+ end if;
+
+ if Ekind (Btyp) = E_Access_Protected_Subprogram_Type
+ and then Is_Entity_Name (P)
+ and then not Is_Protected_Type (Scope (Entity (P)))
+ then
+ Error_Msg_N ("context requires a protected subprogram", P);
+
+ elsif Ekind (Btyp) = E_Access_Subprogram_Type
+ and then Ekind (Etype (N)) = E_Access_Protected_Subprogram_Type
+ then
+ Error_Msg_N ("context requires a non-protected subprogram", P);
+ end if;
+
+ -- The context cannot be a pool-specific type, but this is a
+ -- legality rule, not a resolution rule, so it must be checked
+ -- separately, after possibly disambiguation (see AI-245).
+
+ if Ekind (Btyp) = E_Access_Type
+ and then Attr_Id /= Attribute_Unrestricted_Access
+ then
+ Wrong_Type (N, Typ);
+ end if;
+
+ Set_Etype (N, Typ);
+
+ -- Check for incorrect atomic/volatile reference (RM C.6(12))
+
+ if Attr_Id /= Attribute_Unrestricted_Access then
+ if Is_Atomic_Object (P)
+ and then not Is_Atomic (Designated_Type (Typ))
+ then
+ Error_Msg_N
+ ("access to atomic object cannot yield access-to-" &
+ "non-atomic type", P);
+
+ elsif Is_Volatile_Object (P)
+ and then not Is_Volatile (Designated_Type (Typ))
+ then
+ Error_Msg_N
+ ("access to volatile object cannot yield access-to-" &
+ "non-volatile type", P);
+ end if;
+ end if;
+
+ -------------
+ -- Address --
+ -------------
+
+ -- Deal with resolving the type for Address attribute, overloading
+ -- is not permitted here, since there is no context to resolve it.
+
+ when Attribute_Address | Attribute_Code_Address =>
+
+ -- To be safe, assume that if the address of a variable is taken,
+ -- it may be modified via this address, so note modification.
+
+ if Is_Variable (P) then
+ Note_Possible_Modification (P);
+ end if;
+
+ if Nkind (P) in N_Subexpr
+ and then Is_Overloaded (P)
+ then
+ Get_First_Interp (P, Index, It);
+ Get_Next_Interp (Index, It);
+
+ if Present (It.Nam) then
+ Error_Msg_Name_1 := Aname;
+ Error_Msg_N
+ ("prefix of % attribute cannot be overloaded", N);
+ return;
+ end if;
+ end if;
+
+ -- Do not permit address to be applied to entry
+
+ if (Is_Entity_Name (P) and then Is_Entry (Entity (P)))
+ or else Nkind (P) = N_Entry_Call_Statement
+
+ or else (Nkind (P) = N_Selected_Component
+ and then Is_Entry (Entity (Selector_Name (P))))
+
+ or else (Nkind (P) = N_Indexed_Component
+ and then Nkind (Prefix (P)) = N_Selected_Component
+ and then Is_Entry (Entity (Selector_Name (Prefix (P)))))
+ then
+ Error_Msg_Name_1 := Aname;
+ Error_Msg_N
+ ("prefix of % attribute cannot be entry", N);
+ return;
+ end if;
+
+ if not Is_Entity_Name (P)
+ or else not Is_Overloadable (Entity (P))
+ then
+ if not Is_Task_Type (Etype (P))
+ or else Nkind (P) = N_Explicit_Dereference
+ then
+ Resolve (P, Etype (P));
+ end if;
+ end if;
+
+ -- If this is the name of a derived subprogram, or that of a
+ -- generic actual, the address is that of the original entity.
+
+ if Is_Entity_Name (P)
+ and then Is_Overloadable (Entity (P))
+ and then Present (Alias (Entity (P)))
+ then
+ Rewrite (P,
+ New_Occurrence_Of (Alias (Entity (P)), Sloc (P)));
+ end if;
+
+ ---------------
+ -- AST_Entry --
+ ---------------
+
+ -- Prefix of the AST_Entry attribute is an entry name which must
+ -- not be resolved, since this is definitely not an entry call.
+
+ when Attribute_AST_Entry =>
+ null;
+
+ ------------------
+ -- Body_Version --
+ ------------------
+
+ -- Prefix of Body_Version attribute can be a subprogram name which
+ -- must not be resolved, since this is not a call.
+
+ when Attribute_Body_Version =>
+ null;
+
+ ------------
+ -- Caller --
+ ------------
+
+ -- Prefix of Caller attribute is an entry name which must not
+ -- be resolved, since this is definitely not an entry call.
+
+ when Attribute_Caller =>
+ null;
+
+ ------------------
+ -- Code_Address --
+ ------------------
+
+ -- Shares processing with Address attribute
+
+ -----------
+ -- Count --
+ -----------
+
+ -- Prefix of the Count attribute is an entry name which must not
+ -- be resolved, since this is definitely not an entry call.
+
+ when Attribute_Count =>
+ null;
+
+ ----------------
+ -- Elaborated --
+ ----------------
+
+ -- Prefix of the Elaborated attribute is a subprogram name which
+ -- must not be resolved, since this is definitely not a call. Note
+ -- that it is a library unit, so it cannot be overloaded here.
+
+ when Attribute_Elaborated =>
+ null;
+
+ --------------------
+ -- Mechanism_Code --
+ --------------------
+
+ -- Prefix of the Mechanism_Code attribute is a function name
+ -- which must not be resolved. Should we check for overloaded ???
+
+ when Attribute_Mechanism_Code =>
+ null;
+
+ ------------------
+ -- Partition_ID --
+ ------------------
+
+ -- Most processing is done in sem_dist, after determining the
+ -- context type. Node is rewritten as a conversion to a runtime call.
+
+ when Attribute_Partition_ID =>
+ Process_Partition_Id (N);
+ return;
+
+ -----------
+ -- Range --
+ -----------
+
+ -- We replace the Range attribute node with a range expression
+ -- whose bounds are the 'First and 'Last attributes applied to the
+ -- same prefix. The reason that we do this transformation here
+ -- instead of in the expander is that it simplifies other parts of
+ -- the semantic analysis which assume that the Range has been
+ -- replaced; thus it must be done even when in semantic-only mode
+ -- (note that the RM specifically mentions this equivalence, we
+ -- take care that the prefix is only evaluated once).
+
+ when Attribute_Range => Range_Attribute :
+ declare
+ LB : Node_Id;
+ HB : Node_Id;
+
+ function Check_Discriminated_Prival
+ (N : Node_Id)
+ return Node_Id;
+ -- The range of a private component constrained by a
+ -- discriminant is rewritten to make the discriminant
+ -- explicit. This solves some complex visibility problems
+ -- related to the use of privals.
+
+ function Check_Discriminated_Prival
+ (N : Node_Id)
+ return Node_Id
+ is
+ begin
+ if Is_Entity_Name (N)
+ and then Ekind (Entity (N)) = E_In_Parameter
+ and then not Within_Init_Proc
+ then
+ return Make_Identifier (Sloc (N), Chars (Entity (N)));
+ else
+ return Duplicate_Subexpr (N);
+ end if;
+ end Check_Discriminated_Prival;
+
+ -- Start of processing for Range_Attribute
+
+ begin
+ if not Is_Entity_Name (P)
+ or else not Is_Type (Entity (P))
+ then
+ Resolve (P, Etype (P));
+ end if;
+
+ -- Check whether prefix is (renaming of) private component
+ -- of protected type.
+
+ if Is_Entity_Name (P)
+ and then Comes_From_Source (N)
+ and then Is_Array_Type (Etype (P))
+ and then Number_Dimensions (Etype (P)) = 1
+ and then (Ekind (Scope (Entity (P))) = E_Protected_Type
+ or else
+ Ekind (Scope (Scope (Entity (P)))) =
+ E_Protected_Type)
+ then
+ LB := Check_Discriminated_Prival (
+ Type_Low_Bound (Etype (First_Index (Etype (P)))));
+
+ HB := Check_Discriminated_Prival (
+ Type_High_Bound (Etype (First_Index (Etype (P)))));
+
+ else
+ HB :=
+ Make_Attribute_Reference (Loc,
+ Prefix => Duplicate_Subexpr (P),
+ Attribute_Name => Name_Last,
+ Expressions => Expressions (N));
+
+ LB :=
+ Make_Attribute_Reference (Loc,
+ Prefix => P,
+ Attribute_Name => Name_First,
+ Expressions => Expressions (N));
+ end if;
+
+ -- If the original was marked as Must_Not_Freeze (see code
+ -- in Sem_Ch3.Make_Index), then make sure the rewriting
+ -- does not freeze either.
+
+ if Must_Not_Freeze (N) then
+ Set_Must_Not_Freeze (HB);
+ Set_Must_Not_Freeze (LB);
+ Set_Must_Not_Freeze (Prefix (HB));
+ Set_Must_Not_Freeze (Prefix (LB));
+ end if;
+
+ if Raises_Constraint_Error (Prefix (N)) then
+
+ -- Preserve Sloc of prefix in the new bounds, so that
+ -- the posted warning can be removed if we are within
+ -- unreachable code.
+
+ Set_Sloc (LB, Sloc (Prefix (N)));
+ Set_Sloc (HB, Sloc (Prefix (N)));
+ end if;
+
+ Rewrite (N, Make_Range (Loc, LB, HB));
+ Analyze_And_Resolve (N, Typ);
+
+ -- Normally after resolving attribute nodes, Eval_Attribute
+ -- is called to do any possible static evaluation of the node.
+ -- However, here since the Range attribute has just been
+ -- transformed into a range expression it is no longer an
+ -- attribute node and therefore the call needs to be avoided
+ -- and is accomplished by simply returning from the procedure.
+
+ return;
+ end Range_Attribute;
+
+ -----------------
+ -- UET_Address --
+ -----------------
+
+ -- Prefix must not be resolved in this case, since it is not a
+ -- real entity reference. No action of any kind is require!
+
+ when Attribute_UET_Address =>
+ return;
+
+ ----------------------
+ -- Unchecked_Access --
+ ----------------------
+
+ -- Processing is shared with Access
+
+ -------------------------
+ -- Unrestricted_Access --
+ -------------------------
+
+ -- Processing is shared with Access
+
+ ---------
+ -- Val --
+ ---------
+
+ -- Apply range check. Note that we did not do this during the
+ -- analysis phase, since we wanted Eval_Attribute to have a
+ -- chance at finding an illegal out of range value.
+
+ when Attribute_Val =>
+
+ -- Note that we do our own Eval_Attribute call here rather than
+ -- use the common one, because we need to do processing after
+ -- the call, as per above comment.
+
+ Eval_Attribute (N);
+
+ -- Eval_Attribute may replace the node with a raise CE, or
+ -- fold it to a constant. Obviously we only apply a scalar
+ -- range check if this did not happen!
+
+ if Nkind (N) = N_Attribute_Reference
+ and then Attribute_Name (N) = Name_Val
+ then
+ Apply_Scalar_Range_Check (First (Expressions (N)), Btyp);
+ end if;
+
+ return;
+
+ -------------
+ -- Version --
+ -------------
+
+ -- Prefix of Version attribute can be a subprogram name which
+ -- must not be resolved, since this is not a call.
+
+ when Attribute_Version =>
+ null;
+
+ ----------------------
+ -- Other Attributes --
+ ----------------------
+
+ -- For other attributes, resolve prefix unless it is a type. If
+ -- the attribute reference itself is a type name ('Base and 'Class)
+ -- then this is only legal within a task or protected record.
+
+ when others =>
+ if not Is_Entity_Name (P)
+ or else not Is_Type (Entity (P))
+ then
+ Resolve (P, Etype (P));
+ end if;
+
+ -- If the attribute reference itself is a type name ('Base,
+ -- 'Class) then this is only legal within a task or protected
+ -- record. What is this all about ???
+
+ if Is_Entity_Name (N)
+ and then Is_Type (Entity (N))
+ then
+ if Is_Concurrent_Type (Entity (N))
+ and then In_Open_Scopes (Entity (P))
+ then
+ null;
+ else
+ Error_Msg_N
+ ("invalid use of subtype name in expression or call", N);
+ end if;
+ end if;
+
+ -- For attributes whose argument may be a string, complete
+ -- resolution of argument now. This avoids premature expansion
+ -- (and the creation of transient scopes) before the attribute
+ -- reference is resolved.
+
+ case Attr_Id is
+ when Attribute_Value =>
+ Resolve (First (Expressions (N)), Standard_String);
+
+ when Attribute_Wide_Value =>
+ Resolve (First (Expressions (N)), Standard_Wide_String);
+
+ when others => null;
+ end case;
+ end case;
+
+ -- Normally the Freezing is done by Resolve but sometimes the Prefix
+ -- is not resolved, in which case the freezing must be done now.
+
+ Freeze_Expression (P);
+
+ -- Finally perform static evaluation on the attribute reference
+
+ Eval_Attribute (N);
+
+ end Resolve_Attribute;
+
+end Sem_Attr;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S E M _ A T T R --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.26 $
+-- --
+-- Copyright (C) 1992-1999, 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). --
+-- --
+------------------------------------------------------------------------------
+
+-- Attribute handling is isolated in a separate package to ease the addition
+-- of implementation defined attributes. Logically this processing belongs
+-- in chapter 4. See Sem_Ch4 for a description of the relation of the
+-- Analyze and Resolve routines for expression components.
+
+-- This spec also documents all GNAT implementation defined pragmas
+
+with Snames; use Snames;
+with Types; use Types;
+
+package Sem_Attr is
+
+ type Attribute_Class_Array is array (Attribute_Id) of Boolean;
+ -- Type used to build attribute classification flag arrays
+
+ -----------------------------------------
+ -- Implementation Dependent Attributes --
+ -----------------------------------------
+
+ -- This section describes the implementation dependent attributes
+ -- provided in GNAT, as well as constructing an array of flags
+ -- indicating which attributes these are.
+
+ Attribute_Impl_Def : Attribute_Class_Array := Attribute_Class_Array'(
+
+ ------------------
+ -- Abort_Signal --
+ ------------------
+
+ Attribute_Abort_Signal => True,
+ --
+ -- Standard'Abort_Signal (Standard is the only allowed prefix)
+ -- provides the entity for the special exception used to signal
+ -- task abort or asynchronous transfer of control. Normally this
+ -- attribute should only be used in the tasking runtime (it is
+ -- highly peculiar, and completely outside the normal semantics
+ -- of Ada, for a user program to intercept the abort exception).
+
+ ------------------
+ -- Address_Size --
+ ------------------
+
+ Attribute_Address_Size => True,
+ --
+ -- Standard'Address_Size (Standard is the only allowed prefix) is
+ -- a static constant giving the number of bits in an Address. It
+ -- is used primarily for constructing the definition of Memory_Size
+ -- in package Standard, but may be freely used in user programs.
+ -- This is a static attribute.
+
+ ---------------
+ -- Asm_Input --
+ ---------------
+
+ Attribute_Asm_Input => True,
+ --
+ -- Used only in conjunction with the Asm and Asm_Volatile subprograms
+ -- in package Machine_Code to construct machine instructions. See
+ -- documentation in package Machine_Code in file s-maccod.ads.
+
+ ----------------
+ -- Asm_Output --
+ ----------------
+
+ Attribute_Asm_Output => True,
+ --
+ -- Used only in conjunction with the Asm and Asm_Volatile subprograms
+ -- in package Machine_Code to construct machine instructions. See
+ -- documentation in package Machine_Code in file s-maccod.ads.
+
+ ---------------
+ -- AST_Entry --
+ ---------------
+
+ Attribute_AST_Entry => True,
+ --
+ -- E'Ast_Entry, where E is a task entry, yields a value of the
+ -- predefined type System.DEC.AST_Handler, that enables the given
+ -- entry to be called when an AST occurs. If the name to which the
+ -- attribute applies has not been specified with the pragma AST_Entry,
+ -- the attribute returns the value No_Ast_Handler, and no AST occurs.
+ -- If the entry is for a task that is not callable (T'Callable False),
+ -- the exception program error is raised. If an AST occurs for an
+ -- entry of a task that is terminated, the program is erroneous.
+ --
+ -- The attribute AST_Entry is supported only in OpenVMS versions
+ -- of GNAT. It will be rejected as illegal in other GNAT versions.
+
+ ---------
+ -- Bit --
+ ---------
+
+ Attribute_Bit => True,
+ --
+ -- Obj'Bit, where Obj is any object, yields the bit offset within
+ -- the storage unit (byte) that contains the first bit of storage
+ -- allocated for the object. The value of this attribute is of the
+ -- type Universal_Integer, and is always a non-negative number not
+ -- exceeding the value of System.Storage_Unit.
+ --
+ -- For an object that is a variable or a constant allocated in a
+ -- register, the value is zero. (The use of this attribute does not
+ -- force the allocation of a variable to memory).
+ --
+ -- For an object that is a formal parameter, this attribute applies
+ -- to either the matching actual parameter or to a copy of the
+ -- matching actual parameter.
+ --
+ -- For an access object the value is zero. Note that Obj.all'Bit is
+ -- subject to an Access_Check for the designated object. Similarly
+ -- for a record component X.C'Bit is subject to a discriminant check
+ -- and X(I).Bit and X(I1..I2)'Bit are subject to index checks.
+ --
+ -- This attribute is designed to be compatible with the DEC Ada
+ -- definition and implementation of the Bit attribute.
+
+ ------------------
+ -- Code_Address --
+ ------------------
+
+ Attribute_Code_Address => True,
+ --
+ -- subp'Code_Address, where subp is a subprogram entity, gives the
+ -- address of the first generated instruction for a subprogram. This
+ -- is often, but not always the same as the 'Address value, which is
+ -- the address to be used in a call. The differences occur in the case
+ -- of a nested procedure (where Address yields the address of the
+ -- trampoline code used to load the static link), and on some systems
+ -- which use procedure descriptors (in which case Address yields the
+ -- address of the descriptor).
+
+ -----------------------
+ -- Default_Bit_Order --
+ -----------------------
+
+ Attribute_Default_Bit_Order => True,
+ --
+ -- Standard'Default_Bit_Order (Standard is the only permissible prefix),
+ -- provides the value System.Default_Bit_Order as a Pos value (0 for
+ -- High_Order_First, 1 for Low_Order_First). This is used to construct
+ -- the definition of Default_Bit_Order in package System. This is a
+ -- static attribute.
+
+ ---------------
+ -- Elab_Body --
+ ---------------
+
+ Attribute_Elab_Body => True,
+ --
+ -- This attribute can only be applied to a program unit name. It
+ -- returns the entity for the corresponding elaboration procedure
+ -- for elaborating the body of the referenced unit. This is used
+ -- in the main generated elaboration procedure by the binder, and
+ -- is not normally used in any other context, but there may be
+ -- specialized situations in which it is useful to be able to
+ -- call this elaboration procedure from Ada code, e.g. if it
+ -- is necessary to do selective reelaboration to fix some error.
+
+ ---------------
+ -- Elab_Spec --
+ ---------------
+
+ Attribute_Elab_Spec => True,
+ --
+ -- This attribute can only be applied to a program unit name. It
+ -- returns the entity for the corresponding elaboration procedure
+ -- for elaborating the spec of the referenced unit. This is used
+ -- in the main generated elaboration procedure by the binder, and
+ -- is not normally used in any other context, but there may be
+ -- specialized situations in which it is useful to be able to
+ -- call this elaboration procedure from Ada code, e.g. if it
+ -- is necessary to do selective reelaboration to fix some error.
+
+ ----------------
+ -- Elaborated --
+ ----------------
+
+ Attribute_Elaborated => True,
+ --
+ -- Lunit'Elaborated, where Lunit is a library unit, yields a boolean
+ -- value indicating whether or not the body of the designated library
+ -- unit has been elaborated yet.
+
+
+ --------------
+ -- Enum_Rep --
+ --------------
+
+ Attribute_Enum_Rep => True,
+ --
+ -- For every enumeration subtype S, S'Enum_Rep denotes a function
+ -- with the following specification:
+ --
+ -- function S'Enum_Rep (Arg : S'Base) return universal_integer;
+ --
+ -- The function returns the representation value for the given
+ -- enumeration value. This will be equal to the 'Pos value in the
+ -- absence of an enumeration representation clause. This is a static
+ -- attribute (i.e. the result is static if the argument is static).
+
+ -----------------
+ -- Fixed_Value --
+ -----------------
+
+ Attribute_Fixed_Value => True,
+ --
+ -- For every fixed-point type S, S'Fixed_Value denotes a function
+ -- with the following specification:
+ --
+ -- function S'Fixed_Value (Arg : universal_integer) return S;
+ --
+ -- The value returned is the fixed-point value V such that
+ --
+ -- V = Arg * S'Small
+ --
+ -- The effect is thus equivalent to first converting the argument
+ -- to the integer type used to represent S, and then doing an
+ -- unchecked conversion to the fixed-point type. This attribute is
+ -- primarily intended for use in implementation of the input-output
+ -- functions for fixed-point values.
+
+ -----------------------
+ -- Has_Discriminants --
+ -----------------------
+
+ Attribute_Has_Discriminants => True,
+ --
+ -- Gtyp'Has_Discriminants, where Gtyp is a generic formal type, yields
+ -- a Boolean value indicating whether or not the actual instantiation
+ -- type has discriminants.
+
+ ---------
+ -- Img --
+ ---------
+
+ Attribute_Img => True,
+ --
+ -- The 'Img function is defined for any prefix, P, that denotes an
+ -- object of scalar type T. P'Img is equivalent to T'Image (P). This
+ -- is convenient for debugging. For example:
+ --
+ -- Put_Line ("X = " & X'Img);
+ --
+ -- has the same meaning as the more verbose:
+ --
+ -- Put_Line ("X = " & Temperature_Type'Image (X));
+ --
+ -- where Temperature_Type is the subtype of the object X.
+
+ -------------------
+ -- Integer_Value --
+ -------------------
+
+ Attribute_Integer_Value => True,
+ --
+ -- For every integer type S, S'Integer_Value denotes a function
+ -- with the following specification:
+ --
+ -- function S'Integer_Value (Arg : universal_fixed) return S;
+ --
+ -- The value returned is the integer value V, such that
+ --
+ -- Arg = V * fixed-type'Small
+ --
+ -- The effect is thus equivalent to first doing an unchecked convert
+ -- from the fixed-point type to its corresponding implementation type,
+ -- and then converting the result to the target integer type. This
+ -- attribute is primarily intended for use in implementation of the
+ -- standard input-output functions for fixed-point values.
+
+ ------------------
+ -- Machine_Size --
+ ------------------
+
+ Attribute_Machine_Size => True,
+ --
+ -- This attribute is identical to the Object_Size attribute. It is
+ -- provided for compatibility with the DEC attribute of this name.
+
+ ----------------------------
+ -- Max_Interrupt_Priority --
+ ----------------------------
+
+ Attribute_Max_Interrupt_Priority => True,
+ --
+ -- Standard'Max_Interrupt_Priority (Standard is the only permissible
+ -- prefix), provides the value System.Max_Interrupt_Priority, and is
+ -- intended primarily for constructing this definition in package
+ -- System (see note above in Default_Bit_Order description}. This
+ -- is a static attribute.
+
+ ------------------
+ -- Max_Priority --
+ ------------------
+
+ Attribute_Max_Priority => True,
+ --
+ -- Standard'Max_Priority (Standard is the only permissible prefix)
+ -- provides the value System.Max_Priority, and is intended primarily
+ -- for constructing this definition in package System (see note above
+ -- in Default_Bit_Order description). This is a static attribute.
+
+ -----------------------
+ -- Maximum_Alignment --
+ -----------------------
+
+ Attribute_Maximum_Alignment => True,
+ --
+ -- Standard'Maximum_Alignment (Standard is the only permissible prefix)
+ -- provides the maximum useful alignment value for the target. This
+ -- is a static value that can be used to specify the alignment for an
+ -- object, guaranteeing that it is properly aligned in all cases. The
+ -- time this is useful is when an external object is imported and its
+ -- alignment requirements are unknown. This is a static attribute.
+
+ --------------------
+ -- Mechanism_Code --
+ --------------------
+
+ Attribute_Mechanism_Code => True,
+ --
+ -- function'Mechanism_Code yeilds an integer code for the mechanism
+ -- used for the result of function, and subprogram'Mechanism_Code (n)
+ -- yields the mechanism used for formal parameter number n (a static
+ -- integer value, 1 = first parameter). The code returned is:
+ --
+ -- 1 = by copy (value)
+ -- 2 = by reference
+ -- 3 = by descriptor (default descriptor type)
+ -- 4 = by descriptor (UBS unaligned bit string)
+ -- 5 = by descriptor (UBSB aligned bit string with arbitrary bounds)
+ -- 6 = by descriptor (UBA unaligned bit array)
+ -- 7 = by descriptor (S string, also scalar access type parameter)
+ -- 8 = by descriptor (SB string with arbitrary bounds)
+ -- 9 = by descriptor (A contiguous array)
+ -- 10 = by descriptor (NCA non-contiguous array)
+
+ --------------------
+ -- Null_Parameter --
+ --------------------
+
+ Attribute_Null_Parameter => True,
+ --
+ -- A reference T'Null_Parameter denotes an (imaginary) object of
+ -- type or subtype T allocated at (machine) address zero. The
+ -- attribute is allowed only as the default expression of a formal
+ -- parameter, or as an actual expression of a subporgram call. In
+ -- either case, the subprogram must be imported.
+ --
+ -- The identity of the object is represented by the address zero
+ -- in the argument list, independent of the passing mechanism
+ -- (explicit or default).
+ --
+ -- The reason that this capability is needed is that for a record
+ -- or other composite object passed by reference, there is no other
+ -- way of specifying that a zero address should be passed.
+
+ -----------------
+ -- Object_Size --
+ -----------------
+
+ Attribute_Object_Size => True,
+ --
+ -- Type'Object_Size is the same as Type'Size for all types except
+ -- fixed-point types and discrete types. For fixed-point types and
+ -- discrete types, this attribute gives the size used for default
+ -- allocation of objects and components of the size. See section
+ -- in Einfo ("Handling of type'Size values") for further details.
+
+ -------------------------
+ -- Passed_By_Reference --
+ -------------------------
+
+ Attribute_Passed_By_Reference => True,
+ --
+ -- T'Passed_By_Reference for any subtype T returns a boolean value
+ -- that is true if the type is normally passed by reference and
+ -- false if the type is normally passed by copy in calls. For scalar
+ -- types, the result is always False and is static. For non-scalar
+ -- types, the result is non-static (since it is computed by Gigi).
+
+ ------------------
+ -- Range_Length --
+ ------------------
+
+ Attribute_Range_Length => True,
+ --
+ -- T'Range_Length for any discrete type T yields the number of
+ -- values represented by the subtype (zero for a null range). The
+ -- result is static for static subtypes. Note that Range_Length
+ -- applied to the index subtype of a one dimensional array always
+ -- gives the same result as Range applied to the array itself.
+ -- The result is of type universal integer.
+
+ ------------------
+ -- Storage_Unit --
+ ------------------
+
+ Attribute_Storage_Unit => True,
+ --
+ -- Standard'Storage_Unit (Standard is the only permissible prefix)
+ -- provides the value System.Storage_Unit, and is intended primarily
+ -- for constructing this definition in package System (see note above
+ -- in Default_Bit_Order description). The is a static attribute.
+
+ ----------
+ -- Tick --
+ ----------
+
+ Attribute_Tick => True,
+ --
+ -- Standard'Tick (Standard is the only permissible prefix) provides
+ -- the value System.Tick, and is intended primarily for constructing
+ -- this definition in package System (see note above in description
+ -- of Default_Bit_Order). This is a static attribute.
+
+ ----------------
+ -- To_Address --
+ ----------------
+
+ Attribute_To_Address => True,
+ --
+ -- System'To_Address (Address is the only permissible prefix)
+ -- is a function that takes any integer value, and converts it into
+ -- an address value. The semantics is to first convert the integer
+ -- value to type Integer_Address according to normal conversion
+ -- rules, and then to convert this to an address using the same
+ -- semantics as the System.Storage_Elements.To_Address function.
+ -- The important difference is that this is a static attribute
+ -- so it can be used in initializations in preealborate packages.
+
+ ----------------
+ -- Type_Class --
+ ----------------
+
+ Attribute_Type_Class => True,
+ --
+ -- T'Type_Class for any type or subtype T yields the value of the
+ -- type class for the full type of T. If T is a generic formal type,
+ -- then the value is the value for the corresponding actual subtype.
+ -- The value of this attribute is of type System.Aux_DEC.Type_Class,
+ -- which has the following definition:
+ --
+ -- type Type_Class is
+ -- (Type_Class_Enumeration,
+ -- Type_Class_Integer,
+ -- Type_Class_Fixed_Point,
+ -- Type_Class_Floating_Point,
+ -- Type_Class_Array,
+ -- Type_Class_Record,
+ -- Type_Class_Access,
+ -- Type_Class_Task,
+ -- Type_Class_Address);
+ --
+ -- Protected types yield the value Type_Class_Task, which thus
+ -- applies to all concurrent types. This attribute is designed to
+ -- be compatible with the DEC Ada attribute of the same name.
+ --
+ -- Note: if pragma Extend_System is used to merge the definitions of
+ -- Aux_DEC into System, then the type Type_Class can be referenced
+ -- as an entity within System, as can its enumeration literals.
+
+ -----------------
+ -- UET_Address --
+ -----------------
+
+ Attribute_UET_Address => True,
+ --
+ -- Unit'UET_Address, where Unit is a program unit, yields the address
+ -- of the unit exception table for the specified unit. This is only
+ -- used in the internal implementation of exception handling. See the
+ -- implementation of unit Ada.Exceptions for details on its use.
+
+ ------------------------------
+ -- Universal_Literal_String --
+ ------------------------------
+
+ Attribute_Universal_Literal_String => True,
+ --
+ -- The prefix of 'Universal_Literal_String must be a named number.
+ -- The static result is the string consisting of the characters of
+ -- the number as defined in the original source. This allows the
+ -- user program to access the actual text of named numbers without
+ -- intermediate conversions and without the need to enclose the
+ -- strings in quotes (which would preclude their use as numbers).
+ -- This is used internally for the construction of values of the
+ -- floating-point attributes from the file ttypef.ads, but may
+ -- also be used by user programs.
+
+ -------------------------
+ -- Unrestricted_Access --
+ -------------------------
+
+ Attribute_Unrestricted_Access => True,
+ --
+ -- The Unrestricted_Access attribute is similar to Access except that
+ -- all accessibility and aliased view checks are omitted. This is very
+ -- much a user-beware attribute. Basically its status is very similar
+ -- to Address, for which it is a desirable replacement where the value
+ -- desired is an access type. In other words, its effect is identical
+ -- to first taking 'Address and then doing an unchecked conversion to
+ -- a desired access type. Note that in GNAT, but not necessarily in
+ -- other implementations, the use of static chains for inner level
+ -- subprograms means that Unrestricted_Access applied to a subprogram
+ -- yields a value that can be called as long as the subprogram is in
+ -- scope (normal Ada 95 accessibility rules restrict this usage).
+
+ ---------------
+ -- VADS_Size --
+ ---------------
+
+ Attribute_VADS_Size => True,
+ --
+ -- Typ'VADS_Size yields the Size value typically yielded by some
+ -- Ada 83 compilers. The differences between VADS_Size and Size
+ -- is that for scalar types for which no Size has been specified,
+ -- VADS_Size yields the Object_Size rather than the Value_Size.
+ -- For example, while Natural'Size is typically 31, the value of
+ -- Natural'VADS_Size is 32. For all other types, Size and VADS_Size
+ -- yield the same value.
+
+ ----------------
+ -- Value_Size --
+ ----------------
+
+ Attribute_Value_Size => True,
+ --
+ -- Type'Value_Size is the number of bits required to represent a
+ -- value of the given subtype. It is the same as Type'Size, but,
+ -- unlike Size, may be set for non-first subtypes. See section
+ -- in Einfo ("Handling of type'Size values") for further details.
+
+ ---------------
+ -- Word_Size --
+ ---------------
+
+ Attribute_Word_Size => True,
+ --
+ -- Standard'Word_Size (Standard is the only permissible prefix)
+ -- provides the value System.Word_Size, and is intended primarily
+ -- for constructing this definition in package System (see note above
+ -- in Default_Bit_Order description). This is a static attribute.
+
+ others => False);
+
+ -----------------
+ -- Subprograms --
+ -----------------
+
+ procedure Analyze_Attribute (N : Node_Id);
+ -- Performs bottom up semantic analysis of an attribute. Note that the
+ -- parser has already checked that type returning attributes appear only
+ -- in appropriate contexts (i.e. in subtype marks, or as prefixes for
+ -- other attributes).
+
+ procedure Resolve_Attribute (N : Node_Id; Typ : Entity_Id);
+ -- Performs type resolution of attribute. If the attribute yields
+ -- a universal value, mark its type as that of the context. On
+ -- the other hand, if the context itself is universal (as in
+ -- T'Val (T'Pos (X)), mark the type as being the largest type of
+ -- that class that can be used at run-time. This is correct since
+ -- either the value gets folded (in which case it doesn't matter
+ -- what type of the class we give if, since the folding uses universal
+ -- arithmetic anyway) or it doesn't get folded (in which case it is
+ -- going to be dealt with at runtime, and the largest type is right).
+
+end Sem_Attr;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S E M _ C A S E --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.13 $
+-- --
+-- Copyright (C) 1996-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 Atree; use Atree;
+with Einfo; use Einfo;
+with Errout; use Errout;
+with Namet; use Namet;
+with Nlists; use Nlists;
+with Sem; use Sem;
+with Sem_Eval; use Sem_Eval;
+with Sem_Res; use Sem_Res;
+with Sem_Util; use Sem_Util;
+with Sem_Type; use Sem_Type;
+with Snames; use Snames;
+with Stand; use Stand;
+with Sinfo; use Sinfo;
+with Uintp; use Uintp;
+
+with GNAT.Heap_Sort_A; use GNAT.Heap_Sort_A;
+
+package body Sem_Case is
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ type Sort_Choice_Table_Type is array (Nat range <>) of Choice_Bounds;
+ -- This new array type is used as the actual table type for sorting
+ -- discrete choices. The reason for not using Choice_Table_Type, is that
+ -- in Sort_Choice_Table_Type we reserve entry 0 for the sorting algortim
+ -- (this is not absolutely necessary but it makes the code more
+ -- efficient).
+
+ procedure Check_Choices
+ (Choice_Table : in out Sort_Choice_Table_Type;
+ Bounds_Type : Entity_Id;
+ Others_Present : Boolean;
+ Msg_Sloc : Source_Ptr);
+ -- This is the procedure which verifies that a set of case statement,
+ -- array aggregate or record variant choices has no duplicates, and
+ -- covers the range specified by Bounds_Type. Choice_Table contains the
+ -- discrete choices to check. These must start at position 1.
+ -- Furthermore Choice_Table (0) must exist. This element is used by
+ -- the sorting algorithm as a temporary. Others_Present is a flag
+ -- indicating whether or not an Others choice is present. Finally
+ -- Msg_Sloc gives the source location of the construct containing the
+ -- choices in the Choice_Table.
+
+ function Choice_Image (Value : Uint; Ctype : Entity_Id) return Name_Id;
+ -- Given a Pos value of enumeration type Ctype, returns the name
+ -- ID of an appropriate string to be used in error message output.
+
+ -------------------
+ -- Check_Choices --
+ -------------------
+
+ procedure Check_Choices
+ (Choice_Table : in out Sort_Choice_Table_Type;
+ Bounds_Type : Entity_Id;
+ Others_Present : Boolean;
+ Msg_Sloc : Source_Ptr)
+ is
+
+ function Lt_Choice (C1, C2 : Natural) return Boolean;
+ -- Comparison routine for comparing Choice_Table entries.
+ -- Use the lower bound of each Choice as the key.
+
+ procedure Move_Choice (From : Natural; To : Natural);
+ -- Move routine for sorting the Choice_Table.
+
+ procedure Issue_Msg (Value1 : Node_Id; Value2 : Node_Id);
+ procedure Issue_Msg (Value1 : Node_Id; Value2 : Uint);
+ procedure Issue_Msg (Value1 : Uint; Value2 : Node_Id);
+ procedure Issue_Msg (Value1 : Uint; Value2 : Uint);
+ -- Issue an error message indicating that there are missing choices,
+ -- followed by the image of the missing choices themselves which lie
+ -- between Value1 and Value2 inclusive.
+
+ ---------------
+ -- Issue_Msg --
+ ---------------
+
+ procedure Issue_Msg (Value1 : Node_Id; Value2 : Node_Id) is
+ begin
+ Issue_Msg (Expr_Value (Value1), Expr_Value (Value2));
+ end Issue_Msg;
+
+ procedure Issue_Msg (Value1 : Node_Id; Value2 : Uint) is
+ begin
+ Issue_Msg (Expr_Value (Value1), Value2);
+ end Issue_Msg;
+
+ procedure Issue_Msg (Value1 : Uint; Value2 : Node_Id) is
+ begin
+ Issue_Msg (Value1, Expr_Value (Value2));
+ end Issue_Msg;
+
+ procedure Issue_Msg (Value1 : Uint; Value2 : Uint) is
+ begin
+ -- In some situations, we call this with a null range, and
+ -- obviously we don't want to complain in this case!
+
+ if Value1 > Value2 then
+ return;
+ end if;
+
+ -- Case of only one value that is missing
+
+ if Value1 = Value2 then
+ if Is_Integer_Type (Bounds_Type) then
+ Error_Msg_Uint_1 := Value1;
+ Error_Msg ("missing case value: ^!", Msg_Sloc);
+ else
+ Error_Msg_Name_1 := Choice_Image (Value1, Bounds_Type);
+ Error_Msg ("missing case value: %!", Msg_Sloc);
+ end if;
+
+ -- More than one choice value, so print range of values
+
+ else
+ if Is_Integer_Type (Bounds_Type) then
+ Error_Msg_Uint_1 := Value1;
+ Error_Msg_Uint_2 := Value2;
+ Error_Msg ("missing case values: ^ .. ^!", Msg_Sloc);
+ else
+ Error_Msg_Name_1 := Choice_Image (Value1, Bounds_Type);
+ Error_Msg_Name_2 := Choice_Image (Value2, Bounds_Type);
+ Error_Msg ("missing case values: % .. %!", Msg_Sloc);
+ end if;
+ end if;
+ end Issue_Msg;
+
+ ---------------
+ -- Lt_Choice --
+ ---------------
+
+ function Lt_Choice (C1, C2 : Natural) return Boolean is
+ begin
+ return
+ Expr_Value (Choice_Table (Nat (C1)).Lo)
+ <= Expr_Value (Choice_Table (Nat (C2)).Lo);
+ end Lt_Choice;
+
+ -----------------
+ -- Move_Choice --
+ -----------------
+
+ procedure Move_Choice (From : Natural; To : Natural) is
+ begin
+ Choice_Table (Nat (To)) := Choice_Table (Nat (From));
+ end Move_Choice;
+
+ -- Variables local to Check_Choices
+
+ Choice : Node_Id;
+ Bounds_Lo : constant Node_Id := Type_Low_Bound (Bounds_Type);
+ Bounds_Hi : constant Node_Id := Type_High_Bound (Bounds_Type);
+
+ Prev_Choice : Node_Id;
+
+ Hi : Uint;
+ Lo : Uint;
+ Prev_Hi : Uint;
+
+ -- Start processing for Check_Choices
+
+ begin
+
+ -- Choice_Table must start at 0 which is an unused location used
+ -- by the sorting algorithm. However the first valid position for
+ -- a discrete choice is 1.
+
+ pragma Assert (Choice_Table'First = 0);
+
+ if Choice_Table'Last = 0 then
+ if not Others_Present then
+ Issue_Msg (Bounds_Lo, Bounds_Hi);
+ end if;
+ return;
+ end if;
+
+ Sort
+ (Positive (Choice_Table'Last),
+ Move_Choice'Unrestricted_Access,
+ Lt_Choice'Unrestricted_Access);
+
+ Lo := Expr_Value (Choice_Table (1).Lo);
+ Hi := Expr_Value (Choice_Table (1).Hi);
+ Prev_Hi := Hi;
+
+ if not Others_Present and then Expr_Value (Bounds_Lo) < Lo then
+ Issue_Msg (Bounds_Lo, Lo - 1);
+ end if;
+
+ for J in 2 .. Choice_Table'Last loop
+ Lo := Expr_Value (Choice_Table (J).Lo);
+ Hi := Expr_Value (Choice_Table (J).Hi);
+
+ if Lo <= Prev_Hi then
+ Prev_Choice := Choice_Table (J - 1).Node;
+ Choice := Choice_Table (J).Node;
+
+ if Sloc (Prev_Choice) <= Sloc (Choice) then
+ Error_Msg_Sloc := Sloc (Prev_Choice);
+ Error_Msg_N ("duplication of choice value#", Choice);
+ else
+ Error_Msg_Sloc := Sloc (Choice);
+ Error_Msg_N ("duplication of choice value#", Prev_Choice);
+ end if;
+
+ elsif not Others_Present and then Lo /= Prev_Hi + 1 then
+ Issue_Msg (Prev_Hi + 1, Lo - 1);
+ end if;
+
+ Prev_Hi := Hi;
+ end loop;
+
+ if not Others_Present and then Expr_Value (Bounds_Hi) > Hi then
+ Issue_Msg (Hi + 1, Bounds_Hi);
+ end if;
+ end Check_Choices;
+
+ ------------------
+ -- Choice_Image --
+ ------------------
+
+ function Choice_Image (Value : Uint; Ctype : Entity_Id) return Name_Id is
+ Rtp : constant Entity_Id := Root_Type (Ctype);
+ Lit : Entity_Id;
+ C : Int;
+
+ begin
+ -- For character, or wide character. If we are in 7-bit ASCII graphic
+ -- range, then build and return appropriate character literal name
+
+ if Rtp = Standard_Character
+ or else Rtp = Standard_Wide_Character
+ then
+ C := UI_To_Int (Value);
+
+ if C in 16#20# .. 16#7E# then
+ Name_Buffer (1) := ''';
+ Name_Buffer (2) := Character'Val (C);
+ Name_Buffer (3) := ''';
+ Name_Len := 3;
+ return Name_Find;
+ end if;
+
+ -- For user defined enumeration type, find enum/char literal
+
+ else
+ Lit := First_Literal (Rtp);
+
+ for J in 1 .. UI_To_Int (Value) loop
+ Next_Literal (Lit);
+ end loop;
+
+ -- If enumeration literal, just return its value
+
+ if Nkind (Lit) = N_Defining_Identifier then
+ return Chars (Lit);
+
+ -- For character literal, get the name and use it if it is
+ -- for a 7-bit ASCII graphic character in 16#20#..16#7E#.
+
+ else
+ Get_Decoded_Name_String (Chars (Lit));
+
+ if Name_Len = 3
+ and then Name_Buffer (2) in
+ Character'Val (16#20#) .. Character'Val (16#7E#)
+ then
+ return Chars (Lit);
+ end if;
+ end if;
+ end if;
+
+ -- If we fall through, we have a character literal which is not in
+ -- the 7-bit ASCII graphic set. For such cases, we construct the
+ -- name "type'val(nnn)" where type is the choice type, and nnn is
+ -- the pos value passed as an argument to Choice_Image.
+
+ Get_Name_String (Chars (First_Subtype (Ctype)));
+ Name_Len := Name_Len + 1;
+ Name_Buffer (Name_Len) := ''';
+ Name_Len := Name_Len + 1;
+ Name_Buffer (Name_Len) := 'v';
+ Name_Len := Name_Len + 1;
+ Name_Buffer (Name_Len) := 'a';
+ Name_Len := Name_Len + 1;
+ Name_Buffer (Name_Len) := 'l';
+ Name_Len := Name_Len + 1;
+ Name_Buffer (Name_Len) := '(';
+
+ UI_Image (Value);
+
+ for J in 1 .. UI_Image_Length loop
+ Name_Len := Name_Len + 1;
+ Name_Buffer (Name_Len) := UI_Image_Buffer (J);
+ end loop;
+
+ Name_Len := Name_Len + 1;
+ Name_Buffer (Name_Len) := ')';
+ return Name_Find;
+ end Choice_Image;
+
+ -----------
+ -- No_OP --
+ -----------
+
+ procedure No_OP (C : Node_Id) is
+ begin
+ null;
+ end No_OP;
+
+ --------------------------------
+ -- Generic_Choices_Processing --
+ --------------------------------
+
+ package body Generic_Choices_Processing is
+
+ ---------------------
+ -- Analyze_Choices --
+ ---------------------
+
+ procedure Analyze_Choices
+ (N : Node_Id;
+ Subtyp : Entity_Id;
+ Choice_Table : in out Choice_Table_Type;
+ Last_Choice : out Nat;
+ Raises_CE : out Boolean;
+ Others_Present : out Boolean)
+ is
+
+ Nb_Choices : constant Nat := Choice_Table'Length;
+ Sort_Choice_Table : Sort_Choice_Table_Type (0 .. Nb_Choices);
+
+ Choice_Type : constant Entity_Id := Base_Type (Subtyp);
+ -- The actual type against which the discrete choices are
+ -- resolved. Note that this type is always the base type not the
+ -- subtype of the ruling expression, index or discriminant.
+
+ Bounds_Type : Entity_Id;
+ -- The type from which are derived the bounds of the values
+ -- covered by th discrete choices (see 3.8.1 (4)). If a discrete
+ -- choice specifies a value outside of these bounds we have an error.
+
+ Bounds_Lo : Uint;
+ Bounds_Hi : Uint;
+ -- The actual bounds of the above type.
+
+ Expected_Type : Entity_Id;
+ -- The expected type of each choice. Equal to Choice_Type, except
+ -- if the expression is universal, in which case the choices can
+ -- be of any integer type.
+
+ procedure Check (Choice : Node_Id; Lo, Hi : Node_Id);
+ -- Checks the validity of the bounds of a choice. When the bounds
+ -- are static and no error occurred the bounds are entered into
+ -- the choices table so that they can be sorted later on.
+
+ -----------
+ -- Check --
+ -----------
+
+ procedure Check (Choice : Node_Id; Lo, Hi : Node_Id) is
+ Lo_Val : Uint;
+ Hi_Val : Uint;
+
+ begin
+ -- First check if an error was already detected on either bounds
+
+ if Etype (Lo) = Any_Type or else Etype (Hi) = Any_Type then
+ return;
+
+ -- Do not insert non static choices in the table to be sorted
+
+ elsif not Is_Static_Expression (Lo)
+ or else not Is_Static_Expression (Hi)
+ then
+ Process_Non_Static_Choice (Choice);
+ return;
+
+ -- Ignore range which raise constraint error
+
+ elsif Raises_Constraint_Error (Lo)
+ or else Raises_Constraint_Error (Hi)
+ then
+ Raises_CE := True;
+ return;
+
+ -- Otherwise we have an OK static choice
+
+ else
+ Lo_Val := Expr_Value (Lo);
+ Hi_Val := Expr_Value (Hi);
+
+ -- Do not insert null ranges in the choices table
+
+ if Lo_Val > Hi_Val then
+ Process_Empty_Choice (Choice);
+ return;
+ end if;
+ end if;
+
+ -- Check for bound out of range.
+
+ if Lo_Val < Bounds_Lo then
+ if Is_Integer_Type (Bounds_Type) then
+ Error_Msg_Uint_1 := Bounds_Lo;
+ Error_Msg_N ("minimum allowed choice value is^", Lo);
+ else
+ Error_Msg_Name_1 := Choice_Image (Bounds_Lo, Bounds_Type);
+ Error_Msg_N ("minimum allowed choice value is%", Lo);
+ end if;
+
+ elsif Hi_Val > Bounds_Hi then
+ if Is_Integer_Type (Bounds_Type) then
+ Error_Msg_Uint_1 := Bounds_Hi;
+ Error_Msg_N ("maximum allowed choice value is^", Hi);
+ else
+ Error_Msg_Name_1 := Choice_Image (Bounds_Hi, Bounds_Type);
+ Error_Msg_N ("maximum allowed choice value is%", Hi);
+ end if;
+ end if;
+
+ -- We still store the bounds in the table, even if they are out
+ -- of range, since this may prevent unnecessary cascaded errors
+ -- for values that are covered by such an excessive range.
+
+ Last_Choice := Last_Choice + 1;
+ Sort_Choice_Table (Last_Choice).Lo := Lo;
+ Sort_Choice_Table (Last_Choice).Hi := Hi;
+ Sort_Choice_Table (Last_Choice).Node := Choice;
+ end Check;
+
+ -- Variables local to Analyze_Choices
+
+ Alt : Node_Id;
+ -- A case statement alternative, an array aggregate component
+ -- association or a variant in a record type declaration
+
+ Choice : Node_Id;
+ Kind : Node_Kind;
+ -- The node kind of the current Choice.
+
+ E : Entity_Id;
+
+ -- Start of processing for Analyze_Choices
+
+ begin
+ Last_Choice := 0;
+ Raises_CE := False;
+ Others_Present := False;
+
+ -- If Subtyp is not a static subtype Ada 95 requires then we use
+ -- the bounds of its base type to determine the values covered by
+ -- the discrete choices.
+
+ if Is_OK_Static_Subtype (Subtyp) then
+ Bounds_Type := Subtyp;
+ else
+ Bounds_Type := Choice_Type;
+ end if;
+
+ -- Obtain static bounds of type, unless this is a generic formal
+ -- discrete type for which all choices will be non-static.
+
+ if not Is_Generic_Type (Root_Type (Bounds_Type))
+ or else Ekind (Bounds_Type) /= E_Enumeration_Type
+ then
+ Bounds_Lo := Expr_Value (Type_Low_Bound (Bounds_Type));
+ Bounds_Hi := Expr_Value (Type_High_Bound (Bounds_Type));
+ end if;
+
+ if Choice_Type = Universal_Integer then
+ Expected_Type := Any_Integer;
+ else
+ Expected_Type := Choice_Type;
+ end if;
+
+ -- Now loop through the case statement alternatives or array
+ -- aggregate component associations or record variants.
+
+ Alt := First (Get_Alternatives (N));
+ while Present (Alt) loop
+
+ -- If pragma, just analyze it
+
+ if Nkind (Alt) = N_Pragma then
+ Analyze (Alt);
+
+ -- Otherwise check each choice against its base type
+
+ else
+ Choice := First (Get_Choices (Alt));
+
+ while Present (Choice) loop
+ Analyze (Choice);
+ Kind := Nkind (Choice);
+
+ -- Choice is a Range
+
+ if Kind = N_Range
+ or else (Kind = N_Attribute_Reference
+ and then Attribute_Name (Choice) = Name_Range)
+ then
+ Resolve (Choice, Expected_Type);
+ Check (Choice, Low_Bound (Choice), High_Bound (Choice));
+
+ -- Choice is a subtype name
+
+ elsif Is_Entity_Name (Choice)
+ and then Is_Type (Entity (Choice))
+ then
+ if not Covers (Expected_Type, Etype (Choice)) then
+ Wrong_Type (Choice, Choice_Type);
+
+ else
+ E := Entity (Choice);
+
+ if not Is_Static_Subtype (E) then
+ Process_Non_Static_Choice (Choice);
+ else
+ Check
+ (Choice, Type_Low_Bound (E), Type_High_Bound (E));
+ end if;
+ end if;
+
+ -- Choice is a subtype indication
+
+ elsif Kind = N_Subtype_Indication then
+ Resolve_Discrete_Subtype_Indication
+ (Choice, Expected_Type);
+
+ if Etype (Choice) /= Any_Type then
+ declare
+ C : constant Node_Id := Constraint (Choice);
+ R : constant Node_Id := Range_Expression (C);
+ L : constant Node_Id := Low_Bound (R);
+ H : constant Node_Id := High_Bound (R);
+
+ begin
+ E := Entity (Subtype_Mark (Choice));
+
+ if not Is_Static_Subtype (E) then
+ Process_Non_Static_Choice (Choice);
+
+ else
+ if Is_OK_Static_Expression (L)
+ and then Is_OK_Static_Expression (H)
+ then
+ if Expr_Value (L) > Expr_Value (H) then
+ Process_Empty_Choice (Choice);
+ else
+ if Is_Out_Of_Range (L, E) then
+ Apply_Compile_Time_Constraint_Error
+ (L, "static value out of range");
+ end if;
+
+ if Is_Out_Of_Range (H, E) then
+ Apply_Compile_Time_Constraint_Error
+ (H, "static value out of range");
+ end if;
+ end if;
+ end if;
+
+ Check (Choice, L, H);
+ end if;
+ end;
+ end if;
+
+ -- The others choice is only allowed for the last
+ -- alternative and as its only choice.
+
+ elsif Kind = N_Others_Choice then
+ if not (Choice = First (Get_Choices (Alt))
+ and then Choice = Last (Get_Choices (Alt))
+ and then Alt = Last (Get_Alternatives (N)))
+ then
+ Error_Msg_N
+ ("the choice OTHERS must appear alone and last",
+ Choice);
+ return;
+ end if;
+
+ Others_Present := True;
+
+ -- Only other possibility is an expression
+
+ else
+ Resolve (Choice, Expected_Type);
+ Check (Choice, Choice, Choice);
+ end if;
+
+ Next (Choice);
+ end loop;
+
+ Process_Associated_Node (Alt);
+ end if;
+
+ Next (Alt);
+ end loop;
+
+ Check_Choices
+ (Sort_Choice_Table (0 .. Last_Choice),
+ Bounds_Type,
+ Others_Present or else (Choice_Type = Universal_Integer),
+ Sloc (N));
+
+ -- Now copy the sorted discrete choices
+
+ for J in 1 .. Last_Choice loop
+ Choice_Table (Choice_Table'First - 1 + J) := Sort_Choice_Table (J);
+ end loop;
+
+ end Analyze_Choices;
+
+ -----------------------
+ -- Number_Of_Choices --
+ -----------------------
+
+ function Number_Of_Choices (N : Node_Id) return Nat is
+ Alt : Node_Id;
+ -- A case statement alternative, an array aggregate component
+ -- association or a record variant.
+
+ Choice : Node_Id;
+ Count : Nat := 0;
+
+ begin
+ if not Present (Get_Alternatives (N)) then
+ return 0;
+ end if;
+
+ Alt := First_Non_Pragma (Get_Alternatives (N));
+ while Present (Alt) loop
+
+ Choice := First (Get_Choices (Alt));
+ while Present (Choice) loop
+ if Nkind (Choice) /= N_Others_Choice then
+ Count := Count + 1;
+ end if;
+
+ Next (Choice);
+ end loop;
+
+ Next_Non_Pragma (Alt);
+ end loop;
+
+ return Count;
+ end Number_Of_Choices;
+
+ end Generic_Choices_Processing;
+
+end Sem_Case;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S E M _ C A S E --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.5 $ --
+-- --
+-- Copyright (C) 1996 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 Types; use Types;
+
+-- Package containing all the routines to proces a list of discrete choices.
+-- Such lists can occur in 3 different constructs: case statements, array
+-- aggregates and record variants. We have factorized what used to be 3 very
+-- similar sets of routines here. If you didn't figure it out already Choi
+-- in the package name stands for Choices.
+
+package Sem_Case is
+
+ type Choice_Bounds is record
+ Lo : Node_Id;
+ Hi : Node_Id;
+ Node : Node_Id;
+ end record;
+
+ type Choice_Table_Type is array (Pos range <>) of Choice_Bounds;
+ -- Table type used to sort the choices present in a case statement,
+ -- array aggregate or record variant.
+
+ procedure No_OP (C : Node_Id);
+ -- The no-operation routine. Does absolutely nothing. Can be used
+ -- in the following generic for the parameter Proces_Empty_Choice.
+
+ generic
+ with function Get_Alternatives (N : Node_Id) return List_Id;
+ -- Function needed to get to the actual list of case statement
+ -- alternatives, or array aggregate component associations or
+ -- record variants from which we can then access the actual lists
+ -- of discrete choices. N is the node for the original construct
+ -- ie a case statement, an array aggregate or a record variant.
+
+ with function Get_Choices (A : Node_Id) return List_Id;
+ -- Given a case statement alternative, array aggregate component
+ -- association or record variant A we need different access functions
+ -- to get to the actual list of discrete choices.
+
+ with procedure Process_Empty_Choice (Choice : Node_Id);
+ -- Processing to carry out for an empty Choice.
+
+ with procedure Process_Non_Static_Choice (Choice : Node_Id);
+ -- Processing to carry out for a non static Choice.
+
+ with procedure Process_Associated_Node (A : Node_Id);
+ -- Associated to each case alternative, aggregate component
+ -- association or record variant A there is a node or list of nodes
+ -- that need semantic processing. This routine implements that
+ -- processing.
+
+ package Generic_Choices_Processing is
+
+ function Number_Of_Choices (N : Node_Id) return Nat;
+ -- Iterates through the choices of N, (N can be a case statement,
+ -- array aggregate or record variant), counting all the Choice nodes
+ -- except for the Others choice.
+
+ procedure Analyze_Choices
+ (N : Node_Id;
+ Subtyp : Entity_Id;
+ Choice_Table : in out Choice_Table_Type;
+ Last_Choice : out Nat;
+ Raises_CE : out Boolean;
+ Others_Present : out Boolean);
+ -- From a case statement, array aggregate or record variant N, this
+ -- routine analyzes the corresponding list of discrete choices.
+ -- Subtyp is the subtype of the discrete choices. The type against
+ -- which the discrete choices must be resolved is its base type.
+ --
+ -- On entry Choice_Table must be big enough to contain all the
+ -- discrete choices encountered.
+ --
+ -- On exit Choice_Table contains all the static and non empty
+ -- discrete choices in sorted order. Last_Choice gives the position
+ -- of the last valid choice in Choice_Table, Choice_Table'First
+ -- contains the first. We can have Last_Choice < Choice_Table'Last
+ -- for one (or several) of the following reasons:
+ --
+ -- (a) The list of choices contained a non static choice
+ --
+ -- (b) The list of choices contained an empty choice
+ -- (something like "1 .. 0 => ")
+ --
+ -- (c) One of the bounds of a discrete choice contains an
+ -- error or raises constraint error.
+ --
+ -- In one of the bounds of a discrete choice raises a constraint
+ -- error the flag Raise_CE is set.
+ --
+ -- Finally Others_Present is set to True if an Others choice is
+ -- present in the list of choices.
+
+ end Generic_Choices_Processing;
+
+end Sem_Case;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S E M _ C A T --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.57 $
+-- --
+-- 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). --
+-- --
+------------------------------------------------------------------------------
+
+with Atree; use Atree;
+with Debug; use Debug;
+with Einfo; use Einfo;
+with Elists; use Elists;
+with Errout; use Errout;
+with Exp_Tss; use Exp_Tss;
+with Fname; use Fname;
+with Lib; use Lib;
+with Nlists; use Nlists;
+with Sem; use Sem;
+with Sem_Util; use Sem_Util;
+with Sinfo; use Sinfo;
+with Snames; use Snames;
+with Stand; use Stand;
+
+package body Sem_Cat is
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ procedure Check_Categorization_Dependencies
+ (Unit_Entity : Entity_Id;
+ Depended_Entity : Entity_Id;
+ Info_Node : Node_Id;
+ Is_Subunit : Boolean);
+ -- This procedure checks that the categorization of a lib unit and that
+ -- of the depended unit satisfy dependency restrictions.
+ -- The depended_entity can be the entity in a with_clause item, in which
+ -- case Info_Node denotes that item. The depended_entity can also be the
+ -- parent unit of a child unit, in which case Info_Node is the declaration
+ -- of the child unit. The error message is posted on Info_Node, and is
+ -- specialized if Is_Subunit is true.
+
+ procedure Check_Non_Static_Default_Expr
+ (Type_Def : Node_Id;
+ Obj_Decl : Node_Id);
+ -- Iterate through the component list of a record definition, check
+ -- that no component is declared with a nonstatic default value.
+ -- If a nonstatic default exists, report an error on Obj_Decl.
+
+ -- Iterate through the component list of a record definition, check
+ -- that no component is declared with a non-static default value.
+
+ function Missing_Read_Write_Attributes (E : Entity_Id) return Boolean;
+ -- Return True if the entity or one of its subcomponent is an access
+ -- type which does not have user-defined Read and Write attribute.
+
+ function In_RCI_Declaration (N : Node_Id) return Boolean;
+ -- Determines if a declaration is within the visible part of a Remote
+ -- Call Interface compilation unit, for semantic checking purposes only,
+ -- (returns false within an instance and within the package body).
+
+ function In_RT_Declaration return Boolean;
+ -- Determines if current scope is within a Remote Types compilation unit,
+ -- for semantic checking purposes.
+
+ function Is_Non_Remote_Access_Type (E : Entity_Id) return Boolean;
+ -- Returns true if the entity is a non-remote access type
+
+ function In_Shared_Passive_Unit return Boolean;
+ -- Determines if current scope is within a Shared Passive compilation unit
+
+ function Static_Discriminant_Expr (L : List_Id) return Boolean;
+ -- Iterate through the list of discriminants to check if any of them
+ -- contains non-static default expression, which is a violation in
+ -- a preelaborated library unit.
+
+ procedure Validate_Remote_Access_Object_Type_Declaration (T : Entity_Id);
+ -- Check validity of declaration if RCI unit. It should not contain
+ -- the declaration of an access-to-object type unless it is a
+ -- general access type that designates a class-wide limited
+ -- private type. There are also constraints about the primitive
+ -- subprograms of the class-wide type. RM E.2 (9, 13, 14)
+
+ function Is_Recursively_Limited_Private (E : Entity_Id) return Boolean;
+ -- Return True if E is a limited private type, or if E is a private
+ -- extension of a type whose parent verifies this property (hence the
+ -- recursive keyword).
+
+ ---------------------------------------
+ -- Check_Categorization_Dependencies --
+ ---------------------------------------
+
+ procedure Check_Categorization_Dependencies
+ (Unit_Entity : Entity_Id;
+ Depended_Entity : Entity_Id;
+ Info_Node : Node_Id;
+ Is_Subunit : Boolean)
+ is
+ N : Node_Id := Info_Node;
+
+ type Categorization is
+ (Pure, Shared_Passive, Remote_Types,
+ Remote_Call_Interface, Pre_Elaborated, Normal);
+
+ Unit_Category : Categorization;
+ With_Category : Categorization;
+
+ function Get_Categorization (E : Entity_Id) return Categorization;
+ -- Check categorization flags from entity, and return in the form
+ -- of a corresponding enumeration value.
+
+ function Get_Categorization (E : Entity_Id) return Categorization is
+ begin
+ if Is_Preelaborated (E) then
+ return Pre_Elaborated;
+ elsif Is_Pure (E) then
+ return Pure;
+ elsif Is_Shared_Passive (E) then
+ return Shared_Passive;
+ elsif Is_Remote_Types (E) then
+ return Remote_Types;
+ elsif Is_Remote_Call_Interface (E) then
+ return Remote_Call_Interface;
+ else
+ return Normal;
+ end if;
+ end Get_Categorization;
+
+ -- Start of processing for Check_Categorization_Dependencies
+
+ begin
+ -- Intrinsic subprograms are preelaborated, so do not impose any
+ -- categorization dependencies.
+
+ if Is_Intrinsic_Subprogram (Depended_Entity) then
+ return;
+ end if;
+
+ Unit_Category := Get_Categorization (Unit_Entity);
+ With_Category := Get_Categorization (Depended_Entity);
+
+ if With_Category > Unit_Category then
+
+ if (Unit_Category = Remote_Types
+ or else Unit_Category = Remote_Call_Interface)
+ and then In_Package_Body (Unit_Entity)
+ then
+ null;
+
+ elsif Is_Subunit then
+ Error_Msg_NE ("subunit cannot depend on&"
+ & " (parent has wrong categorization)", N, Depended_Entity);
+ else
+ Error_Msg_NE ("current unit cannot depend on&"
+ & " (wrong categorization)", N, Depended_Entity);
+ end if;
+ end if;
+
+ end Check_Categorization_Dependencies;
+
+ -----------------------------------
+ -- Check_Non_Static_Default_Expr --
+ -----------------------------------
+
+ procedure Check_Non_Static_Default_Expr
+ (Type_Def : Node_Id;
+ Obj_Decl : Node_Id)
+ is
+ Recdef : Node_Id;
+ Component_Decl : Node_Id;
+
+ begin
+ if Nkind (Type_Def) = N_Derived_Type_Definition then
+ Recdef := Record_Extension_Part (Type_Def);
+
+ if No (Recdef) then
+ return;
+ end if;
+
+ else
+ Recdef := Type_Def;
+ end if;
+
+ -- Check that component declarations do not involve:
+
+ -- a. a non-static default expression, where the object is
+ -- declared to be default initialized.
+
+ -- b. a dynamic Itype (discriminants and constraints)
+
+ if Null_Present (Recdef) then
+ return;
+ else
+ Component_Decl := First (Component_Items (Component_List (Recdef)));
+ end if;
+
+ while Present (Component_Decl)
+ and then Nkind (Component_Decl) = N_Component_Declaration
+ loop
+ if Present (Expression (Component_Decl))
+ and then Nkind (Expression (Component_Decl)) /= N_Null
+ and then not Is_Static_Expression (Expression (Component_Decl))
+ then
+ Error_Msg_Sloc := Sloc (Component_Decl);
+ Error_Msg_N
+ ("object in preelaborated unit has nonstatic default#",
+ Obj_Decl);
+
+ -- Fix this later ???
+
+ -- elsif Has_Dynamic_Itype (Component_Decl) then
+ -- Error_Msg_N
+ -- ("dynamic type discriminant," &
+ -- " constraint in preelaborated unit",
+ -- Component_Decl);
+ end if;
+
+ Next (Component_Decl);
+ end loop;
+ end Check_Non_Static_Default_Expr;
+
+ ---------------------------
+ -- In_Preelaborated_Unit --
+ ---------------------------
+
+ function In_Preelaborated_Unit return Boolean is
+ Unit_Entity : constant Entity_Id := Current_Scope;
+ Unit_Kind : constant Node_Kind :=
+ Nkind (Unit (Cunit (Current_Sem_Unit)));
+
+ begin
+ -- There are no constraints on body of remote_call_interface or
+ -- remote_types packages..
+
+ return (Unit_Entity /= Standard_Standard)
+ and then (Is_Preelaborated (Unit_Entity)
+ or else Is_Pure (Unit_Entity)
+ or else Is_Shared_Passive (Unit_Entity)
+ or else
+ ((Is_Remote_Types (Unit_Entity)
+ or else Is_Remote_Call_Interface (Unit_Entity))
+ and then Ekind (Unit_Entity) = E_Package
+ and then Unit_Kind /= N_Package_Body
+ and then not In_Package_Body (Unit_Entity)
+ and then not In_Instance));
+ end In_Preelaborated_Unit;
+
+ ------------------
+ -- In_Pure_Unit --
+ ------------------
+
+ function In_Pure_Unit return Boolean is
+ begin
+ return Is_Pure (Current_Scope);
+ end In_Pure_Unit;
+
+ ------------------------
+ -- In_RCI_Declaration --
+ ------------------------
+
+ function In_RCI_Declaration (N : Node_Id) return Boolean is
+ Unit_Entity : constant Entity_Id := Current_Scope;
+ Unit_Kind : constant Node_Kind :=
+ Nkind (Unit (Cunit (Current_Sem_Unit)));
+
+ begin
+ -- There are no restrictions on the private part or body
+ -- of an RCI unit.
+
+ return Is_Remote_Call_Interface (Unit_Entity)
+ and then (Ekind (Unit_Entity) = E_Package
+ or else Ekind (Unit_Entity) = E_Generic_Package)
+ and then Unit_Kind /= N_Package_Body
+ and then List_Containing (N) =
+ Visible_Declarations
+ (Specification (Unit_Declaration_Node (Unit_Entity)))
+ and then not In_Package_Body (Unit_Entity)
+ and then not In_Instance;
+ end In_RCI_Declaration;
+
+ -----------------------
+ -- In_RT_Declaration --
+ -----------------------
+
+ function In_RT_Declaration return Boolean is
+ Unit_Entity : constant Entity_Id := Current_Scope;
+ Unit_Kind : constant Node_Kind :=
+ Nkind (Unit (Cunit (Current_Sem_Unit)));
+
+ begin
+ -- There are no restrictions on the body of a Remote Types unit.
+
+ return Is_Remote_Types (Unit_Entity)
+ and then (Ekind (Unit_Entity) = E_Package
+ or else Ekind (Unit_Entity) = E_Generic_Package)
+ and then Unit_Kind /= N_Package_Body
+ and then not In_Package_Body (Unit_Entity)
+ and then not In_Instance;
+ end In_RT_Declaration;
+
+ ----------------------------
+ -- In_Shared_Passive_Unit --
+ ----------------------------
+
+ function In_Shared_Passive_Unit return Boolean is
+ Unit_Entity : constant Entity_Id := Current_Scope;
+
+ begin
+ return Is_Shared_Passive (Unit_Entity);
+ end In_Shared_Passive_Unit;
+
+ ---------------------------------------
+ -- In_Subprogram_Task_Protected_Unit --
+ ---------------------------------------
+
+ function In_Subprogram_Task_Protected_Unit return Boolean is
+ E : Entity_Id;
+ K : Entity_Kind;
+
+ begin
+ -- The following is to verify that a declaration is inside
+ -- subprogram, generic subprogram, task unit, protected unit.
+ -- Used to validate if a lib. unit is Pure. RM 10.2.1(16).
+
+ -- Use scope chain to check successively outer scopes
+
+ E := Current_Scope;
+ loop
+ K := Ekind (E);
+
+ if K = E_Procedure
+ or else K = E_Function
+ or else K = E_Generic_Procedure
+ or else K = E_Generic_Function
+ or else K = E_Task_Type
+ or else K = E_Task_Subtype
+ or else K = E_Protected_Type
+ or else K = E_Protected_Subtype
+ then
+ return True;
+
+ elsif E = Standard_Standard then
+ return False;
+ end if;
+
+ E := Scope (E);
+ end loop;
+
+ end In_Subprogram_Task_Protected_Unit;
+
+ -------------------------------
+ -- Is_Non_Remote_Access_Type --
+ -------------------------------
+
+ function Is_Non_Remote_Access_Type (E : Entity_Id) return Boolean is
+ begin
+ return Is_Access_Type (E)
+ and then not Is_Remote_Access_To_Class_Wide_Type (E)
+ and then not Is_Remote_Access_To_Subprogram_Type (E);
+ end Is_Non_Remote_Access_Type;
+
+ ------------------------------------
+ -- Is_Recursively_Limited_Private --
+ ------------------------------------
+
+ function Is_Recursively_Limited_Private (E : Entity_Id) return Boolean is
+ P : constant Node_Id := Parent (E);
+
+ begin
+ if Nkind (P) = N_Private_Type_Declaration
+ and then Is_Limited_Record (E)
+ then
+ return True;
+ elsif Nkind (P) = N_Private_Extension_Declaration then
+ return Is_Recursively_Limited_Private (Etype (E));
+ elsif Nkind (P) = N_Formal_Type_Declaration
+ and then Ekind (E) = E_Record_Type_With_Private
+ and then Is_Generic_Type (E)
+ and then Is_Limited_Record (E)
+ then
+ return True;
+ else
+ return False;
+ end if;
+ end Is_Recursively_Limited_Private;
+
+ ----------------------------------
+ -- Missing_Read_Write_Attribute --
+ ----------------------------------
+
+ function Missing_Read_Write_Attributes (E : Entity_Id) return Boolean is
+ Component : Entity_Id;
+ Component_Type : Entity_Id;
+
+ function Has_Read_Write_Attributes (E : Entity_Id) return Boolean;
+ -- Return True if entity has Read and Write attributes
+
+ -------------------------------
+ -- Has_Read_Write_Attributes --
+ -------------------------------
+
+ function Has_Read_Write_Attributes (E : Entity_Id) return Boolean is
+ Rep_Item : Node_Id := First_Rep_Item (E);
+ Read_Attribute : Boolean := False;
+ Write_Attribute : Boolean := False;
+
+ begin
+ -- We start from the declaration node and then loop until the end
+ -- of the list until we find those two attribute definition clauses.
+
+ while Present (Rep_Item) loop
+ if Chars (Rep_Item) = Name_Read then
+ Read_Attribute := True;
+ elsif Chars (Rep_Item) = Name_Write then
+ Write_Attribute := True;
+ end if;
+
+ if Read_Attribute and Write_Attribute then
+ return True;
+ end if;
+
+ Next_Rep_Item (Rep_Item);
+ end loop;
+
+ return False;
+ end Has_Read_Write_Attributes;
+
+ -- Start of processing for Missing_Read_Write_Attributes
+
+ begin
+ if Has_Read_Write_Attributes (E) then
+ return False;
+ elsif Is_Non_Remote_Access_Type (E) then
+ return True;
+ end if;
+
+ if Is_Record_Type (E) then
+ Component := First_Entity (E);
+ while Present (Component) loop
+ Component_Type := Etype (Component);
+
+ if (Is_Non_Remote_Access_Type (Component_Type)
+ or else Is_Record_Type (Component_Type))
+ and then Missing_Read_Write_Attributes (Component_Type)
+ then
+ return True;
+ end if;
+
+ Next_Entity (Component);
+ end loop;
+ end if;
+
+ return False;
+ end Missing_Read_Write_Attributes;
+
+ -------------------------------------
+ -- Set_Categorization_From_Pragmas --
+ -------------------------------------
+
+ procedure Set_Categorization_From_Pragmas (N : Node_Id) is
+ P : constant Node_Id := Parent (N);
+ S : constant Entity_Id := Current_Scope;
+
+ procedure Set_Parents (Visibility : Boolean);
+ -- If this is a child instance, the parents are not immediately
+ -- visible during analysis. Make them momentarily visible so that
+ -- the argument of the pragma can be resolved properly, and reset
+ -- afterwards.
+
+ procedure Set_Parents (Visibility : Boolean) is
+ Par : Entity_Id := Scope (S);
+
+ begin
+ while Present (Par) and then Par /= Standard_Standard loop
+ Set_Is_Immediately_Visible (Par, Visibility);
+ Par := Scope (Par);
+ end loop;
+ end Set_Parents;
+
+ begin
+ -- Deal with categorization pragmas in Pragmas of Compilation_Unit.
+ -- The purpose is to set categorization flags before analyzing the
+ -- unit itself, so as to diagnose violations of categorization as
+ -- we process each declaration, even though the pragma appears after
+ -- the unit.
+
+ if Nkind (P) /= N_Compilation_Unit then
+ return;
+ end if;
+
+ declare
+ PN : Node_Id := First (Pragmas_After (Aux_Decls_Node (P)));
+
+ begin
+
+ if Is_Child_Unit (S)
+ and then Is_Generic_Instance (S)
+ then
+ Set_Parents (True);
+ end if;
+
+ while Present (PN) loop
+
+ -- Skip implicit types that may have been introduced by
+ -- previous analysis.
+
+ if Nkind (PN) = N_Pragma then
+
+ case Get_Pragma_Id (Chars (PN)) is
+ when Pragma_All_Calls_Remote |
+ Pragma_Preelaborate |
+ Pragma_Pure |
+ Pragma_Remote_Call_Interface |
+ Pragma_Remote_Types |
+ Pragma_Shared_Passive => Analyze (PN);
+ when others => null;
+ end case;
+ end if;
+
+ Next (PN);
+ end loop;
+ if Is_Child_Unit (S)
+ and then Is_Generic_Instance (S)
+ then
+ Set_Parents (False);
+ end if;
+
+ end;
+ end Set_Categorization_From_Pragmas;
+
+ ------------------------------
+ -- Static_Discriminant_Expr --
+ ------------------------------
+
+ function Static_Discriminant_Expr (L : List_Id) return Boolean is
+ Discriminant_Spec : Node_Id;
+
+ begin
+ Discriminant_Spec := First (L);
+ while Present (Discriminant_Spec) loop
+ if Present (Expression (Discriminant_Spec))
+ and then not Is_Static_Expression (Expression (Discriminant_Spec))
+ then
+ return False;
+ end if;
+
+ Next (Discriminant_Spec);
+ end loop;
+
+ return True;
+ end Static_Discriminant_Expr;
+
+ --------------------------------------
+ -- Validate_Access_Type_Declaration --
+ --------------------------------------
+
+ procedure Validate_Access_Type_Declaration (T : Entity_Id; N : Node_Id) is
+ Def : constant Node_Id := Type_Definition (N);
+
+ begin
+ case Nkind (Def) is
+ when N_Access_To_Subprogram_Definition =>
+
+ -- A pure library_item must not contain the declaration of a
+ -- named access type, except within a subprogram, generic
+ -- subprogram, task unit, or protected unit (RM 10.2.1(16)).
+
+ if Comes_From_Source (T)
+ and then In_Pure_Unit
+ and then not In_Subprogram_Task_Protected_Unit
+ then
+ Error_Msg_N ("named access type not allowed in pure unit", T);
+ end if;
+
+ when N_Access_To_Object_Definition =>
+
+ if Comes_From_Source (T)
+ and then In_Pure_Unit
+ and then not In_Subprogram_Task_Protected_Unit
+ then
+ Error_Msg_N
+ ("named access type not allowed in pure unit", T);
+ end if;
+
+ -- Check for RCI unit type declaration. It should not contain
+ -- the declaration of an access-to-object type unless it is a
+ -- general access type that designates a class-wide limited
+ -- private type. There are also constraints about the primitive
+ -- subprograms of the class-wide type.
+
+ Validate_Remote_Access_Object_Type_Declaration (T);
+
+ -- Check for shared passive unit type declaration. It should
+ -- not contain the declaration of access to class wide type,
+ -- access to task type and access to protected type with entry.
+
+ Validate_SP_Access_Object_Type_Decl (T);
+
+ when others => null;
+ end case;
+
+ -- Set Categorization flag of package on entity as well, to allow
+ -- easy checks later on for required validations of RCI units. This
+ -- is only done for entities that are in the original source.
+
+ if Comes_From_Source (T) then
+ if Is_Remote_Call_Interface (Scope (T))
+ and then not In_Package_Body (Scope (T))
+ then
+ Set_Is_Remote_Call_Interface (T);
+ end if;
+
+ if Is_Remote_Types (Scope (T))
+ and then not In_Package_Body (Scope (T))
+ then
+ Set_Is_Remote_Types (T);
+ end if;
+ end if;
+ end Validate_Access_Type_Declaration;
+
+ ----------------------------
+ -- Validate_Ancestor_Part --
+ ----------------------------
+
+ procedure Validate_Ancestor_Part (N : Node_Id) is
+ A : constant Node_Id := Ancestor_Part (N);
+ T : Entity_Id := Entity (A);
+
+ begin
+ if In_Preelaborated_Unit
+ and then not In_Subprogram_Or_Concurrent_Unit
+ and then (not Inside_A_Generic
+ or else Present (Enclosing_Generic_Body (N)))
+ then
+ -- We relax the restriction of 10.2.1(9) within GNAT
+ -- units to allow packages such as Ada.Strings.Unbounded
+ -- to be implemented (i.p., Null_Unbounded_String).
+ -- (There are ACVC tests that check that the restriction
+ -- is enforced, but note that AI-161, once approved,
+ -- will relax the restriction prohibiting default-
+ -- initialized objects of private and controlled
+ -- types.)
+
+ if Is_Private_Type (T)
+ and then not Is_Internal_File_Name
+ (Unit_File_Name (Get_Source_Unit (N)))
+ then
+ Error_Msg_N
+ ("private ancestor type not allowed in preelaborated unit", A);
+
+ elsif Is_Record_Type (T) then
+ if Nkind (Parent (T)) = N_Full_Type_Declaration then
+ Check_Non_Static_Default_Expr
+ (Type_Definition (Parent (T)), A);
+ end if;
+ end if;
+ end if;
+ end Validate_Ancestor_Part;
+
+ ----------------------------------------
+ -- Validate_Categorization_Dependency --
+ ----------------------------------------
+
+ procedure Validate_Categorization_Dependency
+ (N : Node_Id;
+ E : Entity_Id)
+ is
+ K : constant Node_Kind := Nkind (N);
+ P : Node_Id := Parent (N);
+ U : Entity_Id := E;
+ Is_Subunit : constant Boolean := Nkind (P) = N_Subunit;
+
+ begin
+ -- Only validate library units and subunits. For subunits, checks
+ -- concerning withed units apply to the parent compilation unit.
+
+ if Is_Subunit then
+ P := Parent (P);
+ U := Scope (E);
+
+ while Present (U)
+ and then not Is_Compilation_Unit (U)
+ and then not Is_Child_Unit (U)
+ loop
+ U := Scope (U);
+ end loop;
+
+ end if;
+
+ if Nkind (P) /= N_Compilation_Unit then
+ return;
+ end if;
+
+ -- Body of RCI unit does not need validation.
+
+ if Is_Remote_Call_Interface (E)
+ and then (Nkind (N) = N_Package_Body
+ or else Nkind (N) = N_Subprogram_Body)
+ then
+ return;
+ end if;
+
+ -- Process with clauses
+
+ declare
+ Item : Node_Id;
+ Entity_Of_Withed : Entity_Id;
+
+ begin
+ Item := First (Context_Items (P));
+
+ while Present (Item) loop
+ if Nkind (Item) = N_With_Clause
+ and then not Implicit_With (Item)
+ then
+ Entity_Of_Withed := Entity (Name (Item));
+ Check_Categorization_Dependencies
+ (U, Entity_Of_Withed, Item, Is_Subunit);
+ end if;
+
+ Next (Item);
+ end loop;
+ end;
+
+ -- Child depends on parent; therefore parent should also
+ -- be categorized and satify the dependency hierarchy.
+
+ -- Check if N is a child spec.
+
+ if (K in N_Generic_Declaration or else
+ K in N_Generic_Instantiation or else
+ K in N_Generic_Renaming_Declaration or else
+ K = N_Package_Declaration or else
+ K = N_Package_Renaming_Declaration or else
+ K = N_Subprogram_Declaration or else
+ K = N_Subprogram_Renaming_Declaration)
+ and then Present (Parent_Spec (N))
+ then
+ declare
+ Parent_Lib_U : constant Node_Id := Parent_Spec (N);
+ Parent_Kind : constant Node_Kind :=
+ Nkind (Unit (Parent_Lib_U));
+ Parent_Entity : Entity_Id;
+
+ begin
+ if Parent_Kind = N_Package_Instantiation
+ or else Parent_Kind = N_Procedure_Instantiation
+ or else Parent_Kind = N_Function_Instantiation
+ or else Parent_Kind = N_Package_Renaming_Declaration
+ or else Parent_Kind in N_Generic_Renaming_Declaration
+ then
+ Parent_Entity := Defining_Entity (Unit (Parent_Lib_U));
+
+ else
+ Parent_Entity :=
+ Defining_Entity (Specification (Unit (Parent_Lib_U)));
+ end if;
+
+ Check_Categorization_Dependencies (E, Parent_Entity, N, False);
+
+ -- Verify that public child of an RCI library unit
+ -- must also be an RCI library unit (RM E.2.3(15)).
+
+ if Is_Remote_Call_Interface (Parent_Entity)
+ and then not Private_Present (P)
+ and then not Is_Remote_Call_Interface (E)
+ then
+ Error_Msg_N
+ ("public child of rci unit must also be rci unit", N);
+ return;
+ end if;
+ end;
+ end if;
+
+ end Validate_Categorization_Dependency;
+
+ --------------------------------
+ -- Validate_Controlled_Object --
+ --------------------------------
+
+ procedure Validate_Controlled_Object (E : Entity_Id) is
+ begin
+ -- For now, never apply this check for internal GNAT units, since we
+ -- have a number of cases in the library where we are stuck with objects
+ -- of this type, and the RM requires Preelaborate.
+
+ -- For similar reasons, we only do this check for source entities, since
+ -- we generate entities of this type in some situations.
+
+ -- Note that the 10.2.1(9) restrictions are not relevant to us anyway.
+ -- We have to enforce them for RM compatibility, but we have no trouble
+ -- accepting these objects and doing the right thing. Note that there is
+ -- no requirement that Preelaborate not actually generate any code!
+
+ if In_Preelaborated_Unit
+ and then not Debug_Flag_PP
+ and then Comes_From_Source (E)
+ and then not
+ Is_Internal_File_Name (Unit_File_Name (Get_Source_Unit (E)))
+ and then (not Inside_A_Generic
+ or else Present (Enclosing_Generic_Body (E)))
+ and then not Is_Protected_Type (Etype (E))
+ then
+ Error_Msg_N
+ ("library level controlled object not allowed in " &
+ "preelaborated unit", E);
+ end if;
+ end Validate_Controlled_Object;
+
+ --------------------------------------
+ -- Validate_Null_Statement_Sequence --
+ --------------------------------------
+
+ procedure Validate_Null_Statement_Sequence (N : Node_Id) is
+ Item : Node_Id;
+
+ begin
+ if In_Preelaborated_Unit then
+ Item := First (Statements (Handled_Statement_Sequence (N)));
+
+ while Present (Item) loop
+ if Nkind (Item) /= N_Label
+ and then Nkind (Item) /= N_Null_Statement
+ then
+ Error_Msg_N
+ ("statements not allowed in preelaborated unit", Item);
+ exit;
+ end if;
+
+ Next (Item);
+ end loop;
+ end if;
+ end Validate_Null_Statement_Sequence;
+
+ ---------------------------------
+ -- Validate_Object_Declaration --
+ ---------------------------------
+
+ procedure Validate_Object_Declaration (N : Node_Id) is
+ Id : constant Entity_Id := Defining_Identifier (N);
+ E : constant Node_Id := Expression (N);
+ Odf : constant Node_Id := Object_Definition (N);
+ T : constant Entity_Id := Etype (Id);
+
+ begin
+ -- Verify that any access to subprogram object does not have in its
+ -- subprogram profile access type parameters or limited parameters
+ -- without Read and Write attributes (E.2.3(13)).
+
+ Validate_RCI_Subprogram_Declaration (N);
+
+ -- Check that if we are in preelaborated elaboration code, then we
+ -- do not have an instance of a default initialized private, task or
+ -- protected object declaration which would violate (RM 10.2.1(9)).
+ -- Note that constants are never default initialized (and the test
+ -- below also filters out deferred constants). A variable is default
+ -- initialized if it does *not* have an initialization expression.
+
+ -- Filter out cases that are not declaration of a variable from source
+
+ if Nkind (N) /= N_Object_Declaration
+ or else Constant_Present (N)
+ or else not Comes_From_Source (Id)
+ then
+ return;
+ end if;
+
+ -- Exclude generic specs from the checks (this will get rechecked
+ -- on instantiations).
+
+ if Inside_A_Generic
+ and then not Present (Enclosing_Generic_Body (Id))
+ then
+ return;
+ end if;
+
+ -- Required checks for declaration that is in a preelaborated
+ -- package and is not within some subprogram.
+
+ if In_Preelaborated_Unit
+ and then not In_Subprogram_Or_Concurrent_Unit
+ then
+ -- Check for default initialized variable case. Note that in
+ -- accordance with (RM B.1(24)) imported objects are not
+ -- subject to default initialization.
+
+ if No (E) and then not Is_Imported (Id) then
+ declare
+ Ent : Entity_Id := T;
+
+ begin
+ -- An array whose component type is a record with nonstatic
+ -- default expressions is a violation, so we get the array's
+ -- component type.
+
+ if Is_Array_Type (Ent) then
+ declare
+ Comp_Type : Entity_Id := Component_Type (Ent);
+
+ begin
+ while Is_Array_Type (Comp_Type) loop
+ Comp_Type := Component_Type (Comp_Type);
+ end loop;
+
+ Ent := Comp_Type;
+ end;
+ end if;
+
+ -- Object decl. that is of record type and has no default expr.
+ -- should check if there is any non-static default expression
+ -- in component decl. of the record type decl.
+
+ if Is_Record_Type (Ent) then
+ if Nkind (Parent (Ent)) = N_Full_Type_Declaration then
+ Check_Non_Static_Default_Expr
+ (Type_Definition (Parent (Ent)), N);
+
+ elsif Nkind (Odf) = N_Subtype_Indication
+ and then not Is_Array_Type (T)
+ and then not Is_Private_Type (T)
+ then
+ Check_Non_Static_Default_Expr (Type_Definition
+ (Parent (Entity (Subtype_Mark (Odf)))), N);
+ end if;
+ end if;
+
+ -- We relax the restriction of 10.2.1(9) within GNAT
+ -- units. (There are ACVC tests that check that the
+ -- restriction is enforced, but note that AI-161,
+ -- once approved, will relax the restriction prohibiting
+ -- default-initialized objects of private types, and
+ -- will recommend a pragma for marking private types.)
+
+ if (Is_Private_Type (Ent)
+ or else Depends_On_Private (Ent))
+ and then not Is_Internal_File_Name
+ (Unit_File_Name (Get_Source_Unit (N)))
+ then
+ Error_Msg_N
+ ("private object not allowed in preelaborated unit", N);
+ return;
+
+ -- Access to Task or Protected type
+
+ elsif Is_Entity_Name (Odf)
+ and then Present (Etype (Odf))
+ and then Is_Access_Type (Etype (Odf))
+ then
+ Ent := Designated_Type (Etype (Odf));
+
+ elsif Is_Entity_Name (Odf) then
+ Ent := Entity (Odf);
+
+ elsif Nkind (Odf) = N_Subtype_Indication then
+ Ent := Etype (Subtype_Mark (Odf));
+
+ elsif
+ Nkind (Odf) = N_Constrained_Array_Definition
+ then
+ Ent := Component_Type (T);
+
+ -- else
+ -- return;
+ end if;
+
+ if Is_Task_Type (Ent)
+ or else (Is_Protected_Type (Ent) and then Has_Entries (Ent))
+ then
+ Error_Msg_N
+ ("concurrent object not allowed in preelaborated unit",
+ N);
+ return;
+ end if;
+ end;
+ end if;
+
+ -- Non-static discriminant not allowed in preelaborayted unit
+
+ if Is_Record_Type (Etype (Id)) then
+ declare
+ ET : constant Entity_Id := Etype (Id);
+ EE : constant Entity_Id := Etype (Etype (Id));
+ PEE : Node_Id;
+
+ begin
+ if Has_Discriminants (ET)
+ and then Present (EE)
+ then
+ PEE := Parent (EE);
+
+ if Nkind (PEE) = N_Full_Type_Declaration
+ and then not Static_Discriminant_Expr
+ (Discriminant_Specifications (PEE))
+ then
+ Error_Msg_N
+ ("non-static discriminant in preelaborated unit",
+ PEE);
+ end if;
+ end if;
+ end;
+ end if;
+ end if;
+
+ -- A pure library_item must not contain the declaration of any
+ -- variable except within a subprogram, generic subprogram, task
+ -- unit or protected unit (RM 10.2.1(16)).
+
+ if In_Pure_Unit
+ and then not In_Subprogram_Task_Protected_Unit
+ then
+ Error_Msg_N ("declaration of variable not allowed in pure unit", N);
+
+ -- The visible part of an RCI library unit must not contain the
+ -- declaration of a variable (RM E.1.3(9))
+
+ elsif In_RCI_Declaration (N) then
+ Error_Msg_N ("declaration of variable not allowed in rci unit", N);
+
+ -- The visible part of a Shared Passive library unit must not contain
+ -- the declaration of a variable (RM E.2.2(7))
+
+ elsif In_RT_Declaration then
+ Error_Msg_N
+ ("variable declaration not allowed in remote types unit", N);
+ end if;
+
+ end Validate_Object_Declaration;
+
+ --------------------------------
+ -- Validate_RCI_Declarations --
+ --------------------------------
+
+ procedure Validate_RCI_Declarations (P : Entity_Id) is
+ E : Entity_Id;
+
+ begin
+ E := First_Entity (P);
+
+ while Present (E) loop
+ if Comes_From_Source (E) then
+
+ if Is_Limited_Type (E) then
+ Error_Msg_N
+ ("Limited type not allowed in rci unit", Parent (E));
+
+ elsif Ekind (E) = E_Generic_Function
+ or else Ekind (E) = E_Generic_Package
+ or else Ekind (E) = E_Generic_Procedure
+ then
+ Error_Msg_N ("generic declaration not allowed in rci unit",
+ Parent (E));
+
+ elsif (Ekind (E) = E_Function
+ or else Ekind (E) = E_Procedure)
+ and then Has_Pragma_Inline (E)
+ then
+ Error_Msg_N
+ ("inlined subprogram not allowed in rci unit", Parent (E));
+
+ -- Inner packages that are renamings need not be checked.
+ -- Generic RCI packages are subject to the checks, but
+ -- entities that come from formal packages are not part of the
+ -- visible declarations of the package and are not checked.
+
+ elsif Ekind (E) = E_Package then
+ if Present (Renamed_Entity (E)) then
+ null;
+
+ elsif Ekind (P) /= E_Generic_Package
+ or else List_Containing (Unit_Declaration_Node (E)) /=
+ Generic_Formal_Declarations
+ (Unit_Declaration_Node (P))
+ then
+ Validate_RCI_Declarations (E);
+ end if;
+ end if;
+ end if;
+
+ Next_Entity (E);
+ end loop;
+ end Validate_RCI_Declarations;
+
+ -----------------------------------------
+ -- Validate_RCI_Subprogram_Declaration --
+ -----------------------------------------
+
+ procedure Validate_RCI_Subprogram_Declaration (N : Node_Id) is
+ K : Node_Kind := Nkind (N);
+ Profile : List_Id;
+ Id : Node_Id;
+ Param_Spec : Node_Id;
+ Param_Type : Entity_Id;
+ Base_Param_Type : Entity_Id;
+ Type_Decl : Node_Id;
+ Error_Node : Node_Id := N;
+
+ begin
+ -- There are two possible cases in which this procedure is called:
+
+ -- 1. called from Analyze_Subprogram_Declaration.
+ -- 2. called from Validate_Object_Declaration (access to subprogram).
+
+ if not In_RCI_Declaration (N) then
+ return;
+ end if;
+
+ if K = N_Subprogram_Declaration then
+ Profile := Parameter_Specifications (Specification (N));
+
+ else pragma Assert (K = N_Object_Declaration);
+ Id := Defining_Identifier (N);
+
+ if Nkind (Id) = N_Defining_Identifier
+ and then Nkind (Parent (Etype (Id))) = N_Full_Type_Declaration
+ and then Ekind (Etype (Id)) = E_Access_Subprogram_Type
+ then
+ Profile :=
+ Parameter_Specifications (Type_Definition (Parent (Etype (Id))));
+ else
+ return;
+ end if;
+ end if;
+
+ -- Iterate through the parameter specification list, checking that
+ -- no access parameter and no limited type parameter in the list.
+ -- RM E.2.3 (14)
+
+ if Present (Profile) then
+ Param_Spec := First (Profile);
+
+ while Present (Param_Spec) loop
+ Param_Type := Etype (Defining_Identifier (Param_Spec));
+ Type_Decl := Parent (Param_Type);
+
+ if Ekind (Param_Type) = E_Anonymous_Access_Type then
+
+ if K = N_Subprogram_Declaration then
+ Error_Node := Param_Spec;
+ end if;
+
+ -- Report error only if declaration is in source program.
+
+ if Comes_From_Source
+ (Defining_Entity (Specification (N)))
+ then
+ Error_Msg_N
+ ("subprogram in rci unit cannot have access parameter",
+ Error_Node);
+ end if;
+
+ -- For limited private type parameter, we check only the
+ -- private declaration and ignore full type declaration,
+ -- unless this is the only declaration for the type, eg.
+ -- as a limited record.
+
+ elsif Is_Limited_Type (Param_Type)
+ and then (Nkind (Type_Decl) = N_Private_Type_Declaration
+ or else
+ (Nkind (Type_Decl) = N_Full_Type_Declaration
+ and then not (Has_Private_Declaration (Param_Type))
+ and then Comes_From_Source (N)))
+ then
+
+ -- A limited parameter is legal only if user-specified
+ -- Read and Write attributes exist for it.
+ -- second part of RM E.2.3 (14)
+
+ if No (Full_View (Param_Type))
+ and then Ekind (Param_Type) /= E_Record_Type
+ then
+ -- type does not have completion yet, so if declared in
+ -- in the current RCI scope it is illegal, and will be
+ -- flagged subsequently.
+ return;
+ end if;
+
+ Base_Param_Type := Base_Type (Underlying_Type (Param_Type));
+
+ if No (TSS (Base_Param_Type, Name_uRead))
+ or else No (TSS (Base_Param_Type, Name_uWrite))
+ then
+
+ if K = N_Subprogram_Declaration then
+ Error_Node := Param_Spec;
+ end if;
+
+ Error_Msg_N
+ ("limited parameter in rci unit "
+ & "must have read/write attributes ", Error_Node);
+ end if;
+ end if;
+
+ Next (Param_Spec);
+ end loop;
+ end if;
+ end Validate_RCI_Subprogram_Declaration;
+
+ ----------------------------------------------------
+ -- Validate_Remote_Access_Object_Type_Declaration --
+ ----------------------------------------------------
+
+ procedure Validate_Remote_Access_Object_Type_Declaration (T : Entity_Id) is
+ Direct_Designated_Type : Entity_Id;
+ Desig_Type : Entity_Id;
+ Primitive_Subprograms : Elist_Id;
+ Subprogram : Elmt_Id;
+ Subprogram_Node : Node_Id;
+ Profile : List_Id;
+ Param_Spec : Node_Id;
+ Param_Type : Entity_Id;
+ Limited_Type_Decl : Node_Id;
+
+ begin
+ -- We are called from Analyze_Type_Declaration, and the Nkind
+ -- of the given node is N_Access_To_Object_Definition.
+
+ if not Comes_From_Source (T)
+ or else (not In_RCI_Declaration (Parent (T))
+ and then not In_RT_Declaration)
+ then
+ return;
+ end if;
+
+ -- An access definition in the private part of a Remote Types package
+ -- may be legal if it has user-defined Read and Write attributes. This
+ -- will be checked at the end of the package spec processing.
+
+ if In_RT_Declaration and then In_Private_Part (Scope (T)) then
+ return;
+ end if;
+
+ -- Check RCI unit type declaration. It should not contain the
+ -- declaration of an access-to-object type unless it is a
+ -- general access type that designates a class-wide limited
+ -- private type. There are also constraints about the primitive
+ -- subprograms of the class-wide type (RM E.2.3(14)).
+
+ if Ekind (T) /= E_General_Access_Type
+ or else Ekind (Designated_Type (T)) /= E_Class_Wide_Type
+ then
+ if In_RCI_Declaration (Parent (T)) then
+ Error_Msg_N
+ ("access type in Remote_Call_Interface unit must be " &
+ "general access", T);
+ else
+ Error_Msg_N ("access type in Remote_Types unit must be " &
+ "general access", T);
+ end if;
+ Error_Msg_N ("\to class-wide type", T);
+ return;
+ end if;
+
+ Direct_Designated_Type := Designated_Type (T);
+
+ Desig_Type := Etype (Direct_Designated_Type);
+
+ if not Is_Recursively_Limited_Private (Desig_Type) then
+ Error_Msg_N
+ ("error in designated type of remote access to class-wide type", T);
+ Error_Msg_N
+ ("\must be tagged limited private or private extension of type", T);
+ return;
+ end if;
+
+ Primitive_Subprograms := Primitive_Operations (Desig_Type);
+ Subprogram := First_Elmt (Primitive_Subprograms);
+
+ while Subprogram /= No_Elmt loop
+ Subprogram_Node := Node (Subprogram);
+
+ if not Comes_From_Source (Subprogram_Node) then
+ goto Next_Subprogram;
+ end if;
+
+ Profile := Parameter_Specifications (Parent (Subprogram_Node));
+
+ -- Profile must exist, otherwise not primitive operation
+
+ Param_Spec := First (Profile);
+
+ while Present (Param_Spec) loop
+
+ -- Now find out if this parameter is a controlling parameter
+
+ Param_Type := Parameter_Type (Param_Spec);
+
+ if (Nkind (Param_Type) = N_Access_Definition
+ and then Etype (Subtype_Mark (Param_Type)) = Desig_Type)
+ or else (Nkind (Param_Type) /= N_Access_Definition
+ and then Etype (Param_Type) = Desig_Type)
+ then
+ -- It is a controlling parameter, so specific checks below
+ -- do not apply.
+
+ null;
+
+ elsif
+ Nkind (Param_Type) = N_Access_Definition
+ then
+ -- From RM E.2.2(14), no access parameter other than
+ -- controlling ones may be used.
+
+ Error_Msg_N
+ ("non-controlling access parameter", Param_Spec);
+
+ elsif
+ Is_Limited_Type (Etype (Defining_Identifier (Param_Spec)))
+ then
+ -- Not a controlling parameter, so type must have Read
+ -- and Write attributes.
+ -- ??? I suspect this to be dead code because any violation
+ -- should be caught before in sem_attr.adb (with the message
+ -- "limited type ... used in ... has no stream attr."). ST
+
+ if Nkind (Param_Type) in N_Has_Etype
+ and then Nkind (Parent (Etype (Param_Type))) =
+ N_Private_Type_Declaration
+ then
+ Param_Type := Etype (Param_Type);
+ Limited_Type_Decl := Parent (Param_Type);
+
+ if No (TSS (Param_Type, Name_uRead))
+ or else No (TSS (Param_Type, Name_uWrite))
+ then
+ Error_Msg_N
+ ("limited formal must have Read and Write attributes",
+ Param_Spec);
+ end if;
+ end if;
+ end if;
+
+ -- Check next parameter in this subprogram
+
+ Next (Param_Spec);
+ end loop;
+
+ <<Next_Subprogram>>
+ Next_Elmt (Subprogram);
+ end loop;
+
+ -- Now this is an RCI unit access-to-class-wide-limited-private type
+ -- declaration. Set the type entity to be Is_Remote_Call_Interface to
+ -- optimize later checks by avoiding tree traversal to find out if this
+ -- entity is inside an RCI unit.
+
+ Set_Is_Remote_Call_Interface (T);
+
+ end Validate_Remote_Access_Object_Type_Declaration;
+
+ -----------------------------------------------
+ -- Validate_Remote_Access_To_Class_Wide_Type --
+ -----------------------------------------------
+
+ procedure Validate_Remote_Access_To_Class_Wide_Type (N : Node_Id) is
+ K : constant Node_Kind := Nkind (N);
+ PK : constant Node_Kind := Nkind (Parent (N));
+ E : Entity_Id;
+
+ begin
+ -- This subprogram enforces the checks in (RM E.2.2(8)) for
+ -- certain uses of class-wide limited private types.
+
+ -- Storage_Pool and Storage_Size are not defined for such types
+ --
+ -- The expected type of allocator must not not be such a type.
+
+ -- The actual parameter of generic instantiation must not
+ -- be such a type if the formal parameter is of an access type.
+
+ -- On entry, there are five cases
+
+ -- 1. called from sem_attr Analyze_Attribute where attribute
+ -- name is either Storage_Pool or Storage_Size.
+
+ -- 2. called from exp_ch4 Expand_N_Allocator
+
+ -- 3. called from sem_ch12 Analyze_Associations
+
+ -- 4. called from sem_ch4 Analyze_Explicit_Dereference
+
+ -- 5. called from sem_res Resolve_Actuals
+
+ if K = N_Attribute_Reference then
+ E := Etype (Prefix (N));
+
+ if Is_Remote_Access_To_Class_Wide_Type (E) then
+ Error_Msg_N ("incorrect attribute of remote operand", N);
+ return;
+ end if;
+
+ elsif K = N_Allocator then
+ E := Etype (N);
+
+ if Is_Remote_Access_To_Class_Wide_Type (E) then
+ Error_Msg_N ("incorrect expected remote type of allocator", N);
+ return;
+ end if;
+
+ elsif K in N_Has_Entity then
+ E := Entity (N);
+
+ if Is_Remote_Access_To_Class_Wide_Type (E) then
+ Error_Msg_N ("incorrect remote type generic actual", N);
+ return;
+ end if;
+
+ -- This subprogram also enforces the checks in E.2.2(13).
+ -- A value of such type must not be dereferenced unless as a
+ -- controlling operand of a dispatching call.
+
+ elsif K = N_Explicit_Dereference
+ and then (Comes_From_Source (N)
+ or else (Nkind (Original_Node (N)) = N_Selected_Component
+ and then Comes_From_Source (Original_Node (N))))
+ then
+ E := Etype (Prefix (N));
+
+ -- If the class-wide type is not a remote one, the restrictions
+ -- do not apply.
+
+ if not Is_Remote_Access_To_Class_Wide_Type (E) then
+ return;
+ end if;
+
+ -- If we have a true dereference that comes from source and that
+ -- is a controlling argument for a dispatching call, accept it.
+
+ if K = N_Explicit_Dereference
+ and then Is_Actual_Parameter (N)
+ and then Is_Controlling_Actual (N)
+ then
+ return;
+ end if;
+
+ -- If we are just within a procedure or function call and the
+ -- dereference has not been analyzed, return because this
+ -- procedure will be called again from sem_res Resolve_Actuals.
+
+ if Is_Actual_Parameter (N)
+ and then not Analyzed (N)
+ then
+ return;
+ end if;
+
+ -- The following is to let the compiler generated tags check
+ -- pass through without error message. This is a bit kludgy
+ -- isn't there some better way of making this exclusion ???
+
+ if (PK = N_Selected_Component
+ and then Present (Parent (Parent (N)))
+ and then Nkind (Parent (Parent (N))) = N_Op_Ne)
+ or else (PK = N_Unchecked_Type_Conversion
+ and then Present (Parent (Parent (N)))
+ and then
+ Nkind (Parent (Parent (N))) = N_Selected_Component)
+ then
+ return;
+ end if;
+
+ -- The following code is needed for expansion of RACW Write
+ -- attribute, since such expressions can appear in the expanded
+ -- code.
+
+ if not Comes_From_Source (N)
+ and then
+ (PK = N_In
+ or else PK = N_Attribute_Reference
+ or else
+ (PK = N_Type_Conversion
+ and then Present (Parent (N))
+ and then Present (Parent (Parent (N)))
+ and then
+ Nkind (Parent (Parent (N))) = N_Selected_Component))
+ then
+ return;
+ end if;
+
+ Error_Msg_N ("incorrect remote type dereference", N);
+ end if;
+ end Validate_Remote_Access_To_Class_Wide_Type;
+
+ -----------------------------------------------
+ -- Validate_Remote_Access_To_Subprogram_Type --
+ -----------------------------------------------
+
+ procedure Validate_Remote_Access_To_Subprogram_Type (N : Node_Id) is
+ Type_Def : constant Node_Id := Type_Definition (N);
+ Current_Parameter : Node_Id;
+
+ begin
+ if Present (Parameter_Specifications (Type_Def)) then
+ Current_Parameter := First (Parameter_Specifications (Type_Def));
+ while Present (Current_Parameter) loop
+ if Nkind (Parameter_Type (Current_Parameter)) =
+ N_Access_Definition
+ then
+ Error_Msg_N
+ ("remote access to subprogram type declaration contains",
+ Current_Parameter);
+ Error_Msg_N
+ ("\parameter of an anonymous access type", Current_Parameter);
+ end if;
+
+ Current_Parameter := Next (Current_Parameter);
+ end loop;
+ end if;
+ end Validate_Remote_Access_To_Subprogram_Type;
+
+ ------------------------------------------
+ -- Validate_Remote_Type_Type_Conversion --
+ ------------------------------------------
+
+ procedure Validate_Remote_Type_Type_Conversion (N : Node_Id) is
+ S : constant Entity_Id := Etype (N);
+ E : constant Entity_Id := Etype (Expression (N));
+
+ begin
+ -- This test is required in the case where a conversion appears
+ -- inside a normal package, it does not necessarily have to be
+ -- inside an RCI, Remote_Types unit (RM E.2.2(9,12)).
+
+ if Is_Remote_Access_To_Subprogram_Type (E)
+ and then not Is_Remote_Access_To_Subprogram_Type (S)
+ then
+ Error_Msg_N ("incorrect conversion of remote operand", N);
+ return;
+
+ elsif Is_Remote_Access_To_Class_Wide_Type (E)
+ and then not Is_Remote_Access_To_Class_Wide_Type (S)
+ then
+ Error_Msg_N ("incorrect conversion of remote operand", N);
+ return;
+ end if;
+
+ -- If a local access type is converted into a RACW type, then the
+ -- current unit has a pointer that may now be exported to another
+ -- partition.
+
+ if Is_Remote_Access_To_Class_Wide_Type (S)
+ and then not Is_Remote_Access_To_Class_Wide_Type (E)
+ then
+ Set_Has_RACW (Current_Sem_Unit);
+ end if;
+ end Validate_Remote_Type_Type_Conversion;
+
+ -------------------------------
+ -- Validate_RT_RAT_Component --
+ -------------------------------
+
+ procedure Validate_RT_RAT_Component (N : Node_Id) is
+ Spec : constant Node_Id := Specification (N);
+ Name_U : constant Entity_Id := Defining_Entity (Spec);
+ Typ : Entity_Id;
+ First_Priv_Ent : constant Entity_Id := First_Private_Entity (Name_U);
+ In_Visible_Part : Boolean := True;
+
+ begin
+ if not Is_Remote_Types (Name_U) then
+ return;
+ end if;
+
+ Typ := First_Entity (Name_U);
+ while Present (Typ) loop
+ if In_Visible_Part and then Typ = First_Priv_Ent then
+ In_Visible_Part := False;
+ end if;
+
+ if Comes_From_Source (Typ)
+ and then Is_Type (Typ)
+ and then (In_Visible_Part or else Has_Private_Declaration (Typ))
+ then
+ if Missing_Read_Write_Attributes (Typ) then
+ if Is_Non_Remote_Access_Type (Typ) then
+ Error_Msg_N
+ ("non-remote access type without user-defined Read " &
+ "and Write attributes", Typ);
+ else
+ Error_Msg_N
+ ("record type containing a component of a " &
+ "non-remote access", Typ);
+ Error_Msg_N
+ ("\type without Read and Write attributes " &
+ "('R'M E.2.2(8))", Typ);
+ end if;
+ end if;
+ end if;
+
+ Next_Entity (Typ);
+ end loop;
+ end Validate_RT_RAT_Component;
+
+ -----------------------------------------
+ -- Validate_SP_Access_Object_Type_Decl --
+ -----------------------------------------
+
+ procedure Validate_SP_Access_Object_Type_Decl (T : Entity_Id) is
+ Direct_Designated_Type : Entity_Id;
+
+ function Has_Entry_Declarations (E : Entity_Id) return Boolean;
+ -- Return true if the protected type designated by T has
+ -- entry declarations.
+
+ function Has_Entry_Declarations (E : Entity_Id) return Boolean is
+ Ety : Entity_Id;
+
+ begin
+ if Nkind (Parent (E)) = N_Protected_Type_Declaration then
+ Ety := First_Entity (E);
+ while Present (Ety) loop
+ if Ekind (Ety) = E_Entry then
+ return True;
+ end if;
+
+ Next_Entity (Ety);
+ end loop;
+ end if;
+
+ return False;
+ end Has_Entry_Declarations;
+
+ -- Start of processing for Validate_SP_Access_Object_Type_Decl
+
+ begin
+ -- We are called from Sem_Ch3.Analyze_Type_Declaration, and the
+ -- Nkind of the given entity is N_Access_To_Object_Definition.
+
+ if not Comes_From_Source (T)
+ or else not In_Shared_Passive_Unit
+ or else In_Subprogram_Task_Protected_Unit
+ then
+ return;
+ end if;
+
+ -- Check Shared Passive unit. It should not contain the declaration
+ -- of an access-to-object type whose designated type is a class-wide
+ -- type, task type or protected type with entry (RM E.2.1(7)).
+
+ Direct_Designated_Type := Designated_Type (T);
+
+ if Ekind (Direct_Designated_Type) = E_Class_Wide_Type then
+ Error_Msg_N
+ ("invalid access-to-class-wide type in shared passive unit", T);
+ return;
+
+ elsif Ekind (Direct_Designated_Type) in Task_Kind then
+ Error_Msg_N
+ ("invalid access-to-task type in shared passive unit", T);
+ return;
+
+ elsif Ekind (Direct_Designated_Type) in Protected_Kind
+ and then Has_Entry_Declarations (Direct_Designated_Type)
+ then
+ Error_Msg_N
+ ("invalid access-to-protected type in shared passive unit", T);
+ return;
+ end if;
+ end Validate_SP_Access_Object_Type_Decl;
+
+ ---------------------------------
+ -- Validate_Static_Object_Name --
+ ---------------------------------
+
+ procedure Validate_Static_Object_Name (N : Node_Id) is
+ E : Entity_Id;
+
+ function Is_Primary (N : Node_Id) return Boolean;
+ -- Determine whether node is syntactically a primary in an expression.
+
+ function Is_Primary (N : Node_Id) return Boolean is
+ K : constant Node_Kind := Nkind (Parent (N));
+
+ begin
+ case K is
+
+ when N_Op | N_In | N_Not_In =>
+ return True;
+
+ when N_Aggregate
+ | N_Component_Association
+ | N_Index_Or_Discriminant_Constraint =>
+ return True;
+
+ when N_Attribute_Reference =>
+ return Attribute_Name (Parent (N)) /= Name_Address
+ and then Attribute_Name (Parent (N)) /= Name_Access
+ and then Attribute_Name (Parent (N)) /= Name_Unchecked_Access
+ and then
+ Attribute_Name (Parent (N)) /= Name_Unrestricted_Access;
+
+ when N_Indexed_Component =>
+ return (N /= Prefix (Parent (N))
+ or else Is_Primary (Parent (N)));
+
+ when N_Qualified_Expression | N_Type_Conversion =>
+ return Is_Primary (Parent (N));
+
+ when N_Assignment_Statement | N_Object_Declaration =>
+ return (N = Expression (Parent (N)));
+
+ when N_Selected_Component =>
+ return Is_Primary (Parent (N));
+
+ when others =>
+ return False;
+ end case;
+ end Is_Primary;
+
+ -- Start of processing for Validate_Static_Object_Name
+
+ begin
+ if not In_Preelaborated_Unit
+ or else not Comes_From_Source (N)
+ or else In_Subprogram_Or_Concurrent_Unit
+ or else Ekind (Current_Scope) = E_Block
+ then
+ return;
+
+ -- Filter out cases where primary is default in a component
+ -- declaration, discriminant specification, or actual in a record
+ -- type initialization call.
+
+ -- Initialization call of internal types.
+
+ elsif Nkind (Parent (N)) = N_Procedure_Call_Statement then
+
+ if Present (Parent (Parent (N)))
+ and then Nkind (Parent (Parent (N))) = N_Freeze_Entity
+ then
+ return;
+ end if;
+
+ if Nkind (Name (Parent (N))) = N_Identifier
+ and then not Comes_From_Source (Entity (Name (Parent (N))))
+ then
+ return;
+ end if;
+ end if;
+
+ -- Error if the name is a primary in an expression. The parent must not
+ -- be an operator, or a selected component or an indexed component that
+ -- is itself a primary. Entities that are actuals do not need to be
+ -- checked, because the call itself will be diagnosed.
+
+ if Is_Primary (N)
+ and then (not Inside_A_Generic
+ or else Present (Enclosing_Generic_Body (N)))
+ then
+ if Ekind (Entity (N)) = E_Variable then
+ Error_Msg_N ("non-static object name in preelaborated unit", N);
+
+ -- We take the view that a constant defined in another preelaborated
+ -- unit is preelaborable, even though it may have a private type and
+ -- thus appear non-static in a client. This must be the intent of
+ -- the language, but currently is an RM gap.
+
+ elsif Ekind (Entity (N)) = E_Constant
+ and then not Is_Static_Expression (N)
+ then
+ E := Entity (N);
+
+ if Is_Internal_File_Name (Unit_File_Name (Get_Source_Unit (N)))
+ and then
+ Enclosing_Lib_Unit_Node (N) /= Enclosing_Lib_Unit_Node (E)
+ and then (Is_Preelaborated (Scope (E))
+ or else Is_Pure (Scope (E))
+ or else (Present (Renamed_Object (E))
+ and then
+ Is_Entity_Name (Renamed_Object (E))
+ and then
+ (Is_Preelaborated
+ (Scope (Renamed_Object (E)))
+ or else
+ Is_Pure (Scope
+ (Renamed_Object (E))))))
+ then
+ null;
+ else
+ Error_Msg_N ("non-static constant in preelaborated unit", N);
+ end if;
+ end if;
+ end if;
+ end Validate_Static_Object_Name;
+
+end Sem_Cat;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S E M _ C A T --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.14 $
+-- --
+-- 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). --
+-- --
+------------------------------------------------------------------------------
+
+-- This unit contains the routines used for checking for conformance with
+-- the semantic restrictions required for the categorization pragmas:
+--
+-- Preelaborate
+-- Pure,
+-- Remote_Call_Interface
+-- Remote_Types
+-- Shared_Passive
+--
+-- Note that we treat Preelaborate as a categorization pragma, even though
+-- strictly, according to RM E.2(2,3), the term does not apply in this case.
+
+with Types; use Types;
+
+package Sem_Cat is
+
+ function In_Preelaborated_Unit return Boolean;
+ -- Determines if the current scope is within a preelaborated compilation
+ -- unit, that is one to which one of the pragmas Preelaborate, Pure,
+ -- Shared_Passive, Remote_Types, or inside a unit other than a package
+ -- body with pragma Remote_Call_Interface.
+
+ function In_Pure_Unit return Boolean;
+ pragma Inline (In_Pure_Unit);
+ -- Determines if the current scope is within pure compilation unit,
+ -- that is, one to which the pragmas Pure is applied.
+
+ function In_Subprogram_Task_Protected_Unit return Boolean;
+ -- Determines if the current scope is within a subprogram, task
+ -- or protected unit. Used to validate if the library unit is Pure
+ -- (RM 10.2.1(16)).
+
+ procedure Set_Categorization_From_Pragmas (N : Node_Id);
+ -- Since validation of categorization dependency is done during analyze
+ -- so categorization flags from following pragmas should be set before
+ -- validation begin. N is the N_Compilation_Unit node.
+
+ procedure Validate_Access_Type_Declaration (T : Entity_Id; N : Node_Id);
+ -- Validate all constraints against declaration of access types in
+ -- categorized library units. Usually this is a violation in Pure unit,
+ -- Shared_Passive unit. N is the declaration node.
+
+ procedure Validate_Ancestor_Part (N : Node_Id);
+ -- Checks that a type given as the ancestor in an extension aggregate
+ -- satisfies the restriction of 10.2.1(9).
+
+ procedure Validate_Categorization_Dependency (N : Node_Id; E : Entity_Id);
+ -- There are restrictions on lib unit that semantically depends on other
+ -- units (RM E.2(5), 10.2.1(11). This procedure checks the restrictions
+ -- on categorizations. N is the current unit node, and E is the current
+ -- library unit entity.
+
+ procedure Validate_Controlled_Object (E : Entity_Id);
+ -- Given an entity for a library level controlled object, check that it is
+ -- not in a preelaborated unit (prohibited by RM 10.2.1(9)).
+
+ procedure Validate_Null_Statement_Sequence (N : Node_Id);
+ -- Given N, a package body node, check that a handled statement sequence
+ -- in a preelaborable body contains no statements other than labels or
+ -- null statements, as required by RM 10.2.1(6).
+
+ procedure Validate_Object_Declaration (N : Node_Id);
+ -- Given N, an object declaration node, validates all the constraints in
+ -- a preelaborable library unit, including creation of task objects etc.
+ -- Note that this is called when the corresponding object is frozen since
+ -- the checks cannot be made before knowing if the object is imported.
+
+ procedure Validate_RCI_Declarations (P : Entity_Id);
+ -- Apply semantic checks given in E2.3(10-14).
+
+ procedure Validate_RCI_Subprogram_Declaration (N : Node_Id);
+ -- Check for RCI unit subprogram declarations with respect to
+ -- in-lined subprogram and subprogram with access parameter or
+ -- limited type parameter without Read and Write.
+
+ procedure Validate_Remote_Access_To_Class_Wide_Type (N : Node_Id);
+ -- Checks that Storage_Pool and Storage_Size attribute references are
+ -- not applied to remote access-to-class-wide types. And the expected
+ -- type for an allocator shall not be a remote access-to-class-wide
+ -- type. And a remote access-to-class-wide type shall not be an actual
+ -- parameter for a generic formal access type. RM E.2.3(22).
+
+ procedure Validate_Remote_Access_To_Subprogram_Type (N : Node_Id);
+ -- Checks that a remote access to subprogram type does not have a
+ -- parameter of an access type. This is not strictly forbidden at this
+ -- time, but this is useless, as such a RAS type will not be usable
+ -- per E.2.2(12) and E.2.3(14).
+
+ procedure Validate_RT_RAT_Component (N : Node_Id);
+ -- Given N, the package library unit declaration node, we should check
+ -- against RM:9.95 E.2.2(8): the full view of a type declared in the
+ -- visible part of a Remote Types unit has a part that is of a non-remote
+ -- access type which has no read/write.
+
+ procedure Validate_Remote_Type_Type_Conversion (N : Node_Id);
+ -- Check for remote-type type conversion constraints. First, a value of
+ -- a remote access-to-subprogram type can be converted only to another
+ -- type conformant remote access-to-subprogram type. Secondly, a value
+ -- of a remote access-to-class-wide type can be converted only to another
+ -- remote access-to-class-wide type (RM E.2.3(17,20)).
+
+ procedure Validate_SP_Access_Object_Type_Decl (T : Entity_Id);
+ -- Check validity of declaration if shared passive unit. It should not
+ -- contain the declaration of an access-to-object type whose designated
+ -- type is a class-wide type ,task type or protected type. E.2.1(7).
+ -- T is the entity of the declared type.
+
+ procedure Validate_Static_Object_Name (N : Node_Id);
+ -- In the elaboration code of a preelaborated library unit, check
+ -- that we do not have the evaluation of a primary that is a name of
+ -- an object, unless the name is a static expression (RM 10.2.1(8)).
+ -- Non-static constant and variable are the targets, generic parameters
+ -- are not included because the generic declaration and body are
+ -- preelaborable.
+
+end Sem_Cat;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S E M _ C H 1 0 --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.402 $
+-- --
+-- 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). --
+-- --
+------------------------------------------------------------------------------
+
+with Atree; use Atree;
+with Debug; use Debug;
+with Einfo; use Einfo;
+with Errout; use Errout;
+with Exp_Util; use Exp_Util;
+with Fname; use Fname;
+with Fname.UF; use Fname.UF;
+with Freeze; use Freeze;
+with Impunit; use Impunit;
+with Inline; use Inline;
+with Lib; use Lib;
+with Lib.Load; use Lib.Load;
+with Lib.Xref; use Lib.Xref;
+with Namet; use Namet;
+with Nlists; use Nlists;
+with Nmake; use Nmake;
+with Opt; use Opt;
+with Output; use Output;
+with Restrict; use Restrict;
+with Sem; use Sem;
+with Sem_Ch6; use Sem_Ch6;
+with Sem_Ch7; use Sem_Ch7;
+with Sem_Ch8; use Sem_Ch8;
+with Sem_Dist; use Sem_Dist;
+with Sem_Prag; use Sem_Prag;
+with Sem_Util; use Sem_Util;
+with Sem_Warn; use Sem_Warn;
+with Stand; use Stand;
+with Sinfo; use Sinfo;
+with Sinfo.CN; use Sinfo.CN;
+with Sinput; use Sinput;
+with Snames; use Snames;
+with Style; use Style;
+with Tbuild; use Tbuild;
+with Ttypes; use Ttypes;
+with Uname; use Uname;
+
+package body Sem_Ch10 is
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ procedure Analyze_Context (N : Node_Id);
+ -- Analyzes items in the context clause of compilation unit
+
+ procedure Check_With_Type_Clauses (N : Node_Id);
+ -- If N is a body, verify that any with_type clauses on the spec, or
+ -- on the spec of any parent, have a matching with_clause.
+
+ procedure Check_Private_Child_Unit (N : Node_Id);
+ -- If a with_clause mentions a private child unit, the compilation
+ -- unit must be a member of the same family, as described in 10.1.2 (8).
+
+ procedure Check_Stub_Level (N : Node_Id);
+ -- Verify that a stub is declared immediately within a compilation unit,
+ -- and not in an inner frame.
+
+ procedure Expand_With_Clause (Nam : Node_Id; N : Node_Id);
+ -- When a child unit appears in a context clause, the implicit withs on
+ -- parents are made explicit, and with clauses are inserted in the context
+ -- clause before the one for the child. If a parent in the with_clause
+ -- is a renaming, the implicit with_clause is on the renaming whose name
+ -- is mentioned in the with_clause, and not on the package it renames.
+ -- N is the compilation unit whose list of context items receives the
+ -- implicit with_clauses.
+
+ procedure Implicit_With_On_Parent (Child_Unit : Node_Id; N : Node_Id);
+ -- If the main unit is a child unit, implicit withs are also added for
+ -- all its ancestors.
+
+ procedure Install_Context_Clauses (N : Node_Id);
+ -- Subsidiary to previous one. Process only with_ and use_clauses for
+ -- current unit and its library unit if any.
+
+ procedure Install_Withed_Unit (With_Clause : Node_Id);
+ -- If the unit is not a child unit, make unit immediately visible.
+ -- The caller ensures that the unit is not already currently installed.
+
+ procedure Install_Parents (Lib_Unit : Node_Id; Is_Private : Boolean);
+ -- This procedure establishes the context for the compilation of a child
+ -- unit. If Lib_Unit is a child library spec then the context of the parent
+ -- is installed, and the parent itself made immediately visible, so that
+ -- the child unit is processed in the declarative region of the parent.
+ -- Install_Parents makes a recursive call to itself to ensure that all
+ -- parents are loaded in the nested case. If Lib_Unit is a library body,
+ -- the only effect of Install_Parents is to install the private decls of
+ -- the parents, because the visible parent declarations will have been
+ -- installed as part of the context of the corresponding spec.
+
+ procedure Install_Siblings (U_Name : Entity_Id; N : Node_Id);
+ -- In the compilation of a child unit, a child of any of the ancestor
+ -- units is directly visible if it is visible, because the parent is in
+ -- an enclosing scope. Iterate over context to find child units of U_Name
+ -- or of some ancestor of it.
+
+ function Is_Child_Spec (Lib_Unit : Node_Id) return Boolean;
+ -- Lib_Unit is a library unit which may be a spec or a body. Is_Child_Spec
+ -- returns True if Lib_Unit is a library spec which is a child spec, i.e.
+ -- a library spec that has a parent. If the call to Is_Child_Spec returns
+ -- True, then Parent_Spec (Lib_Unit) is non-Empty and points to the
+ -- compilation unit for the parent spec.
+ --
+ -- Lib_Unit can also be a subprogram body that acts as its own spec. If
+ -- the Parent_Spec is non-empty, this is also a child unit.
+
+ procedure Remove_With_Type_Clause (Name : Node_Id);
+ -- Remove imported type and its enclosing package from visibility, and
+ -- remove attributes of imported type so they don't interfere with its
+ -- analysis (should it appear otherwise in the context).
+
+ procedure Remove_Context_Clauses (N : Node_Id);
+ -- Subsidiary of previous one. Remove use_ and with_clauses.
+
+ procedure Remove_Parents (Lib_Unit : Node_Id);
+ -- Remove_Parents checks if Lib_Unit is a child spec. If so then the parent
+ -- contexts established by the corresponding call to Install_Parents are
+ -- removed. Remove_Parents contains a recursive call to itself to ensure
+ -- that all parents are removed in the nested case.
+
+ procedure Remove_Unit_From_Visibility (Unit_Name : Entity_Id);
+ -- Reset all visibility flags on unit after compiling it, either as a
+ -- main unit or as a unit in the context.
+
+ procedure Analyze_Proper_Body (N : Node_Id; Nam : Entity_Id);
+ -- Common processing for all stubs (subprograms, tasks, packages, and
+ -- protected cases). N is the stub to be analyzed. Once the subunit
+ -- name is established, load and analyze. Nam is the non-overloadable
+ -- entity for which the proper body provides a completion. Subprogram
+ -- stubs are handled differently because they can be declarations.
+
+ ------------------------------
+ -- Analyze_Compilation_Unit --
+ ------------------------------
+
+ procedure Analyze_Compilation_Unit (N : Node_Id) is
+ Unit_Node : constant Node_Id := Unit (N);
+ Lib_Unit : Node_Id := Library_Unit (N);
+ Spec_Id : Node_Id;
+ Main_Cunit : constant Node_Id := Cunit (Main_Unit);
+ Par_Spec_Name : Unit_Name_Type;
+ Unum : Unit_Number_Type;
+
+ procedure Generate_Parent_References (N : Node_Id; P_Id : Entity_Id);
+ -- Generate cross-reference information for the parents of child units.
+ -- N is a defining_program_unit_name, and P_Id is the immediate parent.
+
+ --------------------------------
+ -- Generate_Parent_References --
+ --------------------------------
+
+ procedure Generate_Parent_References (N : Node_Id; P_Id : Entity_Id) is
+ Pref : Node_Id;
+ P_Name : Entity_Id := P_Id;
+
+ begin
+ Pref := Name (Parent (Defining_Entity (N)));
+
+ if Nkind (Pref) = N_Expanded_Name then
+
+ -- Done already, if the unit has been compiled indirectly as
+ -- part of the closure of its context because of inlining.
+
+ return;
+ end if;
+
+ while Nkind (Pref) = N_Selected_Component loop
+ Change_Selected_Component_To_Expanded_Name (Pref);
+ Set_Entity (Pref, P_Name);
+ Set_Etype (Pref, Etype (P_Name));
+ Generate_Reference (P_Name, Pref, 'r');
+ Pref := Prefix (Pref);
+ P_Name := Scope (P_Name);
+ end loop;
+
+ -- The guard here on P_Name is to handle the error condition where
+ -- the parent unit is missing because the file was not found.
+
+ if Present (P_Name) then
+ Set_Entity (Pref, P_Name);
+ Set_Etype (Pref, Etype (P_Name));
+ Generate_Reference (P_Name, Pref, 'r');
+ Style.Check_Identifier (Pref, P_Name);
+ end if;
+ end Generate_Parent_References;
+
+ -- Start of processing for Analyze_Compilation_Unit
+
+ begin
+ Process_Compilation_Unit_Pragmas (N);
+
+ -- If the unit is a subunit whose parent has not been analyzed (which
+ -- indicates that the main unit is a subunit, either the current one or
+ -- one of its descendents) then the subunit is compiled as part of the
+ -- analysis of the parent, which we proceed to do. Basically this gets
+ -- handled from the top down and we don't want to do anything at this
+ -- level (i.e. this subunit will be handled on the way down from the
+ -- parent), so at this level we immediately return. If the subunit
+ -- ends up not analyzed, it means that the parent did not contain a
+ -- stub for it, or that there errors were dectected in some ancestor.
+
+ if Nkind (Unit_Node) = N_Subunit
+ and then not Analyzed (Lib_Unit)
+ then
+ Semantics (Lib_Unit);
+
+ if not Analyzed (Proper_Body (Unit_Node)) then
+ if Errors_Detected > 0 then
+ Error_Msg_N ("subunit not analyzed (errors in parent unit)", N);
+ else
+ Error_Msg_N ("missing stub for subunit", N);
+ end if;
+ end if;
+
+ return;
+ end if;
+
+ -- Analyze context (this will call Sem recursively for with'ed units)
+
+ Analyze_Context (N);
+
+ -- If the unit is a package body, the spec is already loaded and must
+ -- be analyzed first, before we analyze the body.
+
+ if Nkind (Unit_Node) = N_Package_Body then
+
+ -- If no Lib_Unit, then there was a serious previous error, so
+ -- just ignore the entire analysis effort
+
+ if No (Lib_Unit) then
+ return;
+
+ else
+ Semantics (Lib_Unit);
+ Check_Unused_Withs (Get_Cunit_Unit_Number (Lib_Unit));
+
+ -- Verify that the library unit is a package declaration.
+
+ if Nkind (Unit (Lib_Unit)) /= N_Package_Declaration
+ and then
+ Nkind (Unit (Lib_Unit)) /= N_Generic_Package_Declaration
+ then
+ Error_Msg_N
+ ("no legal package declaration for package body", N);
+ return;
+
+ -- Otherwise, the entity in the declaration is visible. Update
+ -- the version to reflect dependence of this body on the spec.
+
+ else
+ Spec_Id := Defining_Entity (Unit (Lib_Unit));
+ Set_Is_Immediately_Visible (Spec_Id, True);
+ Version_Update (N, Lib_Unit);
+
+ if Nkind (Defining_Unit_Name (Unit_Node))
+ = N_Defining_Program_Unit_Name
+ then
+ Generate_Parent_References (Unit_Node, Scope (Spec_Id));
+ end if;
+ end if;
+ end if;
+
+ -- If the unit is a subprogram body, then we similarly need to analyze
+ -- its spec. However, things are a little simpler in this case, because
+ -- here, this analysis is done only for error checking and consistency
+ -- purposes, so there's nothing else to be done.
+
+ elsif Nkind (Unit_Node) = N_Subprogram_Body then
+ if Acts_As_Spec (N) then
+
+ -- If the subprogram body is a child unit, we must create a
+ -- declaration for it, in order to properly load the parent(s).
+ -- After this, the original unit does not acts as a spec, because
+ -- there is an explicit one. If this unit appears in a context
+ -- clause, then an implicit with on the parent will be added when
+ -- installing the context. If this is the main unit, there is no
+ -- Unit_Table entry for the declaration, (It has the unit number
+ -- of the main unit) and code generation is unaffected.
+
+ Unum := Get_Cunit_Unit_Number (N);
+ Par_Spec_Name := Get_Parent_Spec_Name (Unit_Name (Unum));
+
+ if Par_Spec_Name /= No_Name then
+ Unum :=
+ Load_Unit
+ (Load_Name => Par_Spec_Name,
+ Required => True,
+ Subunit => False,
+ Error_Node => N);
+
+ if Unum /= No_Unit then
+
+ -- Build subprogram declaration and attach parent unit to it
+ -- This subprogram declaration does not come from source!
+
+ declare
+ Loc : constant Source_Ptr := Sloc (N);
+ SCS : constant Boolean :=
+ Get_Comes_From_Source_Default;
+
+ begin
+ Set_Comes_From_Source_Default (False);
+ Lib_Unit :=
+ Make_Compilation_Unit (Loc,
+ Context_Items => New_Copy_List (Context_Items (N)),
+ Unit =>
+ Make_Subprogram_Declaration (Sloc (N),
+ Specification =>
+ Copy_Separate_Tree
+ (Specification (Unit_Node))),
+ Aux_Decls_Node =>
+ Make_Compilation_Unit_Aux (Loc));
+
+ Set_Library_Unit (N, Lib_Unit);
+ Set_Parent_Spec (Unit (Lib_Unit), Cunit (Unum));
+ Semantics (Lib_Unit);
+ Set_Acts_As_Spec (N, False);
+ Set_Comes_From_Source_Default (SCS);
+ end;
+ end if;
+ end if;
+
+ -- Here for subprogram with separate declaration
+
+ else
+ Semantics (Lib_Unit);
+ Check_Unused_Withs (Get_Cunit_Unit_Number (Lib_Unit));
+ Version_Update (N, Lib_Unit);
+ end if;
+
+ if Nkind (Defining_Unit_Name (Specification (Unit_Node))) =
+ N_Defining_Program_Unit_Name
+ then
+ Generate_Parent_References (
+ Specification (Unit_Node),
+ Scope (Defining_Entity (Unit (Lib_Unit))));
+ end if;
+ end if;
+
+ -- If it is a child unit, the parent must be elaborated first
+ -- and we update version, since we are dependent on our parent.
+
+ if Is_Child_Spec (Unit_Node) then
+
+ -- The analysis of the parent is done with style checks off
+
+ declare
+ Save_Style_Check : constant Boolean := Opt.Style_Check;
+ Save_C_Restrict : constant Save_Compilation_Unit_Restrictions :=
+ Compilation_Unit_Restrictions_Save;
+
+ begin
+ if not GNAT_Mode then
+ Style_Check := False;
+ end if;
+
+ Semantics (Parent_Spec (Unit_Node));
+ Version_Update (N, Parent_Spec (Unit_Node));
+ Style_Check := Save_Style_Check;
+ Compilation_Unit_Restrictions_Restore (Save_C_Restrict);
+ end;
+ end if;
+
+ -- With the analysis done, install the context. Note that we can't
+ -- install the context from the with clauses as we analyze them,
+ -- because each with clause must be analyzed in a clean visibility
+ -- context, so we have to wait and install them all at once.
+
+ Install_Context (N);
+
+ if Is_Child_Spec (Unit_Node) then
+
+ -- Set the entities of all parents in the program_unit_name.
+
+ Generate_Parent_References (
+ Unit_Node, Defining_Entity (Unit (Parent_Spec (Unit_Node))));
+ end if;
+
+ -- All components of the context: with-clauses, library unit, ancestors
+ -- if any, (and their context) are analyzed and installed. Now analyze
+ -- the unit itself, which is either a package, subprogram spec or body.
+
+ Analyze (Unit_Node);
+
+ -- The above call might have made Unit_Node an N_Subprogram_Body
+ -- from something else, so propagate any Acts_As_Spec flag.
+
+ if Nkind (Unit_Node) = N_Subprogram_Body
+ and then Acts_As_Spec (Unit_Node)
+ then
+ Set_Acts_As_Spec (N);
+ end if;
+
+ -- Treat compilation unit pragmas that appear after the library unit
+
+ if Present (Pragmas_After (Aux_Decls_Node (N))) then
+ declare
+ Prag_Node : Node_Id := First (Pragmas_After (Aux_Decls_Node (N)));
+
+ begin
+ while Present (Prag_Node) loop
+ Analyze (Prag_Node);
+ Next (Prag_Node);
+ end loop;
+ end;
+ end if;
+
+ -- Generate distribution stub files if requested and no error
+
+ if N = Main_Cunit
+ and then (Distribution_Stub_Mode = Generate_Receiver_Stub_Body
+ or else
+ Distribution_Stub_Mode = Generate_Caller_Stub_Body)
+ and then not Fatal_Error (Main_Unit)
+ then
+ if Is_RCI_Pkg_Spec_Or_Body (N) then
+
+ -- Regular RCI package
+
+ Add_Stub_Constructs (N);
+
+ elsif (Nkind (Unit_Node) = N_Package_Declaration
+ and then Is_Shared_Passive (Defining_Entity
+ (Specification (Unit_Node))))
+ or else (Nkind (Unit_Node) = N_Package_Body
+ and then
+ Is_Shared_Passive (Corresponding_Spec (Unit_Node)))
+ then
+ -- Shared passive package
+
+ Add_Stub_Constructs (N);
+
+ elsif Nkind (Unit_Node) = N_Package_Instantiation
+ and then
+ Is_Remote_Call_Interface
+ (Defining_Entity (Specification (Instance_Spec (Unit_Node))))
+ then
+ -- Instantiation of a RCI generic package
+
+ Add_Stub_Constructs (N);
+ end if;
+
+ -- Reanalyze the unit with the new constructs
+
+ Analyze (Unit_Node);
+ end if;
+
+ if Nkind (Unit_Node) = N_Package_Declaration
+ or else Nkind (Unit_Node) in N_Generic_Declaration
+ or else Nkind (Unit_Node) = N_Package_Renaming_Declaration
+ or else Nkind (Unit_Node) = N_Subprogram_Declaration
+ then
+ Remove_Unit_From_Visibility (Defining_Entity (Unit_Node));
+
+ elsif Nkind (Unit_Node) = N_Package_Body
+ or else (Nkind (Unit_Node) = N_Subprogram_Body
+ and then not Acts_As_Spec (Unit_Node))
+ then
+ -- Bodies that are not the main unit are compiled if they
+ -- are generic or contain generic or inlined units. Their
+ -- analysis brings in the context of the corresponding spec
+ -- (unit declaration) which must be removed as well, to
+ -- return the compilation environment to its proper state.
+
+ Remove_Context (Lib_Unit);
+ Set_Is_Immediately_Visible (Defining_Entity (Unit (Lib_Unit)), False);
+ end if;
+
+ -- Last step is to deinstall the context we just installed
+ -- as well as the unit just compiled.
+
+ Remove_Context (N);
+
+ -- If this is the main unit and we are generating code, we must
+ -- check that all generic units in the context have a body if they
+ -- need it, even if they have not been instantiated. In the absence
+ -- of .ali files for generic units, we must force the load of the body,
+ -- just to produce the proper error if the body is absent. We skip this
+ -- verification if the main unit itself is generic.
+
+ if Get_Cunit_Unit_Number (N) = Main_Unit
+ and then Operating_Mode = Generate_Code
+ and then Expander_Active
+ then
+ -- Indicate that the main unit is now analyzed, to catch possible
+ -- circularities between it and generic bodies. Remove main unit
+ -- from visibility. This might seem superfluous, but the main unit
+ -- must not be visible in the generic body expansions that follow.
+
+ Set_Analyzed (N, True);
+ Set_Is_Immediately_Visible (Cunit_Entity (Main_Unit), False);
+
+ declare
+ Item : Node_Id;
+ Nam : Entity_Id;
+ Un : Unit_Number_Type;
+
+ Save_Style_Check : constant Boolean := Opt.Style_Check;
+ Save_C_Restrict : constant Save_Compilation_Unit_Restrictions :=
+ Compilation_Unit_Restrictions_Save;
+
+ begin
+ Item := First (Context_Items (N));
+
+ while Present (Item) loop
+
+ if Nkind (Item) = N_With_Clause
+ and then not Implicit_With (Item)
+ then
+ Nam := Entity (Name (Item));
+
+ if (Ekind (Nam) = E_Generic_Procedure
+ and then not Is_Intrinsic_Subprogram (Nam))
+ or else (Ekind (Nam) = E_Generic_Function
+ and then not Is_Intrinsic_Subprogram (Nam))
+ or else (Ekind (Nam) = E_Generic_Package
+ and then Unit_Requires_Body (Nam))
+ then
+ Opt.Style_Check := False;
+
+ if Present (Renamed_Object (Nam)) then
+ Un :=
+ Load_Unit
+ (Load_Name => Get_Body_Name
+ (Get_Unit_Name
+ (Unit_Declaration_Node
+ (Renamed_Object (Nam)))),
+ Required => False,
+ Subunit => False,
+ Error_Node => N,
+ Renamings => True);
+ else
+ Un :=
+ Load_Unit
+ (Load_Name => Get_Body_Name
+ (Get_Unit_Name (Item)),
+ Required => False,
+ Subunit => False,
+ Error_Node => N,
+ Renamings => True);
+ end if;
+
+ if Un = No_Unit then
+ Error_Msg_NE
+ ("body of generic unit& not found", Item, Nam);
+ exit;
+
+ elsif not Analyzed (Cunit (Un))
+ and then Un /= Main_Unit
+ then
+ Opt.Style_Check := False;
+ Semantics (Cunit (Un));
+ end if;
+ end if;
+ end if;
+
+ Next (Item);
+ end loop;
+
+ Style_Check := Save_Style_Check;
+ Compilation_Unit_Restrictions_Restore (Save_C_Restrict);
+ end;
+ end if;
+
+ -- Deal with creating elaboration Boolean if needed. We create an
+ -- elaboration boolean only for units that come from source since
+ -- units manufactured by the compiler never need elab checks.
+
+ if Comes_From_Source (N)
+ and then
+ (Nkind (Unit (N)) = N_Package_Declaration or else
+ Nkind (Unit (N)) = N_Generic_Package_Declaration or else
+ Nkind (Unit (N)) = N_Subprogram_Declaration or else
+ Nkind (Unit (N)) = N_Generic_Subprogram_Declaration)
+ then
+ declare
+ Loc : constant Source_Ptr := Sloc (N);
+ Unum : constant Unit_Number_Type := Get_Source_Unit (Loc);
+
+ begin
+ Spec_Id := Defining_Entity (Unit (N));
+ Generate_Definition (Spec_Id);
+
+ -- See if an elaboration entity is required for possible
+ -- access before elaboration checking. Note that we must
+ -- allow for this even if -gnatE is not set, since a client
+ -- may be compiled in -gnatE mode and reference the entity.
+
+ -- Case of units which do not require elaboration checks
+
+ if
+ -- Pure units do not need checks
+
+ Is_Pure (Spec_Id)
+
+ -- Preelaborated units do not need checks
+
+ or else Is_Preelaborated (Spec_Id)
+
+ -- No checks needed if pagma Elaborate_Body present
+
+ or else Has_Pragma_Elaborate_Body (Spec_Id)
+
+ -- No checks needed if unit does not require a body
+
+ or else not Unit_Requires_Body (Spec_Id)
+
+ -- No checks needed for predefined files
+
+ or else Is_Predefined_File_Name (Unit_File_Name (Unum))
+
+ -- No checks required if no separate spec
+
+ or else Acts_As_Spec (N)
+ then
+ -- This is a case where we only need the entity for
+ -- checking to prevent multiple elaboration checks.
+
+ Set_Elaboration_Entity_Required (Spec_Id, False);
+
+ -- Case of elaboration entity is required for access before
+ -- elaboration checking (so certainly we must build it!)
+
+ else
+ Set_Elaboration_Entity_Required (Spec_Id, True);
+ end if;
+
+ Build_Elaboration_Entity (N, Spec_Id);
+ end;
+ end if;
+
+ -- Finally, freeze the compilation unit entity. This for sure is needed
+ -- because of some warnings that can be output (see Freeze_Subprogram),
+ -- but may in general be required. If freezing actions result, place
+ -- them in the compilation unit actions list, and analyze them.
+
+ declare
+ Loc : constant Source_Ptr := Sloc (N);
+ L : constant List_Id :=
+ Freeze_Entity (Cunit_Entity (Current_Sem_Unit), Loc);
+
+ begin
+ while Is_Non_Empty_List (L) loop
+ Insert_Library_Level_Action (Remove_Head (L));
+ end loop;
+ end;
+
+ Set_Analyzed (N);
+
+ if Nkind (Unit_Node) = N_Package_Declaration
+ and then Get_Cunit_Unit_Number (N) /= Main_Unit
+ and then Front_End_Inlining
+ and then Expander_Active
+ then
+ Check_Body_For_Inlining (N, Defining_Entity (Unit_Node));
+ end if;
+ end Analyze_Compilation_Unit;
+
+ ---------------------
+ -- Analyze_Context --
+ ---------------------
+
+ procedure Analyze_Context (N : Node_Id) is
+ Item : Node_Id;
+
+ begin
+ -- Loop through context items
+
+ Item := First (Context_Items (N));
+ while Present (Item) loop
+
+ -- For with clause, analyze the with clause, and then update
+ -- the version, since we are dependent on a unit that we with.
+
+ if Nkind (Item) = N_With_Clause then
+
+ -- Skip analyzing with clause if no unit, nothing to do (this
+ -- happens for a with that references a non-existant unit)
+
+ if Present (Library_Unit (Item)) then
+ Analyze (Item);
+ end if;
+
+ if not Implicit_With (Item) then
+ Version_Update (N, Library_Unit (Item));
+ end if;
+
+ -- But skip use clauses at this stage, since we don't want to do
+ -- any installing of potentially use visible entities until we
+ -- we actually install the complete context (in Install_Context).
+ -- Otherwise things can get installed in the wrong context.
+ -- Similarly, pragmas are analyzed in Install_Context, after all
+ -- the implicit with's on parent units are generated.
+
+ else
+ null;
+ end if;
+
+ Next (Item);
+ end loop;
+ end Analyze_Context;
+
+ -------------------------------
+ -- Analyze_Package_Body_Stub --
+ -------------------------------
+
+ procedure Analyze_Package_Body_Stub (N : Node_Id) is
+ Id : constant Entity_Id := Defining_Identifier (N);
+ Nam : Entity_Id;
+
+ begin
+ -- The package declaration must be in the current declarative part.
+
+ Check_Stub_Level (N);
+ Nam := Current_Entity_In_Scope (Id);
+
+ if No (Nam) or else not Is_Package (Nam) then
+ Error_Msg_N ("missing specification for package stub", N);
+
+ elsif Has_Completion (Nam)
+ and then Present (Corresponding_Body (Unit_Declaration_Node (Nam)))
+ then
+ Error_Msg_N ("duplicate or redundant stub for package", N);
+
+ else
+ -- Indicate that the body of the package exists. If we are doing
+ -- only semantic analysis, the stub stands for the body. If we are
+ -- generating code, the existence of the body will be confirmed
+ -- when we load the proper body.
+
+ Set_Has_Completion (Nam);
+ Set_Scope (Defining_Entity (N), Current_Scope);
+ Analyze_Proper_Body (N, Nam);
+ end if;
+ end Analyze_Package_Body_Stub;
+
+ -------------------------
+ -- Analyze_Proper_Body --
+ -------------------------
+
+ procedure Analyze_Proper_Body (N : Node_Id; Nam : Entity_Id) is
+ Subunit_Name : constant Unit_Name_Type := Get_Unit_Name (N);
+ Unum : Unit_Number_Type;
+ Subunit_Not_Found : Boolean := False;
+
+ procedure Optional_Subunit;
+ -- This procedure is called when the main unit is a stub, or when we
+ -- are not generating code. In such a case, we analyze the subunit if
+ -- present, which is user-friendly and in fact required for ASIS, but
+ -- we don't complain if the subunit is missing.
+
+ ----------------------
+ -- Optional_Subunit --
+ ----------------------
+
+ procedure Optional_Subunit is
+ Comp_Unit : Node_Id;
+
+ begin
+ -- Try to load subunit, but ignore any errors that occur during
+ -- the loading of the subunit, by using the special feature in
+ -- Errout to ignore all errors. Note that Fatal_Error will still
+ -- be set, so we will be able to check for this case below.
+
+ Ignore_Errors_Enable := Ignore_Errors_Enable + 1;
+ Unum :=
+ Load_Unit
+ (Load_Name => Subunit_Name,
+ Required => False,
+ Subunit => True,
+ Error_Node => N);
+ Ignore_Errors_Enable := Ignore_Errors_Enable - 1;
+
+ -- All done if we successfully loaded the subunit
+
+ if Unum /= No_Unit and then not Fatal_Error (Unum) then
+ Comp_Unit := Cunit (Unum);
+
+ Set_Corresponding_Stub (Unit (Comp_Unit), N);
+ Analyze_Subunit (Comp_Unit);
+ Set_Library_Unit (N, Comp_Unit);
+
+ elsif Unum = No_Unit
+ and then Present (Nam)
+ then
+ if Is_Protected_Type (Nam) then
+ Set_Corresponding_Body (Parent (Nam), Defining_Identifier (N));
+ else
+ Set_Corresponding_Body (
+ Unit_Declaration_Node (Nam), Defining_Identifier (N));
+ end if;
+ end if;
+ end Optional_Subunit;
+
+ -- Start of processing for Analyze_Proper_Body
+
+ begin
+ -- If the subunit is already loaded, it means that the main unit
+ -- is a subunit, and that the current unit is one of its parents
+ -- which was being analyzed to provide the needed context for the
+ -- analysis of the subunit. In this case we analyze the subunit and
+ -- continue with the parent, without looking a subsequent subunits.
+
+ if Is_Loaded (Subunit_Name) then
+
+ -- If the proper body is already linked to the stub node,
+ -- the stub is in a generic unit and just needs analyzing.
+
+ if Present (Library_Unit (N)) then
+ Set_Corresponding_Stub (Unit (Library_Unit (N)), N);
+ Analyze_Subunit (Library_Unit (N));
+
+ -- Otherwise we must load the subunit and link to it
+
+ else
+ -- Load the subunit, this must work, since we originally
+ -- loaded the subunit earlier on. So this will not really
+ -- load it, just give access to it.
+
+ Unum :=
+ Load_Unit
+ (Load_Name => Subunit_Name,
+ Required => True,
+ Subunit => False,
+ Error_Node => N);
+
+ -- And analyze the subunit in the parent context (note that we
+ -- do not call Semantics, since that would remove the parent
+ -- context). Because of this, we have to manually reset the
+ -- compiler state to Analyzing since it got destroyed by Load.
+
+ if Unum /= No_Unit then
+ Compiler_State := Analyzing;
+ Set_Corresponding_Stub (Unit (Cunit (Unum)), N);
+ Analyze_Subunit (Cunit (Unum));
+ Set_Library_Unit (N, Cunit (Unum));
+ end if;
+ end if;
+
+ -- If the main unit is a subunit, then we are just performing semantic
+ -- analysis on that subunit, and any other subunits of any parent unit
+ -- should be ignored, except that if we are building trees for ASIS
+ -- usage we want to annotate the stub properly.
+
+ elsif Nkind (Unit (Cunit (Main_Unit))) = N_Subunit
+ and then Subunit_Name /= Unit_Name (Main_Unit)
+ then
+ if Tree_Output then
+ Optional_Subunit;
+ end if;
+
+ -- But before we return, set the flag for unloaded subunits. This
+ -- will suppress junk warnings of variables in the same declarative
+ -- part (or a higher level one) that are in danger of looking unused
+ -- when in fact there might be a declaration in the subunit that we
+ -- do not intend to load.
+
+ Unloaded_Subunits := True;
+ return;
+
+ -- If the subunit is not already loaded, and we are generating code,
+ -- then this is the case where compilation started from the parent,
+ -- and we are generating code for an entire subunit tree. In that
+ -- case we definitely need to load the subunit.
+
+ -- In order to continue the analysis with the rest of the parent,
+ -- and other subunits, we load the unit without requiring its
+ -- presence, and emit a warning if not found, rather than terminating
+ -- the compilation abruptly, as for other missing file problems.
+
+ elsif Operating_Mode = Generate_Code then
+
+ -- If the proper body is already linked to the stub node,
+ -- the stub is in a generic unit and just needs analyzing.
+
+ -- We update the version. Although we are not technically
+ -- semantically dependent on the subunit, given our approach
+ -- of macro substitution of subunits, it makes sense to
+ -- include it in the version identification.
+
+ if Present (Library_Unit (N)) then
+ Set_Corresponding_Stub (Unit (Library_Unit (N)), N);
+ Analyze_Subunit (Library_Unit (N));
+ Version_Update (Cunit (Main_Unit), Library_Unit (N));
+
+ -- Otherwise we must load the subunit and link to it
+
+ else
+ Unum :=
+ Load_Unit
+ (Load_Name => Subunit_Name,
+ Required => False,
+ Subunit => True,
+ Error_Node => N);
+
+ if Operating_Mode = Generate_Code
+ and then Unum = No_Unit
+ then
+ Error_Msg_Name_1 := Subunit_Name;
+ Error_Msg_Name_2 :=
+ Get_File_Name (Subunit_Name, Subunit => True);
+ Error_Msg_N
+ ("subunit% in file{ not found!?", N);
+ Subunits_Missing := True;
+ Subunit_Not_Found := True;
+ end if;
+
+ -- Load_Unit may reset Compiler_State, since it may have been
+ -- necessary to parse an additional units, so we make sure
+ -- that we reset it to the Analyzing state.
+
+ Compiler_State := Analyzing;
+
+ if Unum /= No_Unit and then not Fatal_Error (Unum) then
+
+ if Debug_Flag_L then
+ Write_Str ("*** Loaded subunit from stub. Analyze");
+ Write_Eol;
+ end if;
+
+ declare
+ Comp_Unit : constant Node_Id := Cunit (Unum);
+
+ begin
+ -- Check for child unit instead of subunit
+
+ if Nkind (Unit (Comp_Unit)) /= N_Subunit then
+ Error_Msg_N
+ ("expected SEPARATE subunit, found child unit",
+ Cunit_Entity (Unum));
+
+ -- OK, we have a subunit, so go ahead and analyze it,
+ -- and set Scope of entity in stub, for ASIS use.
+
+ else
+ Set_Corresponding_Stub (Unit (Comp_Unit), N);
+ Analyze_Subunit (Comp_Unit);
+ Set_Library_Unit (N, Comp_Unit);
+
+ -- We update the version. Although we are not technically
+ -- semantically dependent on the subunit, given our
+ -- approach of macro substitution of subunits, it makes
+ -- sense to include it in the version identification.
+
+ Version_Update (Cunit (Main_Unit), Comp_Unit);
+ end if;
+ end;
+ end if;
+ end if;
+
+ -- The remaining case is when the subunit is not already loaded and
+ -- we are not generating code. In this case we are just performing
+ -- semantic analysis on the parent, and we are not interested in
+ -- the subunit. For subprograms, analyze the stub as a body. For
+ -- other entities the stub has already been marked as completed.
+
+ else
+ Optional_Subunit;
+ end if;
+
+ end Analyze_Proper_Body;
+
+ ----------------------------------
+ -- Analyze_Protected_Body_Stub --
+ ----------------------------------
+
+ procedure Analyze_Protected_Body_Stub (N : Node_Id) is
+ Nam : Entity_Id := Current_Entity_In_Scope (Defining_Identifier (N));
+
+ begin
+ Check_Stub_Level (N);
+
+ -- First occurence of name may have been as an incomplete type.
+
+ if Present (Nam) and then Ekind (Nam) = E_Incomplete_Type then
+ Nam := Full_View (Nam);
+ end if;
+
+ if No (Nam)
+ or else not Is_Protected_Type (Etype (Nam))
+ then
+ Error_Msg_N ("missing specification for Protected body", N);
+ else
+ Set_Scope (Defining_Entity (N), Current_Scope);
+ Set_Has_Completion (Etype (Nam));
+ Analyze_Proper_Body (N, Etype (Nam));
+ end if;
+ end Analyze_Protected_Body_Stub;
+
+ ----------------------------------
+ -- Analyze_Subprogram_Body_Stub --
+ ----------------------------------
+
+ -- A subprogram body stub can appear with or without a previous
+ -- specification. If there is one, the analysis of the body will
+ -- find it and verify conformance. The formals appearing in the
+ -- specification of the stub play no role, except for requiring an
+ -- additional conformance check. If there is no previous subprogram
+ -- declaration, the stub acts as a spec, and provides the defining
+ -- entity for the subprogram.
+
+ procedure Analyze_Subprogram_Body_Stub (N : Node_Id) is
+ Decl : Node_Id;
+
+ begin
+ Check_Stub_Level (N);
+
+ -- Verify that the identifier for the stub is unique within this
+ -- declarative part.
+
+ if Nkind (Parent (N)) = N_Block_Statement
+ or else Nkind (Parent (N)) = N_Package_Body
+ or else Nkind (Parent (N)) = N_Subprogram_Body
+ then
+ Decl := First (Declarations (Parent (N)));
+
+ while Present (Decl)
+ and then Decl /= N
+ loop
+ if Nkind (Decl) = N_Subprogram_Body_Stub
+ and then (Chars (Defining_Unit_Name (Specification (Decl)))
+ = Chars (Defining_Unit_Name (Specification (N))))
+ then
+ Error_Msg_N ("identifier for stub is not unique", N);
+ end if;
+
+ Next (Decl);
+ end loop;
+ end if;
+
+ -- Treat stub as a body, which checks conformance if there is a previous
+ -- declaration, or else introduces entity and its signature.
+
+ Analyze_Subprogram_Body (N);
+
+ if Errors_Detected = 0 then
+ Analyze_Proper_Body (N, Empty);
+ end if;
+
+ end Analyze_Subprogram_Body_Stub;
+
+ ---------------------
+ -- Analyze_Subunit --
+ ---------------------
+
+ -- A subunit is compiled either by itself (for semantic checking)
+ -- or as part of compiling the parent (for code generation). In
+ -- either case, by the time we actually process the subunit, the
+ -- parent has already been installed and analyzed. The node N is
+ -- a compilation unit, whose context needs to be treated here,
+ -- because we come directly here from the parent without calling
+ -- Analyze_Compilation_Unit.
+
+ -- The compilation context includes the explicit context of the
+ -- subunit, and the context of the parent, together with the parent
+ -- itself. In order to compile the current context, we remove the
+ -- one inherited from the parent, in order to have a clean visibility
+ -- table. We restore the parent context before analyzing the proper
+ -- body itself. On exit, we remove only the explicit context of the
+ -- subunit.
+
+ procedure Analyze_Subunit (N : Node_Id) is
+ Lib_Unit : constant Node_Id := Library_Unit (N);
+ Par_Unit : constant Entity_Id := Current_Scope;
+
+ Lib_Spec : Node_Id := Library_Unit (Lib_Unit);
+ Num_Scopes : Int := 0;
+ Use_Clauses : array (1 .. Scope_Stack.Last) of Node_Id;
+ Enclosing_Child : Entity_Id := Empty;
+
+ procedure Analyze_Subunit_Context;
+ -- Capture names in use clauses of the subunit. This must be done
+ -- before re-installing parent declarations, because items in the
+ -- context must not be hidden by declarations local to the parent.
+
+ procedure Re_Install_Parents (L : Node_Id; Scop : Entity_Id);
+ -- Recursive procedure to restore scope of all ancestors of subunit,
+ -- from outermost in. If parent is not a subunit, the call to install
+ -- context installs context of spec and (if parent is a child unit)
+ -- the context of its parents as well. It is confusing that parents
+ -- should be treated differently in both cases, but the semantics are
+ -- just not identical.
+
+ procedure Re_Install_Use_Clauses;
+ -- As part of the removal of the parent scope, the use clauses are
+ -- removed, to be reinstalled when the context of the subunit has
+ -- been analyzed. Use clauses may also have been affected by the
+ -- analysis of the context of the subunit, so they have to be applied
+ -- again, to insure that the compilation environment of the rest of
+ -- the parent unit is identical.
+
+ procedure Remove_Scope;
+ -- Remove current scope from scope stack, and preserve the list
+ -- of use clauses in it, to be reinstalled after context is analyzed.
+
+ ------------------------------
+ -- Analyze_Subunit_Context --
+ ------------------------------
+
+ procedure Analyze_Subunit_Context is
+ Item : Node_Id;
+ Nam : Node_Id;
+ Unit_Name : Entity_Id;
+
+ begin
+ Analyze_Context (N);
+ Item := First (Context_Items (N));
+
+ -- make withed units immediately visible. If child unit, make the
+ -- ultimate parent immediately visible.
+
+ while Present (Item) loop
+
+ if Nkind (Item) = N_With_Clause then
+ Unit_Name := Entity (Name (Item));
+
+ while Is_Child_Unit (Unit_Name) loop
+ Set_Is_Visible_Child_Unit (Unit_Name);
+ Unit_Name := Scope (Unit_Name);
+ end loop;
+
+ if not Is_Immediately_Visible (Unit_Name) then
+ Set_Is_Immediately_Visible (Unit_Name);
+ Set_Context_Installed (Item);
+ end if;
+
+ elsif Nkind (Item) = N_Use_Package_Clause then
+ Nam := First (Names (Item));
+
+ while Present (Nam) loop
+ Analyze (Nam);
+ Next (Nam);
+ end loop;
+
+ elsif Nkind (Item) = N_Use_Type_Clause then
+ Nam := First (Subtype_Marks (Item));
+
+ while Present (Nam) loop
+ Analyze (Nam);
+ Next (Nam);
+ end loop;
+ end if;
+
+ Next (Item);
+ end loop;
+
+ Item := First (Context_Items (N));
+
+ -- reset visibility of withed units. They will be made visible
+ -- again when we install the subunit context.
+
+ while Present (Item) loop
+
+ if Nkind (Item) = N_With_Clause then
+ Unit_Name := Entity (Name (Item));
+
+ while Is_Child_Unit (Unit_Name) loop
+ Set_Is_Visible_Child_Unit (Unit_Name, False);
+ Unit_Name := Scope (Unit_Name);
+ end loop;
+
+ if Context_Installed (Item) then
+ Set_Is_Immediately_Visible (Unit_Name, False);
+ Set_Context_Installed (Item, False);
+ end if;
+ end if;
+
+ Next (Item);
+ end loop;
+
+ end Analyze_Subunit_Context;
+
+ ------------------------
+ -- Re_Install_Parents --
+ ------------------------
+
+ procedure Re_Install_Parents (L : Node_Id; Scop : Entity_Id) is
+ E : Entity_Id;
+
+ begin
+ if Nkind (Unit (L)) = N_Subunit then
+ Re_Install_Parents (Library_Unit (L), Scope (Scop));
+ end if;
+
+ Install_Context (L);
+
+ -- If the subunit occurs within a child unit, we must restore the
+ -- immediate visibility of any siblings that may occur in context.
+
+ if Present (Enclosing_Child) then
+ Install_Siblings (Enclosing_Child, L);
+ end if;
+
+ New_Scope (Scop);
+
+ if Scop /= Par_Unit then
+ Set_Is_Immediately_Visible (Scop);
+ end if;
+
+ E := First_Entity (Current_Scope);
+
+ while Present (E) loop
+ Set_Is_Immediately_Visible (E);
+ Next_Entity (E);
+ end loop;
+
+ -- A subunit appears within a body, and for a nested subunits
+ -- all the parents are bodies. Restore full visibility of their
+ -- private entities.
+
+ if Ekind (Scop) = E_Package then
+ Set_In_Package_Body (Scop);
+ Install_Private_Declarations (Scop);
+ end if;
+ end Re_Install_Parents;
+
+ ----------------------------
+ -- Re_Install_Use_Clauses --
+ ----------------------------
+
+ procedure Re_Install_Use_Clauses is
+ U : Node_Id;
+
+ begin
+ for J in reverse 1 .. Num_Scopes loop
+ U := Use_Clauses (J);
+ Scope_Stack.Table (Scope_Stack.Last - J + 1).First_Use_Clause := U;
+ Install_Use_Clauses (U);
+ end loop;
+ end Re_Install_Use_Clauses;
+
+ ------------------
+ -- Remove_Scope --
+ ------------------
+
+ procedure Remove_Scope is
+ E : Entity_Id;
+
+ begin
+ Num_Scopes := Num_Scopes + 1;
+ Use_Clauses (Num_Scopes) :=
+ Scope_Stack.Table (Scope_Stack.Last).First_Use_Clause;
+ E := First_Entity (Current_Scope);
+
+ while Present (E) loop
+ Set_Is_Immediately_Visible (E, False);
+ Next_Entity (E);
+ end loop;
+
+ if Is_Child_Unit (Current_Scope) then
+ Enclosing_Child := Current_Scope;
+ end if;
+
+ Pop_Scope;
+ end Remove_Scope;
+
+ -- Start of processing for Analyze_Subunit
+
+ begin
+ if not Is_Empty_List (Context_Items (N)) then
+
+ -- Save current use clauses.
+
+ Remove_Scope;
+ Remove_Context (Lib_Unit);
+
+ -- Now remove parents and their context, including enclosing
+ -- subunits and the outer parent body which is not a subunit.
+
+ if Present (Lib_Spec) then
+ Remove_Context (Lib_Spec);
+
+ while Nkind (Unit (Lib_Spec)) = N_Subunit loop
+ Lib_Spec := Library_Unit (Lib_Spec);
+ Remove_Scope;
+ Remove_Context (Lib_Spec);
+ end loop;
+
+ if Nkind (Unit (Lib_Unit)) = N_Subunit then
+ Remove_Scope;
+ end if;
+
+ if Nkind (Unit (Lib_Spec)) = N_Package_Body then
+ Remove_Context (Library_Unit (Lib_Spec));
+ end if;
+ end if;
+
+ Analyze_Subunit_Context;
+ Re_Install_Parents (Lib_Unit, Par_Unit);
+
+ -- If the context includes a child unit of the parent of the
+ -- subunit, the parent will have been removed from visibility,
+ -- after compiling that cousin in the context. The visibility
+ -- of the parent must be restored now. This also applies if the
+ -- context includes another subunit of the same parent which in
+ -- turn includes a child unit in its context.
+
+ if Ekind (Par_Unit) = E_Package then
+ if not Is_Immediately_Visible (Par_Unit)
+ or else (Present (First_Entity (Par_Unit))
+ and then not Is_Immediately_Visible
+ (First_Entity (Par_Unit)))
+ then
+ Set_Is_Immediately_Visible (Par_Unit);
+ Install_Visible_Declarations (Par_Unit);
+ Install_Private_Declarations (Par_Unit);
+ end if;
+ end if;
+
+ Re_Install_Use_Clauses;
+ Install_Context (N);
+
+ -- If the subunit is within a child unit, then siblings of any
+ -- parent unit that appear in the context clause of the subunit
+ -- must also be made immediately visible.
+
+ if Present (Enclosing_Child) then
+ Install_Siblings (Enclosing_Child, N);
+ end if;
+
+ end if;
+
+ Analyze (Proper_Body (Unit (N)));
+ Remove_Context (N);
+
+ end Analyze_Subunit;
+
+ ----------------------------
+ -- Analyze_Task_Body_Stub --
+ ----------------------------
+
+ procedure Analyze_Task_Body_Stub (N : Node_Id) is
+ Nam : Entity_Id := Current_Entity_In_Scope (Defining_Identifier (N));
+ Loc : constant Source_Ptr := Sloc (N);
+
+ begin
+ Check_Stub_Level (N);
+
+ -- First occurence of name may have been as an incomplete type.
+
+ if Present (Nam) and then Ekind (Nam) = E_Incomplete_Type then
+ Nam := Full_View (Nam);
+ end if;
+
+ if No (Nam)
+ or else not Is_Task_Type (Etype (Nam))
+ then
+ Error_Msg_N ("missing specification for task body", N);
+ else
+ Set_Scope (Defining_Entity (N), Current_Scope);
+ Set_Has_Completion (Etype (Nam));
+ Analyze_Proper_Body (N, Etype (Nam));
+
+ -- Set elaboration flag to indicate that entity is callable.
+ -- This cannot be done in the expansion of the body itself,
+ -- because the proper body is not in a declarative part. This
+ -- is only done if expansion is active, because the context
+ -- may be generic and the flag not defined yet.
+
+ if Expander_Active then
+ Insert_After (N,
+ Make_Assignment_Statement (Loc,
+ Name =>
+ Make_Identifier (Loc,
+ New_External_Name (Chars (Etype (Nam)), 'E')),
+ Expression => New_Reference_To (Standard_True, Loc)));
+ end if;
+
+ end if;
+ end Analyze_Task_Body_Stub;
+
+ -------------------------
+ -- Analyze_With_Clause --
+ -------------------------
+
+ -- Analyze the declaration of a unit in a with clause. At end,
+ -- label the with clause with the defining entity for the unit.
+
+ procedure Analyze_With_Clause (N : Node_Id) is
+ Unit_Kind : constant Node_Kind := Nkind (Unit (Library_Unit (N)));
+ E_Name : Entity_Id;
+ Par_Name : Entity_Id;
+ Pref : Node_Id;
+ U : Node_Id;
+
+ Intunit : Boolean;
+ -- Set True if the unit currently being compiled is an internal unit
+
+ Save_Style_Check : constant Boolean := Opt.Style_Check;
+ Save_C_Restrict : constant Save_Compilation_Unit_Restrictions :=
+ Compilation_Unit_Restrictions_Save;
+
+ begin
+ -- We reset ordinary style checking during the analysis of a with'ed
+ -- unit, but we do NOT reset GNAT special analysis mode (the latter
+ -- definitely *does* apply to with'ed units).
+
+ if not GNAT_Mode then
+ Style_Check := False;
+ end if;
+
+ -- If the library unit is a predefined unit, and we are in no
+ -- run time mode, then temporarily reset No_Run_Time mode for the
+ -- analysis of the with'ed unit. The No_Run_Time pragma does not
+ -- prevent explicit with'ing of run-time units.
+
+ if No_Run_Time
+ and then
+ Is_Predefined_File_Name
+ (Unit_File_Name (Get_Source_Unit (Unit (Library_Unit (N)))))
+ then
+ No_Run_Time := False;
+ Semantics (Library_Unit (N));
+ No_Run_Time := True;
+
+ else
+ Semantics (Library_Unit (N));
+ end if;
+
+ U := Unit (Library_Unit (N));
+ Intunit := Is_Internal_File_Name (Unit_File_Name (Current_Sem_Unit));
+
+ -- Following checks are skipped for dummy packages (those supplied
+ -- for with's where no matching file could be found). Such packages
+ -- are identified by the Sloc value being set to No_Location
+
+ if Sloc (U) /= No_Location then
+
+ -- Check restrictions, except that we skip the check if this
+ -- is an internal unit unless we are compiling the internal
+ -- unit as the main unit. We also skip this for dummy packages.
+
+ if not Intunit or else Current_Sem_Unit = Main_Unit then
+ Check_Restricted_Unit (Unit_Name (Get_Source_Unit (U)), N);
+ end if;
+
+ -- Check for inappropriate with of internal implementation unit
+ -- if we are currently compiling the main unit and the main unit
+ -- is itself not an internal unit.
+
+ if Implementation_Unit_Warnings
+ and then Current_Sem_Unit = Main_Unit
+ and then Implementation_Unit (Get_Source_Unit (U))
+ and then not Intunit
+ then
+ Error_Msg_N ("& is an internal 'G'N'A'T unit?", Name (N));
+ Error_Msg_N
+ ("\use of this unit is non-portable and version-dependent?",
+ Name (N));
+ end if;
+ end if;
+
+ -- Semantic analysis of a generic unit is performed on a copy of
+ -- the original tree. Retrieve the entity on which semantic info
+ -- actually appears.
+
+ if Unit_Kind in N_Generic_Declaration then
+ E_Name := Defining_Entity (U);
+
+ -- Note: in the following test, Unit_Kind is the original Nkind, but
+ -- in the case of an instantiation, the call to Semantics above will
+ -- have replaced the unit by its instantiated version.
+
+ elsif Unit_Kind = N_Package_Instantiation
+ and then Nkind (U) = N_Package_Body
+ then
+ -- Instantiation node is replaced with body of instance.
+ -- Unit name is defining unit name in corresponding spec.
+
+ E_Name := Corresponding_Spec (U);
+
+ elsif Unit_Kind = N_Package_Instantiation
+ and then Nkind (U) = N_Package_Instantiation
+ then
+ -- If the instance has not been rewritten as a package declaration,
+ -- then it appeared already in a previous with clause. Retrieve
+ -- the entity from the previous instance.
+
+ E_Name := Defining_Entity (Specification (Instance_Spec (U)));
+
+ elsif Unit_Kind = N_Procedure_Instantiation
+ or else Unit_Kind = N_Function_Instantiation
+ then
+ -- Instantiation node is replaced with a package that contains
+ -- renaming declarations and instance itself. The subprogram
+ -- Instance is declared in the visible part of the wrapper package.
+
+ E_Name := First_Entity (Defining_Entity (U));
+
+ while Present (E_Name) loop
+ exit when Is_Subprogram (E_Name)
+ and then Is_Generic_Instance (E_Name);
+ E_Name := Next_Entity (E_Name);
+ end loop;
+
+ elsif Unit_Kind = N_Package_Renaming_Declaration
+ or else Unit_Kind in N_Generic_Renaming_Declaration
+ then
+ E_Name := Defining_Entity (U);
+
+ elsif Unit_Kind = N_Subprogram_Body
+ and then Nkind (Name (N)) = N_Selected_Component
+ and then not Acts_As_Spec (Library_Unit (N))
+ then
+ -- For a child unit that has no spec, one has been created and
+ -- analyzed. The entity required is that of the spec.
+
+ E_Name := Corresponding_Spec (U);
+
+ else
+ E_Name := Defining_Entity (U);
+ end if;
+
+ if Nkind (Name (N)) = N_Selected_Component then
+
+ -- Child unit in a with clause
+
+ Change_Selected_Component_To_Expanded_Name (Name (N));
+ end if;
+
+ -- Restore style checks and restrictions
+
+ Style_Check := Save_Style_Check;
+ Compilation_Unit_Restrictions_Restore (Save_C_Restrict);
+
+ -- Record the reference, but do NOT set the unit as referenced, we
+ -- want to consider the unit as unreferenced if this is the only
+ -- reference that occurs.
+
+ Set_Entity_With_Style_Check (Name (N), E_Name);
+ Generate_Reference (E_Name, Name (N), Set_Ref => False);
+
+ if Is_Child_Unit (E_Name) then
+ Pref := Prefix (Name (N));
+ Par_Name := Scope (E_Name);
+
+ while Nkind (Pref) = N_Selected_Component loop
+ Change_Selected_Component_To_Expanded_Name (Pref);
+ Set_Entity_With_Style_Check (Pref, Par_Name);
+
+ Generate_Reference (Par_Name, Pref);
+ Pref := Prefix (Pref);
+ Par_Name := Scope (Par_Name);
+ end loop;
+
+ if Present (Entity (Pref))
+ and then not Analyzed (Parent (Parent (Entity (Pref))))
+ then
+ -- If the entity is set without its unit being compiled,
+ -- the original parent is a renaming, and Par_Name is the
+ -- renamed entity. For visibility purposes, we need the
+ -- original entity, which must be analyzed now, because
+ -- Load_Unit retrieves directly the renamed unit, and the
+ -- renaming declaration itself has not been analyzed.
+
+ Analyze (Parent (Parent (Entity (Pref))));
+ pragma Assert (Renamed_Object (Entity (Pref)) = Par_Name);
+ Par_Name := Entity (Pref);
+ end if;
+
+ Set_Entity_With_Style_Check (Pref, Par_Name);
+ Generate_Reference (Par_Name, Pref);
+ end if;
+
+ -- If the withed unit is System, and a system extension pragma is
+ -- present, compile the extension now, rather than waiting for
+ -- a visibility check on a specific entity.
+
+ if Chars (E_Name) = Name_System
+ and then Scope (E_Name) = Standard_Standard
+ and then Present (System_Extend_Pragma_Arg)
+ and then Present_System_Aux (N)
+ then
+ -- If the extension is not present, an error will have been emitted.
+
+ null;
+ end if;
+ end Analyze_With_Clause;
+
+ ------------------------------
+ -- Analyze_With_Type_Clause --
+ ------------------------------
+
+ procedure Analyze_With_Type_Clause (N : Node_Id) is
+ Loc : constant Source_Ptr := Sloc (N);
+ Nam : Node_Id := Name (N);
+ Pack : Node_Id;
+ Decl : Node_Id;
+ P : Entity_Id;
+ Unum : Unit_Number_Type;
+ Sel : Node_Id;
+
+ procedure Decorate_Tagged_Type (T : Entity_Id; Kind : Entity_Kind);
+ -- Set basic attributes of type, including its class_wide type.
+
+ function In_Chain (E : Entity_Id) return Boolean;
+ -- Check that the imported type is not already in the homonym chain,
+ -- for example through a with_type clause in a parent unit.
+
+ --------------------------
+ -- Decorate_Tagged_Type --
+ --------------------------
+
+ procedure Decorate_Tagged_Type (T : Entity_Id; Kind : Entity_Kind) is
+ CW : Entity_Id;
+
+ begin
+ Set_Ekind (T, E_Record_Type);
+ Set_Is_Tagged_Type (T);
+ Set_Etype (T, T);
+ Set_From_With_Type (T);
+ Set_Scope (T, P);
+
+ if not In_Chain (T) then
+ Set_Homonym (T, Current_Entity (T));
+ Set_Current_Entity (T);
+ end if;
+
+ -- Build bogus class_wide type, if not previously done.
+
+ if No (Class_Wide_Type (T)) then
+ CW := Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
+
+ Set_Ekind (CW, E_Class_Wide_Type);
+ Set_Etype (CW, T);
+ Set_Scope (CW, P);
+ Set_Is_Tagged_Type (CW);
+ Set_Is_First_Subtype (CW, True);
+ Init_Size_Align (CW);
+ Set_Has_Unknown_Discriminants
+ (CW, True);
+ Set_Class_Wide_Type (CW, CW);
+ Set_Equivalent_Type (CW, Empty);
+ Set_From_With_Type (CW);
+
+ Set_Class_Wide_Type (T, CW);
+ end if;
+ end Decorate_Tagged_Type;
+
+ --------------
+ -- In_Chain --
+ --------------
+
+ function In_Chain (E : Entity_Id) return Boolean is
+ H : Entity_Id := Current_Entity (E);
+
+ begin
+ while Present (H) loop
+
+ if H = E then
+ return True;
+ else
+ H := Homonym (H);
+ end if;
+ end loop;
+
+ return False;
+ end In_Chain;
+
+ -- Start of processing for Analyze_With_Type_Clause
+
+ begin
+ if Nkind (Nam) = N_Selected_Component then
+ Pack := New_Copy_Tree (Prefix (Nam));
+ Sel := Selector_Name (Nam);
+
+ else
+ Error_Msg_N ("illegal name for imported type", Nam);
+ return;
+ end if;
+
+ Decl :=
+ Make_Package_Declaration (Loc,
+ Specification =>
+ (Make_Package_Specification (Loc,
+ Defining_Unit_Name => Pack,
+ Visible_Declarations => New_List,
+ End_Label => Empty)));
+
+ Unum :=
+ Load_Unit
+ (Load_Name => Get_Unit_Name (Decl),
+ Required => True,
+ Subunit => False,
+ Error_Node => Nam);
+
+ if Unum = No_Unit
+ or else Nkind (Unit (Cunit (Unum))) /= N_Package_Declaration
+ then
+ Error_Msg_N ("imported type must be declared in package", Nam);
+ return;
+
+ elsif Unum = Current_Sem_Unit then
+
+ -- If type is defined in unit being analyzed, then the clause
+ -- is redundant.
+
+ return;
+
+ else
+ P := Cunit_Entity (Unum);
+ end if;
+
+ -- Find declaration for imported type, and set its basic attributes
+ -- if it has not been analyzed (which will be the case if there is
+ -- circular dependence).
+
+ declare
+ Decl : Node_Id;
+ Typ : Entity_Id;
+
+ begin
+ if not Analyzed (Cunit (Unum))
+ and then not From_With_Type (P)
+ then
+ Set_Ekind (P, E_Package);
+ Set_Etype (P, Standard_Void_Type);
+ Set_From_With_Type (P);
+ Set_Scope (P, Standard_Standard);
+ Set_Homonym (P, Current_Entity (P));
+ Set_Current_Entity (P);
+
+ elsif Analyzed (Cunit (Unum))
+ and then Is_Child_Unit (P)
+ then
+ -- If the child unit is already in scope, indicate that it is
+ -- visible, and remains so after intervening calls to rtsfind.
+
+ Set_Is_Visible_Child_Unit (P);
+ end if;
+
+ if Nkind (Parent (P)) = N_Defining_Program_Unit_Name then
+
+ -- Make parent packages visible.
+
+ declare
+ Parent_Comp : Node_Id;
+ Parent_Id : Entity_Id;
+ Child : Entity_Id;
+
+ begin
+ Child := P;
+ Parent_Comp := Parent_Spec (Unit (Cunit (Unum)));
+
+ loop
+ Parent_Id := Defining_Entity (Unit (Parent_Comp));
+ Set_Scope (Child, Parent_Id);
+
+ -- The type may be imported from a child unit, in which
+ -- case the current compilation appears in the name. Do
+ -- not change its visibility here because it will conflict
+ -- with the subsequent normal processing.
+
+ if not Analyzed (Unit_Declaration_Node (Parent_Id))
+ and then Parent_Id /= Cunit_Entity (Current_Sem_Unit)
+ then
+ Set_Ekind (Parent_Id, E_Package);
+ Set_Etype (Parent_Id, Standard_Void_Type);
+
+ -- The same package may appear is several with_type
+ -- clauses.
+
+ if not From_With_Type (Parent_Id) then
+ Set_Homonym (Parent_Id, Current_Entity (Parent_Id));
+ Set_Current_Entity (Parent_Id);
+ Set_From_With_Type (Parent_Id);
+ end if;
+ end if;
+
+ Set_Is_Immediately_Visible (Parent_Id);
+
+ Child := Parent_Id;
+ Parent_Comp := Parent_Spec (Unit (Parent_Comp));
+ exit when No (Parent_Comp);
+ end loop;
+
+ Set_Scope (Parent_Id, Standard_Standard);
+ end;
+ end if;
+
+ -- Even if analyzed, the package may not be currently visible. It
+ -- must be while the with_type clause is active.
+
+ Set_Is_Immediately_Visible (P);
+
+ Decl :=
+ First (Visible_Declarations (Specification (Unit (Cunit (Unum)))));
+
+ while Present (Decl) loop
+
+ if Nkind (Decl) = N_Full_Type_Declaration
+ and then Chars (Defining_Identifier (Decl)) = Chars (Sel)
+ then
+ Typ := Defining_Identifier (Decl);
+
+ if Tagged_Present (N) then
+
+ -- The declaration must indicate that this is a tagged
+ -- type or a type extension.
+
+ if (Nkind (Type_Definition (Decl)) = N_Record_Definition
+ and then Tagged_Present (Type_Definition (Decl)))
+ or else
+ (Nkind (Type_Definition (Decl))
+ = N_Derived_Type_Definition
+ and then Present
+ (Record_Extension_Part (Type_Definition (Decl))))
+ then
+ null;
+ else
+ Error_Msg_N ("imported type is not a tagged type", Nam);
+ return;
+ end if;
+
+ if not Analyzed (Decl) then
+
+ -- Unit is not currently visible. Add basic attributes
+ -- to type and build its class-wide type.
+
+ Init_Size_Align (Typ);
+ Decorate_Tagged_Type (Typ, E_Record_Type);
+ end if;
+
+ else
+ if Nkind (Type_Definition (Decl))
+ /= N_Access_To_Object_Definition
+ then
+ Error_Msg_N
+ ("imported type is not an access type", Nam);
+
+ elsif not Analyzed (Decl) then
+ Set_Ekind (Typ, E_Access_Type);
+ Set_Etype (Typ, Typ);
+ Set_Scope (Typ, P);
+ Init_Size (Typ, System_Address_Size);
+ Init_Alignment (Typ);
+ Set_Directly_Designated_Type (Typ, Standard_Integer);
+ Set_From_With_Type (Typ);
+
+ if not In_Chain (Typ) then
+ Set_Homonym (Typ, Current_Entity (Typ));
+ Set_Current_Entity (Typ);
+ end if;
+ end if;
+ end if;
+
+ Set_Entity (Sel, Typ);
+ return;
+
+ elsif ((Nkind (Decl) = N_Private_Type_Declaration
+ and then Tagged_Present (Decl))
+ or else (Nkind (Decl) = N_Private_Extension_Declaration))
+ and then Chars (Defining_Identifier (Decl)) = Chars (Sel)
+ then
+ Typ := Defining_Identifier (Decl);
+
+ if not Tagged_Present (N) then
+ Error_Msg_N ("type must be declared tagged", N);
+
+ elsif not Analyzed (Decl) then
+ Decorate_Tagged_Type (Typ, E_Private_Type);
+ end if;
+
+ Set_Entity (Sel, Typ);
+ Set_From_With_Type (Typ);
+ return;
+ end if;
+
+ Decl := Next (Decl);
+ end loop;
+
+ Error_Msg_NE ("not a visible access or tagged type in&", Nam, P);
+ end;
+ end Analyze_With_Type_Clause;
+
+ -----------------------------
+ -- Check_With_Type_Clauses --
+ -----------------------------
+
+ procedure Check_With_Type_Clauses (N : Node_Id) is
+ Lib_Unit : constant Node_Id := Unit (N);
+
+ procedure Check_Parent_Context (U : Node_Id);
+ -- Examine context items of parent unit to locate with_type clauses.
+
+ --------------------------
+ -- Check_Parent_Context --
+ --------------------------
+
+ procedure Check_Parent_Context (U : Node_Id) is
+ Item : Node_Id;
+
+ begin
+ Item := First (Context_Items (U));
+ while Present (Item) loop
+ if Nkind (Item) = N_With_Type_Clause
+ and then not Error_Posted (Item)
+ and then
+ From_With_Type (Scope (Entity (Selector_Name (Name (Item)))))
+ then
+ Error_Msg_Sloc := Sloc (Item);
+ Error_Msg_N ("Missing With_Clause for With_Type_Clause#", N);
+ end if;
+
+ Next (Item);
+ end loop;
+ end Check_Parent_Context;
+
+ -- Start of processing for Check_With_Type_Clauses
+
+ begin
+ if Extensions_Allowed
+ and then (Nkind (Lib_Unit) = N_Package_Body
+ or else Nkind (Lib_Unit) = N_Subprogram_Body)
+ then
+ Check_Parent_Context (Library_Unit (N));
+ if Is_Child_Spec (Unit (Library_Unit (N))) then
+ Check_Parent_Context (Parent_Spec (Unit (Library_Unit (N))));
+ end if;
+ end if;
+ end Check_With_Type_Clauses;
+
+ ------------------------------
+ -- Check_Private_Child_Unit --
+ ------------------------------
+
+ procedure Check_Private_Child_Unit (N : Node_Id) is
+ Lib_Unit : constant Node_Id := Unit (N);
+ Item : Node_Id;
+ Curr_Unit : Entity_Id;
+ Sub_Parent : Node_Id;
+ Priv_Child : Entity_Id;
+ Par_Lib : Entity_Id;
+ Par_Spec : Node_Id;
+
+ function Is_Private_Library_Unit (Unit : Entity_Id) return Boolean;
+ -- Returns true if and only if the library unit is declared with
+ -- an explicit designation of private.
+
+ function Is_Private_Library_Unit (Unit : Entity_Id) return Boolean is
+ begin
+ return Private_Present (Parent (Unit_Declaration_Node (Unit)));
+ end Is_Private_Library_Unit;
+
+ -- Start of processing for Check_Private_Child_Unit
+
+ begin
+ if Nkind (Lib_Unit) = N_Package_Body
+ or else Nkind (Lib_Unit) = N_Subprogram_Body
+ then
+ Curr_Unit := Defining_Entity (Unit (Library_Unit (N)));
+ Par_Lib := Curr_Unit;
+
+ elsif Nkind (Lib_Unit) = N_Subunit then
+
+ -- The parent is itself a body. The parent entity is to be found
+ -- in the corresponding spec.
+
+ Sub_Parent := Library_Unit (N);
+ Curr_Unit := Defining_Entity (Unit (Library_Unit (Sub_Parent)));
+
+ -- If the parent itself is a subunit, Curr_Unit is the entity
+ -- of the enclosing body, retrieve the spec entity which is
+ -- the proper ancestor we need for the following tests.
+
+ if Ekind (Curr_Unit) = E_Package_Body then
+ Curr_Unit := Spec_Entity (Curr_Unit);
+ end if;
+
+ Par_Lib := Curr_Unit;
+
+ else
+ Curr_Unit := Defining_Entity (Lib_Unit);
+
+ Par_Lib := Curr_Unit;
+ Par_Spec := Parent_Spec (Lib_Unit);
+
+ if No (Par_Spec) then
+ Par_Lib := Empty;
+ else
+ Par_Lib := Defining_Entity (Unit (Par_Spec));
+ end if;
+ end if;
+
+ -- Loop through context items
+
+ Item := First (Context_Items (N));
+ while Present (Item) loop
+
+ if Nkind (Item) = N_With_Clause
+ and then not Implicit_With (Item)
+ and then Is_Private_Descendant (Entity (Name (Item)))
+ then
+ Priv_Child := Entity (Name (Item));
+
+ declare
+ Curr_Parent : Entity_Id := Par_Lib;
+ Child_Parent : Entity_Id := Scope (Priv_Child);
+ Prv_Ancestor : Entity_Id := Child_Parent;
+ Curr_Private : Boolean := Is_Private_Library_Unit (Curr_Unit);
+
+ begin
+ -- If the child unit is a public child then locate
+ -- the nearest private ancestor; Child_Parent will
+ -- then be set to the parent of that ancestor.
+
+ if not Is_Private_Library_Unit (Priv_Child) then
+ while Present (Prv_Ancestor)
+ and then not Is_Private_Library_Unit (Prv_Ancestor)
+ loop
+ Prv_Ancestor := Scope (Prv_Ancestor);
+ end loop;
+
+ if Present (Prv_Ancestor) then
+ Child_Parent := Scope (Prv_Ancestor);
+ end if;
+ end if;
+
+ while Present (Curr_Parent)
+ and then Curr_Parent /= Standard_Standard
+ and then Curr_Parent /= Child_Parent
+ loop
+ Curr_Private :=
+ Curr_Private or else Is_Private_Library_Unit (Curr_Parent);
+ Curr_Parent := Scope (Curr_Parent);
+ end loop;
+
+ if not Present (Curr_Parent) then
+ Curr_Parent := Standard_Standard;
+ end if;
+
+ if Curr_Parent /= Child_Parent then
+
+ if Ekind (Priv_Child) = E_Generic_Package
+ and then Chars (Priv_Child) in Text_IO_Package_Name
+ and then Chars (Scope (Scope (Priv_Child))) = Name_Ada
+ then
+ Error_Msg_NE
+ ("& is a nested package, not a compilation unit",
+ Name (Item), Priv_Child);
+
+ else
+ Error_Msg_N
+ ("unit in with clause is private child unit!", Item);
+ Error_Msg_NE
+ ("current unit must also have parent&!",
+ Item, Child_Parent);
+ end if;
+
+ elsif not Curr_Private
+ and then Nkind (Lib_Unit) /= N_Package_Body
+ and then Nkind (Lib_Unit) /= N_Subprogram_Body
+ and then Nkind (Lib_Unit) /= N_Subunit
+ then
+ Error_Msg_NE
+ ("current unit must also be private descendant of&",
+ Item, Child_Parent);
+ end if;
+ end;
+ end if;
+
+ Next (Item);
+ end loop;
+
+ end Check_Private_Child_Unit;
+
+ ----------------------
+ -- Check_Stub_Level --
+ ----------------------
+
+ procedure Check_Stub_Level (N : Node_Id) is
+ Par : constant Node_Id := Parent (N);
+ Kind : constant Node_Kind := Nkind (Par);
+
+ begin
+ if (Kind = N_Package_Body
+ or else Kind = N_Subprogram_Body
+ or else Kind = N_Task_Body
+ or else Kind = N_Protected_Body)
+
+ and then (Nkind (Parent (Par)) = N_Compilation_Unit
+ or else Nkind (Parent (Par)) = N_Subunit)
+ then
+ null;
+
+ -- In an instance, a missing stub appears at any level. A warning
+ -- message will have been emitted already for the missing file.
+
+ elsif not In_Instance then
+ Error_Msg_N ("stub cannot appear in an inner scope", N);
+
+ elsif Expander_Active then
+ Error_Msg_N ("missing proper body", N);
+ end if;
+ end Check_Stub_Level;
+
+ ------------------------
+ -- Expand_With_Clause --
+ ------------------------
+
+ procedure Expand_With_Clause (Nam : Node_Id; N : Node_Id) is
+ Loc : constant Source_Ptr := Sloc (Nam);
+ Ent : constant Entity_Id := Entity (Nam);
+ Withn : Node_Id;
+ P : Node_Id;
+
+ function Build_Unit_Name (Nam : Node_Id) return Node_Id;
+
+ function Build_Unit_Name (Nam : Node_Id) return Node_Id is
+ Result : Node_Id;
+
+ begin
+ if Nkind (Nam) = N_Identifier then
+ return New_Occurrence_Of (Entity (Nam), Loc);
+
+ else
+ Result :=
+ Make_Expanded_Name (Loc,
+ Chars => Chars (Entity (Nam)),
+ Prefix => Build_Unit_Name (Prefix (Nam)),
+ Selector_Name => New_Occurrence_Of (Entity (Nam), Loc));
+ Set_Entity (Result, Entity (Nam));
+ return Result;
+ end if;
+ end Build_Unit_Name;
+
+ begin
+ New_Nodes_OK := New_Nodes_OK + 1;
+ Withn :=
+ Make_With_Clause (Loc, Name => Build_Unit_Name (Nam));
+
+ P := Parent (Unit_Declaration_Node (Ent));
+ Set_Library_Unit (Withn, P);
+ Set_Corresponding_Spec (Withn, Ent);
+ Set_First_Name (Withn, True);
+ Set_Implicit_With (Withn, True);
+
+ Prepend (Withn, Context_Items (N));
+ Mark_Rewrite_Insertion (Withn);
+ Install_Withed_Unit (Withn);
+
+ if Nkind (Nam) = N_Expanded_Name then
+ Expand_With_Clause (Prefix (Nam), N);
+ end if;
+
+ New_Nodes_OK := New_Nodes_OK - 1;
+ end Expand_With_Clause;
+
+ -----------------------------
+ -- Implicit_With_On_Parent --
+ -----------------------------
+
+ procedure Implicit_With_On_Parent
+ (Child_Unit : Node_Id;
+ N : Node_Id)
+ is
+ Loc : constant Source_Ptr := Sloc (N);
+ P : constant Node_Id := Parent_Spec (Child_Unit);
+ P_Unit : constant Node_Id := Unit (P);
+
+ P_Name : Entity_Id := Defining_Entity (P_Unit);
+ Withn : Node_Id;
+
+ function Build_Ancestor_Name (P : Node_Id) return Node_Id;
+ -- Build prefix of child unit name. Recurse if needed.
+
+ function Build_Unit_Name return Node_Id;
+ -- If the unit is a child unit, build qualified name with all
+ -- ancestors.
+
+ -------------------------
+ -- Build_Ancestor_Name --
+ -------------------------
+
+ function Build_Ancestor_Name (P : Node_Id) return Node_Id is
+ P_Ref : Node_Id := New_Reference_To (Defining_Entity (P), Loc);
+
+ begin
+ if No (Parent_Spec (P)) then
+ return P_Ref;
+ else
+ return
+ Make_Selected_Component (Loc,
+ Prefix => Build_Ancestor_Name (Unit (Parent_Spec (P))),
+ Selector_Name => P_Ref);
+ end if;
+ end Build_Ancestor_Name;
+
+ ---------------------
+ -- Build_Unit_Name --
+ ---------------------
+
+ function Build_Unit_Name return Node_Id is
+ Result : Node_Id;
+
+ begin
+ if No (Parent_Spec (P_Unit)) then
+ return New_Reference_To (P_Name, Loc);
+ else
+ Result :=
+ Make_Expanded_Name (Loc,
+ Chars => Chars (P_Name),
+ Prefix => Build_Ancestor_Name (Unit (Parent_Spec (P_Unit))),
+ Selector_Name => New_Reference_To (P_Name, Loc));
+ Set_Entity (Result, P_Name);
+ return Result;
+ end if;
+ end Build_Unit_Name;
+
+ -- Start of processing for Implicit_With_On_Parent
+
+ begin
+ New_Nodes_OK := New_Nodes_OK + 1;
+ Withn := Make_With_Clause (Loc, Name => Build_Unit_Name);
+
+ Set_Library_Unit (Withn, P);
+ Set_Corresponding_Spec (Withn, P_Name);
+ Set_First_Name (Withn, True);
+ Set_Implicit_With (Withn, True);
+
+ -- Node is placed at the beginning of the context items, so that
+ -- subsequent use clauses on the parent can be validated.
+
+ Prepend (Withn, Context_Items (N));
+ Mark_Rewrite_Insertion (Withn);
+ Install_Withed_Unit (Withn);
+
+ if Is_Child_Spec (P_Unit) then
+ Implicit_With_On_Parent (P_Unit, N);
+ end if;
+ New_Nodes_OK := New_Nodes_OK - 1;
+ end Implicit_With_On_Parent;
+
+ ---------------------
+ -- Install_Context --
+ ---------------------
+
+ procedure Install_Context (N : Node_Id) is
+ Lib_Unit : Node_Id := Unit (N);
+
+ begin
+ Install_Context_Clauses (N);
+
+ if Is_Child_Spec (Lib_Unit) then
+ Install_Parents (Lib_Unit, Private_Present (Parent (Lib_Unit)));
+ end if;
+
+ Check_With_Type_Clauses (N);
+ end Install_Context;
+
+ -----------------------------
+ -- Install_Context_Clauses --
+ -----------------------------
+
+ procedure Install_Context_Clauses (N : Node_Id) is
+ Lib_Unit : Node_Id := Unit (N);
+ Item : Node_Id;
+ Uname_Node : Entity_Id;
+ Check_Private : Boolean := False;
+ Decl_Node : Node_Id;
+ Lib_Parent : Entity_Id;
+
+ begin
+ -- Loop through context clauses to find the with/use clauses
+
+ Item := First (Context_Items (N));
+ while Present (Item) loop
+
+ -- Case of explicit WITH clause
+
+ if Nkind (Item) = N_With_Clause
+ and then not Implicit_With (Item)
+ then
+ -- If Name (Item) is not an entity name, something is wrong, and
+ -- this will be detected in due course, for now ignore the item
+
+ if not Is_Entity_Name (Name (Item)) then
+ goto Continue;
+ end if;
+
+ Uname_Node := Entity (Name (Item));
+
+ if Is_Private_Descendant (Uname_Node) then
+ Check_Private := True;
+ end if;
+
+ Install_Withed_Unit (Item);
+
+ Decl_Node := Unit_Declaration_Node (Uname_Node);
+
+ -- If the unit is a subprogram instance, it appears nested
+ -- within a package that carries the parent information.
+
+ if Is_Generic_Instance (Uname_Node)
+ and then Ekind (Uname_Node) /= E_Package
+ then
+ Decl_Node := Parent (Parent (Decl_Node));
+ end if;
+
+ if Is_Child_Spec (Decl_Node) then
+ if Nkind (Name (Item)) = N_Expanded_Name then
+ Expand_With_Clause (Prefix (Name (Item)), N);
+ else
+ -- if not an expanded name, the child unit must be a
+ -- renaming, nothing to do.
+
+ null;
+ end if;
+
+ elsif Nkind (Decl_Node) = N_Subprogram_Body
+ and then not Acts_As_Spec (Parent (Decl_Node))
+ and then Is_Child_Spec (Unit (Library_Unit (Parent (Decl_Node))))
+ then
+ Implicit_With_On_Parent
+ (Unit (Library_Unit (Parent (Decl_Node))), N);
+ end if;
+
+ -- Check license conditions unless this is a dummy unit
+
+ if Sloc (Library_Unit (Item)) /= No_Location then
+ License_Check : declare
+ Withl : constant License_Type :=
+ License (Source_Index
+ (Get_Source_Unit
+ (Library_Unit (Item))));
+
+ Unitl : constant License_Type :=
+ License (Source_Index (Current_Sem_Unit));
+
+ procedure License_Error;
+ -- Signal error of bad license
+
+ -------------------
+ -- License_Error --
+ -------------------
+
+ procedure License_Error is
+ begin
+ Error_Msg_N
+ ("?license of with'ed unit & is incompatible",
+ Name (Item));
+ end License_Error;
+
+ -- Start of processing for License_Check
+
+ begin
+ case Unitl is
+ when Unknown =>
+ null;
+
+ when Restricted =>
+ if Withl = GPL then
+ License_Error;
+ end if;
+
+ when GPL =>
+ if Withl = Restricted then
+ License_Error;
+ end if;
+
+ when Modified_GPL =>
+ if Withl = Restricted or else Withl = GPL then
+ License_Error;
+ end if;
+
+ when Unrestricted =>
+ null;
+ end case;
+ end License_Check;
+ end if;
+
+ -- Case of USE PACKAGE clause
+
+ elsif Nkind (Item) = N_Use_Package_Clause then
+ Analyze_Use_Package (Item);
+
+ -- Case of USE TYPE clause
+
+ elsif Nkind (Item) = N_Use_Type_Clause then
+ Analyze_Use_Type (Item);
+
+ -- Case of WITH TYPE clause
+
+ -- A With_Type_Clause is processed when installing the context,
+ -- because it is a visibility mechanism and does not create a
+ -- semantic dependence on other units, as a With_Clause does.
+
+ elsif Nkind (Item) = N_With_Type_Clause then
+ Analyze_With_Type_Clause (Item);
+
+ -- case of PRAGMA
+
+ elsif Nkind (Item) = N_Pragma then
+ Analyze (Item);
+ end if;
+
+ <<Continue>>
+ Next (Item);
+ end loop;
+
+ if Is_Child_Spec (Lib_Unit) then
+
+ -- The unit also has implicit withs on its own parents.
+
+ if No (Context_Items (N)) then
+ Set_Context_Items (N, New_List);
+ end if;
+
+ Implicit_With_On_Parent (Lib_Unit, N);
+ end if;
+
+ -- If the unit is a body, the context of the specification must also
+ -- be installed.
+
+ if Nkind (Lib_Unit) = N_Package_Body
+ or else (Nkind (Lib_Unit) = N_Subprogram_Body
+ and then not Acts_As_Spec (N))
+ then
+ Install_Context (Library_Unit (N));
+
+ if Is_Child_Spec (Unit (Library_Unit (N))) then
+
+ -- If the unit is the body of a public child unit, the private
+ -- declarations of the parent must be made visible. If the child
+ -- unit is private, the private declarations have been installed
+ -- already in the call to Install_Parents for the spec. Installing
+ -- private declarations must be done for all ancestors of public
+ -- child units. In addition, sibling units mentioned in the
+ -- context clause of the body are directly visible.
+
+ declare
+ Lib_Spec : Node_Id := Unit (Library_Unit (N));
+ P : Node_Id;
+ P_Name : Entity_Id;
+
+ begin
+ while Is_Child_Spec (Lib_Spec) loop
+ P := Unit (Parent_Spec (Lib_Spec));
+
+ if not (Private_Present (Parent (Lib_Spec))) then
+ P_Name := Defining_Entity (P);
+ Install_Private_Declarations (P_Name);
+ Set_Use (Private_Declarations (Specification (P)));
+ end if;
+
+ Lib_Spec := P;
+ end loop;
+ end;
+ end if;
+
+ -- For a package body, children in context are immediately visible
+
+ Install_Siblings (Defining_Entity (Unit (Library_Unit (N))), N);
+ end if;
+
+ if Nkind (Lib_Unit) = N_Generic_Package_Declaration
+ or else Nkind (Lib_Unit) = N_Generic_Subprogram_Declaration
+ or else Nkind (Lib_Unit) = N_Package_Declaration
+ or else Nkind (Lib_Unit) = N_Subprogram_Declaration
+ then
+ if Is_Child_Spec (Lib_Unit) then
+ Lib_Parent := Defining_Entity (Unit (Parent_Spec (Lib_Unit)));
+ Set_Is_Private_Descendant
+ (Defining_Entity (Lib_Unit),
+ Is_Private_Descendant (Lib_Parent)
+ or else Private_Present (Parent (Lib_Unit)));
+
+ else
+ Set_Is_Private_Descendant
+ (Defining_Entity (Lib_Unit),
+ Private_Present (Parent (Lib_Unit)));
+ end if;
+ end if;
+
+ if Check_Private then
+ Check_Private_Child_Unit (N);
+ end if;
+ end Install_Context_Clauses;
+
+ ---------------------
+ -- Install_Parents --
+ ---------------------
+
+ procedure Install_Parents (Lib_Unit : Node_Id; Is_Private : Boolean) is
+ P : Node_Id;
+ E_Name : Entity_Id;
+ P_Name : Entity_Id;
+ P_Spec : Node_Id;
+
+ begin
+ P := Unit (Parent_Spec (Lib_Unit));
+ P_Name := Defining_Entity (P);
+
+ if Etype (P_Name) = Any_Type then
+ return;
+ end if;
+
+ if Ekind (P_Name) = E_Generic_Package
+ and then Nkind (Lib_Unit) /= N_Generic_Subprogram_Declaration
+ and then Nkind (Lib_Unit) /= N_Generic_Package_Declaration
+ and then Nkind (Lib_Unit) not in N_Generic_Renaming_Declaration
+ then
+ Error_Msg_N
+ ("child of a generic package must be a generic unit", Lib_Unit);
+
+ elsif not Is_Package (P_Name) then
+ Error_Msg_N
+ ("parent unit must be package or generic package", Lib_Unit);
+ raise Unrecoverable_Error;
+
+ elsif Present (Renamed_Object (P_Name)) then
+ Error_Msg_N ("parent unit cannot be a renaming", Lib_Unit);
+ raise Unrecoverable_Error;
+
+ -- Verify that a child of an instance is itself an instance, or
+ -- the renaming of one. Given that an instance that is a unit is
+ -- replaced with a package declaration, check against the original
+ -- node.
+
+ elsif Nkind (Original_Node (P)) = N_Package_Instantiation
+ and then Nkind (Lib_Unit)
+ not in N_Renaming_Declaration
+ and then Nkind (Original_Node (Lib_Unit))
+ not in N_Generic_Instantiation
+ then
+ Error_Msg_N
+ ("child of an instance must be an instance or renaming", Lib_Unit);
+ end if;
+
+ -- This is the recursive call that ensures all parents are loaded
+
+ if Is_Child_Spec (P) then
+ Install_Parents (P,
+ Is_Private or else Private_Present (Parent (Lib_Unit)));
+ end if;
+
+ -- Now we can install the context for this parent
+
+ Install_Context_Clauses (Parent_Spec (Lib_Unit));
+ Install_Siblings (P_Name, Parent (Lib_Unit));
+
+ -- The child unit is in the declarative region of the parent. The
+ -- parent must therefore appear in the scope stack and be visible,
+ -- as when compiling the corresponding body. If the child unit is
+ -- private or it is a package body, private declarations must be
+ -- accessible as well. Use declarations in the parent must also
+ -- be installed. Finally, other child units of the same parent that
+ -- are in the context are immediately visible.
+
+ -- Find entity for compilation unit, and set its private descendant
+ -- status as needed.
+
+ E_Name := Defining_Entity (Lib_Unit);
+
+ Set_Is_Child_Unit (E_Name);
+
+ Set_Is_Private_Descendant (E_Name,
+ Is_Private_Descendant (P_Name)
+ or else Private_Present (Parent (Lib_Unit)));
+
+ P_Spec := Specification (Unit_Declaration_Node (P_Name));
+ New_Scope (P_Name);
+
+ -- Save current visibility of unit
+
+ Scope_Stack.Table (Scope_Stack.Last).Previous_Visibility :=
+ Is_Immediately_Visible (P_Name);
+ Set_Is_Immediately_Visible (P_Name);
+ Install_Visible_Declarations (P_Name);
+ Set_Use (Visible_Declarations (P_Spec));
+
+ if Is_Private
+ or else Private_Present (Parent (Lib_Unit))
+ then
+ Install_Private_Declarations (P_Name);
+ Set_Use (Private_Declarations (P_Spec));
+ end if;
+ end Install_Parents;
+
+ ----------------------
+ -- Install_Siblings --
+ ----------------------
+
+ procedure Install_Siblings (U_Name : Entity_Id; N : Node_Id) is
+ Item : Node_Id;
+ Id : Entity_Id;
+ Prev : Entity_Id;
+
+ function Is_Ancestor (E : Entity_Id) return Boolean;
+ -- Determine whether the scope of a child unit is an ancestor of
+ -- the current unit.
+ -- Shouldn't this be somewhere more general ???
+
+ function Is_Ancestor (E : Entity_Id) return Boolean is
+ Par : Entity_Id;
+
+ begin
+ Par := U_Name;
+
+ while Present (Par)
+ and then Par /= Standard_Standard
+ loop
+
+ if Par = E then
+ return True;
+ end if;
+
+ Par := Scope (Par);
+ end loop;
+
+ return False;
+ end Is_Ancestor;
+
+ -- Start of processing for Install_Siblings
+
+ begin
+ -- Iterate over explicit with clauses, and check whether the
+ -- scope of each entity is an ancestor of the current unit.
+
+ Item := First (Context_Items (N));
+
+ while Present (Item) loop
+
+ if Nkind (Item) = N_With_Clause
+ and then not Implicit_With (Item)
+ then
+ Id := Entity (Name (Item));
+
+ if Is_Child_Unit (Id)
+ and then Is_Ancestor (Scope (Id))
+ then
+ Set_Is_Immediately_Visible (Id);
+ Prev := Current_Entity (Id);
+
+ -- Check for the presence of another unit in the context,
+ -- that may be inadvertently hidden by the child.
+
+ if Present (Prev)
+ and then Is_Immediately_Visible (Prev)
+ and then not Is_Child_Unit (Prev)
+ then
+ declare
+ Clause : Node_Id;
+
+ begin
+ Clause := First (Context_Items (N));
+
+ while Present (Clause) loop
+ if Nkind (Clause) = N_With_Clause
+ and then Entity (Name (Clause)) = Prev
+ then
+ Error_Msg_NE
+ ("child unit& hides compilation unit " &
+ "with the same name?",
+ Name (Item), Id);
+ exit;
+ end if;
+
+ Next (Clause);
+ end loop;
+ end;
+ end if;
+
+ -- the With_Clause may be on a grand-child, which makes
+ -- the child immediately visible.
+
+ elsif Is_Child_Unit (Scope (Id))
+ and then Is_Ancestor (Scope (Scope (Id)))
+ then
+ Set_Is_Immediately_Visible (Scope (Id));
+ end if;
+ end if;
+
+ Next (Item);
+ end loop;
+ end Install_Siblings;
+
+ -------------------------
+ -- Install_Withed_Unit --
+ -------------------------
+
+ procedure Install_Withed_Unit (With_Clause : Node_Id) is
+ Uname : constant Entity_Id := Entity (Name (With_Clause));
+ P : constant Entity_Id := Scope (Uname);
+
+ begin
+ -- We do not apply the restrictions to an internal unit unless
+ -- we are compiling the internal unit as a main unit. This check
+ -- is also skipped for dummy units (for missing packages).
+
+ if Sloc (Uname) /= No_Location
+ and then (not Is_Internal_File_Name (Unit_File_Name (Current_Sem_Unit))
+ or else Current_Sem_Unit = Main_Unit)
+ then
+ Check_Restricted_Unit
+ (Unit_Name (Get_Source_Unit (Uname)), With_Clause);
+ end if;
+
+ if P /= Standard_Standard then
+
+ -- If the unit is not analyzed after analysis of the with clause,
+ -- and it is an instantiation, then it awaits a body and is the main
+ -- unit. Its appearance in the context of some other unit indicates
+ -- a circular dependency (DEC suite perversity).
+
+ if not Analyzed (Uname)
+ and then Nkind (Parent (Uname)) = N_Package_Instantiation
+ then
+ Error_Msg_N
+ ("instantiation depends on itself", Name (With_Clause));
+
+ elsif not Is_Visible_Child_Unit (Uname) then
+ Set_Is_Visible_Child_Unit (Uname);
+
+ if Is_Generic_Instance (Uname)
+ and then Ekind (Uname) in Subprogram_Kind
+ then
+ -- Set flag as well on the visible entity that denotes the
+ -- instance, which renames the current one.
+
+ Set_Is_Visible_Child_Unit
+ (Related_Instance
+ (Defining_Entity (Unit (Library_Unit (With_Clause)))));
+ null;
+ end if;
+
+ -- The parent unit may have been installed already, and
+ -- may have appeared in a use clause.
+
+ if In_Use (Scope (Uname)) then
+ Set_Is_Potentially_Use_Visible (Uname);
+ end if;
+
+ Set_Context_Installed (With_Clause);
+ end if;
+
+ elsif not Is_Immediately_Visible (Uname) then
+ Set_Is_Immediately_Visible (Uname);
+ Set_Context_Installed (With_Clause);
+ end if;
+
+ -- A with-clause overrides a with-type clause: there are no restric-
+ -- tions on the use of package entities.
+
+ if Ekind (Uname) = E_Package then
+ Set_From_With_Type (Uname, False);
+ end if;
+ end Install_Withed_Unit;
+
+ -------------------
+ -- Is_Child_Spec --
+ -------------------
+
+ function Is_Child_Spec (Lib_Unit : Node_Id) return Boolean is
+ K : constant Node_Kind := Nkind (Lib_Unit);
+
+ begin
+ return (K in N_Generic_Declaration or else
+ K in N_Generic_Instantiation or else
+ K in N_Generic_Renaming_Declaration or else
+ K = N_Package_Declaration or else
+ K = N_Package_Renaming_Declaration or else
+ K = N_Subprogram_Declaration or else
+ K = N_Subprogram_Renaming_Declaration)
+ and then Present (Parent_Spec (Lib_Unit));
+ end Is_Child_Spec;
+
+ -----------------------
+ -- Load_Needed_Body --
+ -----------------------
+
+ -- N is a generic unit named in a with clause, or else it is
+ -- a unit that contains a generic unit or an inlined function.
+ -- In order to perform an instantiation, the body of the unit
+ -- must be present. If the unit itself is generic, we assume
+ -- that an instantiation follows, and load and analyze the body
+ -- unconditionally. This forces analysis of the spec as well.
+
+ -- If the unit is not generic, but contains a generic unit, it
+ -- is loaded on demand, at the point of instantiation (see ch12).
+
+ procedure Load_Needed_Body (N : Node_Id; OK : out Boolean) is
+ Body_Name : Unit_Name_Type;
+ Unum : Unit_Number_Type;
+
+ Save_Style_Check : constant Boolean := Opt.Style_Check;
+ -- The loading and analysis is done with style checks off
+
+ begin
+ if not GNAT_Mode then
+ Style_Check := False;
+ end if;
+
+ Body_Name := Get_Body_Name (Get_Unit_Name (Unit (N)));
+ Unum :=
+ Load_Unit
+ (Load_Name => Body_Name,
+ Required => False,
+ Subunit => False,
+ Error_Node => N,
+ Renamings => True);
+
+ if Unum = No_Unit then
+ OK := False;
+
+ else
+ Compiler_State := Analyzing; -- reset after load
+
+ if not Fatal_Error (Unum) then
+ if Debug_Flag_L then
+ Write_Str ("*** Loaded generic body");
+ Write_Eol;
+ end if;
+
+ Semantics (Cunit (Unum));
+ end if;
+
+ OK := True;
+ end if;
+
+ Style_Check := Save_Style_Check;
+ end Load_Needed_Body;
+
+ --------------------
+ -- Remove_Context --
+ --------------------
+
+ procedure Remove_Context (N : Node_Id) is
+ Lib_Unit : constant Node_Id := Unit (N);
+
+ begin
+ -- If this is a child unit, first remove the parent units.
+
+ if Is_Child_Spec (Lib_Unit) then
+ Remove_Parents (Lib_Unit);
+ end if;
+
+ Remove_Context_Clauses (N);
+ end Remove_Context;
+
+ ----------------------------
+ -- Remove_Context_Clauses --
+ ----------------------------
+
+ procedure Remove_Context_Clauses (N : Node_Id) is
+ Item : Node_Id;
+ Unit_Name : Entity_Id;
+
+ begin
+
+ -- Loop through context items and undo with_clauses and use_clauses.
+
+ Item := First (Context_Items (N));
+
+ while Present (Item) loop
+
+ -- We are interested only in with clauses which got installed
+ -- on entry, as indicated by their Context_Installed flag set
+
+ if Nkind (Item) = N_With_Clause
+ and then Context_Installed (Item)
+ then
+ -- Remove items from one with'ed unit
+
+ Unit_Name := Entity (Name (Item));
+ Remove_Unit_From_Visibility (Unit_Name);
+ Set_Context_Installed (Item, False);
+
+ elsif Nkind (Item) = N_Use_Package_Clause then
+ End_Use_Package (Item);
+
+ elsif Nkind (Item) = N_Use_Type_Clause then
+ End_Use_Type (Item);
+
+ elsif Nkind (Item) = N_With_Type_Clause then
+ Remove_With_Type_Clause (Name (Item));
+ end if;
+
+ Next (Item);
+ end loop;
+
+ end Remove_Context_Clauses;
+
+ --------------------
+ -- Remove_Parents --
+ --------------------
+
+ procedure Remove_Parents (Lib_Unit : Node_Id) is
+ P : Node_Id;
+ P_Name : Entity_Id;
+ E : Entity_Id;
+ Vis : constant Boolean :=
+ Scope_Stack.Table (Scope_Stack.Last).Previous_Visibility;
+
+ begin
+ if Is_Child_Spec (Lib_Unit) then
+ P := Unit (Parent_Spec (Lib_Unit));
+ P_Name := Defining_Entity (P);
+
+ Remove_Context_Clauses (Parent_Spec (Lib_Unit));
+ End_Package_Scope (P_Name);
+ Set_Is_Immediately_Visible (P_Name, Vis);
+
+ -- Remove from visibility the siblings as well, which are directly
+ -- visible while the parent is in scope.
+
+ E := First_Entity (P_Name);
+
+ while Present (E) loop
+
+ if Is_Child_Unit (E) then
+ Set_Is_Immediately_Visible (E, False);
+ end if;
+
+ Next_Entity (E);
+ end loop;
+
+ Set_In_Package_Body (P_Name, False);
+
+ -- This is the recursive call to remove the context of any
+ -- higher level parent. This recursion ensures that all parents
+ -- are removed in the reverse order of their installation.
+
+ Remove_Parents (P);
+ end if;
+ end Remove_Parents;
+
+ -----------------------------
+ -- Remove_With_Type_Clause --
+ -----------------------------
+
+ procedure Remove_With_Type_Clause (Name : Node_Id) is
+ Typ : Entity_Id;
+ P : Entity_Id;
+
+ procedure Unchain (E : Entity_Id);
+ -- Remove entity from visibility list.
+
+ procedure Unchain (E : Entity_Id) is
+ Prev : Entity_Id;
+
+ begin
+ Prev := Current_Entity (E);
+
+ -- Package entity may appear is several with_type_clauses, and
+ -- may have been removed already.
+
+ if No (Prev) then
+ return;
+
+ elsif Prev = E then
+ Set_Name_Entity_Id (Chars (E), Homonym (E));
+
+ else
+ while Present (Prev)
+ and then Homonym (Prev) /= E
+ loop
+ Prev := Homonym (Prev);
+ end loop;
+
+ if (Present (Prev)) then
+ Set_Homonym (Prev, Homonym (E));
+ end if;
+ end if;
+ end Unchain;
+
+ begin
+ if Nkind (Name) = N_Selected_Component then
+ Typ := Entity (Selector_Name (Name));
+
+ if No (Typ) then -- error in declaration.
+ return;
+ end if;
+ else
+ return;
+ end if;
+
+ P := Scope (Typ);
+
+ -- If the exporting package has been analyzed, it has appeared in the
+ -- context already and should be left alone. Otherwise, remove from
+ -- visibility.
+
+ if not Analyzed (Unit_Declaration_Node (P)) then
+ Unchain (P);
+ Unchain (Typ);
+ Set_Is_Frozen (Typ, False);
+ end if;
+
+ if Ekind (Typ) = E_Record_Type then
+ Set_From_With_Type (Class_Wide_Type (Typ), False);
+ Set_From_With_Type (Typ, False);
+ end if;
+
+ Set_From_With_Type (P, False);
+
+ -- If P is a child unit, remove parents as well.
+
+ P := Scope (P);
+
+ while Present (P)
+ and then P /= Standard_Standard
+ loop
+ Set_From_With_Type (P, False);
+
+ if not Analyzed (Unit_Declaration_Node (P)) then
+ Unchain (P);
+ end if;
+
+ P := Scope (P);
+ end loop;
+
+ -- The back-end needs to know that an access type is imported, so it
+ -- does not need elaboration and can appear in a mutually recursive
+ -- record definition, so the imported flag on an access type is
+ -- preserved.
+
+ end Remove_With_Type_Clause;
+
+ ---------------------------------
+ -- Remove_Unit_From_Visibility --
+ ---------------------------------
+
+ procedure Remove_Unit_From_Visibility (Unit_Name : Entity_Id) is
+ P : Entity_Id := Scope (Unit_Name);
+
+ begin
+
+ if Debug_Flag_I then
+ Write_Str ("remove withed unit ");
+ Write_Name (Chars (Unit_Name));
+ Write_Eol;
+ end if;
+
+ if P /= Standard_Standard then
+ Set_Is_Visible_Child_Unit (Unit_Name, False);
+ end if;
+
+ Set_Is_Potentially_Use_Visible (Unit_Name, False);
+ Set_Is_Immediately_Visible (Unit_Name, False);
+
+ end Remove_Unit_From_Visibility;
+
+end Sem_Ch10;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S E M _ C H 1 0 --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.7 $ --
+-- --
+-- 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). --
+-- --
+------------------------------------------------------------------------------
+
+with Types; use Types;
+package Sem_Ch10 is
+ procedure Analyze_Compilation_Unit (N : Node_Id);
+ procedure Analyze_With_Clause (N : Node_Id);
+ procedure Analyze_With_Type_Clause (N : Node_Id);
+ procedure Analyze_Subprogram_Body_Stub (N : Node_Id);
+ procedure Analyze_Package_Body_Stub (N : Node_Id);
+ procedure Analyze_Task_Body_Stub (N : Node_Id);
+ procedure Analyze_Protected_Body_Stub (N : Node_Id);
+ procedure Analyze_Subunit (N : Node_Id);
+
+ procedure Install_Context (N : Node_Id);
+ -- Installs the entities from the context clause of the given compilation
+ -- unit into the visibility chains. This is done before analyzing a unit.
+ -- For a child unit, install context of parents as well.
+
+ procedure Remove_Context (N : Node_Id);
+ -- Removes the entities from the context clause of the given compilation
+ -- unit from the visibility chains. This is done on exit from a unit as
+ -- part of cleaning up the visibility chains for the caller. A special
+ -- case is that the call from the Main_Unit can be ignored, since at the
+ -- end of the main unit the visibility table won't be needed in any case.
+ -- For a child unit, remove parents and their context as well.
+
+ procedure Load_Needed_Body (N : Node_Id; OK : out Boolean);
+ -- Load and analyze the body of a context unit that is generic, or
+ -- that contains generic units or inlined units. The body becomes
+ -- part of the semantic dependency set of the unit that needs it.
+ -- The returned result in OK is True if the load is successful,
+ -- and False if the requested file cannot be found.
+
+end Sem_Ch10;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S E M _ C H 1 1 --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.96 $
+-- --
+-- 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). --
+-- --
+------------------------------------------------------------------------------
+
+with Atree; use Atree;
+with Einfo; use Einfo;
+with Errout; use Errout;
+with Lib; use Lib;
+with Lib.Xref; use Lib.Xref;
+with Nlists; use Nlists;
+with Nmake; use Nmake;
+with Opt; use Opt;
+with Restrict; use Restrict;
+with Rtsfind; use Rtsfind;
+with Sem; use Sem;
+with Sem_Ch5; use Sem_Ch5;
+with Sem_Ch8; use Sem_Ch8;
+with Sem_Res; use Sem_Res;
+with Sem_Util; use Sem_Util;
+with Sinfo; use Sinfo;
+with Stand; use Stand;
+with Uintp; use Uintp;
+
+package body Sem_Ch11 is
+
+ -----------------------------------
+ -- Analyze_Exception_Declaration --
+ -----------------------------------
+
+ procedure Analyze_Exception_Declaration (N : Node_Id) is
+ Id : constant Entity_Id := Defining_Identifier (N);
+ PF : constant Boolean := Is_Pure (Current_Scope);
+
+ begin
+ Generate_Definition (Id);
+ Enter_Name (Id);
+ Set_Ekind (Id, E_Exception);
+ Set_Exception_Code (Id, Uint_0);
+ Set_Etype (Id, Standard_Exception_Type);
+
+ Set_Is_Statically_Allocated (Id);
+ Set_Is_Pure (Id, PF);
+
+ end Analyze_Exception_Declaration;
+
+ --------------------------------
+ -- Analyze_Exception_Handlers --
+ --------------------------------
+
+ procedure Analyze_Exception_Handlers (L : List_Id) is
+ Handler : Node_Id;
+ Choice : Entity_Id;
+ Id : Node_Id;
+ H_Scope : Entity_Id := Empty;
+
+ procedure Check_Duplication (Id : Node_Id);
+ -- Iterate through the identifiers in each handler to find duplicates
+
+ -----------------------
+ -- Check_Duplication --
+ -----------------------
+
+ procedure Check_Duplication (Id : Node_Id) is
+ Handler : Node_Id;
+ Id1 : Node_Id;
+
+ begin
+ Handler := First_Non_Pragma (L);
+ while Present (Handler) loop
+ Id1 := First (Exception_Choices (Handler));
+
+ while Present (Id1) loop
+
+ -- Only check against the exception choices which precede
+ -- Id in the handler, since the ones that follow Id have not
+ -- been analyzed yet and will be checked in a subsequent call.
+
+ if Id = Id1 then
+ return;
+
+ elsif Nkind (Id1) /= N_Others_Choice
+ and then Entity (Id) = Entity (Id1)
+ then
+ if Handler /= Parent (Id) then
+ Error_Msg_Sloc := Sloc (Id1);
+ Error_Msg_NE
+ ("exception choice duplicates &#", Id, Id1);
+
+ else
+ if Ada_83 and then Comes_From_Source (Id) then
+ Error_Msg_N
+ ("(Ada 83): duplicate exception choice&", Id);
+ end if;
+ end if;
+ end if;
+
+ Next_Non_Pragma (Id1);
+ end loop;
+
+ Next (Handler);
+ end loop;
+ end Check_Duplication;
+
+ -- Start processing for Analyze_Exception_Handlers
+
+ begin
+ Handler := First (L);
+ Check_Restriction (No_Exceptions, Handler);
+ Check_Restriction (No_Exception_Handlers, Handler);
+
+ -- Loop through handlers (which can include pragmas)
+
+ while Present (Handler) loop
+
+ -- If pragma just analyze it
+
+ if Nkind (Handler) = N_Pragma then
+ Analyze (Handler);
+
+ -- Otherwise we have a real exception handler
+
+ else
+ -- Deal with choice parameter. The exception handler is
+ -- a declarative part for it, so it constitutes a scope
+ -- for visibility purposes. We create an entity to denote
+ -- the whole exception part, and use it as the scope of all
+ -- the choices, which may even have the same name without
+ -- conflict. This scope plays no other role in expansion or
+ -- or code generation.
+
+ Choice := Choice_Parameter (Handler);
+
+ if Present (Choice) then
+
+ if No (H_Scope) then
+ H_Scope := New_Internal_Entity
+ (E_Block, Current_Scope, Sloc (Choice), 'E');
+ end if;
+
+ New_Scope (H_Scope);
+ Set_Etype (H_Scope, Standard_Void_Type);
+
+ -- Set the Finalization Chain entity to Error means that it
+ -- should not be used at that level but the parent one
+ -- should be used instead.
+
+ -- ??? this usage needs documenting in Einfo/Exp_Ch7 ???
+ -- ??? using Error for this non-error condition is nasty ???
+
+ Set_Finalization_Chain_Entity (H_Scope, Error);
+
+ Enter_Name (Choice);
+ Set_Ekind (Choice, E_Variable);
+ Set_Etype (Choice, RTE (RE_Exception_Occurrence));
+ Generate_Definition (Choice);
+ end if;
+
+ Id := First (Exception_Choices (Handler));
+ while Present (Id) loop
+ if Nkind (Id) = N_Others_Choice then
+ if Present (Next (Id))
+ or else Present (Next (Handler))
+ or else Present (Prev (Id))
+ then
+ Error_Msg_N ("OTHERS must appear alone and last", Id);
+ end if;
+
+ else
+ Analyze (Id);
+
+ if not Is_Entity_Name (Id)
+ or else Ekind (Entity (Id)) /= E_Exception
+ then
+ Error_Msg_N ("exception name expected", Id);
+
+ else
+ if Present (Renamed_Entity (Entity (Id))) then
+ Set_Entity (Id, Renamed_Entity (Entity (Id)));
+ end if;
+
+ Check_Duplication (Id);
+
+ -- Check for exception declared within generic formal
+ -- package (which is illegal, see RM 11.2(8))
+
+ declare
+ Ent : Entity_Id := Entity (Id);
+ Scop : Entity_Id := Scope (Ent);
+
+ begin
+ while Scop /= Standard_Standard
+ and then Ekind (Scop) = E_Package
+ loop
+ -- If the exception is declared in an inner
+ -- instance, nothing else to check.
+
+ if Is_Generic_Instance (Scop) then
+ exit;
+
+ elsif Nkind (Declaration_Node (Scop)) =
+ N_Package_Specification
+ and then
+ Nkind (Original_Node (Parent
+ (Declaration_Node (Scop)))) =
+ N_Formal_Package_Declaration
+ then
+ Error_Msg_NE
+ ("exception& is declared in " &
+ "generic formal package", Id, Ent);
+ Error_Msg_N
+ ("\and therefore cannot appear in " &
+ "handler ('R'M 11.2(8))", Id);
+ exit;
+ end if;
+
+ Scop := Scope (Scop);
+ end loop;
+ end;
+ end if;
+ end if;
+
+ Next (Id);
+ end loop;
+
+ Analyze_Statements (Statements (Handler));
+
+ if Present (Choice) then
+ End_Scope;
+ end if;
+
+ end if;
+
+ Next (Handler);
+ end loop;
+ end Analyze_Exception_Handlers;
+
+ --------------------------------
+ -- Analyze_Handled_Statements --
+ --------------------------------
+
+ procedure Analyze_Handled_Statements (N : Node_Id) is
+ Handlers : constant List_Id := Exception_Handlers (N);
+
+ begin
+ Analyze_Statements (Statements (N));
+
+ if Present (Handlers) then
+ Analyze_Exception_Handlers (Handlers);
+
+ elsif Present (At_End_Proc (N)) then
+ Analyze (At_End_Proc (N));
+ end if;
+ end Analyze_Handled_Statements;
+
+ -----------------------------
+ -- Analyze_Raise_Statement --
+ -----------------------------
+
+ procedure Analyze_Raise_Statement (N : Node_Id) is
+ Exception_Id : constant Node_Id := Name (N);
+ Exception_Name : Entity_Id := Empty;
+ P : Node_Id;
+ Nkind_P : Node_Kind;
+
+ begin
+ Check_Unreachable_Code (N);
+
+ -- Check exception restrictions on the original source
+
+ if Comes_From_Source (N) then
+ Check_Restriction (No_Exceptions, N);
+ end if;
+
+ -- Reraise statement
+
+ if No (Exception_Id) then
+
+ P := Parent (N);
+ Nkind_P := Nkind (P);
+
+ while Nkind_P /= N_Exception_Handler
+ and then Nkind_P /= N_Subprogram_Body
+ and then Nkind_P /= N_Package_Body
+ and then Nkind_P /= N_Task_Body
+ and then Nkind_P /= N_Entry_Body
+ loop
+ P := Parent (P);
+ Nkind_P := Nkind (P);
+ end loop;
+
+ if Nkind (P) /= N_Exception_Handler then
+ Error_Msg_N
+ ("reraise statement must appear directly in a handler", N);
+ end if;
+
+ -- Normal case with exception id present
+
+ else
+ Analyze (Exception_Id);
+
+ if Is_Entity_Name (Exception_Id) then
+ Exception_Name := Entity (Exception_Id);
+
+ if Present (Renamed_Object (Exception_Name)) then
+ Set_Entity (Exception_Id, Renamed_Object (Exception_Name));
+ end if;
+ end if;
+
+ if No (Exception_Name)
+ or else Ekind (Exception_Name) /= E_Exception
+ then
+ Error_Msg_N
+ ("exception name expected in raise statement", Exception_Id);
+ end if;
+ end if;
+ end Analyze_Raise_Statement;
+
+ -----------------------------
+ -- Analyze_Raise_xxx_Error --
+ -----------------------------
+
+ -- Normally, the Etype is already set (when this node is used within
+ -- an expression, since it is copied from the node which it rewrites).
+ -- If this node is used in a statement context, then we set the type
+ -- Standard_Void_Type. This is used both by Gigi and by the front end
+ -- to distinguish the statement use and the subexpression use.
+
+ -- The only other required processing is to take care of the Condition
+ -- field if one is present.
+
+ procedure Analyze_Raise_xxx_Error (N : Node_Id) is
+ begin
+ if No (Etype (N)) then
+ Set_Etype (N, Standard_Void_Type);
+ end if;
+
+ if Present (Condition (N)) then
+ Analyze_And_Resolve (Condition (N), Standard_Boolean);
+ end if;
+
+ -- Deal with static cases in obvious manner
+
+ if Nkind (Condition (N)) = N_Identifier then
+ if Entity (Condition (N)) = Standard_True then
+ Set_Condition (N, Empty);
+
+ elsif Entity (Condition (N)) = Standard_False then
+ Rewrite (N, Make_Null_Statement (Sloc (N)));
+ end if;
+ end if;
+
+ end Analyze_Raise_xxx_Error;
+
+ -----------------------------
+ -- Analyze_Subprogram_Info --
+ -----------------------------
+
+ procedure Analyze_Subprogram_Info (N : Node_Id) is
+ begin
+ Set_Etype (N, RTE (RE_Code_Loc));
+ end Analyze_Subprogram_Info;
+
+end Sem_Ch11;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S E M _ C H 1 1 --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.9 $ --
+-- --
+-- 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). --
+-- --
+------------------------------------------------------------------------------
+
+with Types; use Types;
+package Sem_Ch11 is
+ procedure Analyze_Exception_Declaration (N : Node_Id);
+ procedure Analyze_Handled_Statements (N : Node_Id);
+ procedure Analyze_Raise_Statement (N : Node_Id);
+ procedure Analyze_Raise_xxx_Error (N : Node_Id);
+ procedure Analyze_Subprogram_Info (N : Node_Id);
+
+ procedure Analyze_Exception_Handlers (L : List_Id);
+ -- Analyze list of exception handlers of a handled statement sequence
+
+end Sem_Ch11;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S E M _ C H 1 2 --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.776 $
+-- --
+-- 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). --
+-- --
+------------------------------------------------------------------------------
+
+with Atree; use Atree;
+with Einfo; use Einfo;
+with Elists; use Elists;
+with Errout; use Errout;
+with Expander; use Expander;
+with Fname; use Fname;
+with Fname.UF; use Fname.UF;
+with Freeze; use Freeze;
+with Hostparm;
+with Inline; use Inline;
+with Lib; use Lib;
+with Lib.Load; use Lib.Load;
+with Lib.Xref; use Lib.Xref;
+with Nlists; use Nlists;
+with Nmake; use Nmake;
+with Opt; use Opt;
+with Restrict; use Restrict;
+with Rtsfind; use Rtsfind;
+with Sem; use Sem;
+with Sem_Cat; use Sem_Cat;
+with Sem_Ch3; use Sem_Ch3;
+with Sem_Ch6; use Sem_Ch6;
+with Sem_Ch7; use Sem_Ch7;
+with Sem_Ch8; use Sem_Ch8;
+with Sem_Ch10; use Sem_Ch10;
+with Sem_Ch13; use Sem_Ch13;
+with Sem_Elab; use Sem_Elab;
+with Sem_Elim; use Sem_Elim;
+with Sem_Eval; use Sem_Eval;
+with Sem_Res; use Sem_Res;
+with Sem_Type; use Sem_Type;
+with Sem_Util; use Sem_Util;
+with Stand; use Stand;
+with Sinfo; use Sinfo;
+with Sinfo.CN; use Sinfo.CN;
+with Sinput; use Sinput;
+with Sinput.L; use Sinput.L;
+with Snames; use Snames;
+with Stringt; use Stringt;
+with Uname; use Uname;
+with Table;
+with Tbuild; use Tbuild;
+with Uintp; use Uintp;
+with Urealp; use Urealp;
+
+with GNAT.HTable;
+
+package body Sem_Ch12 is
+
+ use Atree.Unchecked_Access;
+ -- This package performs untyped traversals of the tree, therefore it
+ -- needs direct access to the fields of a node.
+
+ ----------------------------------------------------------
+ -- Implementation of Generic Analysis and Instantiation --
+ -----------------------------------------------------------
+
+ -- GNAT implements generics by macro expansion. No attempt is made to
+ -- share generic instantiations (for now). Analysis of a generic definition
+ -- does not perform any expansion action, but the expander must be called
+ -- on the tree for each instantiation, because the expansion may of course
+ -- depend on the generic actuals. All of this is best achieved as follows:
+ --
+ -- a) Semantic analysis of a generic unit is performed on a copy of the
+ -- tree for the generic unit. All tree modifications that follow analysis
+ -- do not affect the original tree. Links are kept between the original
+ -- tree and the copy, in order to recognize non-local references within
+ -- the generic, and propagate them to each instance (recall that name
+ -- resolution is done on the generic declaration: generics are not really
+ -- macros!). This is summarized in the following diagram:
+ --
+ -- .-----------. .----------.
+ -- | semantic |<--------------| generic |
+ -- | copy | | unit |
+ -- | |==============>| |
+ -- |___________| global |__________|
+ -- references | | |
+ -- | | |
+ -- .-----|--|.
+ -- | .-----|---.
+ -- | | .----------.
+ -- | | | generic |
+ -- |__| | |
+ -- |__| instance |
+ -- |__________|
+ --
+ -- b) Each instantiation copies the original tree, and inserts into it a
+ -- series of declarations that describe the mapping between generic formals
+ -- and actuals. For example, a generic In OUT parameter is an object
+ -- renaming of the corresponing actual, etc. Generic IN parameters are
+ -- constant declarations.
+ --
+ -- c) In order to give the right visibility for these renamings, we use
+ -- a different scheme for package and subprogram instantiations. For
+ -- packages, the list of renamings is inserted into the package
+ -- specification, before the visible declarations of the package. The
+ -- renamings are analyzed before any of the text of the instance, and are
+ -- thus visible at the right place. Furthermore, outside of the instance,
+ -- the generic parameters are visible and denote their corresponding
+ -- actuals.
+
+ -- For subprograms, we create a container package to hold the renamings
+ -- and the subprogram instance itself. Analysis of the package makes the
+ -- renaming declarations visible to the subprogram. After analyzing the
+ -- package, the defining entity for the subprogram is touched-up so that
+ -- it appears declared in the current scope, and not inside the container
+ -- package.
+
+ -- If the instantiation is a compilation unit, the container package is
+ -- given the same name as the subprogram instance. This ensures that
+ -- the elaboration procedure called by the binder, using the compilation
+ -- unit name, calls in fact the elaboration procedure for the package.
+
+ -- Not surprisingly, private types complicate this approach. By saving in
+ -- the original generic object the non-local references, we guarantee that
+ -- the proper entities are referenced at the point of instantiation.
+ -- However, for private types, this by itself does not insure that the
+ -- proper VIEW of the entity is used (the full type may be visible at the
+ -- point of generic definition, but not at instantiation, or vice-versa).
+ -- In order to reference the proper view, we special-case any reference
+ -- to private types in the generic object, by saving both views, one in
+ -- the generic and one in the semantic copy. At time of instantiation, we
+ -- check whether the two views are consistent, and exchange declarations if
+ -- necessary, in order to restore the correct visibility. Similarly, if
+ -- the instance view is private when the generic view was not, we perform
+ -- the exchange. After completing the instantiation, we restore the
+ -- current visibility. The flag Has_Private_View marks identifiers in the
+ -- the generic unit that require checking.
+
+ -- Visibility within nested generic units requires special handling.
+ -- Consider the following scheme:
+ --
+ -- type Global is ... -- outside of generic unit.
+ -- generic ...
+ -- package Outer is
+ -- ...
+ -- type Semi_Global is ... -- global to inner.
+ --
+ -- generic ... -- 1
+ -- procedure inner (X1 : Global; X2 : Semi_Global);
+ --
+ -- procedure in2 is new inner (...); -- 4
+ -- end Outer;
+
+ -- package New_Outer is new Outer (...); -- 2
+ -- procedure New_Inner is new New_Outer.Inner (...); -- 3
+
+ -- The semantic analysis of Outer captures all occurrences of Global.
+ -- The semantic analysis of Inner (at 1) captures both occurrences of
+ -- Global and Semi_Global.
+
+ -- At point 2 (instantiation of Outer), we also produce a generic copy
+ -- of Inner, even though Inner is, at that point, not being instantiated.
+ -- (This is just part of the semantic analysis of New_Outer).
+
+ -- Critically, references to Global within Inner must be preserved, while
+ -- references to Semi_Global should not preserved, because they must now
+ -- resolve to an entity within New_Outer. To distinguish between these, we
+ -- use a global variable, Current_Instantiated_Parent, which is set when
+ -- performing a generic copy during instantiation (at 2). This variable is
+ -- used when performing a generic copy that is not an instantiation, but
+ -- that is nested within one, as the occurrence of 1 within 2. The analysis
+ -- of a nested generic only preserves references that are global to the
+ -- enclosing Current_Instantiated_Parent. We use the Scope_Depth value to
+ -- determine whether a reference is external to the given parent.
+
+ -- The instantiation at point 3 requires no special treatment. The method
+ -- works as well for further nestings of generic units, but of course the
+ -- variable Current_Instantiated_Parent must be stacked because nested
+ -- instantiations can occur, e.g. the occurrence of 4 within 2.
+
+ -- The instantiation of package and subprogram bodies is handled in a
+ -- similar manner, except that it is delayed until after semantic
+ -- analysis is complete. In this fashion complex cross-dependencies
+ -- between several package declarations and bodies containing generics
+ -- can be compiled which otherwise would diagnose spurious circularities.
+
+ -- For example, it is possible to compile two packages A and B that
+ -- have the following structure:
+
+ -- package A is package B is
+ -- generic ... generic ...
+ -- package G_A is package G_B is
+
+ -- with B; with A;
+ -- package body A is package body B is
+ -- package N_B is new G_B (..) package N_A is new G_A (..)
+
+ -- The table Pending_Instantiations in package Inline is used to keep
+ -- track of body instantiations that are delayed in this manner. Inline
+ -- handles the actual calls to do the body instantiations. This activity
+ -- is part of Inline, since the processing occurs at the same point, and
+ -- for essentially the same reason, as the handling of inlined routines.
+
+ ----------------------------------------------
+ -- Detection of Instantiation Circularities --
+ ----------------------------------------------
+
+ -- If we have a chain of instantiations that is circular, this is a
+ -- static error which must be detected at compile time. The detection
+ -- of these circularities is carried out at the point that we insert
+ -- a generic instance spec or body. If there is a circularity, then
+ -- the analysis of the offending spec or body will eventually result
+ -- in trying to load the same unit again, and we detect this problem
+ -- as we analyze the package instantiation for the second time.
+
+ -- At least in some cases after we have detected the circularity, we
+ -- get into trouble if we try to keep going. The following flag is
+ -- set if a circularity is detected, and used to abandon compilation
+ -- after the messages have been posted.
+
+ Circularity_Detected : Boolean := False;
+ -- This should really be reset on encountering a new main unit, but in
+ -- practice we are not using multiple main units so it is not critical.
+
+ -----------------------
+ -- Local subprograms --
+ -----------------------
+
+ procedure Abandon_Instantiation (N : Node_Id);
+ pragma No_Return (Abandon_Instantiation);
+ -- Posts an error message "instantiation abandoned" at the indicated
+ -- node and then raises the exception Instantiation_Error to do it.
+
+ procedure Analyze_Formal_Array_Type
+ (T : in out Entity_Id;
+ Def : Node_Id);
+ -- A formal array type is treated like an array type declaration, and
+ -- invokes Array_Type_Declaration (sem_ch3) whose first parameter is
+ -- in-out, because in the case of an anonymous type the entity is
+ -- actually created in the procedure.
+
+ -- The following procedures treat other kinds of formal parameters.
+
+ procedure Analyze_Formal_Derived_Type
+ (N : Node_Id;
+ T : Entity_Id;
+ Def : Node_Id);
+
+ -- All the following need comments???
+
+ procedure Analyze_Formal_Decimal_Fixed_Point_Type
+ (T : Entity_Id; Def : Node_Id);
+ procedure Analyze_Formal_Discrete_Type (T : Entity_Id; Def : Node_Id);
+ procedure Analyze_Formal_Floating_Type (T : Entity_Id; Def : Node_Id);
+ procedure Analyze_Formal_Signed_Integer_Type (T : Entity_Id; Def : Node_Id);
+ procedure Analyze_Formal_Modular_Type (T : Entity_Id; Def : Node_Id);
+ procedure Analyze_Formal_Ordinary_Fixed_Point_Type
+ (T : Entity_Id; Def : Node_Id);
+
+ procedure Analyze_Formal_Private_Type
+ (N : Node_Id;
+ T : Entity_Id;
+ Def : Node_Id);
+ -- This needs comments???
+
+ procedure Analyze_Generic_Formal_Part (N : Node_Id);
+
+ procedure Analyze_Generic_Access_Type (T : Entity_Id; Def : Node_Id);
+ -- This needs comments ???
+
+ function Analyze_Associations
+ (I_Node : Node_Id;
+ Formals : List_Id;
+ F_Copy : List_Id)
+ return List_Id;
+ -- At instantiation time, build the list of associations between formals
+ -- and actuals. Each association becomes a renaming declaration for the
+ -- formal entity. F_Copy is the analyzed list of formals in the generic
+ -- copy. It is used to apply legality checks to the actuals. I_Node is the
+ -- instantiation node itself.
+
+ procedure Analyze_Subprogram_Instantiation
+ (N : Node_Id;
+ K : Entity_Kind);
+
+ procedure Build_Instance_Compilation_Unit_Nodes
+ (N : Node_Id;
+ Act_Body : Node_Id;
+ Act_Decl : Node_Id);
+ -- This procedure is used in the case where the generic instance of a
+ -- subprogram body or package body is a library unit. In this case, the
+ -- original library unit node for the generic instantiation must be
+ -- replaced by the resulting generic body, and a link made to a new
+ -- compilation unit node for the generic declaration. The argument N is
+ -- the original generic instantiation. Act_Body and Act_Decl are the body
+ -- and declaration of the instance (either package body and declaration
+ -- nodes or subprogram body and declaration nodes depending on the case).
+ -- On return, the node N has been rewritten with the actual body.
+
+ procedure Check_Formal_Packages (P_Id : Entity_Id);
+ -- Apply the following to all formal packages in generic associations.
+
+ procedure Check_Formal_Package_Instance
+ (Formal_Pack : Entity_Id;
+ Actual_Pack : Entity_Id);
+ -- Verify that the actuals of the actual instance match the actuals of
+ -- the template for a formal package that is not declared with a box.
+
+ procedure Check_Forward_Instantiation (N : Node_Id; Decl : Node_Id);
+ -- If the generic is a local entity and the corresponding body has not
+ -- been seen yet, flag enclosing packages to indicate that it will be
+ -- elaborated after the generic body. Subprograms declared in the same
+ -- package cannot be inlined by the front-end because front-end inlining
+ -- requires a strict linear order of elaboration.
+
+ procedure Check_Hidden_Child_Unit
+ (N : Node_Id;
+ Gen_Unit : Entity_Id;
+ Act_Decl_Id : Entity_Id);
+ -- If the generic unit is an implicit child instance within a parent
+ -- instance, we need to make an explicit test that it is not hidden by
+ -- a child instance of the same name and parent.
+
+ procedure Check_Private_View (N : Node_Id);
+ -- Check whether the type of a generic entity has a different view between
+ -- the point of generic analysis and the point of instantiation. If the
+ -- view has changed, then at the point of instantiation we restore the
+ -- correct view to perform semantic analysis of the instance, and reset
+ -- the current view after instantiation. The processing is driven by the
+ -- current private status of the type of the node, and Has_Private_View,
+ -- a flag that is set at the point of generic compilation. If view and
+ -- flag are inconsistent then the type is updated appropriately.
+
+ procedure Check_Generic_Actuals
+ (Instance : Entity_Id;
+ Is_Formal_Box : Boolean);
+ -- Similar to previous one. Check the actuals in the instantiation,
+ -- whose views can change between the point of instantiation and the point
+ -- of instantiation of the body. In addition, mark the generic renamings
+ -- as generic actuals, so that they are not compatible with other actuals.
+ -- Recurse on an actual that is a formal package whose declaration has
+ -- a box.
+
+ function Contains_Instance_Of
+ (Inner : Entity_Id;
+ Outer : Entity_Id;
+ N : Node_Id)
+ return Boolean;
+ -- Inner is instantiated within the generic Outer. Check whether Inner
+ -- directly or indirectly contains an instance of Outer or of one of its
+ -- parents, in the case of a subunit. Each generic unit holds a list of
+ -- the entities instantiated within (at any depth). This procedure
+ -- determines whether the set of such lists contains a cycle, i.e. an
+ -- illegal circular instantiation.
+
+ function Denotes_Formal_Package (Pack : Entity_Id) return Boolean;
+ -- Returns True if E is a formal package of an enclosing generic, or
+ -- the actual for such a formal in an enclosing instantiation. Used in
+ -- Restore_Private_Views, to keep the formals of such a package visible
+ -- on exit from an inner instantiation.
+
+ function Find_Actual_Type
+ (Typ : Entity_Id;
+ Gen_Scope : Entity_Id)
+ return Entity_Id;
+ -- When validating the actual types of a child instance, check whether
+ -- the formal is a formal type of the parent unit, and retrieve the current
+ -- actual for it. Typ is the entity in the analyzed formal type declaration
+ -- (component or index type of an array type) and Gen_Scope is the scope of
+ -- the analyzed formal array type.
+
+ function Get_Package_Instantiation_Node (A : Entity_Id) return Node_Id;
+ -- Given the entity of a unit that is an instantiation, retrieve the
+ -- original instance node. This is used when loading the instantiations
+ -- of the ancestors of a child generic that is being instantiated.
+
+ function In_Same_Declarative_Part
+ (F_Node : Node_Id;
+ Inst : Node_Id)
+ return Boolean;
+ -- True if the instantiation Inst and the given freeze_node F_Node appear
+ -- within the same declarative part, ignoring subunits, but with no inter-
+ -- vening suprograms or concurrent units. If true, the freeze node
+ -- of the instance can be placed after the freeze node of the parent,
+ -- which it itself an instance.
+
+ procedure Set_Instance_Of (A : Entity_Id; B : Entity_Id);
+ -- Associate analyzed generic parameter with corresponding
+ -- instance. Used for semantic checks at instantiation time.
+
+ function Has_Been_Exchanged (E : Entity_Id) return Boolean;
+ -- Traverse the Exchanged_Views list to see if a type was private
+ -- and has already been flipped during this phase of instantiation.
+
+ procedure Hide_Current_Scope;
+ -- When compiling a generic child unit, the parent context must be
+ -- present, but the instance and all entities that may be generated
+ -- must be inserted in the current scope. We leave the current scope
+ -- on the stack, but make its entities invisible to avoid visibility
+ -- problems. This is reversed at the end of instantiations. This is
+ -- not done for the instantiation of the bodies, which only require the
+ -- instances of the generic parents to be in scope.
+
+ procedure Install_Body
+ (Act_Body : Node_Id;
+ N : Node_Id;
+ Gen_Body : Node_Id;
+ Gen_Decl : Node_Id);
+ -- If the instantiation happens textually before the body of the generic,
+ -- the instantiation of the body must be analyzed after the generic body,
+ -- and not at the point of instantiation. Such early instantiations can
+ -- happen if the generic and the instance appear in a package declaration
+ -- because the generic body can only appear in the corresponding package
+ -- body. Early instantiations can also appear if generic, instance and
+ -- body are all in the declarative part of a subprogram or entry. Entities
+ -- of packages that are early instantiations are delayed, and their freeze
+ -- node appears after the generic body.
+
+ procedure Insert_After_Last_Decl (N : Node_Id; F_Node : Node_Id);
+ -- Insert freeze node at the end of the declarative part that includes the
+ -- instance node N. If N is in the visible part of an enclosing package
+ -- declaration, the freeze node has to be inserted at the end of the
+ -- private declarations, if any.
+
+ procedure Freeze_Subprogram_Body
+ (Inst_Node : Node_Id;
+ Gen_Body : Node_Id;
+ Pack_Id : Entity_Id);
+ -- The generic body may appear textually after the instance, including
+ -- in the proper body of a stub, or within a different package instance.
+ -- Given that the instance can only be elaborated after the generic, we
+ -- place freeze_nodes for the instance and/or for packages that may enclose
+ -- the instance and the generic, so that the back-end can establish the
+ -- proper order of elaboration.
+
+ procedure Install_Parent (P : Entity_Id; In_Body : Boolean := False);
+ -- When compiling an instance of a child unit the parent (which is
+ -- itself an instance) is an enclosing scope that must be made
+ -- immediately visible. This procedure is also used to install the non-
+ -- generic parent of a generic child unit when compiling its body, so that
+ -- full views of types in the parent are made visible.
+
+ procedure Remove_Parent (In_Body : Boolean := False);
+ -- Reverse effect after instantiation of child is complete.
+
+ procedure Inline_Instance_Body
+ (N : Node_Id;
+ Gen_Unit : Entity_Id;
+ Act_Decl : Node_Id);
+ -- If front-end inlining is requested, instantiate the package body,
+ -- and preserve the visibility of its compilation unit, to insure
+ -- that successive instantiations succeed.
+
+ -- The functions Instantiate_XXX perform various legality checks and build
+ -- the declarations for instantiated generic parameters.
+ -- Need to describe what the parameters are ???
+
+ function Instantiate_Object
+ (Formal : Node_Id;
+ Actual : Node_Id;
+ Analyzed_Formal : Node_Id)
+ return List_Id;
+
+ function Instantiate_Type
+ (Formal : Node_Id;
+ Actual : Node_Id;
+ Analyzed_Formal : Node_Id)
+ return Node_Id;
+
+ function Instantiate_Formal_Subprogram
+ (Formal : Node_Id;
+ Actual : Node_Id;
+ Analyzed_Formal : Node_Id)
+ return Node_Id;
+
+ function Instantiate_Formal_Package
+ (Formal : Node_Id;
+ Actual : Node_Id;
+ Analyzed_Formal : Node_Id)
+ return List_Id;
+ -- If the formal package is declared with a box, special visibility rules
+ -- apply to its formals: they are in the visible part of the package. This
+ -- is true in the declarative region of the formal package, that is to say
+ -- in the enclosing generic or instantiation. For an instantiation, the
+ -- parameters of the formal package are made visible in an explicit step.
+ -- Furthermore, if the actual is a visible use_clause, these formals must
+ -- be made potentially use_visible as well. On exit from the enclosing
+ -- instantiation, the reverse must be done.
+
+ -- For a formal package declared without a box, there are conformance rules
+ -- that apply to the actuals in the generic declaration and the actuals of
+ -- the actual package in the enclosing instantiation. The simplest way to
+ -- apply these rules is to repeat the instantiation of the formal package
+ -- in the context of the enclosing instance, and compare the generic
+ -- associations of this instantiation with those of the actual package.
+
+ function Is_In_Main_Unit (N : Node_Id) return Boolean;
+ -- Test if given node is in the main unit
+
+ procedure Load_Parent_Of_Generic (N : Node_Id; Spec : Node_Id);
+ -- If the generic appears in a separate non-generic library unit,
+ -- load the corresponding body to retrieve the body of the generic.
+ -- N is the node for the generic instantiation, Spec is the generic
+ -- package declaration.
+
+ procedure Inherit_Context (Gen_Decl : Node_Id; Inst : Node_Id);
+ -- Add the context clause of the unit containing a generic unit to
+ -- an instantiation that is a compilation unit.
+
+ function Associated_Node (N : Node_Id) return Node_Id;
+ -- In order to propagate semantic information back from the analyzed
+ -- copy to the original generic, we maintain links between selected nodes
+ -- in the generic and their corresponding copies. At the end of generic
+ -- analysis, the routine Save_Global_References traverses the generic
+ -- tree, examines the semantic information, and preserves the links to
+ -- those nodes that contain global information. At instantiation, the
+ -- information from the associated node is placed on the new copy, so that
+ -- name resolution is not repeated.
+ -- Two kinds of nodes have associated nodes:
+
+ -- a) those that contain entities, that is to say identifiers, expanded_
+ -- names, and operators.
+
+ -- b) aggregates.
+
+ -- For the first class, the associated node preserves the entity if it is
+ -- global. If the generic contains nested instantiations, the associated_
+ -- node itself has been recopied, and a chain of them must be followed.
+
+ -- For aggregates, the associated node allows retrieval of the type, which
+ -- may otherwise not appear in the generic. The view of this type may be
+ -- different between generic and instantiation, and the full view can be
+ -- installed before the instantiation is analyzed. For aggregates of
+ -- type extensions, the same view exchange may have to be performed for
+ -- some of the ancestor types, if their view is private at the point of
+ -- instantiation.
+
+ -- The associated node is stored in Node4, using this field as a free
+ -- union in a fashion that should clearly be under control of sinfo ???
+
+ procedure Move_Freeze_Nodes
+ (Out_Of : Entity_Id;
+ After : Node_Id;
+ L : List_Id);
+ -- Freeze nodes can be generated in the analysis of a generic unit, but
+ -- will not be seen by the back-end. It is necessary to move those nodes
+ -- to the enclosing scope if they freeze an outer entity. We place them
+ -- at the end of the enclosing generic package, which is semantically
+ -- neutral.
+
+ procedure Pre_Analyze_Actuals (N : Node_Id);
+ -- Analyze actuals to perform name resolution. Full resolution is done
+ -- later, when the expected types are known, but names have to be captured
+ -- before installing parents of generics, that are not visible for the
+ -- actuals themselves.
+
+ procedure Set_Associated_Node
+ (Gen_Node : Node_Id;
+ Copy_Node : Node_Id);
+ -- Establish the link between an identifier in the generic unit, and the
+ -- corresponding node in the semantic copy.
+
+ procedure Valid_Default_Attribute (Nam : Entity_Id; Def : Node_Id);
+ -- Verify that an attribute that appears as the default for a formal
+ -- subprogram is a function or procedure with the correct profile.
+
+ -------------------------------------------
+ -- Data Structures for Generic Renamings --
+ -------------------------------------------
+
+ -- The map Generic_Renamings associates generic entities with their
+ -- corresponding actuals. Currently used to validate type instances.
+ -- It will eventually be used for all generic parameters to eliminate
+ -- the need for overload resolution in the instance.
+
+ type Assoc_Ptr is new Int;
+
+ Assoc_Null : constant Assoc_Ptr := -1;
+
+ type Assoc is record
+ Gen_Id : Entity_Id;
+ Act_Id : Entity_Id;
+ Next_In_HTable : Assoc_Ptr;
+ end record;
+
+ package Generic_Renamings is new Table.Table
+ (Table_Component_Type => Assoc,
+ Table_Index_Type => Assoc_Ptr,
+ Table_Low_Bound => 0,
+ Table_Initial => 10,
+ Table_Increment => 100,
+ Table_Name => "Generic_Renamings");
+
+ -- Variable to hold enclosing instantiation. When the environment is
+ -- saved for a subprogram inlining, the corresponding Act_Id is empty.
+
+ Current_Instantiated_Parent : Assoc := (Empty, Empty, Assoc_Null);
+
+ -- Hash table for associations
+
+ HTable_Size : constant := 37;
+ type HTable_Range is range 0 .. HTable_Size - 1;
+
+ procedure Set_Next_Assoc (E : Assoc_Ptr; Next : Assoc_Ptr);
+ function Next_Assoc (E : Assoc_Ptr) return Assoc_Ptr;
+ function Get_Gen_Id (E : Assoc_Ptr) return Entity_Id;
+ function Hash (F : Entity_Id) return HTable_Range;
+
+ package Generic_Renamings_HTable is new GNAT.HTable.Static_HTable (
+ Header_Num => HTable_Range,
+ Element => Assoc,
+ Elmt_Ptr => Assoc_Ptr,
+ Null_Ptr => Assoc_Null,
+ Set_Next => Set_Next_Assoc,
+ Next => Next_Assoc,
+ Key => Entity_Id,
+ Get_Key => Get_Gen_Id,
+ Hash => Hash,
+ Equal => "=");
+
+ Exchanged_Views : Elist_Id;
+ -- This list holds the private views that have been exchanged during
+ -- instantiation to restore the visibility of the generic declaration.
+ -- (see comments above). After instantiation, the current visibility is
+ -- reestablished by means of a traversal of this list.
+
+ Hidden_Entities : Elist_Id;
+ -- This list holds the entities of the current scope that are removed
+ -- from immediate visibility when instantiating a child unit. Their
+ -- visibility is restored in Remove_Parent.
+
+ -- Because instantiations can be recursive, the following must be saved
+ -- on entry and restored on exit from an instantiation (spec or body).
+ -- This is done by the two procedures Save_Env and Restore_Env.
+
+ type Instance_Env is record
+ Ada_83 : Boolean;
+ Instantiated_Parent : Assoc;
+ Exchanged_Views : Elist_Id;
+ Hidden_Entities : Elist_Id;
+ Current_Sem_Unit : Unit_Number_Type;
+ end record;
+
+ package Instance_Envs is new Table.Table (
+ Table_Component_Type => Instance_Env,
+ Table_Index_Type => Int,
+ Table_Low_Bound => 0,
+ Table_Initial => 32,
+ Table_Increment => 100,
+ Table_Name => "Instance_Envs");
+
+ procedure Restore_Private_Views
+ (Pack_Id : Entity_Id;
+ Is_Package : Boolean := True);
+ -- Restore the private views of external types, and unmark the generic
+ -- renamings of actuals, so that they become comptible subtypes again.
+ -- For subprograms, Pack_Id is the package constructed to hold the
+ -- renamings.
+
+ procedure Switch_View (T : Entity_Id);
+ -- Switch the partial and full views of a type and its private
+ -- dependents (i.e. its subtypes and derived types).
+
+ ------------------------------------
+ -- Structures for Error Reporting --
+ ------------------------------------
+
+ Instantiation_Node : Node_Id;
+ -- Used by subprograms that validate instantiation of formal parameters
+ -- where there might be no actual on which to place the error message.
+ -- Also used to locate the instantiation node for generic subunits.
+
+ Instantiation_Error : exception;
+ -- When there is a semantic error in the generic parameter matching,
+ -- there is no point in continuing the instantiation, because the
+ -- number of cascaded errors is unpredictable. This exception aborts
+ -- the instantiation process altogether.
+
+ S_Adjustment : Sloc_Adjustment;
+ -- Offset created for each node in an instantiation, in order to keep
+ -- track of the source position of the instantiation in each of its nodes.
+ -- A subsequent semantic error or warning on a construct of the instance
+ -- points to both places: the original generic node, and the point of
+ -- instantiation. See Sinput and Sinput.L for additional details.
+
+ ------------------------------------------------------------
+ -- Data structure for keeping track when inside a Generic --
+ ------------------------------------------------------------
+
+ -- The following table is used to save values of the Inside_A_Generic
+ -- flag (see spec of Sem) when they are saved by Start_Generic.
+
+ package Generic_Flags is new Table.Table (
+ Table_Component_Type => Boolean,
+ Table_Index_Type => Int,
+ Table_Low_Bound => 0,
+ Table_Initial => 32,
+ Table_Increment => 200,
+ Table_Name => "Generic_Flags");
+
+ ---------------------------
+ -- Abandon_Instantiation --
+ ---------------------------
+
+ procedure Abandon_Instantiation (N : Node_Id) is
+ begin
+ Error_Msg_N ("instantiation abandoned!", N);
+ raise Instantiation_Error;
+ end Abandon_Instantiation;
+
+ --------------------------
+ -- Analyze_Associations --
+ --------------------------
+
+ function Analyze_Associations
+ (I_Node : Node_Id;
+ Formals : List_Id;
+ F_Copy : List_Id)
+ return List_Id
+ is
+ Actuals : List_Id := Generic_Associations (I_Node);
+ Actual : Node_Id;
+ Actual_Types : Elist_Id := New_Elmt_List;
+ Assoc : List_Id := New_List;
+ Formal : Node_Id;
+ Next_Formal : Node_Id;
+ Temp_Formal : Node_Id;
+ Analyzed_Formal : Node_Id;
+ Defaults : Elist_Id := New_Elmt_List;
+ Match : Node_Id;
+ Named : Node_Id;
+ First_Named : Node_Id := Empty;
+ Found_Assoc : Node_Id;
+ Is_Named_Assoc : Boolean;
+ Num_Matched : Int := 0;
+ Num_Actuals : Int := 0;
+
+ function Matching_Actual
+ (F : Entity_Id;
+ A_F : Entity_Id)
+ return Node_Id;
+ -- Find actual that corresponds to a given a formal parameter. If the
+ -- actuals are positional, return the next one, if any. If the actuals
+ -- are named, scan the parameter associations to find the right one.
+ -- A_F is the corresponding entity in the analyzed generic,which is
+ -- placed on the selector name for ASIS use.
+
+ procedure Set_Analyzed_Formal;
+ -- Find the node in the generic copy that corresponds to a given formal.
+ -- The semantic information on this node is used to perform legality
+ -- checks on the actuals. Because semantic analysis can introduce some
+ -- anonymous entities or modify the declaration node itself, the
+ -- correspondence between the two lists is not one-one. In addition to
+ -- anonymous types, the presence a formal equality will introduce an
+ -- implicit declaration for the corresponding inequality.
+
+ ---------------------
+ -- Matching_Actual --
+ ---------------------
+
+ function Matching_Actual
+ (F : Entity_Id;
+ A_F : Entity_Id)
+ return Node_Id
+ is
+ Found : Node_Id;
+ Prev : Node_Id;
+
+ begin
+ Is_Named_Assoc := False;
+
+ -- End of list of purely positional parameters
+
+ if No (Actual) then
+ Found := Empty;
+
+ -- Case of positional parameter corresponding to current formal
+
+ elsif No (Selector_Name (Actual)) then
+ Found := Explicit_Generic_Actual_Parameter (Actual);
+ Found_Assoc := Actual;
+ Num_Matched := Num_Matched + 1;
+ Next (Actual);
+
+ -- Otherwise scan list of named actuals to find the one with the
+ -- desired name. All remaining actuals have explicit names.
+
+ else
+ Is_Named_Assoc := True;
+ Found := Empty;
+ Prev := Empty;
+
+ while Present (Actual) loop
+ if Chars (Selector_Name (Actual)) = Chars (F) then
+ Found := Explicit_Generic_Actual_Parameter (Actual);
+ Set_Entity (Selector_Name (Actual), A_F);
+ Set_Etype (Selector_Name (Actual), Etype (A_F));
+ Found_Assoc := Actual;
+ Num_Matched := Num_Matched + 1;
+ exit;
+ end if;
+
+ Prev := Actual;
+ Next (Actual);
+ end loop;
+
+ -- Reset for subsequent searches. In most cases the named
+ -- associations are in order. If they are not, we reorder them
+ -- to avoid scanning twice the same actual. This is not just a
+ -- question of efficiency: there may be multiple defaults with
+ -- boxes that have the same name. In a nested instantiation we
+ -- insert actuals for those defaults, and cannot rely on their
+ -- names to disambiguate them.
+
+ if Actual = First_Named then
+ Next (First_Named);
+
+ elsif Present (Actual) then
+ Insert_Before (First_Named, Remove_Next (Prev));
+ end if;
+
+ Actual := First_Named;
+ end if;
+
+ return Found;
+ end Matching_Actual;
+
+ -------------------------
+ -- Set_Analyzed_Formal --
+ -------------------------
+
+ procedure Set_Analyzed_Formal is
+ Kind : Node_Kind;
+ begin
+ while Present (Analyzed_Formal) loop
+ Kind := Nkind (Analyzed_Formal);
+
+ case Nkind (Formal) is
+
+ when N_Formal_Subprogram_Declaration =>
+ exit when Kind = N_Formal_Subprogram_Declaration
+ and then
+ Chars
+ (Defining_Unit_Name (Specification (Formal))) =
+ Chars
+ (Defining_Unit_Name (Specification (Analyzed_Formal)));
+
+ when N_Formal_Package_Declaration =>
+ exit when
+ Kind = N_Formal_Package_Declaration
+ or else
+ Kind = N_Generic_Package_Declaration;
+
+ when N_Use_Package_Clause | N_Use_Type_Clause => exit;
+
+ when others =>
+
+ -- Skip freeze nodes, and nodes inserted to replace
+ -- unrecognized pragmas.
+
+ exit when
+ Kind /= N_Formal_Subprogram_Declaration
+ and then Kind /= N_Subprogram_Declaration
+ and then Kind /= N_Freeze_Entity
+ and then Kind /= N_Null_Statement
+ and then Kind /= N_Itype_Reference
+ and then Chars (Defining_Identifier (Formal)) =
+ Chars (Defining_Identifier (Analyzed_Formal));
+ end case;
+
+ Next (Analyzed_Formal);
+ end loop;
+
+ end Set_Analyzed_Formal;
+
+ -- Start of processing for Analyze_Associations
+
+ begin
+ -- If named associations are present, save the first named association
+ -- (it may of course be Empty) to facilitate subsequent name search.
+
+ if Present (Actuals) then
+ First_Named := First (Actuals);
+
+ while Present (First_Named)
+ and then No (Selector_Name (First_Named))
+ loop
+ Num_Actuals := Num_Actuals + 1;
+ Next (First_Named);
+ end loop;
+ end if;
+
+ Named := First_Named;
+ while Present (Named) loop
+ if No (Selector_Name (Named)) then
+ Error_Msg_N ("invalid positional actual after named one", Named);
+ Abandon_Instantiation (Named);
+ end if;
+
+ Num_Actuals := Num_Actuals + 1;
+ Next (Named);
+ end loop;
+
+ if Present (Formals) then
+ Formal := First_Non_Pragma (Formals);
+ Analyzed_Formal := First_Non_Pragma (F_Copy);
+
+ if Present (Actuals) then
+ Actual := First (Actuals);
+
+ -- All formals should have default values
+
+ else
+ Actual := Empty;
+ end if;
+
+ while Present (Formal) loop
+ Set_Analyzed_Formal;
+ Next_Formal := Next_Non_Pragma (Formal);
+
+ case Nkind (Formal) is
+ when N_Formal_Object_Declaration =>
+ Match :=
+ Matching_Actual (
+ Defining_Identifier (Formal),
+ Defining_Identifier (Analyzed_Formal));
+
+ Append_List
+ (Instantiate_Object (Formal, Match, Analyzed_Formal),
+ Assoc);
+
+ when N_Formal_Type_Declaration =>
+ Match :=
+ Matching_Actual (
+ Defining_Identifier (Formal),
+ Defining_Identifier (Analyzed_Formal));
+
+ if No (Match) then
+ Error_Msg_NE ("missing actual for instantiation of &",
+ Instantiation_Node, Defining_Identifier (Formal));
+ Abandon_Instantiation (Instantiation_Node);
+
+ else
+ Analyze (Match);
+ Append_To (Assoc,
+ Instantiate_Type (Formal, Match, Analyzed_Formal));
+
+ -- an instantiation is a freeze point for the actuals,
+ -- unless this is a rewritten formal package.
+
+ if Nkind (I_Node) /= N_Formal_Package_Declaration then
+ Append_Elmt (Entity (Match), Actual_Types);
+ end if;
+ end if;
+
+ -- A remote access-to-class-wide type must not be an
+ -- actual parameter for a generic formal of an access
+ -- type (E.2.2 (17)).
+
+ if Nkind (Analyzed_Formal) = N_Formal_Type_Declaration
+ and then
+ Nkind (Formal_Type_Definition (Analyzed_Formal)) =
+ N_Access_To_Object_Definition
+ then
+ Validate_Remote_Access_To_Class_Wide_Type (Match);
+ end if;
+
+ when N_Formal_Subprogram_Declaration =>
+ Match :=
+ Matching_Actual (
+ Defining_Unit_Name (Specification (Formal)),
+ Defining_Unit_Name (Specification (Analyzed_Formal)));
+
+ -- If the formal subprogram has the same name as
+ -- another formal subprogram of the generic, then
+ -- a named association is illegal (12.3(9)). Exclude
+ -- named associations that are generated for a nested
+ -- instance.
+
+ if Present (Match)
+ and then Is_Named_Assoc
+ and then Comes_From_Source (Found_Assoc)
+ then
+ Temp_Formal := First (Formals);
+ while Present (Temp_Formal) loop
+ if Nkind (Temp_Formal) =
+ N_Formal_Subprogram_Declaration
+ and then Temp_Formal /= Formal
+ and then
+ Chars (Selector_Name (Found_Assoc)) =
+ Chars (Defining_Unit_Name
+ (Specification (Temp_Formal)))
+ then
+ Error_Msg_N
+ ("name not allowed for overloaded formal",
+ Found_Assoc);
+ Abandon_Instantiation (Instantiation_Node);
+ end if;
+
+ Next (Temp_Formal);
+ end loop;
+ end if;
+
+ Append_To (Assoc,
+ Instantiate_Formal_Subprogram
+ (Formal, Match, Analyzed_Formal));
+
+ if No (Match)
+ and then Box_Present (Formal)
+ then
+ Append_Elmt
+ (Defining_Unit_Name (Specification (Last (Assoc))),
+ Defaults);
+ end if;
+
+ when N_Formal_Package_Declaration =>
+ Match :=
+ Matching_Actual (
+ Defining_Identifier (Formal),
+ Defining_Identifier (Original_Node (Analyzed_Formal)));
+
+ if No (Match) then
+ Error_Msg_NE
+ ("missing actual for instantiation of&",
+ Instantiation_Node,
+ Defining_Identifier (Formal));
+
+ Abandon_Instantiation (Instantiation_Node);
+
+ else
+ Analyze (Match);
+ Append_List
+ (Instantiate_Formal_Package
+ (Formal, Match, Analyzed_Formal),
+ Assoc);
+ end if;
+
+ -- For use type and use package appearing in the context
+ -- clause, we have already copied them, so we can just
+ -- move them where they belong (we mustn't recopy them
+ -- since this would mess up the Sloc values).
+
+ when N_Use_Package_Clause |
+ N_Use_Type_Clause =>
+ Remove (Formal);
+ Append (Formal, Assoc);
+
+ when others =>
+ raise Program_Error;
+
+ end case;
+
+ Formal := Next_Formal;
+ Next_Non_Pragma (Analyzed_Formal);
+ end loop;
+
+ if Num_Actuals > Num_Matched then
+ Error_Msg_N
+ ("unmatched actuals in instantiation", Instantiation_Node);
+ end if;
+
+ elsif Present (Actuals) then
+ Error_Msg_N
+ ("too many actuals in generic instantiation", Instantiation_Node);
+ end if;
+
+ declare
+ Elmt : Elmt_Id := First_Elmt (Actual_Types);
+
+ begin
+ while Present (Elmt) loop
+ Freeze_Before (I_Node, Node (Elmt));
+ Next_Elmt (Elmt);
+ end loop;
+ end;
+
+ -- If there are default subprograms, normalize the tree by adding
+ -- explicit associations for them. This is required if the instance
+ -- appears within a generic.
+
+ declare
+ Elmt : Elmt_Id;
+ Subp : Entity_Id;
+ New_D : Node_Id;
+
+ begin
+ Elmt := First_Elmt (Defaults);
+ while Present (Elmt) loop
+ if No (Actuals) then
+ Actuals := New_List;
+ Set_Generic_Associations (I_Node, Actuals);
+ end if;
+
+ Subp := Node (Elmt);
+ New_D :=
+ Make_Generic_Association (Sloc (Subp),
+ Selector_Name => New_Occurrence_Of (Subp, Sloc (Subp)),
+ Explicit_Generic_Actual_Parameter =>
+ New_Occurrence_Of (Subp, Sloc (Subp)));
+ Mark_Rewrite_Insertion (New_D);
+ Append_To (Actuals, New_D);
+ Next_Elmt (Elmt);
+ end loop;
+ end;
+
+ return Assoc;
+ end Analyze_Associations;
+
+ -------------------------------
+ -- Analyze_Formal_Array_Type --
+ -------------------------------
+
+ procedure Analyze_Formal_Array_Type
+ (T : in out Entity_Id;
+ Def : Node_Id)
+ is
+ DSS : Node_Id;
+
+ begin
+ -- Treated like a non-generic array declaration, with
+ -- additional semantic checks.
+
+ Enter_Name (T);
+
+ if Nkind (Def) = N_Constrained_Array_Definition then
+ DSS := First (Discrete_Subtype_Definitions (Def));
+ while Present (DSS) loop
+ if Nkind (DSS) = N_Subtype_Indication
+ or else Nkind (DSS) = N_Range
+ or else Nkind (DSS) = N_Attribute_Reference
+ then
+ Error_Msg_N ("only a subtype mark is allowed in a formal", DSS);
+ end if;
+
+ Next (DSS);
+ end loop;
+ end if;
+
+ Array_Type_Declaration (T, Def);
+ Set_Is_Generic_Type (Base_Type (T));
+
+ if Ekind (Component_Type (T)) = E_Incomplete_Type
+ and then No (Full_View (Component_Type (T)))
+ then
+ Error_Msg_N ("premature usage of incomplete type", Def);
+
+ elsif Is_Internal (Component_Type (T))
+ and then Nkind (Original_Node (Subtype_Indication (Def)))
+ /= N_Attribute_Reference
+ then
+ Error_Msg_N
+ ("only a subtype mark is allowed in a formal",
+ Subtype_Indication (Def));
+ end if;
+
+ end Analyze_Formal_Array_Type;
+
+ ---------------------------------------------
+ -- Analyze_Formal_Decimal_Fixed_Point_Type --
+ ---------------------------------------------
+
+ -- As for other generic types, we create a valid type representation
+ -- with legal but arbitrary attributes, whose values are never considered
+ -- static. For all scalar types we introduce an anonymous base type, with
+ -- the same attributes. We choose the corresponding integer type to be
+ -- Standard_Integer.
+
+ procedure Analyze_Formal_Decimal_Fixed_Point_Type
+ (T : Entity_Id;
+ Def : Node_Id)
+ is
+ Loc : constant Source_Ptr := Sloc (Def);
+ Base : constant Entity_Id :=
+ New_Internal_Entity
+ (E_Decimal_Fixed_Point_Type,
+ Current_Scope, Sloc (Def), 'G');
+ Int_Base : constant Entity_Id := Standard_Integer;
+ Delta_Val : constant Ureal := Ureal_1;
+ Digs_Val : constant Uint := Uint_6;
+
+ begin
+ Enter_Name (T);
+
+ Set_Etype (Base, Base);
+ Set_Size_Info (Base, Int_Base);
+ Set_RM_Size (Base, RM_Size (Int_Base));
+ Set_First_Rep_Item (Base, First_Rep_Item (Int_Base));
+ Set_Digits_Value (Base, Digs_Val);
+ Set_Delta_Value (Base, Delta_Val);
+ Set_Small_Value (Base, Delta_Val);
+ Set_Scalar_Range (Base,
+ Make_Range (Loc,
+ Low_Bound => Make_Real_Literal (Loc, Ureal_1),
+ High_Bound => Make_Real_Literal (Loc, Ureal_1)));
+
+ Set_Is_Generic_Type (Base);
+ Set_Parent (Base, Parent (Def));
+
+ Set_Ekind (T, E_Decimal_Fixed_Point_Subtype);
+ Set_Etype (T, Base);
+ Set_Size_Info (T, Int_Base);
+ Set_RM_Size (T, RM_Size (Int_Base));
+ Set_First_Rep_Item (T, First_Rep_Item (Int_Base));
+ Set_Digits_Value (T, Digs_Val);
+ Set_Delta_Value (T, Delta_Val);
+ Set_Small_Value (T, Delta_Val);
+ Set_Scalar_Range (T, Scalar_Range (Base));
+
+ end Analyze_Formal_Decimal_Fixed_Point_Type;
+
+ ---------------------------------
+ -- Analyze_Formal_Derived_Type --
+ ---------------------------------
+
+ procedure Analyze_Formal_Derived_Type
+ (N : Node_Id;
+ T : Entity_Id;
+ Def : Node_Id)
+ is
+ Loc : constant Source_Ptr := Sloc (Def);
+ New_N : Node_Id;
+ Unk_Disc : Boolean := Unknown_Discriminants_Present (N);
+
+ begin
+ Set_Is_Generic_Type (T);
+
+ if Private_Present (Def) then
+ New_N :=
+ Make_Private_Extension_Declaration (Loc,
+ Defining_Identifier => T,
+ Discriminant_Specifications => Discriminant_Specifications (N),
+ Unknown_Discriminants_Present => Unk_Disc,
+ Subtype_Indication => Subtype_Mark (Def));
+
+ Set_Abstract_Present (New_N, Abstract_Present (Def));
+
+ else
+ New_N :=
+ Make_Full_Type_Declaration (Loc,
+ Defining_Identifier => T,
+ Discriminant_Specifications =>
+ Discriminant_Specifications (Parent (T)),
+ Type_Definition =>
+ Make_Derived_Type_Definition (Loc,
+ Subtype_Indication => Subtype_Mark (Def)));
+
+ Set_Abstract_Present
+ (Type_Definition (New_N), Abstract_Present (Def));
+ end if;
+
+ Rewrite (N, New_N);
+ Analyze (N);
+
+ if Unk_Disc then
+ if not Is_Composite_Type (T) then
+ Error_Msg_N
+ ("unknown discriminants not allowed for elementary types", N);
+ else
+ Set_Has_Unknown_Discriminants (T);
+ Set_Is_Constrained (T, False);
+ end if;
+ end if;
+
+ -- If the parent type has a known size, so does the formal, which
+ -- makes legal representation clauses that involve the formal.
+
+ Set_Size_Known_At_Compile_Time
+ (T, Size_Known_At_Compile_Time (Entity (Subtype_Mark (Def))));
+
+ end Analyze_Formal_Derived_Type;
+
+ ----------------------------------
+ -- Analyze_Formal_Discrete_Type --
+ ----------------------------------
+
+ -- The operations defined for a discrete types are those of an
+ -- enumeration type. The size is set to an arbitrary value, for use
+ -- in analyzing the generic unit.
+
+ procedure Analyze_Formal_Discrete_Type (T : Entity_Id; Def : Node_Id) is
+ Loc : constant Source_Ptr := Sloc (Def);
+ Lo : Node_Id;
+ Hi : Node_Id;
+
+ begin
+ Enter_Name (T);
+ Set_Ekind (T, E_Enumeration_Type);
+ Set_Etype (T, T);
+ Init_Size (T, 8);
+ Init_Alignment (T);
+
+ -- For semantic analysis, the bounds of the type must be set to some
+ -- non-static value. The simplest is to create attribute nodes for
+ -- those bounds, that refer to the type itself. These bounds are never
+ -- analyzed but serve as place-holders.
+
+ Lo :=
+ Make_Attribute_Reference (Loc,
+ Attribute_Name => Name_First,
+ Prefix => New_Reference_To (T, Loc));
+ Set_Etype (Lo, T);
+
+ Hi :=
+ Make_Attribute_Reference (Loc,
+ Attribute_Name => Name_Last,
+ Prefix => New_Reference_To (T, Loc));
+ Set_Etype (Hi, T);
+
+ Set_Scalar_Range (T,
+ Make_Range (Loc,
+ Low_Bound => Lo,
+ High_Bound => Hi));
+
+ end Analyze_Formal_Discrete_Type;
+
+ ----------------------------------
+ -- Analyze_Formal_Floating_Type --
+ ---------------------------------
+
+ procedure Analyze_Formal_Floating_Type (T : Entity_Id; Def : Node_Id) is
+ Base : constant Entity_Id :=
+ New_Internal_Entity
+ (E_Floating_Point_Type, Current_Scope, Sloc (Def), 'G');
+
+ begin
+ -- The various semantic attributes are taken from the predefined type
+ -- Float, just so that all of them are initialized. Their values are
+ -- never used because no constant folding or expansion takes place in
+ -- the generic itself.
+
+ Enter_Name (T);
+ Set_Ekind (T, E_Floating_Point_Subtype);
+ Set_Etype (T, Base);
+ Set_Size_Info (T, (Standard_Float));
+ Set_RM_Size (T, RM_Size (Standard_Float));
+ Set_Digits_Value (T, Digits_Value (Standard_Float));
+ Set_Scalar_Range (T, Scalar_Range (Standard_Float));
+
+ Set_Is_Generic_Type (Base);
+ Set_Etype (Base, Base);
+ Set_Size_Info (Base, (Standard_Float));
+ Set_RM_Size (Base, RM_Size (Standard_Float));
+ Set_Digits_Value (Base, Digits_Value (Standard_Float));
+ Set_Scalar_Range (Base, Scalar_Range (Standard_Float));
+ Set_Parent (Base, Parent (Def));
+ end Analyze_Formal_Floating_Type;
+
+ ---------------------------------
+ -- Analyze_Formal_Modular_Type --
+ ---------------------------------
+
+ procedure Analyze_Formal_Modular_Type (T : Entity_Id; Def : Node_Id) is
+ begin
+ -- Apart from their entity kind, generic modular types are treated
+ -- like signed integer types, and have the same attributes.
+
+ Analyze_Formal_Signed_Integer_Type (T, Def);
+ Set_Ekind (T, E_Modular_Integer_Subtype);
+ Set_Ekind (Etype (T), E_Modular_Integer_Type);
+
+ end Analyze_Formal_Modular_Type;
+
+ ---------------------------------------
+ -- Analyze_Formal_Object_Declaration --
+ ---------------------------------------
+
+ procedure Analyze_Formal_Object_Declaration (N : Node_Id) is
+ E : constant Node_Id := Expression (N);
+ Id : Node_Id := Defining_Identifier (N);
+ K : Entity_Kind;
+ T : Node_Id;
+
+ begin
+ Enter_Name (Id);
+
+ -- Determine the mode of the formal object
+
+ if Out_Present (N) then
+ K := E_Generic_In_Out_Parameter;
+
+ if not In_Present (N) then
+ Error_Msg_N ("formal generic objects cannot have mode OUT", N);
+ end if;
+
+ else
+ K := E_Generic_In_Parameter;
+ end if;
+
+ Find_Type (Subtype_Mark (N));
+ T := Entity (Subtype_Mark (N));
+
+ if Ekind (T) = E_Incomplete_Type then
+ Error_Msg_N ("premature usage of incomplete type", Subtype_Mark (N));
+ end if;
+
+ if K = E_Generic_In_Parameter then
+ if Is_Limited_Type (T) then
+ Error_Msg_N
+ ("generic formal of mode IN must not be of limited type", N);
+ end if;
+
+ if Is_Abstract (T) then
+ Error_Msg_N
+ ("generic formal of mode IN must not be of abstract type", N);
+ end if;
+
+ if Present (E) then
+ Analyze_Default_Expression (E, T);
+ end if;
+
+ Set_Ekind (Id, K);
+ Set_Etype (Id, T);
+
+ -- Case of generic IN OUT parameter.
+
+ else
+ -- If the formal has an unconstrained type, construct its
+ -- actual subtype, as is done for subprogram formals. In this
+ -- fashion, all its uses can refer to specific bounds.
+
+ Set_Ekind (Id, K);
+ Set_Etype (Id, T);
+
+ if (Is_Array_Type (T)
+ and then not Is_Constrained (T))
+ or else
+ (Ekind (T) = E_Record_Type
+ and then Has_Discriminants (T))
+ then
+ declare
+ Non_Freezing_Ref : constant Node_Id :=
+ New_Reference_To (Id, Sloc (Id));
+ Decl : Node_Id;
+
+ begin
+ -- Make sure that the actual subtype doesn't generate
+ -- bogus freezing.
+
+ Set_Must_Not_Freeze (Non_Freezing_Ref);
+ Decl := Build_Actual_Subtype (T, Non_Freezing_Ref);
+ Insert_Before_And_Analyze (N, Decl);
+ Set_Actual_Subtype (Id, Defining_Identifier (Decl));
+ end;
+ else
+ Set_Actual_Subtype (Id, T);
+ end if;
+
+ if Present (E) then
+ Error_Msg_N
+ ("initialization not allowed for `IN OUT` formals", N);
+ end if;
+ end if;
+
+ end Analyze_Formal_Object_Declaration;
+
+ ----------------------------------------------
+ -- Analyze_Formal_Ordinary_Fixed_Point_Type --
+ ----------------------------------------------
+
+ procedure Analyze_Formal_Ordinary_Fixed_Point_Type
+ (T : Entity_Id;
+ Def : Node_Id)
+ is
+ Loc : constant Source_Ptr := Sloc (Def);
+ Base : constant Entity_Id :=
+ New_Internal_Entity
+ (E_Ordinary_Fixed_Point_Type, Current_Scope, Sloc (Def), 'G');
+ begin
+ -- The semantic attributes are set for completeness only, their
+ -- values will never be used, because all properties of the type
+ -- are non-static.
+
+ Enter_Name (T);
+ Set_Ekind (T, E_Ordinary_Fixed_Point_Subtype);
+ Set_Etype (T, Base);
+ Set_Size_Info (T, Standard_Integer);
+ Set_RM_Size (T, RM_Size (Standard_Integer));
+ Set_Small_Value (T, Ureal_1);
+ Set_Delta_Value (T, Ureal_1);
+ Set_Scalar_Range (T,
+ Make_Range (Loc,
+ Low_Bound => Make_Real_Literal (Loc, Ureal_1),
+ High_Bound => Make_Real_Literal (Loc, Ureal_1)));
+
+ Set_Is_Generic_Type (Base);
+ Set_Etype (Base, Base);
+ Set_Size_Info (Base, Standard_Integer);
+ Set_RM_Size (Base, RM_Size (Standard_Integer));
+ Set_Small_Value (Base, Ureal_1);
+ Set_Delta_Value (Base, Ureal_1);
+ Set_Scalar_Range (Base, Scalar_Range (T));
+ Set_Parent (Base, Parent (Def));
+ end Analyze_Formal_Ordinary_Fixed_Point_Type;
+
+ ----------------------------
+ -- Analyze_Formal_Package --
+ ----------------------------
+
+ procedure Analyze_Formal_Package (N : Node_Id) is
+ Loc : constant Source_Ptr := Sloc (N);
+ Formal : Entity_Id := Defining_Identifier (N);
+ Gen_Id : constant Node_Id := Name (N);
+ Gen_Decl : Node_Id;
+ Gen_Unit : Entity_Id;
+ New_N : Node_Id;
+ Parent_Installed : Boolean := False;
+ Renaming : Node_Id;
+ Parent_Instance : Entity_Id;
+ Renaming_In_Par : Entity_Id;
+
+ begin
+ Text_IO_Kludge (Gen_Id);
+
+ Check_Generic_Child_Unit (Gen_Id, Parent_Installed);
+ Gen_Unit := Entity (Gen_Id);
+
+ if Ekind (Gen_Unit) /= E_Generic_Package then
+ Error_Msg_N ("expect generic package name", Gen_Id);
+ return;
+
+ elsif Gen_Unit = Current_Scope then
+ Error_Msg_N
+ ("generic package cannot be used as a formal package of itself",
+ Gen_Id);
+ return;
+ end if;
+
+ -- Check for a formal package that is a package renaming.
+
+ if Present (Renamed_Object (Gen_Unit)) then
+ Gen_Unit := Renamed_Object (Gen_Unit);
+ end if;
+
+ -- The formal package is treated like a regular instance, but only
+ -- the specification needs to be instantiated, to make entities visible.
+
+ if not Box_Present (N) then
+ Hidden_Entities := New_Elmt_List;
+ Analyze_Package_Instantiation (N);
+
+ if Parent_Installed then
+ Remove_Parent;
+ end if;
+
+ else
+ -- If there are no generic associations, the generic parameters
+ -- appear as local entities and are instantiated like them. We copy
+ -- the generic package declaration as if it were an instantiation,
+ -- and analyze it like a regular package, except that we treat the
+ -- formals as additional visible components.
+
+ Save_Env (Gen_Unit, Formal);
+
+ Gen_Decl := Unit_Declaration_Node (Gen_Unit);
+
+ if In_Extended_Main_Source_Unit (N) then
+ Set_Is_Instantiated (Gen_Unit);
+ Generate_Reference (Gen_Unit, N);
+ end if;
+
+ New_N :=
+ Copy_Generic_Node
+ (Original_Node (Gen_Decl), Empty, Instantiating => True);
+ Set_Defining_Unit_Name (Specification (New_N), Formal);
+ Rewrite (N, New_N);
+
+ Enter_Name (Formal);
+ Set_Ekind (Formal, E_Generic_Package);
+ Set_Etype (Formal, Standard_Void_Type);
+ Set_Inner_Instances (Formal, New_Elmt_List);
+ New_Scope (Formal);
+
+ -- Within the formal, the name of the generic package is a renaming
+ -- of the formal (as for a regular instantiation).
+
+ Renaming := Make_Package_Renaming_Declaration (Loc,
+ Defining_Unit_Name =>
+ Make_Defining_Identifier (Loc, Chars (Gen_Unit)),
+ Name => New_Reference_To (Formal, Loc));
+
+ if Present (Visible_Declarations (Specification (N))) then
+ Prepend (Renaming, To => Visible_Declarations (Specification (N)));
+ elsif Present (Private_Declarations (Specification (N))) then
+ Prepend (Renaming, To => Private_Declarations (Specification (N)));
+ end if;
+
+ if Is_Child_Unit (Gen_Unit)
+ and then Parent_Installed
+ then
+ -- Similarly, we have to make the name of the formal visible in
+ -- the parent instance, to resolve properly fully qualified names
+ -- that may appear in the generic unit. The parent instance has
+ -- been placed on the scope stack ahead of the current scope.
+
+ Parent_Instance := Scope_Stack.Table (Scope_Stack.Last - 1).Entity;
+
+ Renaming_In_Par :=
+ Make_Defining_Identifier (Loc, Chars (Gen_Unit));
+ Set_Ekind (Renaming_In_Par, E_Package);
+ Set_Etype (Renaming_In_Par, Standard_Void_Type);
+ Set_Scope (Renaming_In_Par, Parent_Instance);
+ Set_Parent (Renaming_In_Par, Parent (Formal));
+ Set_Renamed_Object (Renaming_In_Par, Formal);
+ Append_Entity (Renaming_In_Par, Parent_Instance);
+ end if;
+
+ Analyze_Generic_Formal_Part (N);
+ Analyze (Specification (N));
+ End_Package_Scope (Formal);
+
+ if Parent_Installed then
+ Remove_Parent;
+ end if;
+
+ Restore_Env;
+
+ -- Inside the generic unit, the formal package is a regular
+ -- package, but no body is needed for it. Note that after
+ -- instantiation, the defining_unit_name we need is in the
+ -- new tree and not in the original. (see Package_Instantiation).
+ -- A generic formal package is an instance, and can be used as
+ -- an actual for an inner instance. Mark its generic parent.
+
+ Set_Ekind (Formal, E_Package);
+ Set_Generic_Parent (Specification (N), Gen_Unit);
+ Set_Has_Completion (Formal, True);
+ end if;
+ end Analyze_Formal_Package;
+
+ ---------------------------------
+ -- Analyze_Formal_Private_Type --
+ ---------------------------------
+
+ procedure Analyze_Formal_Private_Type
+ (N : Node_Id;
+ T : Entity_Id;
+ Def : Node_Id)
+ is
+ begin
+ New_Private_Type (N, T, Def);
+
+ -- Set the size to an arbitrary but legal value.
+
+ Set_Size_Info (T, Standard_Integer);
+ Set_RM_Size (T, RM_Size (Standard_Integer));
+ end Analyze_Formal_Private_Type;
+
+ ----------------------------------------
+ -- Analyze_Formal_Signed_Integer_Type --
+ ----------------------------------------
+
+ procedure Analyze_Formal_Signed_Integer_Type
+ (T : Entity_Id;
+ Def : Node_Id)
+ is
+ Base : constant Entity_Id :=
+ New_Internal_Entity
+ (E_Signed_Integer_Type, Current_Scope, Sloc (Def), 'G');
+
+ begin
+ Enter_Name (T);
+
+ Set_Ekind (T, E_Signed_Integer_Subtype);
+ Set_Etype (T, Base);
+ Set_Size_Info (T, Standard_Integer);
+ Set_RM_Size (T, RM_Size (Standard_Integer));
+ Set_Scalar_Range (T, Scalar_Range (Standard_Integer));
+
+ Set_Is_Generic_Type (Base);
+ Set_Size_Info (Base, Standard_Integer);
+ Set_RM_Size (Base, RM_Size (Standard_Integer));
+ Set_Etype (Base, Base);
+ Set_Scalar_Range (Base, Scalar_Range (Standard_Integer));
+ Set_Parent (Base, Parent (Def));
+ end Analyze_Formal_Signed_Integer_Type;
+
+ -------------------------------
+ -- Analyze_Formal_Subprogram --
+ -------------------------------
+
+ procedure Analyze_Formal_Subprogram (N : Node_Id) is
+ Spec : constant Node_Id := Specification (N);
+ Def : constant Node_Id := Default_Name (N);
+ Nam : constant Entity_Id := Defining_Unit_Name (Spec);
+ Subp : Entity_Id;
+
+ begin
+ if Nkind (Nam) = N_Defining_Program_Unit_Name then
+ Error_Msg_N ("name of formal subprogram must be a direct name", Nam);
+ return;
+ end if;
+
+ Analyze_Subprogram_Declaration (N);
+ Set_Is_Formal_Subprogram (Nam);
+ Set_Has_Completion (Nam);
+
+ -- Default name is resolved at the point of instantiation
+
+ if Box_Present (N) then
+ null;
+
+ -- Else default is bound at the point of generic declaration
+
+ elsif Present (Def) then
+ if Nkind (Def) = N_Operator_Symbol then
+ Find_Direct_Name (Def);
+
+ elsif Nkind (Def) /= N_Attribute_Reference then
+ Analyze (Def);
+
+ else
+ -- For an attribute reference, analyze the prefix and verify
+ -- that it has the proper profile for the subprogram.
+
+ Analyze (Prefix (Def));
+ Valid_Default_Attribute (Nam, Def);
+ return;
+ end if;
+
+ -- Default name may be overloaded, in which case the interpretation
+ -- with the correct profile must be selected, as for a renaming.
+
+ if Etype (Def) = Any_Type then
+ return;
+
+ elsif Nkind (Def) = N_Selected_Component then
+ Subp := Entity (Selector_Name (Def));
+
+ if Ekind (Subp) /= E_Entry then
+ Error_Msg_N ("expect valid subprogram name as default", Def);
+ return;
+ end if;
+
+ elsif Nkind (Def) = N_Indexed_Component then
+
+ if Nkind (Prefix (Def)) /= N_Selected_Component then
+ Error_Msg_N ("expect valid subprogram name as default", Def);
+ return;
+
+ else
+ Subp := Entity (Selector_Name (Prefix (Def)));
+
+ if Ekind (Subp) /= E_Entry_Family then
+ Error_Msg_N ("expect valid subprogram name as default", Def);
+ return;
+ end if;
+ end if;
+
+ elsif Nkind (Def) = N_Character_Literal then
+
+ -- Needs some type checks: subprogram should be parameterless???
+
+ Resolve (Def, (Etype (Nam)));
+
+ elsif (not Is_Entity_Name (Def)
+ or else not Is_Overloadable (Entity (Def)))
+ then
+ Error_Msg_N ("expect valid subprogram name as default", Def);
+ return;
+
+ elsif not Is_Overloaded (Def) then
+ Subp := Entity (Def);
+
+ if Subp = Nam then
+ Error_Msg_N ("premature usage of formal subprogram", Def);
+
+ elsif not Entity_Matches_Spec (Subp, Nam) then
+ Error_Msg_N ("no visible entity matches specification", Def);
+ end if;
+
+ else
+ declare
+ I : Interp_Index;
+ I1 : Interp_Index := 0;
+ It : Interp;
+ It1 : Interp;
+
+ begin
+ Subp := Any_Id;
+ Get_First_Interp (Def, I, It);
+ while Present (It.Nam) loop
+
+ if Entity_Matches_Spec (It.Nam, Nam) then
+ if Subp /= Any_Id then
+ It1 := Disambiguate (Def, I1, I, Etype (Subp));
+
+ if It1 = No_Interp then
+ Error_Msg_N ("ambiguous default subprogram", Def);
+ else
+ Subp := It1.Nam;
+ end if;
+
+ exit;
+
+ else
+ I1 := I;
+ Subp := It.Nam;
+ end if;
+ end if;
+
+ Get_Next_Interp (I, It);
+ end loop;
+ end;
+
+ if Subp /= Any_Id then
+ Set_Entity (Def, Subp);
+
+ if Subp = Nam then
+ Error_Msg_N ("premature usage of formal subprogram", Def);
+
+ elsif Ekind (Subp) /= E_Operator then
+ Check_Mode_Conformant (Subp, Nam);
+ end if;
+
+ else
+ Error_Msg_N ("no visible subprogram matches specification", N);
+ end if;
+ end if;
+ end if;
+ end Analyze_Formal_Subprogram;
+
+ -------------------------------------
+ -- Analyze_Formal_Type_Declaration --
+ -------------------------------------
+
+ procedure Analyze_Formal_Type_Declaration (N : Node_Id) is
+ Def : constant Node_Id := Formal_Type_Definition (N);
+ T : Entity_Id;
+
+ begin
+ T := Defining_Identifier (N);
+
+ if Present (Discriminant_Specifications (N))
+ and then Nkind (Def) /= N_Formal_Private_Type_Definition
+ then
+ Error_Msg_N
+ ("discriminants not allowed for this formal type",
+ Defining_Identifier (First (Discriminant_Specifications (N))));
+ end if;
+
+ -- Enter the new name, and branch to specific routine.
+
+ case Nkind (Def) is
+ when N_Formal_Private_Type_Definition
+ => Analyze_Formal_Private_Type (N, T, Def);
+
+ when N_Formal_Derived_Type_Definition
+ => Analyze_Formal_Derived_Type (N, T, Def);
+
+ when N_Formal_Discrete_Type_Definition
+ => Analyze_Formal_Discrete_Type (T, Def);
+
+ when N_Formal_Signed_Integer_Type_Definition
+ => Analyze_Formal_Signed_Integer_Type (T, Def);
+
+ when N_Formal_Modular_Type_Definition
+ => Analyze_Formal_Modular_Type (T, Def);
+
+ when N_Formal_Floating_Point_Definition
+ => Analyze_Formal_Floating_Type (T, Def);
+
+ when N_Formal_Ordinary_Fixed_Point_Definition
+ => Analyze_Formal_Ordinary_Fixed_Point_Type (T, Def);
+
+ when N_Formal_Decimal_Fixed_Point_Definition
+ => Analyze_Formal_Decimal_Fixed_Point_Type (T, Def);
+
+ when N_Array_Type_Definition
+ => Analyze_Formal_Array_Type (T, Def);
+
+ when N_Access_To_Object_Definition |
+ N_Access_Function_Definition |
+ N_Access_Procedure_Definition
+ => Analyze_Generic_Access_Type (T, Def);
+
+ when others =>
+ raise Program_Error;
+
+ end case;
+
+ Set_Is_Generic_Type (T);
+
+ end Analyze_Formal_Type_Declaration;
+
+ ------------------------------------
+ -- Analyze_Function_Instantiation --
+ ------------------------------------
+
+ procedure Analyze_Function_Instantiation (N : Node_Id) is
+ begin
+ Analyze_Subprogram_Instantiation (N, E_Function);
+ end Analyze_Function_Instantiation;
+
+ ---------------------------------
+ -- Analyze_Generic_Access_Type --
+ ---------------------------------
+
+ procedure Analyze_Generic_Access_Type (T : Entity_Id; Def : Node_Id) is
+ begin
+ Enter_Name (T);
+
+ if Nkind (Def) = N_Access_To_Object_Definition then
+ Access_Type_Declaration (T, Def);
+
+ if Is_Incomplete_Or_Private_Type (Designated_Type (T))
+ and then No (Full_View (Designated_Type (T)))
+ and then not Is_Generic_Type (Designated_Type (T))
+ then
+ Error_Msg_N ("premature usage of incomplete type", Def);
+
+ elsif Is_Internal (Designated_Type (T)) then
+ Error_Msg_N
+ ("only a subtype mark is allowed in a formal", Def);
+ end if;
+
+ else
+ Access_Subprogram_Declaration (T, Def);
+ end if;
+ end Analyze_Generic_Access_Type;
+
+ ---------------------------------
+ -- Analyze_Generic_Formal_Part --
+ ---------------------------------
+
+ procedure Analyze_Generic_Formal_Part (N : Node_Id) is
+ Gen_Parm_Decl : Node_Id;
+
+ begin
+ -- The generic formals are processed in the scope of the generic
+ -- unit, where they are immediately visible. The scope is installed
+ -- by the caller.
+
+ Gen_Parm_Decl := First (Generic_Formal_Declarations (N));
+
+ while Present (Gen_Parm_Decl) loop
+ Analyze (Gen_Parm_Decl);
+ Next (Gen_Parm_Decl);
+ end loop;
+ end Analyze_Generic_Formal_Part;
+
+ ------------------------------------------
+ -- Analyze_Generic_Package_Declaration --
+ ------------------------------------------
+
+ procedure Analyze_Generic_Package_Declaration (N : Node_Id) is
+ Id : Entity_Id;
+ New_N : Node_Id;
+ Save_Parent : Node_Id;
+
+ begin
+ -- Create copy of generic unit, and save for instantiation.
+ -- If the unit is a child unit, do not copy the specifications
+ -- for the parent, which are not part of the generic tree.
+
+ Save_Parent := Parent_Spec (N);
+ Set_Parent_Spec (N, Empty);
+
+ New_N := Copy_Generic_Node (N, Empty, Instantiating => False);
+ Set_Parent_Spec (New_N, Save_Parent);
+ Rewrite (N, New_N);
+ Id := Defining_Entity (N);
+ Generate_Definition (Id);
+
+ -- Expansion is not applied to generic units.
+
+ Start_Generic;
+
+ Enter_Name (Id);
+ Set_Ekind (Id, E_Generic_Package);
+ Set_Etype (Id, Standard_Void_Type);
+ New_Scope (Id);
+ Enter_Generic_Scope (Id);
+ Set_Inner_Instances (Id, New_Elmt_List);
+
+ Set_Categorization_From_Pragmas (N);
+ Set_Is_Pure (Id, Is_Pure (Current_Scope));
+
+ -- For a library unit, we have reconstructed the entity for the
+ -- unit, and must reset it in the library tables.
+
+ if Nkind (Parent (N)) = N_Compilation_Unit then
+ Set_Cunit_Entity (Current_Sem_Unit, Id);
+ end if;
+
+ Analyze_Generic_Formal_Part (N);
+
+ -- After processing the generic formals, analysis proceeds
+ -- as for a non-generic package.
+
+ Analyze (Specification (N));
+
+ Validate_Categorization_Dependency (N, Id);
+
+ End_Generic;
+
+ End_Package_Scope (Id);
+ Exit_Generic_Scope (Id);
+
+ if Nkind (Parent (N)) /= N_Compilation_Unit then
+ Move_Freeze_Nodes (Id, N, Visible_Declarations (Specification (N)));
+ Move_Freeze_Nodes (Id, N, Private_Declarations (Specification (N)));
+ Move_Freeze_Nodes (Id, N, Generic_Formal_Declarations (N));
+
+ else
+ Set_Body_Required (Parent (N), Unit_Requires_Body (Id));
+ Validate_RT_RAT_Component (N);
+ end if;
+
+ end Analyze_Generic_Package_Declaration;
+
+ --------------------------------------------
+ -- Analyze_Generic_Subprogram_Declaration --
+ --------------------------------------------
+
+ procedure Analyze_Generic_Subprogram_Declaration (N : Node_Id) is
+ Spec : Node_Id;
+ Id : Entity_Id;
+ Formals : List_Id;
+ New_N : Node_Id;
+ Save_Parent : Node_Id;
+
+ begin
+ -- Create copy of generic unit,and save for instantiation.
+ -- If the unit is a child unit, do not copy the specifications
+ -- for the parent, which are not part of the generic tree.
+
+ Save_Parent := Parent_Spec (N);
+ Set_Parent_Spec (N, Empty);
+
+ New_N := Copy_Generic_Node (N, Empty, Instantiating => False);
+ Set_Parent_Spec (New_N, Save_Parent);
+ Rewrite (N, New_N);
+
+ Spec := Specification (N);
+ Id := Defining_Entity (Spec);
+ Generate_Definition (Id);
+
+ if Nkind (Id) = N_Defining_Operator_Symbol then
+ Error_Msg_N
+ ("operator symbol not allowed for generic subprogram", Id);
+ end if;
+
+ Start_Generic;
+
+ Enter_Name (Id);
+
+ New_Scope (Id);
+ Set_Inner_Instances (Id, New_Elmt_List);
+ Set_Is_Pure (Id, Is_Pure (Current_Scope));
+
+ Analyze_Generic_Formal_Part (N);
+
+ Formals := Parameter_Specifications (Spec);
+
+ if Present (Formals) then
+ Process_Formals (Id, Formals, Spec);
+ end if;
+
+ if Nkind (Spec) = N_Function_Specification then
+ Set_Ekind (Id, E_Generic_Function);
+ Find_Type (Subtype_Mark (Spec));
+ Set_Etype (Id, Entity (Subtype_Mark (Spec)));
+ else
+ Set_Ekind (Id, E_Generic_Procedure);
+ Set_Etype (Id, Standard_Void_Type);
+ end if;
+
+ -- For a library unit, we have reconstructed the entity for the
+ -- unit, and must reset it in the library tables. We also need
+ -- to make sure that Body_Required is set properly in the original
+ -- compilation unit node.
+
+ if Nkind (Parent (N)) = N_Compilation_Unit then
+ Set_Cunit_Entity (Current_Sem_Unit, Id);
+ Set_Body_Required (Parent (N), Unit_Requires_Body (Id));
+ end if;
+
+ Set_Categorization_From_Pragmas (N);
+ Validate_Categorization_Dependency (N, Id);
+
+ Save_Global_References (Original_Node (N));
+
+ End_Generic;
+ End_Scope;
+
+ end Analyze_Generic_Subprogram_Declaration;
+
+ -----------------------------------
+ -- Analyze_Package_Instantiation --
+ -----------------------------------
+
+ -- Note: this procedure is also used for formal package declarations,
+ -- in which case the argument N is an N_Formal_Package_Declaration
+ -- node. This should really be noted in the spec! ???
+
+ procedure Analyze_Package_Instantiation (N : Node_Id) is
+ Loc : constant Source_Ptr := Sloc (N);
+ Gen_Id : constant Node_Id := Name (N);
+
+ Act_Decl : Node_Id;
+ Act_Decl_Name : Node_Id;
+ Act_Decl_Id : Entity_Id;
+ Act_Spec : Node_Id;
+ Act_Tree : Node_Id;
+
+ Gen_Decl : Node_Id;
+ Gen_Unit : Entity_Id;
+
+ Is_Actual_Pack : Boolean := Is_Internal (Defining_Entity (N));
+ Parent_Installed : Boolean := False;
+ Renaming_List : List_Id;
+ Unit_Renaming : Node_Id;
+ Needs_Body : Boolean;
+ Inline_Now : Boolean := False;
+
+ procedure Delay_Descriptors (E : Entity_Id);
+ -- Delay generation of subprogram descriptors for given entity
+
+ function Might_Inline_Subp return Boolean;
+ -- If inlining is active and the generic contains inlined subprograms,
+ -- we instantiate the body. This may cause superfluous instantiations,
+ -- but it is simpler than detecting the need for the body at the point
+ -- of inlining, when the context of the instance is not available.
+
+ -----------------------
+ -- Delay_Descriptors --
+ -----------------------
+
+ procedure Delay_Descriptors (E : Entity_Id) is
+ begin
+ if not Delay_Subprogram_Descriptors (E) then
+ Set_Delay_Subprogram_Descriptors (E);
+ Pending_Descriptor.Increment_Last;
+ Pending_Descriptor.Table (Pending_Descriptor.Last) := E;
+ end if;
+ end Delay_Descriptors;
+
+ -----------------------
+ -- Might_Inline_Subp --
+ -----------------------
+
+ function Might_Inline_Subp return Boolean is
+ E : Entity_Id;
+
+ begin
+ if not Inline_Processing_Required then
+ return False;
+
+ else
+ E := First_Entity (Gen_Unit);
+
+ while Present (E) loop
+
+ if Is_Subprogram (E)
+ and then Is_Inlined (E)
+ then
+ return True;
+ end if;
+
+ Next_Entity (E);
+ end loop;
+ end if;
+
+ return False;
+ end Might_Inline_Subp;
+
+ -- Start of processing for Analyze_Package_Instantiation
+
+ begin
+ -- Very first thing: apply the special kludge for Text_IO processing
+ -- in case we are instantiating one of the children of [Wide_]Text_IO.
+
+ Text_IO_Kludge (Name (N));
+
+ -- Make node global for error reporting.
+
+ Instantiation_Node := N;
+
+ -- Case of instantiation of a generic package
+
+ if Nkind (N) = N_Package_Instantiation then
+ Act_Decl_Id := New_Copy (Defining_Entity (N));
+ Set_Comes_From_Source (Act_Decl_Id, True);
+
+ if Nkind (Defining_Unit_Name (N)) = N_Defining_Program_Unit_Name then
+ Act_Decl_Name :=
+ Make_Defining_Program_Unit_Name (Loc,
+ Name => New_Copy_Tree (Name (Defining_Unit_Name (N))),
+ Defining_Identifier => Act_Decl_Id);
+ else
+ Act_Decl_Name := Act_Decl_Id;
+ end if;
+
+ -- Case of instantiation of a formal package
+
+ else
+ Act_Decl_Id := Defining_Identifier (N);
+ Act_Decl_Name := Act_Decl_Id;
+ end if;
+
+ Generate_Definition (Act_Decl_Id);
+ Pre_Analyze_Actuals (N);
+
+ Check_Generic_Child_Unit (Gen_Id, Parent_Installed);
+ Gen_Unit := Entity (Gen_Id);
+
+ -- Verify that it is the name of a generic package
+
+ if Etype (Gen_Unit) = Any_Type then
+ return;
+
+ elsif Ekind (Gen_Unit) /= E_Generic_Package then
+ Error_Msg_N
+ ("expect name of generic package in instantiation", Gen_Id);
+ return;
+ end if;
+
+ if In_Extended_Main_Source_Unit (N) then
+ Set_Is_Instantiated (Gen_Unit);
+ Generate_Reference (Gen_Unit, N);
+
+ if Present (Renamed_Object (Gen_Unit)) then
+ Set_Is_Instantiated (Renamed_Object (Gen_Unit));
+ Generate_Reference (Renamed_Object (Gen_Unit), N);
+ end if;
+ end if;
+
+ if Nkind (Gen_Id) = N_Identifier
+ and then Chars (Gen_Unit) = Chars (Defining_Entity (N))
+ then
+ Error_Msg_NE
+ ("& is hidden within declaration of instance", Gen_Id, Gen_Unit);
+
+ elsif Nkind (Gen_Id) = N_Expanded_Name
+ and then Is_Child_Unit (Gen_Unit)
+ and then Nkind (Prefix (Gen_Id)) = N_Identifier
+ and then Chars (Act_Decl_Id) = Chars (Prefix (Gen_Id))
+ then
+ Error_Msg_N
+ ("& is hidden within declaration of instance ", Prefix (Gen_Id));
+ end if;
+
+ -- If renaming, indicate this is an instantiation of renamed unit.
+
+ if Present (Renamed_Object (Gen_Unit))
+ and then Ekind (Renamed_Object (Gen_Unit)) = E_Generic_Package
+ then
+ Gen_Unit := Renamed_Object (Gen_Unit);
+ Set_Entity (Gen_Id, Gen_Unit);
+ end if;
+
+ -- Verify that there are no circular instantiations.
+
+ if In_Open_Scopes (Gen_Unit) then
+ Error_Msg_NE ("instantiation of & within itself", N, Gen_Unit);
+ return;
+
+ elsif Contains_Instance_Of (Gen_Unit, Current_Scope, Gen_Id) then
+ Error_Msg_Node_2 := Current_Scope;
+ Error_Msg_NE
+ ("circular Instantiation: & instantiated in &!", N, Gen_Unit);
+ Circularity_Detected := True;
+ return;
+
+ else
+ Save_Env (Gen_Unit, Act_Decl_Id);
+ Gen_Decl := Unit_Declaration_Node (Gen_Unit);
+
+ -- Initialize renamings map, for error checking, and the list
+ -- that holds private entities whose views have changed between
+ -- generic definition and instantiation. If this is the instance
+ -- created to validate an actual package, the instantiation
+ -- environment is that of the enclosing instance.
+
+ Generic_Renamings.Set_Last (0);
+ Generic_Renamings_HTable.Reset;
+
+ Create_Instantiation_Source (N, Gen_Unit, S_Adjustment);
+
+ -- Copy original generic tree, to produce text for instantiation.
+
+ Act_Tree :=
+ Copy_Generic_Node
+ (Original_Node (Gen_Decl), Empty, Instantiating => True);
+
+ Act_Spec := Specification (Act_Tree);
+
+ -- If this is the instance created to validate an actual package,
+ -- only the formals matter, do not examine the package spec itself.
+
+ if Is_Actual_Pack then
+ Set_Visible_Declarations (Act_Spec, New_List);
+ Set_Private_Declarations (Act_Spec, New_List);
+ end if;
+
+ Renaming_List :=
+ Analyze_Associations
+ (N,
+ Generic_Formal_Declarations (Act_Tree),
+ Generic_Formal_Declarations (Gen_Decl));
+
+ Set_Defining_Unit_Name (Act_Spec, Act_Decl_Name);
+ Set_Is_Generic_Instance (Act_Decl_Id);
+
+ Set_Generic_Parent (Act_Spec, Gen_Unit);
+
+ -- References to the generic in its own declaration or its body
+ -- are references to the instance. Add a renaming declaration for
+ -- the generic unit itself. This declaration, as well as the renaming
+ -- declarations for the generic formals, must remain private to the
+ -- unit: the formals, because this is the language semantics, and
+ -- the unit because its use is an artifact of the implementation.
+
+ Unit_Renaming :=
+ Make_Package_Renaming_Declaration (Loc,
+ Defining_Unit_Name =>
+ Make_Defining_Identifier (Loc, Chars (Gen_Unit)),
+ Name => New_Reference_To (Act_Decl_Id, Loc));
+
+ Append (Unit_Renaming, Renaming_List);
+
+ -- The renaming declarations are the first local declarations of
+ -- the new unit.
+
+ if Is_Non_Empty_List (Visible_Declarations (Act_Spec)) then
+ Insert_List_Before
+ (First (Visible_Declarations (Act_Spec)), Renaming_List);
+ else
+ Set_Visible_Declarations (Act_Spec, Renaming_List);
+ end if;
+
+ Act_Decl :=
+ Make_Package_Declaration (Loc,
+ Specification => Act_Spec);
+
+ -- Save the instantiation node, for subsequent instantiation
+ -- of the body, if there is one and we are generating code for
+ -- the current unit. Mark the unit as having a body, to avoid
+ -- a premature error message.
+
+ -- We instantiate the body if we are generating code, if we are
+ -- generating cross-reference information, or if we are building
+ -- trees for ASIS use.
+
+ declare
+ Enclosing_Body_Present : Boolean := False;
+ Scop : Entity_Id;
+
+ begin
+ if Scope (Gen_Unit) /= Standard_Standard
+ and then not Is_Child_Unit (Gen_Unit)
+ then
+ Scop := Scope (Gen_Unit);
+
+ while Present (Scop)
+ and then Scop /= Standard_Standard
+ loop
+ if Unit_Requires_Body (Scop) then
+ Enclosing_Body_Present := True;
+ exit;
+ end if;
+
+ Scop := Scope (Scop);
+ end loop;
+ end if;
+
+ -- If front-end inlining is enabled, and this is a unit for which
+ -- code will be generated, we instantiate the body at once.
+ -- This is done if the instance is not the main unit, and if the
+ -- generic is not a child unit, to avoid scope problems.
+
+ if Front_End_Inlining
+ and then Expander_Active
+ and then not Is_Child_Unit (Gen_Unit)
+ and then Is_In_Main_Unit (N)
+ and then Nkind (Parent (N)) /= N_Compilation_Unit
+ and then Might_Inline_Subp
+ then
+ Inline_Now := True;
+ end if;
+
+ Needs_Body :=
+ (Unit_Requires_Body (Gen_Unit)
+ or else Enclosing_Body_Present
+ or else Present (Corresponding_Body (Gen_Decl)))
+ and then (Is_In_Main_Unit (N)
+ or else Might_Inline_Subp)
+ and then not Is_Actual_Pack
+ and then not Inline_Now
+
+ and then (Operating_Mode = Generate_Code
+ or else (Operating_Mode = Check_Semantics
+ and then Tree_Output));
+
+ -- If front_end_inlining is enabled, do not instantiate a
+ -- body if within a generic context.
+
+ if Front_End_Inlining
+ and then not Expander_Active
+ then
+ Needs_Body := False;
+ end if;
+
+ end;
+
+ -- If we are generating the calling stubs from the instantiation
+ -- of a generic RCI package, we will not use the body of the
+ -- generic package.
+
+ if Distribution_Stub_Mode = Generate_Caller_Stub_Body
+ and then Is_Compilation_Unit (Defining_Entity (N))
+ then
+ Needs_Body := False;
+ end if;
+
+ if Needs_Body then
+
+ -- Here is a defence against a ludicrous number of instantiations
+ -- caused by a circular set of instantiation attempts.
+
+ if Pending_Instantiations.Last >
+ Hostparm.Max_Instantiations
+ then
+ Error_Msg_N ("too many instantiations", N);
+ raise Unrecoverable_Error;
+ end if;
+
+ -- Indicate that the enclosing scopes contain an instantiation,
+ -- and that cleanup actions should be delayed until after the
+ -- instance body is expanded.
+
+ Check_Forward_Instantiation (N, Gen_Decl);
+ if Nkind (N) = N_Package_Instantiation then
+ declare
+ Enclosing_Master : Entity_Id := Current_Scope;
+
+ begin
+ while Enclosing_Master /= Standard_Standard loop
+
+ if Ekind (Enclosing_Master) = E_Package then
+ if Is_Compilation_Unit (Enclosing_Master) then
+ if In_Package_Body (Enclosing_Master) then
+ Delay_Descriptors
+ (Body_Entity (Enclosing_Master));
+ else
+ Delay_Descriptors
+ (Enclosing_Master);
+ end if;
+
+ exit;
+
+ else
+ Enclosing_Master := Scope (Enclosing_Master);
+ end if;
+
+ elsif Ekind (Enclosing_Master) = E_Generic_Package then
+ Enclosing_Master := Scope (Enclosing_Master);
+
+ elsif Ekind (Enclosing_Master) = E_Generic_Function
+ or else Ekind (Enclosing_Master) = E_Generic_Procedure
+ or else Ekind (Enclosing_Master) = E_Void
+ then
+ -- Cleanup actions will eventually be performed on
+ -- the enclosing instance, if any. enclosing scope
+ -- is void in the formal part of a generic subp.
+
+ exit;
+
+ else
+ if Ekind (Enclosing_Master) = E_Entry
+ and then
+ Ekind (Scope (Enclosing_Master)) = E_Protected_Type
+ then
+ Enclosing_Master :=
+ Protected_Body_Subprogram (Enclosing_Master);
+ end if;
+
+ Set_Delay_Cleanups (Enclosing_Master);
+
+ while Ekind (Enclosing_Master) = E_Block loop
+ Enclosing_Master := Scope (Enclosing_Master);
+ end loop;
+
+ if Is_Subprogram (Enclosing_Master) then
+ Delay_Descriptors (Enclosing_Master);
+
+ elsif Is_Task_Type (Enclosing_Master) then
+ declare
+ TBP : constant Node_Id :=
+ Get_Task_Body_Procedure
+ (Enclosing_Master);
+
+ begin
+ if Present (TBP) then
+ Delay_Descriptors (TBP);
+ Set_Delay_Cleanups (TBP);
+ end if;
+ end;
+ end if;
+
+ exit;
+ end if;
+ end loop;
+ end;
+
+ -- Make entry in table
+
+ Pending_Instantiations.Increment_Last;
+ Pending_Instantiations.Table (Pending_Instantiations.Last) :=
+ (N, Act_Decl, Expander_Active, Current_Sem_Unit);
+ end if;
+ end if;
+
+ Set_Categorization_From_Pragmas (Act_Decl);
+
+ if Parent_Installed then
+ Hide_Current_Scope;
+ end if;
+
+ Set_Instance_Spec (N, Act_Decl);
+
+ -- Case of not a compilation unit
+
+ if Nkind (Parent (N)) /= N_Compilation_Unit then
+ Mark_Rewrite_Insertion (Act_Decl);
+ Insert_Before (N, Act_Decl);
+ Analyze (Act_Decl);
+
+ -- Case of compilation unit that is generic instantiation
+
+ -- Place declaration on current node so context is complete
+ -- for analysis (including nested instantiations).
+
+ else
+ if Cunit_Entity (Current_Sem_Unit) = Defining_Entity (N) then
+
+ -- The entity for the current unit is the newly created one,
+ -- and all semantic information is attached to it.
+
+ Set_Cunit_Entity (Current_Sem_Unit, Act_Decl_Id);
+
+ -- If this is the main unit, replace the main entity as well.
+
+ if Current_Sem_Unit = Main_Unit then
+ Main_Unit_Entity := Act_Decl_Id;
+ end if;
+ end if;
+
+ Set_Unit (Parent (N), Act_Decl);
+ Set_Parent_Spec (Act_Decl, Parent_Spec (N));
+ Analyze (Act_Decl);
+ Set_Unit (Parent (N), N);
+ Set_Body_Required (Parent (N), False);
+
+ -- We never need elaboration checks on instantiations, since
+ -- by definition, the body instantiation is elaborated at the
+ -- same time as the spec instantiation.
+
+ Set_Suppress_Elaboration_Warnings (Act_Decl_Id);
+ Set_Suppress_Elaboration_Checks (Act_Decl_Id);
+ end if;
+
+ Check_Elab_Instantiation (N);
+
+ if ABE_Is_Certain (N) and then Needs_Body then
+ Pending_Instantiations.Decrement_Last;
+ end if;
+ Check_Hidden_Child_Unit (N, Gen_Unit, Act_Decl_Id);
+
+ Set_First_Private_Entity (Defining_Unit_Name (Unit_Renaming),
+ First_Private_Entity (Act_Decl_Id));
+
+ if Nkind (Parent (N)) = N_Compilation_Unit
+ and then not Needs_Body
+ then
+ Rewrite (N, Act_Decl);
+ end if;
+
+ if Present (Corresponding_Body (Gen_Decl))
+ or else Unit_Requires_Body (Gen_Unit)
+ then
+ Set_Has_Completion (Act_Decl_Id);
+ end if;
+
+ Check_Formal_Packages (Act_Decl_Id);
+
+ Restore_Private_Views (Act_Decl_Id);
+
+ if not Generic_Separately_Compiled (Gen_Unit) then
+ Inherit_Context (Gen_Decl, N);
+ end if;
+
+ if Parent_Installed then
+ Remove_Parent;
+ end if;
+
+ Restore_Env;
+ end if;
+
+ Validate_Categorization_Dependency (N, Act_Decl_Id);
+
+ -- Check restriction, but skip this if something went wrong in
+ -- the above analysis, indicated by Act_Decl_Id being void.
+
+ if Ekind (Act_Decl_Id) /= E_Void
+ and then not Is_Library_Level_Entity (Act_Decl_Id)
+ then
+ Check_Restriction (No_Local_Allocators, N);
+ end if;
+
+ if Inline_Now then
+ Inline_Instance_Body (N, Gen_Unit, Act_Decl);
+ end if;
+
+ exception
+ when Instantiation_Error =>
+ if Parent_Installed then
+ Remove_Parent;
+ end if;
+
+ end Analyze_Package_Instantiation;
+
+ ---------------------------
+ -- Inline_Instance_Body --
+ ---------------------------
+
+ procedure Inline_Instance_Body
+ (N : Node_Id;
+ Gen_Unit : Entity_Id;
+ Act_Decl : Node_Id)
+ is
+ Vis : Boolean;
+ Gen_Comp : constant Entity_Id :=
+ Cunit_Entity (Get_Source_Unit (Gen_Unit));
+ Curr_Comp : constant Node_Id := Cunit (Current_Sem_Unit);
+ Curr_Scope : Entity_Id := Empty;
+ Curr_Unit : constant Entity_Id :=
+ Cunit_Entity (Current_Sem_Unit);
+ Removed : Boolean := False;
+ Num_Scopes : Int := 0;
+ Use_Clauses : array (1 .. Scope_Stack.Last) of Node_Id;
+ Instances : array (1 .. Scope_Stack.Last) of Entity_Id;
+ Inner_Scopes : array (1 .. Scope_Stack.Last) of Entity_Id;
+ Num_Inner : Int := 0;
+ N_Instances : Int := 0;
+ S : Entity_Id;
+
+ begin
+ -- Case of generic unit defined in another unit
+
+ if Gen_Comp /= Cunit_Entity (Current_Sem_Unit) then
+ Vis := Is_Immediately_Visible (Gen_Comp);
+
+ S := Current_Scope;
+
+ while Present (S)
+ and then S /= Standard_Standard
+ loop
+ Num_Scopes := Num_Scopes + 1;
+
+ Use_Clauses (Num_Scopes) :=
+ (Scope_Stack.Table
+ (Scope_Stack.Last - Num_Scopes + 1).
+ First_Use_Clause);
+ End_Use_Clauses (Use_Clauses (Num_Scopes));
+
+ exit when Is_Generic_Instance (S)
+ and then (In_Package_Body (S)
+ or else Ekind (S) = E_Procedure
+ or else Ekind (S) = E_Function);
+ S := Scope (S);
+ end loop;
+
+ -- Find and save all enclosing instances.
+
+ S := Current_Scope;
+
+ while Present (S)
+ and then S /= Standard_Standard
+ loop
+ if Is_Generic_Instance (S) then
+ N_Instances := N_Instances + 1;
+ Instances (N_Instances) := S;
+ end if;
+
+ S := Scope (S);
+ end loop;
+
+ -- Remove context of current compilation unit, unless we
+ -- are within a nested package instantiation, in which case
+ -- the context has been removed previously.
+ -- If current scope is the body of a child unit, remove context
+ -- of spec as well.
+
+ S := Current_Scope;
+
+ while Present (S)
+ and then S /= Standard_Standard
+ loop
+ exit when Is_Generic_Instance (S)
+ and then In_Package_Body (S);
+
+ if S = Curr_Unit
+ or else (Ekind (Curr_Unit) = E_Package_Body
+ and then S = Spec_Entity (Curr_Unit))
+ then
+ Removed := True;
+
+ if Is_Child_Unit (S) then
+ -- Remove child unit from stack, as well as inner scopes.
+ -- Removing its context of child unit will remove parent
+ -- units as well.
+
+ while Current_Scope /= S loop
+ Num_Inner := Num_Inner + 1;
+ Inner_Scopes (Num_Inner) := Current_Scope;
+ Pop_Scope;
+ end loop;
+
+ Pop_Scope;
+ Remove_Context (Curr_Comp);
+ Curr_Scope := S;
+
+ else
+ Remove_Context (Curr_Comp);
+ end if;
+
+ if Ekind (Curr_Unit) = E_Package_Body then
+ Remove_Context (Library_Unit (Curr_Comp));
+ end if;
+ end if;
+
+ S := Scope (S);
+ end loop;
+
+ Instantiate_Package_Body
+ ((N, Act_Decl, Expander_Active, Current_Sem_Unit));
+
+ -- Restore context.
+
+ Set_Is_Immediately_Visible (Gen_Comp, Vis);
+
+ -- Reset Generic_Instance flag so that use clauses can be installed
+ -- in the proper order. (See Use_One_Package for effect of enclosing
+ -- instances on processing of use clauses).
+
+ for J in 1 .. N_Instances loop
+ Set_Is_Generic_Instance (Instances (J), False);
+ end loop;
+
+ if Removed then
+ -- Make local entities not visible, so that when the context of
+ -- unit is restored, there are not spurious hidings of use-
+ -- visible entities (which appear in the environment before the
+ -- current scope).
+
+ if Current_Scope /= Standard_Standard then
+ S := First_Entity (Current_Scope);
+
+ while Present (S) loop
+ if Is_Overloadable (S) then
+ Set_Is_Immediately_Visible (S, False);
+ end if;
+
+ Next_Entity (S);
+ end loop;
+ end if;
+
+ Install_Context (Curr_Comp);
+
+ if Current_Scope /= Standard_Standard then
+ S := First_Entity (Current_Scope);
+
+ while Present (S) loop
+ if Is_Overloadable (S) then
+ Set_Is_Immediately_Visible (S);
+ end if;
+
+ Next_Entity (S);
+ end loop;
+ end if;
+
+ if Present (Curr_Scope)
+ and then Is_Child_Unit (Curr_Scope)
+ then
+ New_Scope (Curr_Scope);
+ Set_Is_Immediately_Visible (Curr_Scope);
+
+ -- Finally, restore inner scopes as well.
+
+ for J in reverse 1 .. Num_Inner loop
+ New_Scope (Inner_Scopes (J));
+ end loop;
+ end if;
+ end if;
+
+ for J in reverse 1 .. Num_Scopes loop
+ Install_Use_Clauses (Use_Clauses (J));
+ end loop;
+
+ for J in 1 .. N_Instances loop
+ Set_Is_Generic_Instance (Instances (J), True);
+ end loop;
+
+ -- If generic unit is in current unit, current context is correct.
+
+ else
+ Instantiate_Package_Body
+ ((N, Act_Decl, Expander_Active, Current_Sem_Unit));
+ end if;
+ end Inline_Instance_Body;
+
+ -------------------------------------
+ -- Analyze_Procedure_Instantiation --
+ -------------------------------------
+
+ procedure Analyze_Procedure_Instantiation (N : Node_Id) is
+ begin
+ Analyze_Subprogram_Instantiation (N, E_Procedure);
+ end Analyze_Procedure_Instantiation;
+
+ --------------------------------------
+ -- Analyze_Subprogram_Instantiation --
+ --------------------------------------
+
+ procedure Analyze_Subprogram_Instantiation
+ (N : Node_Id;
+ K : Entity_Kind)
+ is
+ Loc : constant Source_Ptr := Sloc (N);
+ Gen_Id : constant Node_Id := Name (N);
+
+ Act_Decl_Id : Entity_Id;
+ Anon_Id : Entity_Id :=
+ Make_Defining_Identifier
+ (Sloc (Defining_Entity (N)),
+ New_External_Name
+ (Chars (Defining_Entity (N)), 'R'));
+ Act_Decl : Node_Id;
+ Act_Spec : Node_Id;
+ Act_Tree : Node_Id;
+
+ Gen_Unit : Entity_Id;
+ Gen_Decl : Node_Id;
+ Pack_Id : Entity_Id;
+ Parent_Installed : Boolean := False;
+ Renaming_List : List_Id;
+ Spec : Node_Id;
+
+ procedure Analyze_Instance_And_Renamings;
+ -- The instance must be analyzed in a context that includes the
+ -- mappings of generic parameters into actuals. We create a package
+ -- declaration for this purpose, and a subprogram with an internal
+ -- name within the package. The subprogram instance is simply an
+ -- alias for the internal subprogram, declared in the current scope.
+
+ ------------------------------------
+ -- Analyze_Instance_And_Renamings --
+ ------------------------------------
+
+ procedure Analyze_Instance_And_Renamings is
+ Def_Ent : constant Entity_Id := Defining_Entity (N);
+ Pack_Decl : Node_Id;
+
+ begin
+ if Nkind (Parent (N)) = N_Compilation_Unit then
+
+ -- For the case of a compilation unit, the container package
+ -- has the same name as the instantiation, to insure that the
+ -- binder calls the elaboration procedure with the right name.
+ -- Copy the entity of the instance, which may have compilation
+ -- level flags (eg. is_child_unit) set.
+
+ Pack_Id := New_Copy (Def_Ent);
+
+ else
+ -- Otherwise we use the name of the instantiation concatenated
+ -- with its source position to ensure uniqueness if there are
+ -- several instantiations with the same name.
+
+ Pack_Id :=
+ Make_Defining_Identifier (Loc,
+ Chars => New_External_Name
+ (Related_Id => Chars (Def_Ent),
+ Suffix => "GP",
+ Suffix_Index => Source_Offset (Sloc (Def_Ent))));
+ end if;
+
+ Pack_Decl := Make_Package_Declaration (Loc,
+ Specification => Make_Package_Specification (Loc,
+ Defining_Unit_Name => Pack_Id,
+ Visible_Declarations => Renaming_List,
+ End_Label => Empty));
+
+ Set_Instance_Spec (N, Pack_Decl);
+ Set_Is_Generic_Instance (Pack_Id);
+
+ -- Case of not a compilation unit
+
+ if Nkind (Parent (N)) /= N_Compilation_Unit then
+ Mark_Rewrite_Insertion (Pack_Decl);
+ Insert_Before (N, Pack_Decl);
+ Set_Has_Completion (Pack_Id);
+
+ -- Case of an instantiation that is a compilation unit
+
+ -- Place declaration on current node so context is complete
+ -- for analysis (including nested instantiations), and for
+ -- use in a context_clause (see Analyze_With_Clause).
+
+ else
+ Set_Unit (Parent (N), Pack_Decl);
+ Set_Parent_Spec (Pack_Decl, Parent_Spec (N));
+ end if;
+
+ Analyze (Pack_Decl);
+ Check_Formal_Packages (Pack_Id);
+ Set_Is_Generic_Instance (Pack_Id, False);
+
+ -- Body of the enclosing package is supplied when instantiating
+ -- the subprogram body, after semantic analysis is completed.
+
+ if Nkind (Parent (N)) = N_Compilation_Unit then
+
+ -- Remove package itself from visibility, so it does not
+ -- conflict with subprogram.
+
+ Set_Name_Entity_Id (Chars (Pack_Id), Homonym (Pack_Id));
+
+ -- Set name and scope of internal subprogram so that the
+ -- proper external name will be generated. The proper scope
+ -- is the scope of the wrapper package.
+
+ Set_Chars (Anon_Id, Chars (Defining_Entity (N)));
+ Set_Scope (Anon_Id, Scope (Pack_Id));
+ end if;
+
+ Set_Is_Generic_Instance (Anon_Id);
+ Act_Decl_Id := New_Copy (Anon_Id);
+
+ Set_Parent (Act_Decl_Id, Parent (Anon_Id));
+ Set_Chars (Act_Decl_Id, Chars (Defining_Entity (N)));
+ Set_Sloc (Act_Decl_Id, Sloc (Defining_Entity (N)));
+ Set_Comes_From_Source (Act_Decl_Id, True);
+
+ -- The signature may involve types that are not frozen yet, but
+ -- the subprogram will be frozen at the point the wrapper package
+ -- is frozen, so it does not need its own freeze node. In fact, if
+ -- one is created, it might conflict with the freezing actions from
+ -- the wrapper package (see 7206-013).
+
+ Set_Has_Delayed_Freeze (Anon_Id, False);
+
+ -- If the instance is a child unit, mark the Id accordingly. Mark
+ -- the anonymous entity as well, which is the real subprogram and
+ -- which is used when the instance appears in a context clause.
+
+ Set_Is_Child_Unit (Act_Decl_Id, Is_Child_Unit (Defining_Entity (N)));
+ Set_Is_Child_Unit (Anon_Id, Is_Child_Unit (Defining_Entity (N)));
+ New_Overloaded_Entity (Act_Decl_Id);
+ Check_Eliminated (Act_Decl_Id);
+
+ -- In compilation unit case, kill elaboration checks on the
+ -- instantiation, since they are never needed -- the body is
+ -- instantiated at the same point as the spec.
+
+ if Nkind (Parent (N)) = N_Compilation_Unit then
+ Set_Suppress_Elaboration_Warnings (Act_Decl_Id);
+ Set_Suppress_Elaboration_Checks (Act_Decl_Id);
+ Set_Is_Compilation_Unit (Anon_Id);
+
+ Set_Cunit_Entity (Current_Sem_Unit, Pack_Id);
+ end if;
+
+ -- The instance is not a freezing point for the new subprogram.
+
+ Set_Is_Frozen (Act_Decl_Id, False);
+
+ if Nkind (Defining_Entity (N)) = N_Defining_Operator_Symbol then
+ Valid_Operator_Definition (Act_Decl_Id);
+ end if;
+
+ Set_Alias (Act_Decl_Id, Anon_Id);
+ Set_Parent (Act_Decl_Id, Parent (Anon_Id));
+ Set_Has_Completion (Act_Decl_Id);
+ Set_Related_Instance (Pack_Id, Act_Decl_Id);
+
+ if Nkind (Parent (N)) = N_Compilation_Unit then
+ Set_Body_Required (Parent (N), False);
+ end if;
+
+ end Analyze_Instance_And_Renamings;
+
+ -- Start of processing for Analyze_Subprogram_Instantiation
+
+ begin
+ -- Very first thing: apply the special kludge for Text_IO processing
+ -- in case we are instantiating one of the children of [Wide_]Text_IO.
+ -- Of course such an instantiation is bogus (these are packages, not
+ -- subprograms), but we get a better error message if we do this.
+
+ Text_IO_Kludge (Gen_Id);
+
+ -- Make node global for error reporting.
+
+ Instantiation_Node := N;
+ Pre_Analyze_Actuals (N);
+
+ Check_Generic_Child_Unit (Gen_Id, Parent_Installed);
+ Gen_Unit := Entity (Gen_Id);
+
+ Generate_Reference (Gen_Unit, Gen_Id);
+
+ if Nkind (Gen_Id) = N_Identifier
+ and then Chars (Gen_Unit) = Chars (Defining_Entity (N))
+ then
+ Error_Msg_NE
+ ("& is hidden within declaration of instance", Gen_Id, Gen_Unit);
+ end if;
+
+ if Etype (Gen_Unit) = Any_Type then return; end if;
+
+ -- Verify that it is a generic subprogram of the right kind, and that
+ -- it does not lead to a circular instantiation.
+
+ if Ekind (Gen_Unit) /= E_Generic_Procedure
+ and then Ekind (Gen_Unit) /= E_Generic_Function
+ then
+ Error_Msg_N ("expect generic subprogram in instantiation", Gen_Id);
+
+ elsif In_Open_Scopes (Gen_Unit) then
+ Error_Msg_NE ("instantiation of & within itself", N, Gen_Unit);
+
+ elsif Contains_Instance_Of (Gen_Unit, Current_Scope, Gen_Id) then
+ Error_Msg_Node_2 := Current_Scope;
+ Error_Msg_NE
+ ("circular Instantiation: & instantiated in &!", N, Gen_Unit);
+ Circularity_Detected := True;
+
+ elsif K = E_Procedure
+ and then Ekind (Gen_Unit) /= E_Generic_Procedure
+ then
+ if Ekind (Gen_Unit) = E_Generic_Function then
+ Error_Msg_N
+ ("cannot instantiate generic function as procedure", Gen_Id);
+ else
+ Error_Msg_N
+ ("expect name of generic procedure in instantiation", Gen_Id);
+ end if;
+
+ elsif K = E_Function
+ and then Ekind (Gen_Unit) /= E_Generic_Function
+ then
+ if Ekind (Gen_Unit) = E_Generic_Procedure then
+ Error_Msg_N
+ ("cannot instantiate generic procedure as function", Gen_Id);
+ else
+ Error_Msg_N
+ ("expect name of generic function in instantiation", Gen_Id);
+ end if;
+
+ else
+ -- If renaming, indicate that this is instantiation of renamed unit
+
+ if Present (Renamed_Object (Gen_Unit))
+ and then (Ekind (Renamed_Object (Gen_Unit)) = E_Generic_Procedure
+ or else
+ Ekind (Renamed_Object (Gen_Unit)) = E_Generic_Function)
+ then
+ Gen_Unit := Renamed_Object (Gen_Unit);
+ Set_Entity (Gen_Id, Gen_Unit);
+ end if;
+
+ if In_Extended_Main_Source_Unit (N) then
+ Set_Is_Instantiated (Gen_Unit);
+ Generate_Reference (Gen_Unit, N);
+ end if;
+
+ Gen_Decl := Unit_Declaration_Node (Gen_Unit);
+ Spec := Specification (Gen_Decl);
+
+ -- The subprogram itself cannot contain a nested instance, so
+ -- the current parent is left empty.
+
+ Save_Env (Gen_Unit, Empty);
+
+ -- Initialize renamings map, for error checking.
+
+ Generic_Renamings.Set_Last (0);
+ Generic_Renamings_HTable.Reset;
+
+ Create_Instantiation_Source (N, Gen_Unit, S_Adjustment);
+
+ -- Copy original generic tree, to produce text for instantiation.
+
+ Act_Tree :=
+ Copy_Generic_Node
+ (Original_Node (Gen_Decl), Empty, Instantiating => True);
+
+ Act_Spec := Specification (Act_Tree);
+ Renaming_List :=
+ Analyze_Associations
+ (N,
+ Generic_Formal_Declarations (Act_Tree),
+ Generic_Formal_Declarations (Gen_Decl));
+
+ -- Build the subprogram declaration, which does not appear
+ -- in the generic template, and give it a sloc consistent
+ -- with that of the template.
+
+ Set_Defining_Unit_Name (Act_Spec, Anon_Id);
+ Set_Generic_Parent (Act_Spec, Gen_Unit);
+ Act_Decl :=
+ Make_Subprogram_Declaration (Sloc (Act_Spec),
+ Specification => Act_Spec);
+
+ Set_Categorization_From_Pragmas (Act_Decl);
+
+ if Parent_Installed then
+ Hide_Current_Scope;
+ end if;
+
+ Append (Act_Decl, Renaming_List);
+ Analyze_Instance_And_Renamings;
+
+ -- If the generic is marked Import (Intrinsic), then so is the
+ -- instance. This indicates that there is no body to instantiate.
+ -- If generic is marked inline, so it the instance, and the
+ -- anonymous subprogram it renames. If inlined, or else if inlining
+ -- is enabled for the compilation, we generate the instance body
+ -- even if it is not within the main unit.
+
+ -- Any other pragmas might also be inherited ???
+
+ if Is_Intrinsic_Subprogram (Gen_Unit) then
+ Set_Is_Intrinsic_Subprogram (Anon_Id);
+ Set_Is_Intrinsic_Subprogram (Act_Decl_Id);
+
+ if Chars (Gen_Unit) = Name_Unchecked_Conversion then
+ Validate_Unchecked_Conversion (N, Act_Decl_Id);
+ end if;
+ end if;
+
+ Generate_Definition (Act_Decl_Id);
+
+ Set_Is_Inlined (Act_Decl_Id, Is_Inlined (Gen_Unit));
+ Set_Is_Inlined (Anon_Id, Is_Inlined (Gen_Unit));
+
+ Check_Elab_Instantiation (N);
+ Check_Hidden_Child_Unit (N, Gen_Unit, Act_Decl_Id);
+
+ -- Subject to change, pending on if other pragmas are inherited ???
+
+ Validate_Categorization_Dependency (N, Act_Decl_Id);
+
+ if not Is_Intrinsic_Subprogram (Act_Decl_Id) then
+
+ if not Generic_Separately_Compiled (Gen_Unit) then
+ Inherit_Context (Gen_Decl, N);
+ end if;
+
+ Restore_Private_Views (Pack_Id, False);
+
+ -- If the context requires a full instantiation, mark node for
+ -- subsequent construction of the body.
+
+ if (Is_In_Main_Unit (N)
+ or else Is_Inlined (Act_Decl_Id))
+ and then (Operating_Mode = Generate_Code
+ or else (Operating_Mode = Check_Semantics
+ and then Tree_Output))
+ and then (Expander_Active or else Tree_Output)
+ and then not ABE_Is_Certain (N)
+ and then not Is_Eliminated (Act_Decl_Id)
+ then
+ Pending_Instantiations.Increment_Last;
+ Pending_Instantiations.Table (Pending_Instantiations.Last) :=
+ (N, Act_Decl, Expander_Active, Current_Sem_Unit);
+ Check_Forward_Instantiation (N, Gen_Decl);
+
+ -- The wrapper package is always delayed, because it does
+ -- not constitute a freeze point, but to insure that the
+ -- freeze node is placed properly, it is created directly
+ -- when instantiating the body (otherwise the freeze node
+ -- might appear to early for nested instantiations).
+
+ elsif Nkind (Parent (N)) = N_Compilation_Unit then
+
+ -- For ASIS purposes, indicate that the wrapper package has
+ -- replaced the instantiation node.
+
+ Rewrite (N, Unit (Parent (N)));
+ Set_Unit (Parent (N), N);
+ end if;
+
+ elsif Nkind (Parent (N)) = N_Compilation_Unit then
+
+ -- Replace instance node for library-level instantiations
+ -- of intrinsic subprograms, for ASIS use.
+
+ Rewrite (N, Unit (Parent (N)));
+ Set_Unit (Parent (N), N);
+ end if;
+
+ if Parent_Installed then
+ Remove_Parent;
+ end if;
+
+ Restore_Env;
+ Generic_Renamings.Set_Last (0);
+ Generic_Renamings_HTable.Reset;
+ end if;
+
+ exception
+ when Instantiation_Error =>
+ if Parent_Installed then
+ Remove_Parent;
+ end if;
+
+ end Analyze_Subprogram_Instantiation;
+
+ ---------------------
+ -- Associated_Node --
+ ---------------------
+
+ function Associated_Node (N : Node_Id) return Node_Id is
+ Assoc : Node_Id := Node4 (N);
+ -- ??? what is Node4 being used for here?
+
+ begin
+ if Nkind (Assoc) /= Nkind (N) then
+ return Assoc;
+
+ elsif Nkind (Assoc) = N_Aggregate
+ or else Nkind (Assoc) = N_Extension_Aggregate
+ then
+ return Assoc;
+ else
+ -- If the node is part of an inner generic, it may itself have been
+ -- remapped into a further generic copy. Node4 is otherwise used for
+ -- the entity of the node, and will be of a different node kind, or
+ -- else N has been rewritten as a literal or function call.
+
+ while Present (Node4 (Assoc))
+ and then Nkind (Node4 (Assoc)) = Nkind (Assoc)
+ loop
+ Assoc := Node4 (Assoc);
+ end loop;
+
+ -- Follow and additional link in case the final node was rewritten.
+ -- This can only happen with nested generic units.
+
+ if (Nkind (Assoc) = N_Identifier or else Nkind (Assoc) in N_Op)
+ and then Present (Node4 (Assoc))
+ and then (Nkind (Node4 (Assoc)) = N_Function_Call
+ or else Nkind (Node4 (Assoc)) = N_Explicit_Dereference
+ or else Nkind (Node4 (Assoc)) = N_Integer_Literal
+ or else Nkind (Node4 (Assoc)) = N_Real_Literal
+ or else Nkind (Node4 (Assoc)) = N_String_Literal)
+ then
+ Assoc := Node4 (Assoc);
+ end if;
+
+ return Assoc;
+ end if;
+ end Associated_Node;
+
+ -------------------------------------------
+ -- Build_Instance_Compilation_Unit_Nodes --
+ -------------------------------------------
+
+ procedure Build_Instance_Compilation_Unit_Nodes
+ (N : Node_Id;
+ Act_Body : Node_Id;
+ Act_Decl : Node_Id)
+ is
+ Decl_Cunit : Node_Id;
+ Body_Cunit : Node_Id;
+ Citem : Node_Id;
+ New_Main : constant Entity_Id := Defining_Entity (Act_Decl);
+ Old_Main : constant Entity_Id := Cunit_Entity (Main_Unit);
+
+ begin
+ -- A new compilation unit node is built for the instance declaration
+
+ Decl_Cunit :=
+ Make_Compilation_Unit (Sloc (N),
+ Context_Items => Empty_List,
+ Unit => Act_Decl,
+ Aux_Decls_Node =>
+ Make_Compilation_Unit_Aux (Sloc (N)));
+
+ Set_Parent_Spec (Act_Decl, Parent_Spec (N));
+ Set_Body_Required (Decl_Cunit, True);
+
+ -- We use the original instantiation compilation unit as the resulting
+ -- compilation unit of the instance, since this is the main unit.
+
+ Rewrite (N, Act_Body);
+ Body_Cunit := Parent (N);
+
+ -- The two compilation unit nodes are linked by the Library_Unit field
+
+ Set_Library_Unit (Decl_Cunit, Body_Cunit);
+ Set_Library_Unit (Body_Cunit, Decl_Cunit);
+
+ -- The context clause items on the instantiation, which are now
+ -- attached to the body compilation unit (since the body overwrote
+ -- the original instantiation node), semantically belong on the spec,
+ -- so copy them there. It's harmless to leave them on the body as well.
+ -- In fact one could argue that they belong in both places.
+
+ Citem := First (Context_Items (Body_Cunit));
+ while Present (Citem) loop
+ Append (New_Copy (Citem), Context_Items (Decl_Cunit));
+ Next (Citem);
+ end loop;
+
+ -- Propagate categorization flags on packages, so that they appear
+ -- in ali file for the spec of the unit.
+
+ if Ekind (New_Main) = E_Package then
+ Set_Is_Pure (Old_Main, Is_Pure (New_Main));
+ Set_Is_Preelaborated (Old_Main, Is_Preelaborated (New_Main));
+ Set_Is_Remote_Types (Old_Main, Is_Remote_Types (New_Main));
+ Set_Is_Shared_Passive (Old_Main, Is_Shared_Passive (New_Main));
+ Set_Is_Remote_Call_Interface
+ (Old_Main, Is_Remote_Call_Interface (New_Main));
+ end if;
+
+ -- Make entry in Units table, so that binder can generate call to
+ -- elaboration procedure for body, if any.
+
+ Make_Instance_Unit (Body_Cunit);
+ Main_Unit_Entity := New_Main;
+ Set_Cunit_Entity (Main_Unit, Main_Unit_Entity);
+
+ -- Build elaboration entity, since the instance may certainly
+ -- generate elaboration code requiring a flag for protection.
+
+ Build_Elaboration_Entity (Decl_Cunit, New_Main);
+ end Build_Instance_Compilation_Unit_Nodes;
+
+ -----------------------------------
+ -- Check_Formal_Package_Instance --
+ -----------------------------------
+
+ -- If the formal has specific parameters, they must match those of the
+ -- actual. Both of them are instances, and the renaming declarations
+ -- for their formal parameters appear in the same order in both. The
+ -- analyzed formal has been analyzed in the context of the current
+ -- instance.
+
+ procedure Check_Formal_Package_Instance
+ (Formal_Pack : Entity_Id;
+ Actual_Pack : Entity_Id)
+ is
+ E1 : Entity_Id := First_Entity (Actual_Pack);
+ E2 : Entity_Id := First_Entity (Formal_Pack);
+
+ Expr1 : Node_Id;
+ Expr2 : Node_Id;
+
+ procedure Check_Mismatch (B : Boolean);
+ -- Common error routine for mismatch between the parameters of
+ -- the actual instance and those of the formal package.
+
+ procedure Check_Mismatch (B : Boolean) is
+ begin
+ if B then
+ Error_Msg_NE
+ ("actual for & in actual instance does not match formal",
+ Parent (Actual_Pack), E1);
+ end if;
+ end Check_Mismatch;
+
+ -- Start of processing for Check_Formal_Package_Instance
+
+ begin
+ while Present (E1)
+ and then Present (E2)
+ loop
+ exit when Ekind (E1) = E_Package
+ and then Renamed_Entity (E1) = Renamed_Entity (Actual_Pack);
+
+ if Is_Type (E1) then
+
+ -- Subtypes must statically match. E1 and E2 are the
+ -- local entities that are subtypes of the actuals.
+ -- Itypes generated for other parameters need not be checked,
+ -- the check will be performed on the parameters themselves.
+
+ if not Is_Itype (E1)
+ and then not Is_Itype (E2)
+ then
+ Check_Mismatch
+ (not Is_Type (E2)
+ or else Etype (E1) /= Etype (E2)
+ or else not Subtypes_Statically_Match (E1, E2));
+ end if;
+
+ elsif Ekind (E1) = E_Constant then
+
+ -- IN parameters must denote the same static value, or
+ -- the same constant, or the literal null.
+
+ Expr1 := Expression (Parent (E1));
+
+ if Ekind (E2) /= E_Constant then
+ Check_Mismatch (True);
+ goto Next_E;
+ else
+ Expr2 := Expression (Parent (E2));
+ end if;
+
+ if Is_Static_Expression (Expr1) then
+
+ if not Is_Static_Expression (Expr2) then
+ Check_Mismatch (True);
+
+ elsif Is_Integer_Type (Etype (E1)) then
+
+ declare
+ V1 : Uint := Expr_Value (Expr1);
+ V2 : Uint := Expr_Value (Expr2);
+ begin
+ Check_Mismatch (V1 /= V2);
+ end;
+
+ elsif Is_Real_Type (Etype (E1)) then
+
+ declare
+ V1 : Ureal := Expr_Value_R (Expr1);
+ V2 : Ureal := Expr_Value_R (Expr2);
+ begin
+ Check_Mismatch (V1 /= V2);
+ end;
+
+ elsif Is_String_Type (Etype (E1))
+ and then Nkind (Expr1) = N_String_Literal
+ then
+
+ if Nkind (Expr2) /= N_String_Literal then
+ Check_Mismatch (True);
+ else
+ Check_Mismatch
+ (not String_Equal (Strval (Expr1), Strval (Expr2)));
+ end if;
+ end if;
+
+ elsif Is_Entity_Name (Expr1) then
+ if Is_Entity_Name (Expr2) then
+ if Entity (Expr1) = Entity (Expr2) then
+ null;
+
+ elsif Ekind (Entity (Expr2)) = E_Constant
+ and then Is_Entity_Name (Constant_Value (Entity (Expr2)))
+ and then
+ Entity (Constant_Value (Entity (Expr2))) = Entity (Expr1)
+ then
+ null;
+ else
+ Check_Mismatch (True);
+ end if;
+ else
+ Check_Mismatch (True);
+ end if;
+
+ elsif Nkind (Expr1) = N_Null then
+ Check_Mismatch (Nkind (Expr1) /= N_Null);
+
+ else
+ Check_Mismatch (True);
+ end if;
+
+ elsif Ekind (E1) = E_Variable
+ or else Ekind (E1) = E_Package
+ then
+ Check_Mismatch
+ (Ekind (E1) /= Ekind (E2)
+ or else Renamed_Object (E1) /= Renamed_Object (E2));
+
+ elsif Is_Overloadable (E1) then
+
+ -- Verify that the names of the entities match.
+ -- What if actual is an attribute ???
+
+ Check_Mismatch
+ (Ekind (E2) /= Ekind (E1) or else (Alias (E1)) /= Alias (E2));
+
+ else
+ raise Program_Error;
+ end if;
+
+ <<Next_E>>
+ Next_Entity (E1);
+ Next_Entity (E2);
+ end loop;
+ end Check_Formal_Package_Instance;
+
+ ---------------------------
+ -- Check_Formal_Packages --
+ ---------------------------
+
+ procedure Check_Formal_Packages (P_Id : Entity_Id) is
+ E : Entity_Id;
+ Formal_P : Entity_Id;
+
+ begin
+ -- Iterate through the declarations in the instance, looking for
+ -- package renaming declarations that denote instances of formal
+ -- packages. Stop when we find the renaming of the current package
+ -- itself. The declaration for a formal package without a box is
+ -- followed by an internal entity that repeats the instantiation.
+
+ E := First_Entity (P_Id);
+ while Present (E) loop
+ if Ekind (E) = E_Package then
+ if Renamed_Object (E) = P_Id then
+ exit;
+
+ elsif Nkind (Parent (E)) /= N_Package_Renaming_Declaration then
+ null;
+
+ elsif not Box_Present (Parent (Associated_Formal_Package (E))) then
+ Formal_P := Next_Entity (E);
+ Check_Formal_Package_Instance (Formal_P, E);
+ end if;
+ end if;
+
+ Next_Entity (E);
+ end loop;
+ end Check_Formal_Packages;
+
+ ---------------------------------
+ -- Check_Forward_Instantiation --
+ ---------------------------------
+
+ procedure Check_Forward_Instantiation (N : Node_Id; Decl : Node_Id) is
+ S : Entity_Id;
+ Gen_Comp : Entity_Id := Cunit_Entity (Get_Source_Unit (Decl));
+
+ begin
+ -- The instantiation appears before the generic body if we are in the
+ -- scope of the unit containing the generic, either in its spec or in
+ -- the package body. and before the generic body.
+
+ if Ekind (Gen_Comp) = E_Package_Body then
+ Gen_Comp := Spec_Entity (Gen_Comp);
+ end if;
+
+ if In_Open_Scopes (Gen_Comp)
+ and then No (Corresponding_Body (Decl))
+ then
+ S := Current_Scope;
+
+ while Present (S)
+ and then not Is_Compilation_Unit (S)
+ and then not Is_Child_Unit (S)
+ loop
+ if Ekind (S) = E_Package then
+ Set_Has_Forward_Instantiation (S);
+ end if;
+
+ S := Scope (S);
+ end loop;
+ end if;
+ end Check_Forward_Instantiation;
+
+ ---------------------------
+ -- Check_Generic_Actuals --
+ ---------------------------
+
+ -- The visibility of the actuals may be different between the
+ -- point of generic instantiation and the instantiation of the body.
+
+ procedure Check_Generic_Actuals
+ (Instance : Entity_Id;
+ Is_Formal_Box : Boolean)
+ is
+ E : Entity_Id;
+ Astype : Entity_Id;
+
+ begin
+ E := First_Entity (Instance);
+ while Present (E) loop
+ if Is_Type (E)
+ and then Nkind (Parent (E)) = N_Subtype_Declaration
+ and then Scope (Etype (E)) /= Instance
+ and then Is_Entity_Name (Subtype_Indication (Parent (E)))
+ then
+ Check_Private_View (Subtype_Indication (Parent (E)));
+ Set_Is_Generic_Actual_Type (E, True);
+ Set_Is_Hidden (E, False);
+
+ -- We constructed the generic actual type as a subtype of
+ -- the supplied type. This means that it normally would not
+ -- inherit subtype specific attributes of the actual, which
+ -- is wrong for the generic case.
+
+ Astype := Ancestor_Subtype (E);
+
+ if No (Astype) then
+
+ -- can happen when E is an itype that is the full view of
+ -- a private type completed, e.g. with a constrained array.
+
+ Astype := Base_Type (E);
+ end if;
+
+ Set_Size_Info (E, (Astype));
+ Set_RM_Size (E, RM_Size (Astype));
+ Set_First_Rep_Item (E, First_Rep_Item (Astype));
+
+ if Is_Discrete_Or_Fixed_Point_Type (E) then
+ Set_RM_Size (E, RM_Size (Astype));
+
+ -- In nested instances, the base type of an access actual
+ -- may itself be private, and need to be exchanged.
+
+ elsif Is_Access_Type (E)
+ and then Is_Private_Type (Etype (E))
+ then
+ Check_Private_View
+ (New_Occurrence_Of (Etype (E), Sloc (Instance)));
+ end if;
+
+ elsif Ekind (E) = E_Package then
+
+ -- If this is the renaming for the current instance, we're done.
+ -- Otherwise it is a formal package. If the corresponding formal
+ -- was declared with a box, the (instantiations of the) generic
+ -- formal part are also visible. Otherwise, ignore the entity
+ -- created to validate the actuals.
+
+ if Renamed_Object (E) = Instance then
+ exit;
+
+ elsif Nkind (Parent (E)) /= N_Package_Renaming_Declaration then
+ null;
+
+ -- The visibility of a formal of an enclosing generic is already
+ -- correct.
+
+ elsif Denotes_Formal_Package (E) then
+ null;
+
+ elsif Present (Associated_Formal_Package (E))
+ and then Box_Present (Parent (Associated_Formal_Package (E)))
+ then
+ Check_Generic_Actuals (Renamed_Object (E), True);
+ Set_Is_Hidden (E, False);
+ end if;
+
+ else
+ Set_Is_Hidden (E, not Is_Formal_Box);
+ end if;
+
+ Next_Entity (E);
+ end loop;
+
+ end Check_Generic_Actuals;
+
+ ------------------------------
+ -- Check_Generic_Child_Unit --
+ ------------------------------
+
+ procedure Check_Generic_Child_Unit
+ (Gen_Id : Node_Id;
+ Parent_Installed : in out Boolean)
+ is
+ Loc : constant Source_Ptr := Sloc (Gen_Id);
+ Gen_Par : Entity_Id := Empty;
+ Inst_Par : Entity_Id;
+ E : Entity_Id;
+ S : Node_Id;
+
+ function Find_Generic_Child
+ (Scop : Entity_Id;
+ Id : Node_Id)
+ return Entity_Id;
+ -- Search generic parent for possible child unit.
+
+ function In_Enclosing_Instance return Boolean;
+ -- Within an instance of the parent, the child unit may be denoted
+ -- by a simple name. Examine enclosing scopes to locate a possible
+ -- parent instantiation.
+
+ function Find_Generic_Child
+ (Scop : Entity_Id;
+ Id : Node_Id)
+ return Entity_Id
+ is
+ E : Entity_Id;
+
+ begin
+ -- If entity of name is already set, instance has already been
+ -- resolved, e.g. in an enclosing instantiation.
+
+ if Present (Entity (Id)) then
+ if Scope (Entity (Id)) = Scop then
+ return Entity (Id);
+ else
+ return Empty;
+ end if;
+
+ else
+ E := First_Entity (Scop);
+ while Present (E) loop
+ if Chars (E) = Chars (Id)
+ and then Is_Child_Unit (E)
+ then
+ if Is_Child_Unit (E)
+ and then not Is_Visible_Child_Unit (E)
+ then
+ Error_Msg_NE
+ ("generic child unit& is not visible", Gen_Id, E);
+ end if;
+
+ Set_Entity (Id, E);
+ return E;
+ end if;
+
+ Next_Entity (E);
+ end loop;
+
+ return Empty;
+ end if;
+ end Find_Generic_Child;
+
+ function In_Enclosing_Instance return Boolean is
+ Enclosing_Instance : Node_Id;
+
+ begin
+ Enclosing_Instance := Current_Scope;
+
+ while Present (Enclosing_Instance) loop
+ exit when Ekind (Enclosing_Instance) = E_Package
+ and then Nkind (Parent (Enclosing_Instance)) =
+ N_Package_Specification
+ and then Present
+ (Generic_Parent (Parent (Enclosing_Instance)));
+
+ Enclosing_Instance := Scope (Enclosing_Instance);
+ end loop;
+
+ if Present (Enclosing_Instance) then
+ E := Find_Generic_Child
+ (Generic_Parent (Parent (Enclosing_Instance)), Gen_Id);
+ else
+ return False;
+ end if;
+
+ if Present (E) then
+ Rewrite (Gen_Id,
+ Make_Expanded_Name (Loc,
+ Chars => Chars (E),
+ Prefix => New_Occurrence_Of (Enclosing_Instance, Loc),
+ Selector_Name => New_Occurrence_Of (E, Loc)));
+
+ Set_Entity (Gen_Id, E);
+ Set_Etype (Gen_Id, Etype (E));
+ Parent_Installed := False; -- Already in scope.
+ return True;
+ else
+ Analyze (Gen_Id);
+ return False;
+ end if;
+ end In_Enclosing_Instance;
+
+ -- Start of processing for Check_Generic_Child_Unit
+
+ begin
+ -- If the name of the generic is given by a selected component, it
+ -- may be the name of a generic child unit, and the prefix is the name
+ -- of an instance of the parent, in which case the child unit must be
+ -- visible. If this instance is not in scope, it must be placed there
+ -- and removed after instantiation, because what is being instantiated
+ -- is not the original child, but the corresponding child present in
+ -- the instance of the parent.
+
+ -- If the child is instantiated within the parent, it can be given by
+ -- a simple name. In this case the instance is already in scope, but
+ -- the child generic must be recovered from the generic parent as well.
+
+ if Nkind (Gen_Id) = N_Selected_Component then
+ S := Selector_Name (Gen_Id);
+ Analyze (Prefix (Gen_Id));
+ Inst_Par := Entity (Prefix (Gen_Id));
+
+ if Ekind (Inst_Par) = E_Package
+ and then Present (Renamed_Object (Inst_Par))
+ then
+ Inst_Par := Renamed_Object (Inst_Par);
+ end if;
+
+ if Ekind (Inst_Par) = E_Package then
+ if Nkind (Parent (Inst_Par)) = N_Package_Specification then
+ Gen_Par := Generic_Parent (Parent (Inst_Par));
+
+ elsif Nkind (Parent (Inst_Par)) = N_Defining_Program_Unit_Name
+ and then
+ Nkind (Parent (Parent (Inst_Par))) = N_Package_Specification
+ then
+ Gen_Par := Generic_Parent (Parent (Parent (Inst_Par)));
+ end if;
+
+ elsif Ekind (Inst_Par) = E_Generic_Package
+ and then Nkind (Parent (Gen_Id)) = N_Formal_Package_Declaration
+ then
+
+ -- A formal package may be a real child package, and not the
+ -- implicit instance within a parent. In this case the child is
+ -- not visible and has to be retrieved explicitly as well.
+
+ Gen_Par := Inst_Par;
+ end if;
+
+ if Present (Gen_Par) then
+
+ -- The prefix denotes an instantiation. The entity itself
+ -- may be a nested generic, or a child unit.
+
+ E := Find_Generic_Child (Gen_Par, S);
+
+ if Present (E) then
+ Change_Selected_Component_To_Expanded_Name (Gen_Id);
+ Set_Entity (Gen_Id, E);
+ Set_Etype (Gen_Id, Etype (E));
+ Set_Entity (S, E);
+ Set_Etype (S, Etype (E));
+
+ -- Indicate that this is a reference to the parent.
+
+ if In_Extended_Main_Source_Unit (Gen_Id) then
+ Set_Is_Instantiated (Inst_Par);
+ end if;
+
+ -- A common mistake is to replicate the naming scheme of
+ -- a hierarchy by instantiating a generic child directly,
+ -- rather than the implicit child in a parent instance:
+ --
+ -- generic .. package Gpar is ..
+ -- generic .. package Gpar.Child is ..
+ -- package Par is new Gpar ();
+
+ -- with Gpar.Child;
+ -- package Par.Child is new Gpar.Child ();
+ -- rather than Par.Child
+ --
+ -- In this case the instantiation is within Par, which is
+ -- an instance, but Gpar does not denote Par because we are
+ -- not IN the instance of Gpar, so this is illegal. The test
+ -- below recognizes this particular case.
+
+ if Is_Child_Unit (E)
+ and then not Comes_From_Source (Entity (Prefix (Gen_Id)))
+ and then (not In_Instance
+ or else Nkind (Parent (Parent (Gen_Id))) =
+ N_Compilation_Unit)
+ then
+ Error_Msg_N
+ ("prefix of generic child unit must be instance of parent",
+ Gen_Id);
+ end if;
+
+ if not In_Open_Scopes (Inst_Par)
+ and then Nkind (Parent (Gen_Id))
+ not in N_Generic_Renaming_Declaration
+ then
+ Install_Parent (Inst_Par);
+ Parent_Installed := True;
+ end if;
+
+ else
+ -- If the generic parent does not contain an entity that
+ -- corresponds to the selector, the instance doesn't either.
+ -- Analyzing the node will yield the appropriate error message.
+ -- If the entity is not a child unit, then it is an inner
+ -- generic in the parent.
+
+ Analyze (Gen_Id);
+ end if;
+
+ else
+ Analyze (Gen_Id);
+
+ if Is_Child_Unit (Entity (Gen_Id))
+ and then Nkind (Parent (Gen_Id))
+ not in N_Generic_Renaming_Declaration
+ and then not In_Open_Scopes (Inst_Par)
+ then
+ Install_Parent (Inst_Par);
+ Parent_Installed := True;
+ end if;
+ end if;
+
+ elsif Nkind (Gen_Id) = N_Expanded_Name then
+
+ -- Entity already present, analyze prefix, whose meaning may be
+ -- an instance in the current context. If it is an instance of
+ -- a relative within another, the proper parent may still have
+ -- to be installed, if they are not of the same generation.
+
+ Analyze (Prefix (Gen_Id));
+ Inst_Par := Entity (Prefix (Gen_Id));
+
+ if In_Enclosing_Instance then
+ null;
+
+ elsif Present (Entity (Gen_Id))
+ and then Is_Child_Unit (Entity (Gen_Id))
+ and then not In_Open_Scopes (Inst_Par)
+ then
+ Install_Parent (Inst_Par);
+ Parent_Installed := True;
+ end if;
+
+ elsif In_Enclosing_Instance then
+ -- The child unit is found in some enclosing scope.
+ null;
+
+ else
+ Analyze (Gen_Id);
+
+ -- If this is the renaming of the implicit child in a parent
+ -- instance, recover the parent name and install it.
+
+ if Is_Entity_Name (Gen_Id) then
+ E := Entity (Gen_Id);
+
+ if Is_Generic_Unit (E)
+ and then Nkind (Parent (E)) in N_Generic_Renaming_Declaration
+ and then Is_Child_Unit (Renamed_Object (E))
+ and then Is_Generic_Unit (Scope (Renamed_Object (E)))
+ and then Nkind (Name (Parent (E))) = N_Expanded_Name
+ then
+ Rewrite (Gen_Id,
+ New_Copy_Tree (Name (Parent (E))));
+ Inst_Par := Entity (Prefix (Gen_Id));
+
+ if not In_Open_Scopes (Inst_Par) then
+ Install_Parent (Inst_Par);
+ Parent_Installed := True;
+ end if;
+
+ -- If it is a child unit of a non-generic parent, it may be
+ -- use-visible and given by a direct name. Install parent as
+ -- for other cases.
+
+ elsif Is_Generic_Unit (E)
+ and then Is_Child_Unit (E)
+ and then
+ Nkind (Parent (Gen_Id)) not in N_Generic_Renaming_Declaration
+ and then not Is_Generic_Unit (Scope (E))
+ then
+ if not In_Open_Scopes (Scope (E)) then
+ Install_Parent (Scope (E));
+ Parent_Installed := True;
+ end if;
+ end if;
+ end if;
+ end if;
+ end Check_Generic_Child_Unit;
+
+ -----------------------------
+ -- Check_Hidden_Child_Unit --
+ -----------------------------
+
+ procedure Check_Hidden_Child_Unit
+ (N : Node_Id;
+ Gen_Unit : Entity_Id;
+ Act_Decl_Id : Entity_Id)
+ is
+ Gen_Id : Node_Id := Name (N);
+
+ begin
+ if Is_Child_Unit (Gen_Unit)
+ and then Is_Child_Unit (Act_Decl_Id)
+ and then Nkind (Gen_Id) = N_Expanded_Name
+ and then Entity (Prefix (Gen_Id)) = Scope (Act_Decl_Id)
+ and then Chars (Gen_Unit) = Chars (Act_Decl_Id)
+ then
+ Error_Msg_Node_2 := Scope (Act_Decl_Id);
+ Error_Msg_NE
+ ("generic unit & is implicitly declared in &",
+ Defining_Unit_Name (N), Gen_Unit);
+ Error_Msg_N ("\instance must have different name",
+ Defining_Unit_Name (N));
+ end if;
+ end Check_Hidden_Child_Unit;
+
+ ------------------------
+ -- Check_Private_View --
+ ------------------------
+
+ procedure Check_Private_View (N : Node_Id) is
+ T : constant Entity_Id := Etype (N);
+ BT : Entity_Id;
+
+ begin
+ -- Exchange views if the type was not private in the generic but is
+ -- private at the point of instantiation. Do not exchange views if
+ -- the scope of the type is in scope. This can happen if both generic
+ -- and instance are sibling units, or if type is defined in a parent.
+ -- In this case the visibility of the type will be correct for all
+ -- semantic checks.
+
+ if Present (T) then
+ BT := Base_Type (T);
+
+ if Is_Private_Type (T)
+ and then not Has_Private_View (N)
+ and then Present (Full_View (T))
+ and then not In_Open_Scopes (Scope (T))
+ then
+ -- In the generic, the full type was visible. Save the
+ -- private entity, for subsequent exchange.
+
+ Switch_View (T);
+
+ elsif Has_Private_View (N)
+ and then not Is_Private_Type (T)
+ and then not Has_Been_Exchanged (T)
+ and then Etype (Associated_Node (N)) /= T
+ then
+ -- Only the private declaration was visible in the generic. If
+ -- the type appears in a subtype declaration, the subtype in the
+ -- instance must have a view compatible with that of its parent,
+ -- which must be exchanged (see corresponding code in Restore_
+ -- Private_Views). Otherwise, if the type is defined in a parent
+ -- unit, leave full visibility within instance, which is safe.
+
+ if In_Open_Scopes (Scope (Base_Type (T)))
+ and then not Is_Private_Type (Base_Type (T))
+ and then Comes_From_Source (Base_Type (T))
+ then
+ null;
+
+ elsif Nkind (Parent (N)) = N_Subtype_Declaration
+ or else not In_Private_Part (Scope (Base_Type (T)))
+ then
+ Append_Elmt (T, Exchanged_Views);
+ Exchange_Declarations (Etype (Associated_Node (N)));
+ end if;
+
+ -- For composite types with inconsistent representation
+ -- exchange component types accordingly.
+
+ elsif Is_Access_Type (T)
+ and then Is_Private_Type (Designated_Type (T))
+ and then Present (Full_View (Designated_Type (T)))
+ then
+ Switch_View (Designated_Type (T));
+
+ elsif Is_Array_Type (T)
+ and then Is_Private_Type (Component_Type (T))
+ and then not Has_Private_View (N)
+ and then Present (Full_View (Component_Type (T)))
+ then
+ Switch_View (Component_Type (T));
+
+ elsif Is_Private_Type (T)
+ and then Present (Full_View (T))
+ and then Is_Array_Type (Full_View (T))
+ and then Is_Private_Type (Component_Type (Full_View (T)))
+ then
+ Switch_View (T);
+
+ -- Finally, a non-private subtype may have a private base type,
+ -- which must be exchanged for consistency. This can happen when
+ -- instantiating a package body, when the scope stack is empty but
+ -- in fact the subtype and the base type are declared in an enclosing
+ -- scope.
+
+ elsif not Is_Private_Type (T)
+ and then not Has_Private_View (N)
+ and then Is_Private_Type (Base_Type (T))
+ and then Present (Full_View (BT))
+ and then not Is_Generic_Type (BT)
+ and then not In_Open_Scopes (BT)
+ then
+ Append_Elmt (Full_View (BT), Exchanged_Views);
+ Exchange_Declarations (BT);
+ end if;
+ end if;
+ end Check_Private_View;
+
+ --------------------------
+ -- Contains_Instance_Of --
+ --------------------------
+
+ function Contains_Instance_Of
+ (Inner : Entity_Id;
+ Outer : Entity_Id;
+ N : Node_Id)
+ return Boolean
+ is
+ Elmt : Elmt_Id;
+ Scop : Entity_Id;
+
+ begin
+ Scop := Outer;
+
+ -- Verify that there are no circular instantiations. We check whether
+ -- the unit contains an instance of the current scope or some enclosing
+ -- scope (in case one of the instances appears in a subunit). Longer
+ -- circularities involving subunits might seem too pathological to
+ -- consider, but they were not too pathological for the authors of
+ -- DEC bc30vsq, so we loop over all enclosing scopes, and mark all
+ -- enclosing generic scopes as containing an instance.
+
+ loop
+ -- Within a generic subprogram body, the scope is not generic, to
+ -- allow for recursive subprograms. Use the declaration to determine
+ -- whether this is a generic unit.
+
+ if Ekind (Scop) = E_Generic_Package
+ or else (Is_Subprogram (Scop)
+ and then Nkind (Unit_Declaration_Node (Scop)) =
+ N_Generic_Subprogram_Declaration)
+ then
+ Elmt := First_Elmt (Inner_Instances (Inner));
+
+ while Present (Elmt) loop
+ if Node (Elmt) = Scop then
+ Error_Msg_Node_2 := Inner;
+ Error_Msg_NE
+ ("circular Instantiation: & instantiated within &!",
+ N, Scop);
+ return True;
+
+ elsif Node (Elmt) = Inner then
+ return True;
+
+ elsif Contains_Instance_Of (Node (Elmt), Scop, N) then
+ Error_Msg_Node_2 := Inner;
+ Error_Msg_NE
+ ("circular Instantiation: & instantiated within &!",
+ N, Node (Elmt));
+ return True;
+ end if;
+
+ Next_Elmt (Elmt);
+ end loop;
+
+ -- Indicate that Inner is being instantiated within Scop.
+
+ Append_Elmt (Inner, Inner_Instances (Scop));
+ end if;
+
+ if Scop = Standard_Standard then
+ exit;
+ else
+ Scop := Scope (Scop);
+ end if;
+ end loop;
+
+ return False;
+ end Contains_Instance_Of;
+
+ -----------------------
+ -- Copy_Generic_Node --
+ -----------------------
+
+ function Copy_Generic_Node
+ (N : Node_Id;
+ Parent_Id : Node_Id;
+ Instantiating : Boolean)
+ return Node_Id
+ is
+ Ent : Entity_Id;
+ New_N : Node_Id;
+
+ function Copy_Generic_Descendant (D : Union_Id) return Union_Id;
+ -- Check the given value of one of the Fields referenced by the
+ -- current node to determine whether to copy it recursively. The
+ -- field may hold a Node_Id, a List_Id, or an Elist_Id, or a plain
+ -- value (Sloc, Uint, Char) in which case it need not be copied.
+
+ function Copy_Generic_Elist (E : Elist_Id) return Elist_Id;
+ -- Make copy of element list.
+
+ function Copy_Generic_List
+ (L : List_Id;
+ Parent_Id : Node_Id)
+ return List_Id;
+ -- Apply Copy_Node recursively to the members of a node list.
+
+ -----------------------------
+ -- Copy_Generic_Descendant --
+ -----------------------------
+
+ function Copy_Generic_Descendant (D : Union_Id) return Union_Id is
+ begin
+ if D = Union_Id (Empty) then
+ return D;
+
+ elsif D in Node_Range then
+ return Union_Id
+ (Copy_Generic_Node (Node_Id (D), New_N, Instantiating));
+
+ elsif D in List_Range then
+ return Union_Id (Copy_Generic_List (List_Id (D), New_N));
+
+ elsif D in Elist_Range then
+ return Union_Id (Copy_Generic_Elist (Elist_Id (D)));
+
+ -- Nothing else is copyable (e.g. Uint values), return as is
+
+ else
+ return D;
+ end if;
+ end Copy_Generic_Descendant;
+
+ ------------------------
+ -- Copy_Generic_Elist --
+ ------------------------
+
+ function Copy_Generic_Elist (E : Elist_Id) return Elist_Id is
+ M : Elmt_Id;
+ L : Elist_Id;
+
+ begin
+ if Present (E) then
+ L := New_Elmt_List;
+ M := First_Elmt (E);
+ while Present (M) loop
+ Append_Elmt
+ (Copy_Generic_Node (Node (M), Empty, Instantiating), L);
+ Next_Elmt (M);
+ end loop;
+
+ return L;
+
+ else
+ return No_Elist;
+ end if;
+ end Copy_Generic_Elist;
+
+ -----------------------
+ -- Copy_Generic_List --
+ -----------------------
+
+ function Copy_Generic_List
+ (L : List_Id;
+ Parent_Id : Node_Id)
+ return List_Id
+ is
+ N : Node_Id;
+ New_L : List_Id;
+
+ begin
+ if Present (L) then
+ New_L := New_List;
+ Set_Parent (New_L, Parent_Id);
+
+ N := First (L);
+ while Present (N) loop
+ Append (Copy_Generic_Node (N, Empty, Instantiating), New_L);
+ Next (N);
+ end loop;
+
+ return New_L;
+
+ else
+ return No_List;
+ end if;
+ end Copy_Generic_List;
+
+ -- Start of processing for Copy_Generic_Node
+
+ begin
+ if N = Empty then
+ return N;
+ end if;
+
+ New_N := New_Copy (N);
+
+ if Instantiating then
+ Adjust_Instantiation_Sloc (New_N, S_Adjustment);
+ end if;
+
+ if not Is_List_Member (N) then
+ Set_Parent (New_N, Parent_Id);
+ end if;
+
+ -- If defining identifier, then all fields have been copied already
+
+ if Nkind (New_N) in N_Entity then
+ null;
+
+ -- Special casing for identifiers and other entity names and operators
+
+ elsif (Nkind (New_N) = N_Identifier
+ or else Nkind (New_N) = N_Character_Literal
+ or else Nkind (New_N) = N_Expanded_Name
+ or else Nkind (New_N) = N_Operator_Symbol
+ or else Nkind (New_N) in N_Op)
+ then
+ if not Instantiating then
+
+ -- Link both nodes in order to assign subsequently the
+ -- entity of the copy to the original node, in case this
+ -- is a global reference.
+
+ Set_Associated_Node (N, New_N);
+
+ -- If we are within an instantiation, this is a nested generic
+ -- that has already been analyzed at the point of definition. We
+ -- must preserve references that were global to the enclosing
+ -- parent at that point. Other occurrences, whether global or
+ -- local to the current generic, must be resolved anew, so we
+ -- reset the entity in the generic copy. A global reference has
+ -- a smaller depth than the parent, or else the same depth in
+ -- case both are distinct compilation units.
+
+ -- It is also possible for Current_Instantiated_Parent to be
+ -- defined, and for this not to be a nested generic, namely
+ -- if the unit is loaded through Rtsfind. In that case, the
+ -- entity of New_N is only a link to the associated node, and
+ -- not a defining occurrence.
+
+ -- The entities for parent units in the defining_program_unit
+ -- of a generic child unit are established when the context of
+ -- the unit is first analyzed, before the generic copy is made.
+ -- They are preserved in the copy for use in ASIS queries.
+
+ Ent := Entity (New_N);
+
+ if No (Current_Instantiated_Parent.Gen_Id) then
+ if No (Ent)
+ or else Nkind (Ent) /= N_Defining_Identifier
+ or else Nkind (Parent (N)) /= N_Defining_Program_Unit_Name
+ then
+ Set_Associated_Node (New_N, Empty);
+ end if;
+
+ elsif No (Ent)
+ or else
+ not (Nkind (Ent) = N_Defining_Identifier
+ or else
+ Nkind (Ent) = N_Defining_Character_Literal
+ or else
+ Nkind (Ent) = N_Defining_Operator_Symbol)
+ or else No (Scope (Ent))
+ or else Scope (Ent) = Current_Instantiated_Parent.Gen_Id
+ or else (Scope_Depth (Scope (Ent)) >
+ Scope_Depth (Current_Instantiated_Parent.Gen_Id)
+ and then
+ Get_Source_Unit (Ent) =
+ Get_Source_Unit (Current_Instantiated_Parent.Gen_Id))
+ then
+ Set_Associated_Node (New_N, Empty);
+ end if;
+
+ -- Case of instantiating identifier or some other name or operator
+
+ else
+ -- If the associated node is still defined, the entity in
+ -- it is global, and must be copied to the instance.
+
+ if Present (Associated_Node (N)) then
+ if Nkind (Associated_Node (N)) = Nkind (N) then
+ Set_Entity (New_N, Entity (Associated_Node (N)));
+ Check_Private_View (N);
+
+ elsif Nkind (Associated_Node (N)) = N_Function_Call then
+ Set_Entity (New_N, Entity (Name (Associated_Node (N))));
+
+ else
+ Set_Entity (New_N, Empty);
+ end if;
+ end if;
+ end if;
+
+ -- For expanded name, we must copy the Prefix and Selector_Name
+
+ if Nkind (N) = N_Expanded_Name then
+
+ Set_Prefix
+ (New_N, Copy_Generic_Node (Prefix (N), New_N, Instantiating));
+
+ Set_Selector_Name (New_N,
+ Copy_Generic_Node (Selector_Name (N), New_N, Instantiating));
+
+ -- For operators, we must copy the right operand
+
+ elsif Nkind (N) in N_Op then
+
+ Set_Right_Opnd (New_N,
+ Copy_Generic_Node (Right_Opnd (N), New_N, Instantiating));
+
+ -- And for binary operators, the left operand as well
+
+ if Nkind (N) in N_Binary_Op then
+ Set_Left_Opnd (New_N,
+ Copy_Generic_Node (Left_Opnd (N), New_N, Instantiating));
+ end if;
+ end if;
+
+ -- Special casing for stubs
+
+ elsif Nkind (N) in N_Body_Stub then
+
+ -- In any case, we must copy the specification or defining
+ -- identifier as appropriate.
+
+ if Nkind (N) = N_Subprogram_Body_Stub then
+ Set_Specification (New_N,
+ Copy_Generic_Node (Specification (N), New_N, Instantiating));
+
+ else
+ Set_Defining_Identifier (New_N,
+ Copy_Generic_Node
+ (Defining_Identifier (N), New_N, Instantiating));
+ end if;
+
+ -- If we are not instantiating, then this is where we load and
+ -- analyze subunits, i.e. at the point where the stub occurs. A
+ -- more permissivle system might defer this analysis to the point
+ -- of instantiation, but this seems to complicated for now.
+
+ if not Instantiating then
+ declare
+ Subunit_Name : constant Unit_Name_Type := Get_Unit_Name (N);
+ Subunit : Node_Id;
+ Unum : Unit_Number_Type;
+ New_Body : Node_Id;
+
+ begin
+ Unum :=
+ Load_Unit
+ (Load_Name => Subunit_Name,
+ Required => False,
+ Subunit => True,
+ Error_Node => N);
+
+ -- If the proper body is not found, a warning message will
+ -- be emitted when analyzing the stub, or later at the the
+ -- point of instantiation. Here we just leave the stub as is.
+
+ if Unum = No_Unit then
+ Subunits_Missing := True;
+ goto Subunit_Not_Found;
+ end if;
+
+ Subunit := Cunit (Unum);
+
+ -- We must create a generic copy of the subunit, in order
+ -- to perform semantic analysis on it, and we must replace
+ -- the stub in the original generic unit with the subunit,
+ -- in order to preserve non-local references within.
+
+ -- Only the proper body needs to be copied. Library_Unit and
+ -- context clause are simply inherited by the generic copy.
+ -- Note that the copy (which may be recursive if there are
+ -- nested subunits) must be done first, before attaching it
+ -- to the enclosing generic.
+
+ New_Body :=
+ Copy_Generic_Node
+ (Proper_Body (Unit (Subunit)),
+ Empty, Instantiating => False);
+
+ -- Now place the original proper body in the original
+ -- generic unit.
+
+ Rewrite (N, Proper_Body (Unit (Subunit)));
+ Set_Was_Originally_Stub (N);
+
+ -- Finally replace the body of the subunit with its copy,
+ -- and make this new subunit into the library unit of the
+ -- generic copy, which does not have stubs any longer.
+
+ Set_Proper_Body (Unit (Subunit), New_Body);
+ Set_Library_Unit (New_N, Subunit);
+ Inherit_Context (Unit (Subunit), N);
+
+ end;
+
+ -- If we are instantiating, this must be an error case, since
+ -- otherwise we would have replaced the stub node by the proper
+ -- body that corresponds. So just ignore it in the copy (i.e.
+ -- we have copied it, and that is good enough).
+
+ else
+ null;
+ end if;
+
+ <<Subunit_Not_Found>> null;
+
+ -- If the node is a compilation unit, it is the subunit of a stub,
+ -- which has been loaded already (see code below). In this case,
+ -- the library unit field of N points to the parent unit (which
+ -- is a compilation unit) and need not (and cannot!) be copied.
+
+ -- When the proper body of the stub is analyzed, thie library_unit
+ -- link is used to establish the proper context (see sem_ch10).
+
+ -- The other fields of a compilation unit are copied as usual
+
+ elsif Nkind (N) = N_Compilation_Unit then
+
+ -- This code can only be executed when not instantiating, because
+ -- in the copy made for an instantiation, the compilation unit
+ -- node has disappeared at the point that a stub is replaced by
+ -- its proper body.
+
+ pragma Assert (not Instantiating);
+
+ Set_Context_Items (New_N,
+ Copy_Generic_List (Context_Items (N), New_N));
+
+ Set_Unit (New_N,
+ Copy_Generic_Node (Unit (N), New_N, False));
+
+ Set_First_Inlined_Subprogram (New_N,
+ Copy_Generic_Node
+ (First_Inlined_Subprogram (N), New_N, False));
+
+ Set_Aux_Decls_Node (New_N,
+ Copy_Generic_Node (Aux_Decls_Node (N), New_N, False));
+
+ -- For an assignment node, the assignment is known to be semantically
+ -- legal if we are instantiating the template. This avoids incorrect
+ -- diagnostics in generated code.
+
+ elsif Nkind (N) = N_Assignment_Statement then
+
+ -- Copy name and expression fields in usual manner
+
+ Set_Name (New_N,
+ Copy_Generic_Node (Name (N), New_N, Instantiating));
+
+ Set_Expression (New_N,
+ Copy_Generic_Node (Expression (N), New_N, Instantiating));
+
+ if Instantiating then
+ Set_Assignment_OK (Name (New_N), True);
+ end if;
+
+ elsif Nkind (N) = N_Aggregate
+ or else Nkind (N) = N_Extension_Aggregate
+ then
+
+ if not Instantiating then
+ Set_Associated_Node (N, New_N);
+
+ else
+ if Present (Associated_Node (N))
+ and then Nkind (Associated_Node (N)) = Nkind (N)
+ then
+ -- In the generic the aggregate has some composite type.
+ -- If at the point of instantiation the type has a private
+ -- view, install the full view (and that of its ancestors,
+ -- if any).
+
+ declare
+ T : Entity_Id := (Etype (Associated_Node (New_N)));
+ Rt : Entity_Id;
+
+ begin
+ if Present (T)
+ and then Is_Private_Type (T)
+ then
+ Switch_View (T);
+ end if;
+
+ if Present (T)
+ and then Is_Tagged_Type (T)
+ and then Is_Derived_Type (T)
+ then
+ Rt := Root_Type (T);
+
+ loop
+ T := Etype (T);
+
+ if Is_Private_Type (T) then
+ Switch_View (T);
+ end if;
+
+ exit when T = Rt;
+ end loop;
+ end if;
+ end;
+ end if;
+ end if;
+
+ Set_Field1 (New_N, Copy_Generic_Descendant (Field1 (N)));
+ Set_Field2 (New_N, Copy_Generic_Descendant (Field2 (N)));
+ Set_Field3 (New_N, Copy_Generic_Descendant (Field3 (N)));
+ Set_Field5 (New_N, Copy_Generic_Descendant (Field5 (N)));
+
+ -- For a proper body, we must catch the case of a proper body that
+ -- replaces a stub. This represents the point at which a separate
+ -- compilation unit, and hence template file, may be referenced, so
+ -- we must make a new source instantiation entry for the template
+ -- of the subunit, and ensure that all nodes in the subunit are
+ -- adjusted using this new source instantiation entry.
+
+ elsif Nkind (N) in N_Proper_Body then
+
+ declare
+ Save_Adjustment : constant Sloc_Adjustment := S_Adjustment;
+
+ begin
+ if Instantiating and then Was_Originally_Stub (N) then
+ Create_Instantiation_Source
+ (Instantiation_Node, Defining_Entity (N), S_Adjustment);
+ end if;
+
+ -- Now copy the fields of the proper body, using the new
+ -- adjustment factor if one was needed as per test above.
+
+ Set_Field1 (New_N, Copy_Generic_Descendant (Field1 (N)));
+ Set_Field2 (New_N, Copy_Generic_Descendant (Field2 (N)));
+ Set_Field3 (New_N, Copy_Generic_Descendant (Field3 (N)));
+ Set_Field4 (New_N, Copy_Generic_Descendant (Field4 (N)));
+ Set_Field5 (New_N, Copy_Generic_Descendant (Field5 (N)));
+
+ -- Restore the original adjustment factor in case changed
+
+ S_Adjustment := Save_Adjustment;
+ end;
+
+ -- Don't copy Ident or Comment pragmas, since the comment belongs
+ -- to the generic unit, not to the instantiating unit.
+
+ elsif Nkind (N) = N_Pragma
+ and then Instantiating
+ then
+ declare
+ Prag_Id : constant Pragma_Id := Get_Pragma_Id (Chars (N));
+
+ begin
+ if Prag_Id = Pragma_Ident
+ or else Prag_Id = Pragma_Comment
+ then
+ New_N := Make_Null_Statement (Sloc (N));
+
+ else
+ Set_Field1 (New_N, Copy_Generic_Descendant (Field1 (N)));
+ Set_Field2 (New_N, Copy_Generic_Descendant (Field2 (N)));
+ Set_Field3 (New_N, Copy_Generic_Descendant (Field3 (N)));
+ Set_Field4 (New_N, Copy_Generic_Descendant (Field4 (N)));
+ Set_Field5 (New_N, Copy_Generic_Descendant (Field5 (N)));
+ end if;
+ end;
+
+ -- For the remaining nodes, copy recursively their descendants.
+
+ else
+ Set_Field1 (New_N, Copy_Generic_Descendant (Field1 (N)));
+ Set_Field2 (New_N, Copy_Generic_Descendant (Field2 (N)));
+ Set_Field3 (New_N, Copy_Generic_Descendant (Field3 (N)));
+ Set_Field4 (New_N, Copy_Generic_Descendant (Field4 (N)));
+ Set_Field5 (New_N, Copy_Generic_Descendant (Field5 (N)));
+
+ if Instantiating
+ and then Nkind (N) = N_Subprogram_Body
+ then
+ Set_Generic_Parent (Specification (New_N), N);
+ end if;
+ end if;
+
+ return New_N;
+ end Copy_Generic_Node;
+
+ ----------------------------
+ -- Denotes_Formal_Package --
+ ----------------------------
+
+ function Denotes_Formal_Package (Pack : Entity_Id) return Boolean is
+ Par : constant Entity_Id := Current_Instantiated_Parent.Act_Id;
+ Scop : Entity_Id := Scope (Pack);
+ E : Entity_Id;
+
+ begin
+ if Ekind (Scop) = E_Generic_Package
+ or else Nkind (Unit_Declaration_Node (Scop))
+ = N_Generic_Subprogram_Declaration
+ then
+ return True;
+
+ elsif Nkind (Parent (Pack)) = N_Formal_Package_Declaration then
+ return True;
+
+ elsif No (Par) then
+ return False;
+
+ else
+ -- Check whether this package is associated with a formal
+ -- package of the enclosing instantiation. Iterate over the
+ -- list of renamings.
+
+ E := First_Entity (Par);
+ while Present (E) loop
+
+ if Ekind (E) /= E_Package
+ or else Nkind (Parent (E)) /= N_Package_Renaming_Declaration
+ then
+ null;
+ elsif Renamed_Object (E) = Par then
+ return False;
+
+ elsif Renamed_Object (E) = Pack then
+ return True;
+ end if;
+
+ Next_Entity (E);
+ end loop;
+
+ return False;
+ end if;
+ end Denotes_Formal_Package;
+
+ -----------------
+ -- End_Generic --
+ -----------------
+
+ procedure End_Generic is
+ begin
+ -- ??? More things could be factored out in this
+ -- routine. Should probably be done at a later stage.
+
+ Inside_A_Generic := Generic_Flags.Table (Generic_Flags.Last);
+ Generic_Flags.Decrement_Last;
+
+ Expander_Mode_Restore;
+ end End_Generic;
+
+ ----------------------
+ -- Find_Actual_Type --
+ ----------------------
+
+ function Find_Actual_Type
+ (Typ : Entity_Id;
+ Gen_Scope : Entity_Id)
+ return Entity_Id
+ is
+ T : Entity_Id;
+
+ begin
+ if not Is_Child_Unit (Gen_Scope) then
+ return Get_Instance_Of (Typ);
+
+ elsif not Is_Generic_Type (Typ)
+ or else Scope (Typ) = Gen_Scope
+ then
+ return Get_Instance_Of (Typ);
+
+ else
+ T := Current_Entity (Typ);
+ while Present (T) loop
+ if In_Open_Scopes (Scope (T)) then
+ return T;
+ end if;
+
+ T := Homonym (T);
+ end loop;
+
+ return Typ;
+ end if;
+ end Find_Actual_Type;
+
+ ----------------------------
+ -- Freeze_Subprogram_Body --
+ ----------------------------
+
+ procedure Freeze_Subprogram_Body
+ (Inst_Node : Node_Id;
+ Gen_Body : Node_Id;
+ Pack_Id : Entity_Id)
+ is
+ F_Node : Node_Id;
+ Gen_Unit : constant Entity_Id := Entity (Name (Inst_Node));
+ Par : constant Entity_Id := Scope (Gen_Unit);
+ Enc_G : Entity_Id;
+ Enc_I : Node_Id;
+ E_G_Id : Entity_Id;
+
+ function Earlier (N1, N2 : Node_Id) return Boolean;
+ -- Yields True if N1 and N2 appear in the same compilation unit,
+ -- ignoring subunits, and if N1 is to the left of N2 in a left-to-right
+ -- traversal of the tree for the unit.
+
+ function Enclosing_Body (N : Node_Id) return Node_Id;
+ -- Find innermost package body that encloses the given node, and which
+ -- is not a compilation unit. Freeze nodes for the instance, or for its
+ -- enclosing body, may be inserted after the enclosing_body of the
+ -- generic unit.
+
+ function Package_Freeze_Node (B : Node_Id) return Node_Id;
+ -- Find entity for given package body, and locate or create a freeze
+ -- node for it.
+
+ function True_Parent (N : Node_Id) return Node_Id;
+ -- For a subunit, return parent of corresponding stub.
+
+ -------------
+ -- Earlier --
+ -------------
+
+ function Earlier (N1, N2 : Node_Id) return Boolean is
+ D1 : Integer := 0;
+ D2 : Integer := 0;
+ P1 : Node_Id := N1;
+ P2 : Node_Id := N2;
+
+ procedure Find_Depth (P : in out Node_Id; D : in out Integer);
+ -- Find distance from given node to enclosing compilation unit.
+
+ procedure Find_Depth (P : in out Node_Id; D : in out Integer) is
+ begin
+ while Present (P)
+ and then Nkind (P) /= N_Compilation_Unit
+ loop
+ P := True_Parent (P);
+ D := D + 1;
+ end loop;
+ end Find_Depth;
+
+ begin
+ Find_Depth (P1, D1);
+ Find_Depth (P2, D2);
+
+ if P1 /= P2 then
+ return False;
+ else
+ P1 := N1;
+ P2 := N2;
+ end if;
+
+ while D1 > D2 loop
+ P1 := True_Parent (P1);
+ D1 := D1 - 1;
+ end loop;
+
+ while D2 > D1 loop
+ P2 := True_Parent (P2);
+ D2 := D2 - 1;
+ end loop;
+
+ -- At this point P1 and P2 are at the same distance from the root.
+ -- We examine their parents until we find a common declarative
+ -- list, at which point we can establish their relative placement
+ -- by comparing their ultimate slocs. If we reach the root,
+ -- N1 and N2 do not descend from the same declarative list (e.g.
+ -- one is nested in the declarative part and the other is in a block
+ -- in the statement part) and the earlier one is already frozen.
+
+ while not Is_List_Member (P1)
+ or else not Is_List_Member (P2)
+ or else List_Containing (P1) /= List_Containing (P2)
+ loop
+ P1 := True_Parent (P1);
+ P2 := True_Parent (P2);
+
+ if Nkind (Parent (P1)) = N_Subunit then
+ P1 := Corresponding_Stub (Parent (P1));
+ end if;
+
+ if Nkind (Parent (P2)) = N_Subunit then
+ P2 := Corresponding_Stub (Parent (P2));
+ end if;
+
+ if P1 = P2 then
+ return False;
+ end if;
+ end loop;
+
+ return
+ Top_Level_Location (Sloc (P1)) < Top_Level_Location (Sloc (P2));
+ end Earlier;
+
+ --------------------
+ -- Enclosing_Body --
+ --------------------
+
+ function Enclosing_Body (N : Node_Id) return Node_Id is
+ P : Node_Id := Parent (N);
+
+ begin
+ while Present (P)
+ and then Nkind (Parent (P)) /= N_Compilation_Unit
+ loop
+ if Nkind (P) = N_Package_Body then
+
+ if Nkind (Parent (P)) = N_Subunit then
+ return Corresponding_Stub (Parent (P));
+ else
+ return P;
+ end if;
+ end if;
+
+ P := True_Parent (P);
+ end loop;
+
+ return Empty;
+ end Enclosing_Body;
+
+ -------------------------
+ -- Package_Freeze_Node --
+ -------------------------
+
+ function Package_Freeze_Node (B : Node_Id) return Node_Id is
+ Id : Entity_Id;
+
+ begin
+ if Nkind (B) = N_Package_Body then
+ Id := Corresponding_Spec (B);
+
+ else pragma Assert (Nkind (B) = N_Package_Body_Stub);
+ Id := Corresponding_Spec (Proper_Body (Unit (Library_Unit (B))));
+ end if;
+
+ Ensure_Freeze_Node (Id);
+ return Freeze_Node (Id);
+ end Package_Freeze_Node;
+
+ -----------------
+ -- True_Parent --
+ -----------------
+
+ function True_Parent (N : Node_Id) return Node_Id is
+ begin
+ if Nkind (Parent (N)) = N_Subunit then
+ return Parent (Corresponding_Stub (Parent (N)));
+ else
+ return Parent (N);
+ end if;
+ end True_Parent;
+
+ -- Start of processing of Freeze_Subprogram_Body
+
+ begin
+ -- If the instance and the generic body appear within the same
+ -- unit, and the instance preceeds the generic, the freeze node for
+ -- the instance must appear after that of the generic. If the generic
+ -- is nested within another instance I2, then current instance must
+ -- be frozen after I2. In both cases, the freeze nodes are those of
+ -- enclosing packages. Otherwise, the freeze node is placed at the end
+ -- of the current declarative part.
+
+ Enc_G := Enclosing_Body (Gen_Body);
+ Enc_I := Enclosing_Body (Inst_Node);
+ Ensure_Freeze_Node (Pack_Id);
+ F_Node := Freeze_Node (Pack_Id);
+
+ if Is_Generic_Instance (Par)
+ and then Present (Freeze_Node (Par))
+ and then
+ In_Same_Declarative_Part (Freeze_Node (Par), Inst_Node)
+ then
+ Insert_After (Freeze_Node (Par), F_Node);
+
+ -- The body enclosing the instance should be frozen after the body
+ -- that includes the generic, because the body of the instance may
+ -- make references to entities therein. If the two are not in the
+ -- same declarative part, or if the one enclosing the instance is
+ -- frozen already, freeze the instance at the end of the current
+ -- declarative part.
+
+ elsif Is_Generic_Instance (Par)
+ and then Present (Freeze_Node (Par))
+ and then Present (Enc_I)
+ then
+ if In_Same_Declarative_Part (Freeze_Node (Par), Enc_I)
+ or else
+ (Nkind (Enc_I) = N_Package_Body
+ and then
+ In_Same_Declarative_Part (Freeze_Node (Par), Parent (Enc_I)))
+ then
+
+ -- The enclosing package may contain several instances. Rather
+ -- than computing the earliest point at which to insert its
+ -- freeze node, we place it at the end of the declarative part
+ -- of the parent of the generic.
+
+ Insert_After_Last_Decl
+ (Freeze_Node (Par), Package_Freeze_Node (Enc_I));
+ end if;
+
+ Insert_After_Last_Decl (Inst_Node, F_Node);
+
+ elsif Present (Enc_G)
+ and then Present (Enc_I)
+ and then Enc_G /= Enc_I
+ and then Earlier (Inst_Node, Gen_Body)
+ then
+ if Nkind (Enc_G) = N_Package_Body then
+ E_G_Id := Corresponding_Spec (Enc_G);
+ else pragma Assert (Nkind (Enc_G) = N_Package_Body_Stub);
+ E_G_Id :=
+ Corresponding_Spec (Proper_Body (Unit (Library_Unit (Enc_G))));
+ end if;
+
+ -- Freeze package that encloses instance, and place node after
+ -- package that encloses generic. If enclosing package is already
+ -- frozen we have to assume it is at the proper place. This may
+ -- be a potential ABE that requires dynamic checking.
+
+ Insert_After_Last_Decl (Enc_G, Package_Freeze_Node (Enc_I));
+
+ -- Freeze enclosing subunit before instance
+
+ Ensure_Freeze_Node (E_G_Id);
+
+ if not Is_List_Member (Freeze_Node (E_G_Id)) then
+ Insert_After (Enc_G, Freeze_Node (E_G_Id));
+ end if;
+
+ Insert_After_Last_Decl (Inst_Node, F_Node);
+
+ else
+
+ -- If none of the above, insert freeze node at the end of the
+ -- current declarative part.
+
+ Insert_After_Last_Decl (Inst_Node, F_Node);
+ end if;
+ end Freeze_Subprogram_Body;
+
+ ----------------
+ -- Get_Gen_Id --
+ ----------------
+
+ function Get_Gen_Id (E : Assoc_Ptr) return Entity_Id is
+ begin
+ return Generic_Renamings.Table (E).Gen_Id;
+ end Get_Gen_Id;
+
+ ---------------------
+ -- Get_Instance_Of --
+ ---------------------
+
+ function Get_Instance_Of (A : Entity_Id) return Entity_Id is
+ Res : Assoc_Ptr := Generic_Renamings_HTable.Get (A);
+ begin
+ if Res /= Assoc_Null then
+ return Generic_Renamings.Table (Res).Act_Id;
+ else
+ -- On exit, entity is not instantiated: not a generic parameter,
+ -- or else parameter of an inner generic unit.
+
+ return A;
+ end if;
+ end Get_Instance_Of;
+
+ ------------------------------------
+ -- Get_Package_Instantiation_Node --
+ ------------------------------------
+
+ function Get_Package_Instantiation_Node (A : Entity_Id) return Node_Id is
+ Decl : Node_Id := Unit_Declaration_Node (A);
+ Inst : Node_Id;
+
+ begin
+ -- If the instantiation is a compilation unit that does not need a
+ -- body then the instantiation node has been rewritten as a package
+ -- declaration for the instance, and we return the original node.
+ -- If it is a compilation unit and the instance node has not been
+ -- rewritten, then it is still the unit of the compilation.
+ -- Otherwise the instantiation node appears after the declaration.
+ -- If the entity is a formal package, the declaration may have been
+ -- rewritten as a generic declaration (in the case of a formal with a
+ -- box) or left as a formal package declaration if it has actuals, and
+ -- is found with a forward search.
+
+ if Nkind (Parent (Decl)) = N_Compilation_Unit then
+ if Nkind (Original_Node (Decl)) = N_Package_Instantiation then
+ return Original_Node (Decl);
+ else
+ return Unit (Parent (Decl));
+ end if;
+
+ elsif Nkind (Decl) = N_Generic_Package_Declaration
+ and then Nkind (Original_Node (Decl)) = N_Formal_Package_Declaration
+ then
+ return Original_Node (Decl);
+
+ else
+ Inst := Next (Decl);
+ while Nkind (Inst) /= N_Package_Instantiation
+ and then Nkind (Inst) /= N_Formal_Package_Declaration
+ loop
+ Next (Inst);
+ end loop;
+
+ return Inst;
+ end if;
+ end Get_Package_Instantiation_Node;
+
+ ------------------------
+ -- Has_Been_Exchanged --
+ ------------------------
+
+ function Has_Been_Exchanged (E : Entity_Id) return Boolean is
+ Next : Elmt_Id := First_Elmt (Exchanged_Views);
+
+ begin
+ while Present (Next) loop
+ if Full_View (Node (Next)) = E then
+ return True;
+ end if;
+
+ Next_Elmt (Next);
+ end loop;
+
+ return False;
+ end Has_Been_Exchanged;
+
+ ----------
+ -- Hash --
+ ----------
+
+ function Hash (F : Entity_Id) return HTable_Range is
+ begin
+ return HTable_Range (F mod HTable_Size);
+ end Hash;
+
+ ------------------------
+ -- Hide_Current_Scope --
+ ------------------------
+
+ procedure Hide_Current_Scope is
+ C : constant Entity_Id := Current_Scope;
+ E : Entity_Id;
+
+ begin
+ Set_Is_Hidden_Open_Scope (C);
+ E := First_Entity (C);
+
+ while Present (E) loop
+ if Is_Immediately_Visible (E) then
+ Set_Is_Immediately_Visible (E, False);
+ Append_Elmt (E, Hidden_Entities);
+ end if;
+
+ Next_Entity (E);
+ end loop;
+
+ -- Make the scope name invisible as well. This is necessary, but
+ -- might conflict with calls to Rtsfind later on, in case the scope
+ -- is a predefined one. There is no clean solution to this problem, so
+ -- for now we depend on the user not redefining Standard itself in one
+ -- of the parent units.
+
+ if Is_Immediately_Visible (C)
+ and then C /= Standard_Standard
+ then
+ Set_Is_Immediately_Visible (C, False);
+ Append_Elmt (C, Hidden_Entities);
+ end if;
+
+ end Hide_Current_Scope;
+
+ ------------------------------
+ -- In_Same_Declarative_Part --
+ ------------------------------
+
+ function In_Same_Declarative_Part
+ (F_Node : Node_Id;
+ Inst : Node_Id)
+ return Boolean
+ is
+ Decls : Node_Id := Parent (F_Node);
+ Nod : Node_Id := Parent (Inst);
+
+ begin
+ while Present (Nod) loop
+ if Nod = Decls then
+ return True;
+
+ elsif Nkind (Nod) = N_Subprogram_Body
+ or else Nkind (Nod) = N_Package_Body
+ or else Nkind (Nod) = N_Task_Body
+ or else Nkind (Nod) = N_Protected_Body
+ or else Nkind (Nod) = N_Block_Statement
+ then
+ return False;
+
+ elsif Nkind (Nod) = N_Subunit then
+ Nod := Corresponding_Stub (Nod);
+
+ elsif Nkind (Nod) = N_Compilation_Unit then
+ return False;
+ else
+ Nod := Parent (Nod);
+ end if;
+ end loop;
+
+ return False;
+ end In_Same_Declarative_Part;
+
+ ---------------------
+ -- Inherit_Context --
+ ---------------------
+
+ procedure Inherit_Context (Gen_Decl : Node_Id; Inst : Node_Id) is
+ Current_Context : List_Id;
+ Current_Unit : Node_Id;
+ Item : Node_Id;
+ New_I : Node_Id;
+
+ begin
+ if Nkind (Parent (Gen_Decl)) = N_Compilation_Unit then
+
+ -- The inherited context is attached to the enclosing compilation
+ -- unit. This is either the main unit, or the declaration for the
+ -- main unit (in case the instantation appears within the package
+ -- declaration and the main unit is its body).
+
+ Current_Unit := Parent (Inst);
+ while Present (Current_Unit)
+ and then Nkind (Current_Unit) /= N_Compilation_Unit
+ loop
+ Current_Unit := Parent (Current_Unit);
+ end loop;
+
+ Current_Context := Context_Items (Current_Unit);
+
+ Item := First (Context_Items (Parent (Gen_Decl)));
+ while Present (Item) loop
+ if Nkind (Item) = N_With_Clause then
+ New_I := New_Copy (Item);
+ Set_Implicit_With (New_I, True);
+ Append (New_I, Current_Context);
+ end if;
+
+ Next (Item);
+ end loop;
+ end if;
+ end Inherit_Context;
+
+ ----------------------------
+ -- Insert_After_Last_Decl --
+ ----------------------------
+
+ procedure Insert_After_Last_Decl (N : Node_Id; F_Node : Node_Id) is
+ L : List_Id := List_Containing (N);
+ P : Node_Id := Parent (L);
+
+ begin
+ if not Is_List_Member (F_Node) then
+ if Nkind (P) = N_Package_Specification
+ and then L = Visible_Declarations (P)
+ and then Present (Private_Declarations (P))
+ and then not Is_Empty_List (Private_Declarations (P))
+ then
+ L := Private_Declarations (P);
+ end if;
+
+ Insert_After (Last (L), F_Node);
+ end if;
+ end Insert_After_Last_Decl;
+
+ ------------------
+ -- Install_Body --
+ ------------------
+
+ procedure Install_Body
+ (Act_Body : Node_Id;
+ N : Node_Id;
+ Gen_Body : Node_Id;
+ Gen_Decl : Node_Id)
+ is
+ Act_Id : Entity_Id := Corresponding_Spec (Act_Body);
+ Act_Unit : constant Node_Id :=
+ Unit (Cunit (Get_Source_Unit (N)));
+ F_Node : Node_Id;
+ Gen_Id : Entity_Id := Corresponding_Spec (Gen_Body);
+ Gen_Unit : constant Node_Id :=
+ Unit (Cunit (Get_Source_Unit (Gen_Decl)));
+ Orig_Body : Node_Id := Gen_Body;
+ Par : constant Entity_Id := Scope (Gen_Id);
+ Body_Unit : Node_Id;
+
+ Must_Delay : Boolean;
+
+ function Enclosing_Subp (Id : Entity_Id) return Entity_Id;
+ -- Find subprogram (if any) that encloses instance and/or generic body.
+
+ function True_Sloc (N : Node_Id) return Source_Ptr;
+ -- If the instance is nested inside a generic unit, the Sloc of the
+ -- instance indicates the place of the original definition, not the
+ -- point of the current enclosing instance. Pending a better usage of
+ -- Slocs to indicate instantiation places, we determine the place of
+ -- origin of a node by finding the maximum sloc of any ancestor node.
+ -- Why is this not equivalent fo Top_Level_Location ???
+
+ function Enclosing_Subp (Id : Entity_Id) return Entity_Id is
+ Scop : Entity_Id := Scope (Id);
+
+ begin
+ while Scop /= Standard_Standard
+ and then not Is_Overloadable (Scop)
+ loop
+ Scop := Scope (Scop);
+ end loop;
+
+ return Scop;
+ end Enclosing_Subp;
+
+ function True_Sloc (N : Node_Id) return Source_Ptr is
+ Res : Source_Ptr;
+ N1 : Node_Id;
+
+ begin
+ Res := Sloc (N);
+ N1 := N;
+ while Present (N1) and then N1 /= Act_Unit loop
+ if Sloc (N1) > Res then
+ Res := Sloc (N1);
+ end if;
+
+ N1 := Parent (N1);
+ end loop;
+
+ return Res;
+ end True_Sloc;
+
+ -- Start of processing for Install_Body
+
+ begin
+ -- If the body is a subunit, the freeze point is the corresponding
+ -- stub in the current compilation, not the subunit itself.
+
+ if Nkind (Parent (Gen_Body)) = N_Subunit then
+ Orig_Body := Corresponding_Stub (Parent (Gen_Body));
+ else
+ Orig_Body := Gen_Body;
+ end if;
+
+ Body_Unit := Unit (Cunit (Get_Source_Unit (Orig_Body)));
+
+ -- If the instantiation and the generic definition appear in the
+ -- same package declaration, this is an early instantiation.
+ -- If they appear in the same declarative part, it is an early
+ -- instantiation only if the generic body appears textually later,
+ -- and the generic body is also in the main unit.
+
+ -- If instance is nested within a subprogram, and the generic body is
+ -- not, the instance is delayed because the enclosing body is. If
+ -- instance and body are within the same scope, or the same sub-
+ -- program body, indicate explicitly that the instance is delayed.
+
+ Must_Delay :=
+ (Gen_Unit = Act_Unit
+ and then ((Nkind (Gen_Unit) = N_Package_Declaration)
+ or else Nkind (Gen_Unit) = N_Generic_Package_Declaration
+ or else (Gen_Unit = Body_Unit
+ and then True_Sloc (N) < Sloc (Orig_Body)))
+ and then Is_In_Main_Unit (Gen_Unit)
+ and then (Scope (Act_Id) = Scope (Gen_Id)
+ or else
+ Enclosing_Subp (Act_Id) = Enclosing_Subp (Gen_Id)));
+
+ -- If this is an early instantiation, the freeze node is placed after
+ -- the generic body. Otherwise, if the generic appears in an instance,
+ -- we cannot freeze the current instance until the outer one is frozen.
+ -- This is only relevant if the current instance is nested within some
+ -- inner scope not itself within the outer instance. If this scope is
+ -- a package body in the same declarative part as the outer instance,
+ -- then that body needs to be frozen after the outer instance. Finally,
+ -- if no delay is needed, we place the freeze node at the end of the
+ -- current declarative part.
+
+ if Expander_Active then
+ Ensure_Freeze_Node (Act_Id);
+ F_Node := Freeze_Node (Act_Id);
+
+ if Must_Delay then
+ Insert_After (Orig_Body, F_Node);
+
+ elsif Is_Generic_Instance (Par)
+ and then Present (Freeze_Node (Par))
+ and then Scope (Act_Id) /= Par
+ then
+ -- Freeze instance of inner generic after instance of enclosing
+ -- generic.
+
+ if In_Same_Declarative_Part (Freeze_Node (Par), N) then
+ Insert_After (Freeze_Node (Par), F_Node);
+
+ -- Freeze package enclosing instance of inner generic after
+ -- instance of enclosing generic.
+
+ elsif Nkind (Parent (N)) = N_Package_Body
+ and then In_Same_Declarative_Part (Freeze_Node (Par), Parent (N))
+ then
+
+ declare
+ Enclosing : Entity_Id := Corresponding_Spec (Parent (N));
+
+ begin
+ Insert_After_Last_Decl (N, F_Node);
+ Ensure_Freeze_Node (Enclosing);
+
+ if not Is_List_Member (Freeze_Node (Enclosing)) then
+ Insert_After (Freeze_Node (Par), Freeze_Node (Enclosing));
+ end if;
+ end;
+
+ else
+ Insert_After_Last_Decl (N, F_Node);
+ end if;
+
+ else
+ Insert_After_Last_Decl (N, F_Node);
+ end if;
+ end if;
+
+ Set_Is_Frozen (Act_Id);
+ Insert_Before (N, Act_Body);
+ Mark_Rewrite_Insertion (Act_Body);
+ end Install_Body;
+
+ --------------------
+ -- Install_Parent --
+ --------------------
+
+ procedure Install_Parent (P : Entity_Id; In_Body : Boolean := False) is
+ S : Entity_Id := Current_Scope;
+ Inst_Par : Entity_Id;
+ First_Par : Entity_Id;
+ Inst_Node : Node_Id;
+ Gen_Par : Entity_Id;
+ First_Gen : Entity_Id;
+ Ancestors : Elist_Id := New_Elmt_List;
+ Elmt : Elmt_Id;
+
+ procedure Install_Formal_Packages (Par : Entity_Id);
+ -- If any of the formals of the parent are formal packages with box,
+ -- their formal parts are visible in the parent and thus in the child
+ -- unit as well. Analogous to what is done in Check_Generic_Actuals
+ -- for the unit itself.
+
+ procedure Install_Noninstance_Specs (Par : Entity_Id);
+ -- Install the scopes of noninstance parent units ending with Par.
+
+ procedure Install_Spec (Par : Entity_Id);
+ -- The child unit is within the declarative part of the parent, so
+ -- the declarations within the parent are immediately visible.
+
+ -----------------------------
+ -- Install_Formal_Packages --
+ -----------------------------
+
+ procedure Install_Formal_Packages (Par : Entity_Id) is
+ E : Entity_Id;
+
+ begin
+ E := First_Entity (Par);
+
+ while Present (E) loop
+
+ if Ekind (E) = E_Package
+ and then Nkind (Parent (E)) = N_Package_Renaming_Declaration
+ then
+ -- If this is the renaming for the parent instance, done.
+
+ if Renamed_Object (E) = Par then
+ exit;
+
+ -- The visibility of a formal of an enclosing generic is
+ -- already correct.
+
+ elsif Denotes_Formal_Package (E) then
+ null;
+
+ elsif Present (Associated_Formal_Package (E))
+ and then Box_Present (Parent (Associated_Formal_Package (E)))
+ then
+ Check_Generic_Actuals (Renamed_Object (E), True);
+ Set_Is_Hidden (E, False);
+ end if;
+ end if;
+
+ Next_Entity (E);
+ end loop;
+ end Install_Formal_Packages;
+
+ -------------------------------
+ -- Install_Noninstance_Specs --
+ -------------------------------
+
+ procedure Install_Noninstance_Specs (Par : Entity_Id) is
+ begin
+ if Present (Par)
+ and then Par /= Standard_Standard
+ and then not In_Open_Scopes (Par)
+ then
+ Install_Noninstance_Specs (Scope (Par));
+ Install_Spec (Par);
+ end if;
+ end Install_Noninstance_Specs;
+
+ ------------------
+ -- Install_Spec --
+ ------------------
+
+ procedure Install_Spec (Par : Entity_Id) is
+ Spec : constant Node_Id :=
+ Specification (Unit_Declaration_Node (Par));
+
+ begin
+ New_Scope (Par);
+ Set_Is_Immediately_Visible (Par);
+ Install_Visible_Declarations (Par);
+ Install_Private_Declarations (Par);
+ Set_Use (Visible_Declarations (Spec));
+ Set_Use (Private_Declarations (Spec));
+ end Install_Spec;
+
+ -- Start of processing for Install_Parent
+
+ begin
+ -- We need to install the parent instance to compile the instantiation
+ -- of the child, but the child instance must appear in the current
+ -- scope. Given that we cannot place the parent above the current
+ -- scope in the scope stack, we duplicate the current scope and unstack
+ -- both after the instantiation is complete.
+
+ -- If the parent is itself the instantiation of a child unit, we must
+ -- also stack the instantiation of its parent, and so on. Each such
+ -- ancestor is the prefix of the name in a prior instantiation.
+
+ -- If this is a nested instance, the parent unit itself resolves to
+ -- a renaming of the parent instance, whose declaration we need.
+
+ -- Finally, the parent may be a generic (not an instance) when the
+ -- child unit appears as a formal package.
+
+ Inst_Par := P;
+
+ if Present (Renamed_Entity (Inst_Par)) then
+ Inst_Par := Renamed_Entity (Inst_Par);
+ end if;
+
+ First_Par := Inst_Par;
+
+ Gen_Par :=
+ Generic_Parent (Specification (Unit_Declaration_Node (Inst_Par)));
+
+ First_Gen := Gen_Par;
+
+ while Present (Gen_Par)
+ and then Is_Child_Unit (Gen_Par)
+ loop
+ -- Load grandparent instance as well.
+
+ Inst_Node := Get_Package_Instantiation_Node (Inst_Par);
+
+ if Nkind (Name (Inst_Node)) = N_Expanded_Name then
+ Inst_Par := Entity (Prefix (Name (Inst_Node)));
+
+ if Present (Renamed_Entity (Inst_Par)) then
+ Inst_Par := Renamed_Entity (Inst_Par);
+ end if;
+
+ Gen_Par :=
+ Generic_Parent
+ (Specification (Unit_Declaration_Node (Inst_Par)));
+
+ if Present (Gen_Par) then
+ Prepend_Elmt (Inst_Par, Ancestors);
+
+ else
+ -- Parent is not the name of an instantiation.
+
+ Install_Noninstance_Specs (Inst_Par);
+
+ exit;
+ end if;
+
+ else
+ -- Previous error.
+
+ exit;
+ end if;
+ end loop;
+
+ if Present (First_Gen) then
+ Append_Elmt (First_Par, Ancestors);
+
+ else
+ Install_Noninstance_Specs (First_Par);
+ end if;
+
+ if not Is_Empty_Elmt_List (Ancestors) then
+ Elmt := First_Elmt (Ancestors);
+
+ while Present (Elmt) loop
+ Install_Spec (Node (Elmt));
+ Install_Formal_Packages (Node (Elmt));
+
+ Next_Elmt (Elmt);
+ end loop;
+ end if;
+
+ if not In_Body then
+ New_Scope (S);
+ end if;
+ end Install_Parent;
+
+ --------------------------------
+ -- Instantiate_Formal_Package --
+ --------------------------------
+
+ function Instantiate_Formal_Package
+ (Formal : Node_Id;
+ Actual : Node_Id;
+ Analyzed_Formal : Node_Id)
+ return List_Id
+ is
+ Loc : constant Source_Ptr := Sloc (Actual);
+ Actual_Pack : Entity_Id;
+ Formal_Pack : Entity_Id;
+ Gen_Parent : Entity_Id;
+ Decls : List_Id;
+ Nod : Node_Id;
+ Parent_Spec : Node_Id;
+
+ function Formal_Entity
+ (F : Node_Id;
+ Act_Ent : Entity_Id)
+ return Entity_Id;
+ -- Returns the entity associated with the given formal F. In the
+ -- case where F is a formal package, this function will iterate
+ -- through all of F's formals and enter map associations from the
+ -- actuals occurring in the formal package's corresponding actual
+ -- package (obtained via Act_Ent) to the formal package's formal
+ -- parameters. This function is called recursively for arbitrary
+ -- levels of formal packages.
+
+ procedure Map_Entities (Form : Entity_Id; Act : Entity_Id);
+ -- Within the generic part, entities in the formal package are
+ -- visible. To validate subsequent type declarations, indicate
+ -- the correspondence betwen the entities in the analyzed formal,
+ -- and the entities in the actual package. There are three packages
+ -- involved in the instantiation of a formal package: the parent
+ -- generic P1 which appears in the generic declaration, the fake
+ -- instantiation P2 which appears in the analyzed generic, and whose
+ -- visible entities may be used in subsequent formals, and the actual
+ -- P3 in the instance. To validate subsequent formals, me indicate
+ -- that the entities in P2 are mapped into those of P3. The mapping of
+ -- entities has to be done recursively for nested packages.
+
+ -------------------
+ -- Formal_Entity --
+ -------------------
+
+ function Formal_Entity
+ (F : Node_Id;
+ Act_Ent : Entity_Id)
+ return Entity_Id
+ is
+ Orig_Node : Node_Id := F;
+
+ begin
+ case Nkind (F) is
+ when N_Formal_Object_Declaration =>
+ return Defining_Identifier (F);
+
+ when N_Formal_Type_Declaration =>
+ return Defining_Identifier (F);
+
+ when N_Formal_Subprogram_Declaration =>
+ return Defining_Unit_Name (Specification (F));
+
+ when N_Formal_Package_Declaration |
+ N_Generic_Package_Declaration =>
+
+ if Nkind (F) = N_Generic_Package_Declaration then
+ Orig_Node := Original_Node (F);
+ end if;
+
+ declare
+ Actual_Ent : Entity_Id := First_Entity (Act_Ent);
+ Formal_Node : Node_Id;
+ Formal_Ent : Entity_Id;
+
+ Gen_Decl : Node_Id :=
+ Unit_Declaration_Node
+ (Entity (Name (Orig_Node)));
+ Formals : List_Id :=
+ Generic_Formal_Declarations (Gen_Decl);
+
+ begin
+ if Present (Formals) then
+ Formal_Node := First_Non_Pragma (Formals);
+ else
+ Formal_Node := Empty;
+ end if;
+
+ -- As for the loop further below, this loop is making
+ -- a probably invalid assumption about the correspondence
+ -- between formals and actuals and eventually needs to
+ -- corrected to account for cases where the formals are
+ -- not synchronized and in one-to-one correspondence
+ -- with actuals. ???
+
+ -- What is certain is that for a legal program the
+ -- presence of actual entities guarantees the existing
+ -- of formal ones.
+
+ while Present (Actual_Ent)
+ and then Present (Formal_Node)
+ and then Actual_Ent /= First_Private_Entity (Act_Ent)
+ loop
+ -- ??? Are the following calls also needed here:
+ --
+ -- Set_Is_Hidden (Actual_Ent, False);
+ -- Set_Is_Potentially_Use_Visible
+ -- (Actual_Ent, In_Use (Act_Ent));
+
+ Formal_Ent := Formal_Entity (Formal_Node, Actual_Ent);
+ if Present (Formal_Ent) then
+ Set_Instance_Of (Formal_Ent, Actual_Ent);
+ end if;
+ Next_Non_Pragma (Formal_Node);
+
+ Next_Entity (Actual_Ent);
+ end loop;
+ end;
+
+ return Defining_Identifier (Orig_Node);
+
+ when N_Use_Package_Clause =>
+ return Empty;
+
+ when N_Use_Type_Clause =>
+ return Empty;
+
+ -- We return Empty for all other encountered forms of
+ -- declarations because there are some cases of nonformal
+ -- sorts of declaration that can show up (e.g., when array
+ -- formals are present). Since it's not clear what kinds
+ -- can appear among the formals, we won't raise failure here.
+
+ when others =>
+ return Empty;
+
+ end case;
+ end Formal_Entity;
+
+ ------------------
+ -- Map_Entities --
+ ------------------
+
+ procedure Map_Entities (Form : Entity_Id; Act : Entity_Id) is
+ E1 : Entity_Id;
+ E2 : Entity_Id;
+
+ begin
+ Set_Instance_Of (Form, Act);
+
+ E1 := First_Entity (Form);
+ E2 := First_Entity (Act);
+ while Present (E1)
+ and then E1 /= First_Private_Entity (Form)
+ loop
+ if not Is_Internal (E1)
+ and then not Is_Class_Wide_Type (E1)
+ then
+
+ while Present (E2)
+ and then Chars (E2) /= Chars (E1)
+ loop
+ Next_Entity (E2);
+ end loop;
+
+ if No (E2) then
+ exit;
+ else
+ Set_Instance_Of (E1, E2);
+
+ if Is_Type (E1)
+ and then Is_Tagged_Type (E2)
+ then
+ Set_Instance_Of
+ (Class_Wide_Type (E1), Class_Wide_Type (E2));
+ end if;
+
+ if Ekind (E1) = E_Package
+ and then No (Renamed_Object (E1))
+ then
+ Map_Entities (E1, E2);
+ end if;
+ end if;
+ end if;
+
+ Next_Entity (E1);
+ end loop;
+ end Map_Entities;
+
+ -- Start of processing for Instantiate_Formal_Package
+
+ begin
+ Analyze (Actual);
+
+ if not Is_Entity_Name (Actual)
+ or else Ekind (Entity (Actual)) /= E_Package
+ then
+ Error_Msg_N
+ ("expect package instance to instantiate formal", Actual);
+ Abandon_Instantiation (Actual);
+ raise Program_Error;
+
+ else
+ Actual_Pack := Entity (Actual);
+ Set_Is_Instantiated (Actual_Pack);
+
+ -- The actual may be a renamed package, or an outer generic
+ -- formal package whose instantiation is converted into a renaming.
+
+ if Present (Renamed_Object (Actual_Pack)) then
+ Actual_Pack := Renamed_Object (Actual_Pack);
+ end if;
+
+ if Nkind (Analyzed_Formal) = N_Formal_Package_Declaration then
+ Gen_Parent := Get_Instance_Of (Entity (Name (Analyzed_Formal)));
+ Formal_Pack := Defining_Identifier (Analyzed_Formal);
+ else
+ Gen_Parent :=
+ Generic_Parent (Specification (Analyzed_Formal));
+ Formal_Pack :=
+ Defining_Unit_Name (Specification (Analyzed_Formal));
+ end if;
+
+ if Nkind (Parent (Actual_Pack)) = N_Defining_Program_Unit_Name then
+ Parent_Spec := Specification (Unit_Declaration_Node (Actual_Pack));
+ else
+ Parent_Spec := Parent (Actual_Pack);
+ end if;
+
+ if Gen_Parent = Any_Id then
+ Error_Msg_N
+ ("previous error in declaration of formal package", Actual);
+ Abandon_Instantiation (Actual);
+
+ elsif
+ Generic_Parent (Parent_Spec) /= Get_Instance_Of (Gen_Parent)
+ then
+ Error_Msg_NE
+ ("actual parameter must be instance of&", Actual, Gen_Parent);
+ Abandon_Instantiation (Actual);
+ end if;
+
+ Set_Instance_Of (Defining_Identifier (Formal), Actual_Pack);
+ Map_Entities (Formal_Pack, Actual_Pack);
+
+ Nod :=
+ Make_Package_Renaming_Declaration (Loc,
+ Defining_Unit_Name => New_Copy (Defining_Identifier (Formal)),
+ Name => New_Reference_To (Actual_Pack, Loc));
+
+ Set_Associated_Formal_Package (Defining_Unit_Name (Nod),
+ Defining_Identifier (Formal));
+ Decls := New_List (Nod);
+
+ -- If the formal F has a box, then the generic declarations are
+ -- visible in the generic G. In an instance of G, the corresponding
+ -- entities in the actual for F (which are the actuals for the
+ -- instantiation of the generic that F denotes) must also be made
+ -- visible for analysis of the current instance. On exit from the
+ -- current instance, those entities are made private again. If the
+ -- actual is currently in use, these entities are also use-visible.
+
+ -- The loop through the actual entities also steps through the
+ -- formal entities and enters associations from formals to
+ -- actuals into the renaming map. This is necessary to properly
+ -- handle checking of actual parameter associations for later
+ -- formals that depend on actuals declared in the formal package.
+ --
+ -- This processing needs to be reviewed at some point because
+ -- it is probably not entirely correct as written. For example
+ -- there may not be a strict one-to-one correspondence between
+ -- actuals and formals and this loop is currently assuming that
+ -- there is. ???
+
+ if Box_Present (Formal) then
+ declare
+ Actual_Ent : Entity_Id := First_Entity (Actual_Pack);
+ Formal_Node : Node_Id := Empty;
+ Formal_Ent : Entity_Id;
+ Gen_Decl : Node_Id := Unit_Declaration_Node (Gen_Parent);
+ Formals : List_Id := Generic_Formal_Declarations (Gen_Decl);
+
+ begin
+ if Present (Formals) then
+ Formal_Node := First_Non_Pragma (Formals);
+ end if;
+
+ while Present (Actual_Ent)
+ and then Actual_Ent /= First_Private_Entity (Actual_Pack)
+ loop
+ Set_Is_Hidden (Actual_Ent, False);
+ Set_Is_Potentially_Use_Visible
+ (Actual_Ent, In_Use (Actual_Pack));
+
+ if Present (Formal_Node) then
+ Formal_Ent := Formal_Entity (Formal_Node, Actual_Ent);
+
+ if Present (Formal_Ent) then
+ Set_Instance_Of (Formal_Ent, Actual_Ent);
+ end if;
+
+ Next_Non_Pragma (Formal_Node);
+ end if;
+
+ Next_Entity (Actual_Ent);
+ end loop;
+ end;
+
+ -- If the formal is not declared with a box, reanalyze it as
+ -- an instantiation, to verify the matching rules of 12.7. The
+ -- actual checks are performed after the generic associations
+ -- been analyzed.
+
+ else
+ declare
+ I_Pack : constant Entity_Id :=
+ Make_Defining_Identifier (Sloc (Actual),
+ Chars => New_Internal_Name ('P'));
+
+ begin
+ Set_Is_Internal (I_Pack);
+
+ Append_To (Decls,
+ Make_Package_Instantiation (Sloc (Actual),
+ Defining_Unit_Name => I_Pack,
+ Name => New_Occurrence_Of (Gen_Parent, Sloc (Actual)),
+ Generic_Associations =>
+ Generic_Associations (Formal)));
+ end;
+ end if;
+
+ return Decls;
+ end if;
+
+ end Instantiate_Formal_Package;
+
+ -----------------------------------
+ -- Instantiate_Formal_Subprogram --
+ -----------------------------------
+
+ function Instantiate_Formal_Subprogram
+ (Formal : Node_Id;
+ Actual : Node_Id;
+ Analyzed_Formal : Node_Id)
+ return Node_Id
+ is
+ Loc : Source_Ptr := Sloc (Instantiation_Node);
+ Formal_Sub : constant Entity_Id :=
+ Defining_Unit_Name (Specification (Formal));
+ Analyzed_S : constant Entity_Id :=
+ Defining_Unit_Name (Specification (Analyzed_Formal));
+ Decl_Node : Node_Id;
+ Nam : Node_Id;
+ New_Spec : Node_Id;
+
+ function From_Parent_Scope (Subp : Entity_Id) return Boolean;
+ -- If the generic is a child unit, the parent has been installed
+ -- on the scope stack, but a default subprogram cannot resolve to
+ -- something on the parent because that parent is not really part
+ -- of the visible context (it is there to resolve explicit local
+ -- entities). If the default has resolved in this way, we remove
+ -- the entity from immediate visibility and analyze the node again
+ -- to emit an error message or find another visible candidate.
+
+ procedure Valid_Actual_Subprogram (Act : Node_Id);
+ -- Perform legality check and raise exception on failure.
+
+ -----------------------
+ -- From_Parent_Scope --
+ -----------------------
+
+ function From_Parent_Scope (Subp : Entity_Id) return Boolean is
+ Gen_Scope : Node_Id := Scope (Analyzed_S);
+
+ begin
+ while Present (Gen_Scope)
+ and then Is_Child_Unit (Gen_Scope)
+ loop
+ if Scope (Subp) = Scope (Gen_Scope) then
+ return True;
+ end if;
+
+ Gen_Scope := Scope (Gen_Scope);
+ end loop;
+
+ return False;
+ end From_Parent_Scope;
+
+ -----------------------------
+ -- Valid_Actual_Subprogram --
+ -----------------------------
+
+ procedure Valid_Actual_Subprogram (Act : Node_Id) is
+ begin
+ if not Is_Entity_Name (Act)
+ and then Nkind (Act) /= N_Operator_Symbol
+ and then Nkind (Act) /= N_Attribute_Reference
+ and then Nkind (Act) /= N_Selected_Component
+ and then Nkind (Act) /= N_Indexed_Component
+ and then Nkind (Act) /= N_Character_Literal
+ and then Nkind (Act) /= N_Explicit_Dereference
+ then
+ if Etype (Act) /= Any_Type then
+ Error_Msg_NE
+ ("Expect subprogram name to instantiate &",
+ Instantiation_Node, Formal_Sub);
+ end if;
+
+ -- In any case, instantiation cannot continue.
+
+ Abandon_Instantiation (Instantiation_Node);
+ end if;
+ end Valid_Actual_Subprogram;
+
+ -- Start of processing for Instantiate_Formal_Subprogram
+
+ begin
+ New_Spec := New_Copy_Tree (Specification (Formal));
+
+ -- Create new entity for the actual (New_Copy_Tree does not).
+
+ Set_Defining_Unit_Name
+ (New_Spec, Make_Defining_Identifier (Loc, Chars (Formal_Sub)));
+
+ -- Find entity of actual. If the actual is an attribute reference, it
+ -- cannot be resolved here (its formal is missing) but is handled
+ -- instead in Attribute_Renaming. If the actual is overloaded, it is
+ -- fully resolved subsequently, when the renaming declaration for the
+ -- formal is analyzed. If it is an explicit dereference, resolve the
+ -- prefix but not the actual itself, to prevent interpretation as a
+ -- call.
+
+ if Present (Actual) then
+ Loc := Sloc (Actual);
+ Set_Sloc (New_Spec, Loc);
+
+ if Nkind (Actual) = N_Operator_Symbol then
+ Find_Direct_Name (Actual);
+
+ elsif Nkind (Actual) = N_Explicit_Dereference then
+ Analyze (Prefix (Actual));
+
+ elsif Nkind (Actual) /= N_Attribute_Reference then
+ Analyze (Actual);
+ end if;
+
+ Valid_Actual_Subprogram (Actual);
+ Nam := Actual;
+
+ elsif Present (Default_Name (Formal)) then
+
+ if Nkind (Default_Name (Formal)) /= N_Attribute_Reference
+ and then Nkind (Default_Name (Formal)) /= N_Selected_Component
+ and then Nkind (Default_Name (Formal)) /= N_Indexed_Component
+ and then Nkind (Default_Name (Formal)) /= N_Character_Literal
+ and then Present (Entity (Default_Name (Formal)))
+ then
+ Nam := New_Occurrence_Of (Entity (Default_Name (Formal)), Loc);
+ else
+ Nam := New_Copy (Default_Name (Formal));
+ Set_Sloc (Nam, Loc);
+ end if;
+
+ elsif Box_Present (Formal) then
+
+ -- Actual is resolved at the point of instantiation. Create
+ -- an identifier or operator with the same name as the formal.
+
+ if Nkind (Formal_Sub) = N_Defining_Operator_Symbol then
+ Nam := Make_Operator_Symbol (Loc,
+ Chars => Chars (Formal_Sub),
+ Strval => No_String);
+ else
+ Nam := Make_Identifier (Loc, Chars (Formal_Sub));
+ end if;
+
+ else
+ Error_Msg_NE
+ ("missing actual for instantiation of &",
+ Instantiation_Node, Formal_Sub);
+ Abandon_Instantiation (Instantiation_Node);
+ end if;
+
+ Decl_Node :=
+ Make_Subprogram_Renaming_Declaration (Loc,
+ Specification => New_Spec,
+ Name => Nam);
+
+ -- Gather possible interpretations for the actual before analyzing the
+ -- instance. If overloaded, it will be resolved when analyzing the
+ -- renaming declaration.
+
+ if Box_Present (Formal)
+ and then No (Actual)
+ then
+ Analyze (Nam);
+
+ if Is_Child_Unit (Scope (Analyzed_S))
+ and then Present (Entity (Nam))
+ then
+ if not Is_Overloaded (Nam) then
+
+ if From_Parent_Scope (Entity (Nam)) then
+ Set_Is_Immediately_Visible (Entity (Nam), False);
+ Set_Entity (Nam, Empty);
+ Set_Etype (Nam, Empty);
+
+ Analyze (Nam);
+
+ Set_Is_Immediately_Visible (Entity (Nam));
+ end if;
+
+ else
+ declare
+ I : Interp_Index;
+ It : Interp;
+
+ begin
+ Get_First_Interp (Nam, I, It);
+
+ while Present (It.Nam) loop
+ if From_Parent_Scope (It.Nam) then
+ Remove_Interp (I);
+ end if;
+
+ Get_Next_Interp (I, It);
+ end loop;
+ end;
+ end if;
+ end if;
+ end if;
+
+ -- The generic instantiation freezes the actual. This can only be
+ -- done once the actual is resolved, in the analysis of the renaming
+ -- declaration. To indicate that must be done, we set the corresponding
+ -- spec of the node to point to the formal subprogram declaration.
+
+ Set_Corresponding_Spec (Decl_Node, Analyzed_Formal);
+
+ -- We cannot analyze the renaming declaration, and thus find the
+ -- actual, until the all the actuals are assembled in the instance.
+ -- For subsequent checks of other actuals, indicate the node that
+ -- will hold the instance of this formal.
+
+ Set_Instance_Of (Analyzed_S, Nam);
+
+ if Nkind (Actual) = N_Selected_Component
+ and then Is_Task_Type (Etype (Prefix (Actual)))
+ and then not Is_Frozen (Etype (Prefix (Actual)))
+ then
+ -- The renaming declaration will create a body, which must appear
+ -- outside of the instantiation, We move the renaming declaration
+ -- out of the instance, and create an additional renaming inside,
+ -- to prevent freezing anomalies.
+
+ declare
+ Anon_Id : constant Entity_Id :=
+ Make_Defining_Identifier
+ (Loc, New_Internal_Name ('E'));
+ begin
+ Set_Defining_Unit_Name (New_Spec, Anon_Id);
+ Insert_Before (Instantiation_Node, Decl_Node);
+ Analyze (Decl_Node);
+
+ -- Now create renaming within the instance.
+
+ Decl_Node :=
+ Make_Subprogram_Renaming_Declaration (Loc,
+ Specification => New_Copy_Tree (New_Spec),
+ Name => New_Occurrence_Of (Anon_Id, Loc));
+
+ Set_Defining_Unit_Name (Specification (Decl_Node),
+ Make_Defining_Identifier (Loc, Chars (Formal_Sub)));
+ end;
+ end if;
+
+ return Decl_Node;
+ end Instantiate_Formal_Subprogram;
+
+ ------------------------
+ -- Instantiate_Object --
+ ------------------------
+
+ function Instantiate_Object
+ (Formal : Node_Id;
+ Actual : Node_Id;
+ Analyzed_Formal : Node_Id)
+ return List_Id
+ is
+ Formal_Id : constant Entity_Id := Defining_Identifier (Formal);
+ Type_Id : constant Node_Id := Subtype_Mark (Formal);
+ Loc : constant Source_Ptr := Sloc (Actual);
+ Act_Assoc : constant Node_Id := Parent (Actual);
+ Orig_Ftyp : constant Entity_Id :=
+ Etype (Defining_Identifier (Analyzed_Formal));
+ Ftyp : Entity_Id;
+ Decl_Node : Node_Id;
+ Subt_Decl : Node_Id := Empty;
+ List : List_Id := New_List;
+
+ begin
+ if Get_Instance_Of (Formal_Id) /= Formal_Id then
+ Error_Msg_N ("duplicate instantiation of generic parameter", Actual);
+ end if;
+
+ Set_Parent (List, Parent (Actual));
+
+ -- OUT present
+
+ if Out_Present (Formal) then
+
+ -- An IN OUT generic actual must be a name. The instantiation is
+ -- a renaming declaration. The actual is the name being renamed.
+ -- We use the actual directly, rather than a copy, because it is not
+ -- used further in the list of actuals, and because a copy or a use
+ -- of relocate_node is incorrect if the instance is nested within
+ -- a generic. In order to simplify ASIS searches, the Generic_Parent
+ -- field links the declaration to the generic association.
+
+ if No (Actual) then
+ Error_Msg_NE
+ ("missing actual for instantiation of &",
+ Instantiation_Node, Formal_Id);
+ Abandon_Instantiation (Instantiation_Node);
+ end if;
+
+ Decl_Node :=
+ Make_Object_Renaming_Declaration (Loc,
+ Defining_Identifier => New_Copy (Formal_Id),
+ Subtype_Mark => New_Copy_Tree (Type_Id),
+ Name => Actual);
+
+ Set_Corresponding_Generic_Association (Decl_Node, Act_Assoc);
+
+ -- The analysis of the actual may produce insert_action nodes, so
+ -- the declaration must have a context in which to attach them.
+
+ Append (Decl_Node, List);
+ Analyze (Actual);
+
+ -- This check is performed here because Analyze_Object_Renaming
+ -- will not check it when Comes_From_Source is False. Note
+ -- though that the check for the actual being the name of an
+ -- object will be performed in Analyze_Object_Renaming.
+
+ if Is_Object_Reference (Actual)
+ and then Is_Dependent_Component_Of_Mutable_Object (Actual)
+ then
+ Error_Msg_N
+ ("illegal discriminant-dependent component for in out parameter",
+ Actual);
+ end if;
+
+ -- The actual has to be resolved in order to check that it is
+ -- a variable (due to cases such as F(1), where F returns
+ -- access to an array, and for overloaded prefixes).
+
+ Ftyp :=
+ Get_Instance_Of (Etype (Defining_Identifier (Analyzed_Formal)));
+
+ if Is_Private_Type (Ftyp)
+ and then not Is_Private_Type (Etype (Actual))
+ and then (Base_Type (Full_View (Ftyp)) = Base_Type (Etype (Actual))
+ or else Base_Type (Etype (Actual)) = Ftyp)
+ then
+ -- If the actual has the type of the full view of the formal,
+ -- or else a non-private subtype of the formal, then
+ -- the visibility of the formal type has changed. Add to the
+ -- actuals a subtype declaration that will force the exchange
+ -- of views in the body of the instance as well.
+
+ Subt_Decl :=
+ Make_Subtype_Declaration (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc, New_Internal_Name ('P')),
+ Subtype_Indication => New_Occurrence_Of (Ftyp, Loc));
+
+ Prepend (Subt_Decl, List);
+
+ Append_Elmt (Full_View (Ftyp), Exchanged_Views);
+ Exchange_Declarations (Ftyp);
+ end if;
+
+ Resolve (Actual, Ftyp);
+
+ if not Is_Variable (Actual) or else Paren_Count (Actual) > 0 then
+ Error_Msg_NE
+ ("actual for& must be a variable", Actual, Formal_Id);
+
+ elsif Base_Type (Ftyp) /= Base_Type (Etype (Actual)) then
+ Error_Msg_NE (
+ "type of actual does not match type of&", Actual, Formal_Id);
+
+ end if;
+
+ Note_Possible_Modification (Actual);
+
+ -- Check for instantiation of atomic/volatile actual for
+ -- non-atomic/volatile formal (RM C.6 (12)).
+
+ if Is_Atomic_Object (Actual)
+ and then not Is_Atomic (Orig_Ftyp)
+ then
+ Error_Msg_N
+ ("cannot instantiate non-atomic formal object " &
+ "with atomic actual", Actual);
+
+ elsif Is_Volatile_Object (Actual)
+ and then not Is_Volatile (Orig_Ftyp)
+ then
+ Error_Msg_N
+ ("cannot instantiate non-volatile formal object " &
+ "with volatile actual", Actual);
+ end if;
+
+ -- OUT not present
+
+ else
+ -- The instantiation of a generic formal in-parameter
+ -- is a constant declaration. The actual is the expression for
+ -- that declaration.
+
+ if Present (Actual) then
+
+ Decl_Node := Make_Object_Declaration (Loc,
+ Defining_Identifier => New_Copy (Formal_Id),
+ Constant_Present => True,
+ Object_Definition => New_Copy_Tree (Type_Id),
+ Expression => Actual);
+
+ Set_Corresponding_Generic_Association (Decl_Node, Act_Assoc);
+
+ -- A generic formal object of a tagged type is defined
+ -- to be aliased so the new constant must also be treated
+ -- as aliased.
+
+ if Is_Tagged_Type
+ (Etype (Defining_Identifier (Analyzed_Formal)))
+ then
+ Set_Aliased_Present (Decl_Node);
+ end if;
+
+ Append (Decl_Node, List);
+ Analyze (Actual);
+
+ declare
+ Typ : Entity_Id
+ := Get_Instance_Of
+ (Etype (Defining_Identifier (Analyzed_Formal)));
+ begin
+ Freeze_Before (Instantiation_Node, Typ);
+
+ -- If the actual is an aggregate, perform name resolution
+ -- on its components (the analysis of an aggregate does not
+ -- do it) to capture local names that may be hidden if the
+ -- generic is a child unit.
+
+ if Nkind (Actual) = N_Aggregate then
+ Pre_Analyze_And_Resolve (Actual, Typ);
+ end if;
+ end;
+
+ elsif Present (Expression (Formal)) then
+
+ -- Use default to construct declaration.
+
+ Decl_Node :=
+ Make_Object_Declaration (Sloc (Formal),
+ Defining_Identifier => New_Copy (Formal_Id),
+ Constant_Present => True,
+ Object_Definition => New_Copy (Type_Id),
+ Expression => New_Copy_Tree (Expression (Formal)));
+
+ Append (Decl_Node, List);
+ Set_Analyzed (Expression (Decl_Node), False);
+
+ else
+ Error_Msg_NE
+ ("missing actual for instantiation of &",
+ Instantiation_Node, Formal_Id);
+ Abandon_Instantiation (Instantiation_Node);
+ end if;
+
+ end if;
+
+ return List;
+ end Instantiate_Object;
+
+ ------------------------------
+ -- Instantiate_Package_Body --
+ ------------------------------
+
+ procedure Instantiate_Package_Body
+ (Body_Info : Pending_Body_Info)
+ is
+ Act_Decl : constant Node_Id := Body_Info.Act_Decl;
+ Inst_Node : constant Node_Id := Body_Info.Inst_Node;
+ Loc : constant Source_Ptr := Sloc (Inst_Node);
+
+ Gen_Id : constant Node_Id := Name (Inst_Node);
+ Gen_Unit : constant Entity_Id := Entity (Name (Inst_Node));
+ Gen_Decl : constant Node_Id := Unit_Declaration_Node (Gen_Unit);
+ Act_Spec : constant Node_Id := Specification (Act_Decl);
+ Act_Decl_Id : constant Entity_Id := Defining_Entity (Act_Spec);
+
+ Act_Body_Name : Node_Id;
+ Gen_Body : Node_Id;
+ Gen_Body_Id : Node_Id;
+ Act_Body : Node_Id;
+ Act_Body_Id : Entity_Id;
+
+ Parent_Installed : Boolean := False;
+ Save_Style_Check : Boolean := Style_Check;
+
+ begin
+ Gen_Body_Id := Corresponding_Body (Gen_Decl);
+ Expander_Mode_Save_And_Set (Body_Info.Expander_Status);
+
+ if No (Gen_Body_Id) then
+ Load_Parent_Of_Generic (Inst_Node, Specification (Gen_Decl));
+ Gen_Body_Id := Corresponding_Body (Gen_Decl);
+ end if;
+
+ -- Establish global variable for sloc adjustment and for error
+ -- recovery.
+
+ Instantiation_Node := Inst_Node;
+
+ if Present (Gen_Body_Id) then
+ Save_Env (Gen_Unit, Act_Decl_Id);
+ Style_Check := False;
+ Current_Sem_Unit := Body_Info.Current_Sem_Unit;
+
+ Gen_Body := Unit_Declaration_Node (Gen_Body_Id);
+
+ Create_Instantiation_Source
+ (Inst_Node, Gen_Body_Id, S_Adjustment);
+
+ Act_Body :=
+ Copy_Generic_Node
+ (Original_Node (Gen_Body), Empty, Instantiating => True);
+
+ -- Build new name (possibly qualified) for body declaration.
+
+ Act_Body_Id := New_Copy (Act_Decl_Id);
+
+ -- Some attributes of the spec entity are not inherited by the
+ -- body entity.
+
+ Set_Handler_Records (Act_Body_Id, No_List);
+
+ if Nkind (Defining_Unit_Name (Act_Spec)) =
+ N_Defining_Program_Unit_Name
+ then
+ Act_Body_Name :=
+ Make_Defining_Program_Unit_Name (Loc,
+ Name => New_Copy_Tree (Name (Defining_Unit_Name (Act_Spec))),
+ Defining_Identifier => Act_Body_Id);
+ else
+ Act_Body_Name := Act_Body_Id;
+ end if;
+
+ Set_Defining_Unit_Name (Act_Body, Act_Body_Name);
+
+ Set_Corresponding_Spec (Act_Body, Act_Decl_Id);
+ Check_Generic_Actuals (Act_Decl_Id, False);
+
+ -- If it is a child unit, make the parent instance (which is an
+ -- instance of the parent of the generic) visible. The parent
+ -- instance is the prefix of the name of the generic unit.
+
+ if Ekind (Scope (Gen_Unit)) = E_Generic_Package
+ and then Nkind (Gen_Id) = N_Expanded_Name
+ then
+ Install_Parent (Entity (Prefix (Gen_Id)), In_Body => True);
+ Parent_Installed := True;
+
+ elsif Is_Child_Unit (Gen_Unit) then
+ Install_Parent (Scope (Gen_Unit), In_Body => True);
+ Parent_Installed := True;
+ end if;
+
+ -- If the instantiation is a library unit, and this is the main
+ -- unit, then build the resulting compilation unit nodes for the
+ -- instance. If this is a compilation unit but it is not the main
+ -- unit, then it is the body of a unit in the context, that is being
+ -- compiled because it is encloses some inlined unit or another
+ -- generic unit being instantiated. In that case, this body is not
+ -- part of the current compilation, and is not attached to the tree,
+ -- but its parent must be set for analysis.
+
+ if Nkind (Parent (Inst_Node)) = N_Compilation_Unit then
+
+ if Parent (Inst_Node) = Cunit (Main_Unit) then
+ Build_Instance_Compilation_Unit_Nodes
+ (Inst_Node, Act_Body, Act_Decl);
+ Analyze (Inst_Node);
+
+ -- If the instance is a child unit itself, then set the
+ -- scope of the expanded body to be the parent of the
+ -- instantiation (ensuring that the fully qualified name
+ -- will be generated for the elaboration subprogram).
+
+ if Nkind (Defining_Unit_Name (Act_Spec)) =
+ N_Defining_Program_Unit_Name
+ then
+ Set_Scope
+ (Defining_Entity (Inst_Node), Scope (Act_Decl_Id));
+ end if;
+
+ else
+ Set_Parent (Act_Body, Parent (Inst_Node));
+ Analyze (Act_Body);
+ end if;
+
+ -- Case where instantiation is not a library unit
+
+ else
+ -- If this is an early instantiation, i.e. appears textually
+ -- before the corresponding body and must be elaborated first,
+ -- indicate that the body instance is to be delayed.
+
+ Install_Body (Act_Body, Inst_Node, Gen_Body, Gen_Decl);
+
+ -- Now analyze the body. We turn off all checks if this is
+ -- an internal unit, since there is no reason to have checks
+ -- on for any predefined run-time library code. All such
+ -- code is designed to be compiled with checks off.
+
+ -- Note that we do NOT apply this criterion to children of
+ -- GNAT (or on VMS, children of DEC). The latter units must
+ -- suppress checks explicitly if this is needed.
+
+ if Is_Predefined_File_Name
+ (Unit_File_Name (Get_Source_Unit (Gen_Decl)))
+ then
+ Analyze (Act_Body, Suppress => All_Checks);
+ else
+ Analyze (Act_Body);
+ end if;
+ end if;
+
+ if not Generic_Separately_Compiled (Gen_Unit) then
+ Inherit_Context (Gen_Body, Inst_Node);
+ end if;
+
+ Restore_Private_Views (Act_Decl_Id);
+ Restore_Env;
+ Style_Check := Save_Style_Check;
+
+ -- If we have no body, and the unit requires a body, then complain.
+ -- This complaint is suppressed if we have detected other errors
+ -- (since a common reason for missing the body is that it had errors).
+
+ elsif Unit_Requires_Body (Gen_Unit) then
+ if Errors_Detected = 0 then
+ Error_Msg_NE
+ ("cannot find body of generic package &", Inst_Node, Gen_Unit);
+
+ -- Don't attempt to perform any cleanup actions if some other
+ -- error was aready detected, since this can cause blowups.
+
+ else
+ return;
+ end if;
+
+ -- Case of package that does not need a body
+
+ else
+ -- If the instantiation of the declaration is a library unit,
+ -- rewrite the original package instantiation as a package
+ -- declaration in the compilation unit node.
+
+ if Nkind (Parent (Inst_Node)) = N_Compilation_Unit then
+ Set_Parent_Spec (Act_Decl, Parent_Spec (Inst_Node));
+ Rewrite (Inst_Node, Act_Decl);
+
+ -- If the instantiation is not a library unit, then append the
+ -- declaration to the list of implicitly generated entities.
+ -- unless it is already a list member which means that it was
+ -- already processed
+
+ elsif not Is_List_Member (Act_Decl) then
+ Mark_Rewrite_Insertion (Act_Decl);
+ Insert_Before (Inst_Node, Act_Decl);
+ end if;
+ end if;
+
+ Expander_Mode_Restore;
+
+ -- Remove the parent instances if they have been placed on the
+ -- scope stack to compile the body.
+
+ if Parent_Installed then
+ Remove_Parent (In_Body => True);
+ end if;
+ end Instantiate_Package_Body;
+
+ ---------------------------------
+ -- Instantiate_Subprogram_Body --
+ ---------------------------------
+
+ procedure Instantiate_Subprogram_Body
+ (Body_Info : Pending_Body_Info)
+ is
+ Act_Decl : constant Node_Id := Body_Info.Act_Decl;
+ Inst_Node : constant Node_Id := Body_Info.Inst_Node;
+ Loc : constant Source_Ptr := Sloc (Inst_Node);
+
+ Decls : List_Id;
+ Gen_Id : constant Node_Id := Name (Inst_Node);
+ Gen_Unit : constant Entity_Id := Entity (Name (Inst_Node));
+ Gen_Decl : constant Node_Id := Unit_Declaration_Node (Gen_Unit);
+ Anon_Id : constant Entity_Id :=
+ Defining_Unit_Name (Specification (Act_Decl));
+ Gen_Body : Node_Id;
+ Gen_Body_Id : Node_Id;
+ Act_Body : Node_Id;
+ Act_Body_Id : Entity_Id;
+ Pack_Id : Entity_Id := Defining_Unit_Name (Parent (Act_Decl));
+ Pack_Body : Node_Id;
+ Prev_Formal : Entity_Id;
+ Unit_Renaming : Node_Id;
+
+ Parent_Installed : Boolean := False;
+ Save_Style_Check : Boolean := Style_Check;
+
+ begin
+ Gen_Body_Id := Corresponding_Body (Gen_Decl);
+
+ Expander_Mode_Save_And_Set (Body_Info.Expander_Status);
+
+ if No (Gen_Body_Id) then
+ Load_Parent_Of_Generic (Inst_Node, Specification (Gen_Decl));
+ Gen_Body_Id := Corresponding_Body (Gen_Decl);
+ end if;
+
+ Instantiation_Node := Inst_Node;
+
+ if Present (Gen_Body_Id) then
+ Gen_Body := Unit_Declaration_Node (Gen_Body_Id);
+
+ if Nkind (Gen_Body) = N_Subprogram_Body_Stub then
+
+ -- Either body is not present, or context is non-expanding, as
+ -- when compiling a subunit. Mark the instance as completed.
+
+ Set_Has_Completion (Anon_Id);
+ return;
+ end if;
+
+ Save_Env (Gen_Unit, Anon_Id);
+ Style_Check := False;
+ Current_Sem_Unit := Body_Info.Current_Sem_Unit;
+ Create_Instantiation_Source (Inst_Node, Gen_Body_Id, S_Adjustment);
+
+ Act_Body :=
+ Copy_Generic_Node
+ (Original_Node (Gen_Body), Empty, Instantiating => True);
+ Act_Body_Id := Defining_Entity (Act_Body);
+ Set_Chars (Act_Body_Id, Chars (Anon_Id));
+ Set_Sloc (Act_Body_Id, Sloc (Defining_Entity (Inst_Node)));
+ Set_Corresponding_Spec (Act_Body, Anon_Id);
+ Set_Has_Completion (Anon_Id);
+ Check_Generic_Actuals (Pack_Id, False);
+
+ -- If it is a child unit, make the parent instance (which is an
+ -- instance of the parent of the generic) visible. The parent
+ -- instance is the prefix of the name of the generic unit.
+
+ if Ekind (Scope (Gen_Unit)) = E_Generic_Package
+ and then Nkind (Gen_Id) = N_Expanded_Name
+ then
+ Install_Parent (Entity (Prefix (Gen_Id)), In_Body => True);
+ Parent_Installed := True;
+
+ elsif Is_Child_Unit (Gen_Unit) then
+ Install_Parent (Scope (Gen_Unit), In_Body => True);
+ Parent_Installed := True;
+ end if;
+
+ -- Inside its body, a reference to the generic unit is a reference
+ -- to the instance. The corresponding renaming is the first
+ -- declaration in the body.
+
+ Unit_Renaming :=
+ Make_Subprogram_Renaming_Declaration (Loc,
+ Specification =>
+ Copy_Generic_Node (
+ Specification (Original_Node (Gen_Body)),
+ Empty,
+ Instantiating => True),
+ Name => New_Occurrence_Of (Anon_Id, Loc));
+
+ -- If there is a formal subprogram with the same name as the
+ -- unit itself, do not add this renaming declaration. This is
+ -- a temporary fix for one ACVC test. ???
+
+ Prev_Formal := First_Entity (Pack_Id);
+ while Present (Prev_Formal) loop
+ if Chars (Prev_Formal) = Chars (Gen_Unit)
+ and then Is_Overloadable (Prev_Formal)
+ then
+ exit;
+ end if;
+
+ Next_Entity (Prev_Formal);
+ end loop;
+
+ if Present (Prev_Formal) then
+ Decls := New_List (Act_Body);
+ else
+ Decls := New_List (Unit_Renaming, Act_Body);
+ end if;
+
+ -- The subprogram body is placed in the body of a dummy package
+ -- body, whose spec contains the subprogram declaration as well
+ -- as the renaming declarations for the generic parameters.
+
+ Pack_Body := Make_Package_Body (Loc,
+ Defining_Unit_Name => New_Copy (Pack_Id),
+ Declarations => Decls);
+
+ Set_Corresponding_Spec (Pack_Body, Pack_Id);
+
+ -- If the instantiation is a library unit, then build resulting
+ -- compilation unit nodes for the instance. The declaration of
+ -- the enclosing package is the grandparent of the subprogram
+ -- declaration. First replace the instantiation node as the unit
+ -- of the corresponding compilation.
+
+ if Nkind (Parent (Inst_Node)) = N_Compilation_Unit then
+
+ if Parent (Inst_Node) = Cunit (Main_Unit) then
+ Set_Unit (Parent (Inst_Node), Inst_Node);
+ Build_Instance_Compilation_Unit_Nodes
+ (Inst_Node, Pack_Body, Parent (Parent (Act_Decl)));
+ Analyze (Inst_Node);
+ else
+ Set_Parent (Pack_Body, Parent (Inst_Node));
+ Analyze (Pack_Body);
+ end if;
+
+ else
+ Insert_Before (Inst_Node, Pack_Body);
+ Mark_Rewrite_Insertion (Pack_Body);
+ Analyze (Pack_Body);
+
+ if Expander_Active then
+ Freeze_Subprogram_Body (Inst_Node, Gen_Body, Pack_Id);
+ end if;
+ end if;
+
+ if not Generic_Separately_Compiled (Gen_Unit) then
+ Inherit_Context (Gen_Body, Inst_Node);
+ end if;
+
+ Restore_Private_Views (Pack_Id, False);
+
+ if Parent_Installed then
+ Remove_Parent (In_Body => True);
+ end if;
+
+ Restore_Env;
+ Style_Check := Save_Style_Check;
+
+ -- Body not found. Error was emitted already. If there were no
+ -- previous errors, this may be an instance whose scope is a premature
+ -- instance. In that case we must insure that the (legal) program does
+ -- raise program error if executed. We generate a subprogram body for
+ -- this purpose. See DEC ac30vso.
+
+ elsif Errors_Detected = 0
+ and then Nkind (Parent (Inst_Node)) /= N_Compilation_Unit
+ then
+ if Ekind (Anon_Id) = E_Procedure then
+ Act_Body :=
+ Make_Subprogram_Body (Loc,
+ Specification =>
+ Make_Procedure_Specification (Loc,
+ Defining_Unit_Name => New_Copy (Anon_Id),
+ Parameter_Specifications =>
+ New_Copy_List
+ (Parameter_Specifications (Parent (Anon_Id)))),
+
+ Declarations => Empty_List,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements =>
+ New_List (Make_Raise_Program_Error (Loc))));
+ else
+ Act_Body :=
+ Make_Subprogram_Body (Loc,
+ Specification =>
+ Make_Function_Specification (Loc,
+ Defining_Unit_Name => New_Copy (Anon_Id),
+ Parameter_Specifications =>
+ New_Copy_List
+ (Parameter_Specifications (Parent (Anon_Id))),
+ Subtype_Mark =>
+ New_Occurrence_Of (Etype (Anon_Id), Loc)),
+
+ Declarations => Empty_List,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => New_List (
+ Make_Return_Statement (Loc,
+ Expression => Make_Raise_Program_Error (Loc)))));
+ end if;
+
+ Pack_Body := Make_Package_Body (Loc,
+ Defining_Unit_Name => New_Copy (Pack_Id),
+ Declarations => New_List (Act_Body));
+
+ Insert_After (Inst_Node, Pack_Body);
+ Set_Corresponding_Spec (Pack_Body, Pack_Id);
+ Analyze (Pack_Body);
+ end if;
+
+ Expander_Mode_Restore;
+ end Instantiate_Subprogram_Body;
+
+ ----------------------
+ -- Instantiate_Type --
+ ----------------------
+
+ function Instantiate_Type
+ (Formal : Node_Id;
+ Actual : Node_Id;
+ Analyzed_Formal : Node_Id)
+ return Node_Id
+ is
+ Loc : constant Source_Ptr := Sloc (Actual);
+ Gen_T : constant Entity_Id := Defining_Identifier (Formal);
+ A_Gen_T : constant Entity_Id := Defining_Identifier (Analyzed_Formal);
+ Ancestor : Entity_Id;
+ Def : constant Node_Id := Formal_Type_Definition (Formal);
+ Act_T : Entity_Id;
+ Decl_Node : Node_Id;
+
+ procedure Validate_Array_Type_Instance;
+ procedure Validate_Access_Subprogram_Instance;
+ procedure Validate_Access_Type_Instance;
+ procedure Validate_Derived_Type_Instance;
+ procedure Validate_Private_Type_Instance;
+ -- These procedures perform validation tests for the named case
+
+ function Subtypes_Match (Gen_T, Act_T : Entity_Id) return Boolean;
+ -- Check that base types are the same and that the subtypes match
+ -- statically. Used in several of the above.
+
+ --------------------
+ -- Subtypes_Match --
+ --------------------
+
+ function Subtypes_Match (Gen_T, Act_T : Entity_Id) return Boolean is
+ T : constant Entity_Id := Get_Instance_Of (Gen_T);
+
+ begin
+ return (Base_Type (T) = Base_Type (Act_T)
+-- why is the and then commented out here???
+-- and then Is_Constrained (T) = Is_Constrained (Act_T)
+ and then Subtypes_Statically_Match (T, Act_T))
+
+ or else (Is_Class_Wide_Type (Gen_T)
+ and then Is_Class_Wide_Type (Act_T)
+ and then
+ Subtypes_Match (
+ Get_Instance_Of (Root_Type (Gen_T)),
+ Root_Type (Act_T)));
+ end Subtypes_Match;
+
+ -----------------------------------------
+ -- Validate_Access_Subprogram_Instance --
+ -----------------------------------------
+
+ procedure Validate_Access_Subprogram_Instance is
+ begin
+ if not Is_Access_Type (Act_T)
+ or else Ekind (Designated_Type (Act_T)) /= E_Subprogram_Type
+ then
+ Error_Msg_NE
+ ("expect access type in instantiation of &", Actual, Gen_T);
+ Abandon_Instantiation (Actual);
+ end if;
+
+ Check_Mode_Conformant
+ (Designated_Type (Act_T),
+ Designated_Type (A_Gen_T),
+ Actual,
+ Get_Inst => True);
+
+ if Ekind (Base_Type (Act_T)) = E_Access_Protected_Subprogram_Type then
+ if Ekind (A_Gen_T) = E_Access_Subprogram_Type then
+ Error_Msg_NE
+ ("protected access type not allowed for formal &",
+ Actual, Gen_T);
+ end if;
+
+ elsif Ekind (A_Gen_T) = E_Access_Protected_Subprogram_Type then
+ Error_Msg_NE
+ ("expect protected access type for formal &",
+ Actual, Gen_T);
+ end if;
+ end Validate_Access_Subprogram_Instance;
+
+ -----------------------------------
+ -- Validate_Access_Type_Instance --
+ -----------------------------------
+
+ procedure Validate_Access_Type_Instance is
+ Desig_Type : Entity_Id :=
+ Find_Actual_Type (Designated_Type (A_Gen_T), Scope (A_Gen_T));
+
+ begin
+ if not Is_Access_Type (Act_T) then
+ Error_Msg_NE
+ ("expect access type in instantiation of &", Actual, Gen_T);
+ Abandon_Instantiation (Actual);
+ end if;
+
+ if Is_Access_Constant (A_Gen_T) then
+ if not Is_Access_Constant (Act_T) then
+ Error_Msg_N
+ ("actual type must be access-to-constant type", Actual);
+ Abandon_Instantiation (Actual);
+ end if;
+ else
+ if Is_Access_Constant (Act_T) then
+ Error_Msg_N
+ ("actual type must be access-to-variable type", Actual);
+ Abandon_Instantiation (Actual);
+
+ elsif Ekind (A_Gen_T) = E_General_Access_Type
+ and then Ekind (Base_Type (Act_T)) /= E_General_Access_Type
+ then
+ Error_Msg_N ("actual must be general access type!", Actual);
+ Error_Msg_NE ("add ALL to }!", Actual, Act_T);
+ Abandon_Instantiation (Actual);
+ end if;
+ end if;
+
+ -- The designated subtypes, that is to say the subtypes introduced
+ -- by an access type declaration (and not by a subtype declaration)
+ -- must match.
+
+ if not Subtypes_Match
+ (Desig_Type, Designated_Type (Base_Type (Act_T)))
+ then
+ Error_Msg_NE
+ ("designated type of actual does not match that of formal &",
+ Actual, Gen_T);
+ Abandon_Instantiation (Actual);
+
+ elsif Is_Access_Type (Designated_Type (Act_T))
+ and then Is_Constrained (Designated_Type (Designated_Type (Act_T)))
+ /=
+ Is_Constrained (Designated_Type (Desig_Type))
+ then
+ Error_Msg_NE
+ ("designated type of actual does not match that of formal &",
+ Actual, Gen_T);
+ Abandon_Instantiation (Actual);
+ end if;
+ end Validate_Access_Type_Instance;
+
+ ----------------------------------
+ -- Validate_Array_Type_Instance --
+ ----------------------------------
+
+ procedure Validate_Array_Type_Instance is
+ I1 : Node_Id;
+ I2 : Node_Id;
+ T2 : Entity_Id;
+
+ function Formal_Dimensions return Int;
+ -- Count number of dimensions in array type formal
+
+ function Formal_Dimensions return Int is
+ Num : Int := 0;
+ Index : Node_Id;
+
+ begin
+ if Nkind (Def) = N_Constrained_Array_Definition then
+ Index := First (Discrete_Subtype_Definitions (Def));
+ else
+ Index := First (Subtype_Marks (Def));
+ end if;
+
+ while Present (Index) loop
+ Num := Num + 1;
+ Next_Index (Index);
+ end loop;
+
+ return Num;
+ end Formal_Dimensions;
+
+ -- Start of processing for Validate_Array_Type_Instance
+
+ begin
+ if not Is_Array_Type (Act_T) then
+ Error_Msg_NE
+ ("expect array type in instantiation of &", Actual, Gen_T);
+ Abandon_Instantiation (Actual);
+
+ elsif Nkind (Def) = N_Constrained_Array_Definition then
+ if not (Is_Constrained (Act_T)) then
+ Error_Msg_NE
+ ("expect constrained array in instantiation of &",
+ Actual, Gen_T);
+ Abandon_Instantiation (Actual);
+ end if;
+
+ else
+ if Is_Constrained (Act_T) then
+ Error_Msg_NE
+ ("expect unconstrained array in instantiation of &",
+ Actual, Gen_T);
+ Abandon_Instantiation (Actual);
+ end if;
+ end if;
+
+ if Formal_Dimensions /= Number_Dimensions (Act_T) then
+ Error_Msg_NE
+ ("dimensions of actual do not match formal &", Actual, Gen_T);
+ Abandon_Instantiation (Actual);
+ end if;
+
+ I1 := First_Index (A_Gen_T);
+ I2 := First_Index (Act_T);
+ for J in 1 .. Formal_Dimensions loop
+
+ -- If the indices of the actual were given by a subtype_mark,
+ -- the index was transformed into a range attribute. Retrieve
+ -- the original type mark for checking.
+
+ if Is_Entity_Name (Original_Node (I2)) then
+ T2 := Entity (Original_Node (I2));
+ else
+ T2 := Etype (I2);
+ end if;
+
+ if not Subtypes_Match
+ (Find_Actual_Type (Etype (I1), Scope (A_Gen_T)), T2)
+ then
+ Error_Msg_NE
+ ("index types of actual do not match those of formal &",
+ Actual, Gen_T);
+ Abandon_Instantiation (Actual);
+ end if;
+
+ Next_Index (I1);
+ Next_Index (I2);
+ end loop;
+
+ if not Subtypes_Match (
+ Find_Actual_Type (Component_Type (A_Gen_T), Scope (A_Gen_T)),
+ Component_Type (Act_T))
+ then
+ Error_Msg_NE
+ ("component subtype of actual does not match that of formal &",
+ Actual, Gen_T);
+ Abandon_Instantiation (Actual);
+ end if;
+
+ if Has_Aliased_Components (A_Gen_T)
+ and then not Has_Aliased_Components (Act_T)
+ then
+ Error_Msg_NE
+ ("actual must have aliased components to match formal type &",
+ Actual, Gen_T);
+ end if;
+
+ end Validate_Array_Type_Instance;
+
+ ------------------------------------
+ -- Validate_Derived_Type_Instance --
+ ------------------------------------
+
+ procedure Validate_Derived_Type_Instance is
+ Actual_Discr : Entity_Id;
+ Ancestor_Discr : Entity_Id;
+
+ begin
+ -- If the parent type in the generic declaration is itself
+ -- a previous formal type, then it is local to the generic
+ -- and absent from the analyzed generic definition. In that
+ -- case the ancestor is the instance of the formal (which must
+ -- have been instantiated previously). Otherwise, the analyzed
+ -- generic carries the parent type. If the parent type is defined
+ -- in a previous formal package, then the scope of that formal
+ -- package is that of the generic type itself, and it has already
+ -- been mapped into the corresponding type in the actual package.
+
+ -- Common case: parent type defined outside of the generic.
+
+ if Is_Entity_Name (Subtype_Mark (Def))
+ and then Present (Entity (Subtype_Mark (Def)))
+ then
+ Ancestor := Get_Instance_Of (Entity (Subtype_Mark (Def)));
+
+ -- Check whether parent is defined in a previous formal package.
+
+ elsif
+ Scope (Scope (Base_Type (Etype (A_Gen_T)))) = Scope (A_Gen_T)
+ then
+ Ancestor :=
+ Get_Instance_Of (Base_Type (Etype (A_Gen_T)));
+
+ elsif Is_Derived_Type (Get_Instance_Of (A_Gen_T)) then
+ Ancestor :=
+ Get_Instance_Of (Base_Type (Get_Instance_Of (A_Gen_T)));
+
+ else
+ Ancestor := Get_Instance_Of (Etype (Base_Type (A_Gen_T)));
+ end if;
+
+ if not Is_Ancestor (Base_Type (Ancestor), Act_T) then
+ Error_Msg_NE
+ ("expect type derived from & in instantiation",
+ Actual, First_Subtype (Ancestor));
+ Abandon_Instantiation (Actual);
+ end if;
+
+ -- Perform atomic/volatile checks (RM C.6(12))
+
+ if Is_Atomic (Act_T) and then not Is_Atomic (Ancestor) then
+ Error_Msg_N
+ ("cannot have atomic actual type for non-atomic formal type",
+ Actual);
+
+ elsif Is_Volatile (Act_T)
+ and then not Is_Volatile (Ancestor)
+ and then Is_By_Reference_Type (Ancestor)
+ then
+ Error_Msg_N
+ ("cannot have volatile actual type for non-volatile formal type",
+ Actual);
+ end if;
+
+ -- It should not be necessary to check for unknown discriminants
+ -- on Formal, but for some reason Has_Unknown_Discriminants is
+ -- false for A_Gen_T, so Is_Indefinite_Subtype incorrectly
+ -- returns False. This needs fixing. ???
+
+ if not Is_Indefinite_Subtype (A_Gen_T)
+ and then not Unknown_Discriminants_Present (Formal)
+ and then Is_Indefinite_Subtype (Act_T)
+ then
+ Error_Msg_N
+ ("actual subtype must be constrained", Actual);
+ Abandon_Instantiation (Actual);
+ end if;
+
+ if not Unknown_Discriminants_Present (Formal) then
+ if Is_Constrained (Ancestor) then
+ if not Is_Constrained (Act_T) then
+ Error_Msg_N
+ ("actual subtype must be constrained", Actual);
+ Abandon_Instantiation (Actual);
+ end if;
+
+ -- Ancestor is unconstrained
+
+ elsif Is_Constrained (Act_T) then
+ if Ekind (Ancestor) = E_Access_Type
+ or else Is_Composite_Type (Ancestor)
+ then
+ Error_Msg_N
+ ("actual subtype must be unconstrained", Actual);
+ Abandon_Instantiation (Actual);
+ end if;
+
+ -- A class-wide type is only allowed if the formal has
+ -- unknown discriminants.
+
+ elsif Is_Class_Wide_Type (Act_T)
+ and then not Has_Unknown_Discriminants (Ancestor)
+ then
+ Error_Msg_NE
+ ("actual for & cannot be a class-wide type", Actual, Gen_T);
+ Abandon_Instantiation (Actual);
+
+ -- Otherwise, the formal and actual shall have the same
+ -- number of discriminants and each discriminant of the
+ -- actual must correspond to a discriminant of the formal.
+
+ elsif Has_Discriminants (Act_T)
+ and then Has_Discriminants (Ancestor)
+ then
+ Actual_Discr := First_Discriminant (Act_T);
+ Ancestor_Discr := First_Discriminant (Ancestor);
+ while Present (Actual_Discr)
+ and then Present (Ancestor_Discr)
+ loop
+ if Base_Type (Act_T) /= Base_Type (Ancestor) and then
+ not Present (Corresponding_Discriminant (Actual_Discr))
+ then
+ Error_Msg_NE
+ ("discriminant & does not correspond " &
+ "to ancestor discriminant", Actual, Actual_Discr);
+ Abandon_Instantiation (Actual);
+ end if;
+
+ Next_Discriminant (Actual_Discr);
+ Next_Discriminant (Ancestor_Discr);
+ end loop;
+
+ if Present (Actual_Discr) or else Present (Ancestor_Discr) then
+ Error_Msg_NE
+ ("actual for & must have same number of discriminants",
+ Actual, Gen_T);
+ Abandon_Instantiation (Actual);
+ end if;
+
+ -- This case should be caught by the earlier check for
+ -- for constrainedness, but the check here is added for
+ -- completeness.
+
+ elsif Has_Discriminants (Act_T) then
+ Error_Msg_NE
+ ("actual for & must not have discriminants", Actual, Gen_T);
+ Abandon_Instantiation (Actual);
+
+ elsif Has_Discriminants (Ancestor) then
+ Error_Msg_NE
+ ("actual for & must have known discriminants", Actual, Gen_T);
+ Abandon_Instantiation (Actual);
+ end if;
+
+ if not Subtypes_Statically_Compatible (Act_T, Ancestor) then
+ Error_Msg_N
+ ("constraint on actual is incompatible with formal", Actual);
+ Abandon_Instantiation (Actual);
+ end if;
+ end if;
+
+ end Validate_Derived_Type_Instance;
+
+ ------------------------------------
+ -- Validate_Private_Type_Instance --
+ ------------------------------------
+
+ procedure Validate_Private_Type_Instance is
+ Formal_Discr : Entity_Id;
+ Actual_Discr : Entity_Id;
+ Formal_Subt : Entity_Id;
+
+ begin
+ if (Is_Limited_Type (Act_T)
+ or else Is_Limited_Composite (Act_T))
+ and then not Is_Limited_Type (A_Gen_T)
+ then
+ Error_Msg_NE
+ ("actual for non-limited & cannot be a limited type", Actual,
+ Gen_T);
+ Abandon_Instantiation (Actual);
+
+ elsif Is_Indefinite_Subtype (Act_T)
+ and then not Is_Indefinite_Subtype (A_Gen_T)
+ and then Ada_95
+ then
+ Error_Msg_NE
+ ("actual for & must be a definite subtype", Actual, Gen_T);
+
+ elsif not Is_Tagged_Type (Act_T)
+ and then Is_Tagged_Type (A_Gen_T)
+ then
+ Error_Msg_NE
+ ("actual for & must be a tagged type", Actual, Gen_T);
+
+ elsif Has_Discriminants (A_Gen_T) then
+ if not Has_Discriminants (Act_T) then
+ Error_Msg_NE
+ ("actual for & must have discriminants", Actual, Gen_T);
+ Abandon_Instantiation (Actual);
+
+ elsif Is_Constrained (Act_T) then
+ Error_Msg_NE
+ ("actual for & must be unconstrained", Actual, Gen_T);
+ Abandon_Instantiation (Actual);
+
+ else
+ Formal_Discr := First_Discriminant (A_Gen_T);
+ Actual_Discr := First_Discriminant (Act_T);
+ while Formal_Discr /= Empty loop
+ if Actual_Discr = Empty then
+ Error_Msg_NE
+ ("discriminants on actual do not match formal",
+ Actual, Gen_T);
+ Abandon_Instantiation (Actual);
+ end if;
+
+ Formal_Subt := Get_Instance_Of (Etype (Formal_Discr));
+
+ -- access discriminants match if designated types do.
+
+ if Ekind (Base_Type (Formal_Subt)) = E_Anonymous_Access_Type
+ and then (Ekind (Base_Type (Etype (Actual_Discr))))
+ = E_Anonymous_Access_Type
+ and then Get_Instance_Of (
+ Designated_Type (Base_Type (Formal_Subt)))
+ = Designated_Type (Base_Type (Etype (Actual_Discr)))
+ then
+ null;
+
+ elsif Base_Type (Formal_Subt) /=
+ Base_Type (Etype (Actual_Discr))
+ then
+ Error_Msg_NE
+ ("types of actual discriminants must match formal",
+ Actual, Gen_T);
+ Abandon_Instantiation (Actual);
+
+ elsif not Subtypes_Statically_Match
+ (Formal_Subt, Etype (Actual_Discr))
+ and then Ada_95
+ then
+ Error_Msg_NE
+ ("subtypes of actual discriminants must match formal",
+ Actual, Gen_T);
+ Abandon_Instantiation (Actual);
+ end if;
+
+ Next_Discriminant (Formal_Discr);
+ Next_Discriminant (Actual_Discr);
+ end loop;
+
+ if Actual_Discr /= Empty then
+ Error_Msg_NE
+ ("discriminants on actual do not match formal",
+ Actual, Gen_T);
+ Abandon_Instantiation (Actual);
+ end if;
+ end if;
+
+ end if;
+
+ Ancestor := Gen_T;
+ end Validate_Private_Type_Instance;
+
+ -- Start of processing for Instantiate_Type
+
+ begin
+ if Get_Instance_Of (A_Gen_T) /= A_Gen_T then
+ Error_Msg_N ("duplicate instantiation of generic type", Actual);
+ return Error;
+
+ elsif not Is_Entity_Name (Actual)
+ or else not Is_Type (Entity (Actual))
+ then
+ Error_Msg_NE
+ ("expect valid subtype mark to instantiate &", Actual, Gen_T);
+ Abandon_Instantiation (Actual);
+
+ else
+ Act_T := Entity (Actual);
+
+ if Ekind (Act_T) = E_Incomplete_Type then
+ if No (Underlying_Type (Act_T)) then
+ Error_Msg_N ("premature use of incomplete type", Actual);
+ Abandon_Instantiation (Actual);
+ else
+ Act_T := Full_View (Act_T);
+ Set_Entity (Actual, Act_T);
+
+ if Has_Private_Component (Act_T) then
+ Error_Msg_N
+ ("premature use of type with private component", Actual);
+ end if;
+ end if;
+
+ elsif Is_Private_Type (Act_T)
+ and then Is_Private_Type (Base_Type (Act_T))
+ and then not Is_Generic_Type (Act_T)
+ and then not Is_Derived_Type (Act_T)
+ and then No (Full_View (Root_Type (Act_T)))
+ then
+ Error_Msg_N ("premature use of private type", Actual);
+
+ elsif Has_Private_Component (Act_T) then
+ Error_Msg_N
+ ("premature use of type with private component", Actual);
+ end if;
+
+ Set_Instance_Of (A_Gen_T, Act_T);
+
+ -- If the type is generic, the class-wide type may also be used
+
+ if Is_Tagged_Type (A_Gen_T)
+ and then Is_Tagged_Type (Act_T)
+ and then not Is_Class_Wide_Type (A_Gen_T)
+ then
+ Set_Instance_Of (Class_Wide_Type (A_Gen_T),
+ Class_Wide_Type (Act_T));
+ end if;
+
+ if not Is_Abstract (A_Gen_T)
+ and then Is_Abstract (Act_T)
+ then
+ Error_Msg_N
+ ("actual of non-abstract formal cannot be abstract", Actual);
+ end if;
+
+ if Is_Scalar_Type (Gen_T) then
+ Set_Instance_Of (Etype (A_Gen_T), Etype (Act_T));
+ end if;
+ end if;
+
+ case Nkind (Def) is
+ when N_Formal_Private_Type_Definition =>
+ Validate_Private_Type_Instance;
+
+ when N_Formal_Derived_Type_Definition =>
+ Validate_Derived_Type_Instance;
+
+ when N_Formal_Discrete_Type_Definition =>
+ if not Is_Discrete_Type (Act_T) then
+ Error_Msg_NE
+ ("expect discrete type in instantiation of&", Actual, Gen_T);
+ Abandon_Instantiation (Actual);
+ end if;
+
+ when N_Formal_Signed_Integer_Type_Definition =>
+ if not Is_Signed_Integer_Type (Act_T) then
+ Error_Msg_NE
+ ("expect signed integer type in instantiation of&",
+ Actual, Gen_T);
+ Abandon_Instantiation (Actual);
+ end if;
+
+ when N_Formal_Modular_Type_Definition =>
+ if not Is_Modular_Integer_Type (Act_T) then
+ Error_Msg_NE
+ ("expect modular type in instantiation of &", Actual, Gen_T);
+ Abandon_Instantiation (Actual);
+ end if;
+
+ when N_Formal_Floating_Point_Definition =>
+ if not Is_Floating_Point_Type (Act_T) then
+ Error_Msg_NE
+ ("expect float type in instantiation of &", Actual, Gen_T);
+ Abandon_Instantiation (Actual);
+ end if;
+
+ when N_Formal_Ordinary_Fixed_Point_Definition =>
+ if not Is_Ordinary_Fixed_Point_Type (Act_T) then
+ Error_Msg_NE
+ ("expect ordinary fixed point type in instantiation of &",
+ Actual, Gen_T);
+ Abandon_Instantiation (Actual);
+ end if;
+
+ when N_Formal_Decimal_Fixed_Point_Definition =>
+ if not Is_Decimal_Fixed_Point_Type (Act_T) then
+ Error_Msg_NE
+ ("expect decimal type in instantiation of &",
+ Actual, Gen_T);
+ Abandon_Instantiation (Actual);
+ end if;
+
+ when N_Array_Type_Definition =>
+ Validate_Array_Type_Instance;
+
+ when N_Access_To_Object_Definition =>
+ Validate_Access_Type_Instance;
+
+ when N_Access_Function_Definition |
+ N_Access_Procedure_Definition =>
+ Validate_Access_Subprogram_Instance;
+
+ when others =>
+ raise Program_Error;
+
+ end case;
+
+ Decl_Node :=
+ Make_Subtype_Declaration (Loc,
+ Defining_Identifier => New_Copy (Gen_T),
+ Subtype_Indication => New_Reference_To (Act_T, Loc));
+
+ if Is_Private_Type (Act_T) then
+ Set_Has_Private_View (Subtype_Indication (Decl_Node));
+ end if;
+
+ -- Flag actual derived types so their elaboration produces the
+ -- appropriate renamings for the primitive operations of the ancestor.
+ -- Flag actual for formal private types as well, to determine whether
+ -- operations in the private part may override inherited operations.
+
+ if Nkind (Def) = N_Formal_Derived_Type_Definition
+ or else Nkind (Def) = N_Formal_Private_Type_Definition
+ then
+ Set_Generic_Parent_Type (Decl_Node, Ancestor);
+ end if;
+
+ return Decl_Node;
+ end Instantiate_Type;
+
+ ---------------------
+ -- Is_In_Main_Unit --
+ ---------------------
+
+ function Is_In_Main_Unit (N : Node_Id) return Boolean is
+ Unum : constant Unit_Number_Type := Get_Source_Unit (N);
+
+ Current_Unit : Node_Id;
+
+ begin
+ if Unum = Main_Unit then
+ return True;
+
+ -- If the current unit is a subunit then it is either the main unit
+ -- or is being compiled as part of the main unit.
+
+ elsif Nkind (N) = N_Compilation_Unit then
+ return Nkind (Unit (N)) = N_Subunit;
+ end if;
+
+ Current_Unit := Parent (N);
+ while Present (Current_Unit)
+ and then Nkind (Current_Unit) /= N_Compilation_Unit
+ loop
+ Current_Unit := Parent (Current_Unit);
+ end loop;
+
+ -- The instantiation node is in the main unit, or else the current
+ -- node (perhaps as the result of nested instantiations) is in the
+ -- main unit, or in the declaration of the main unit, which in this
+ -- last case must be a body.
+
+ return Unum = Main_Unit
+ or else Current_Unit = Cunit (Main_Unit)
+ or else Current_Unit = Library_Unit (Cunit (Main_Unit))
+ or else (Present (Library_Unit (Current_Unit))
+ and then Is_In_Main_Unit (Library_Unit (Current_Unit)));
+ end Is_In_Main_Unit;
+
+ ----------------------------
+ -- Load_Parent_Of_Generic --
+ ----------------------------
+
+ procedure Load_Parent_Of_Generic (N : Node_Id; Spec : Node_Id) is
+ Comp_Unit : constant Node_Id := Cunit (Get_Source_Unit (Spec));
+ True_Parent : Node_Id;
+ Inst_Node : Node_Id;
+ OK : Boolean;
+ Save_Style_Check : Boolean := Style_Check;
+
+ begin
+ if not In_Same_Source_Unit (N, Spec)
+ or else Nkind (Unit (Comp_Unit)) = N_Package_Declaration
+ or else (Nkind (Unit (Comp_Unit)) = N_Package_Body
+ and then not Is_In_Main_Unit (Spec))
+ then
+ -- Find body of parent of spec, and analyze it. A special case
+ -- arises when the parent is an instantiation, that is to say when
+ -- we are currently instantiating a nested generic. In that case,
+ -- there is no separate file for the body of the enclosing instance.
+ -- Instead, the enclosing body must be instantiated as if it were
+ -- a pending instantiation, in order to produce the body for the
+ -- nested generic we require now. Note that in that case the
+ -- generic may be defined in a package body, the instance defined
+ -- in the same package body, and the original enclosing body may not
+ -- be in the main unit.
+
+ True_Parent := Parent (Spec);
+ Inst_Node := Empty;
+
+ while Present (True_Parent)
+ and then Nkind (True_Parent) /= N_Compilation_Unit
+ loop
+ if Nkind (True_Parent) = N_Package_Declaration
+ and then
+ Nkind (Original_Node (True_Parent)) = N_Package_Instantiation
+ then
+ -- Parent is a compilation unit that is an instantiation.
+ -- Instantiation node has been replaced with package decl.
+
+ Inst_Node := Original_Node (True_Parent);
+ exit;
+
+ elsif Nkind (True_Parent) = N_Package_Declaration
+ and then Present (Generic_Parent (Specification (True_Parent)))
+ then
+ -- Parent is an instantiation within another specification.
+ -- Declaration for instance has been inserted before original
+ -- instantiation node. A direct link would be preferable?
+
+ Inst_Node := Next (True_Parent);
+
+ while Present (Inst_Node)
+ and then Nkind (Inst_Node) /= N_Package_Instantiation
+ loop
+ Next (Inst_Node);
+ end loop;
+
+ -- If the instance appears within a generic, and the generic
+ -- unit is defined within a formal package of the enclosing
+ -- generic, there is no generic body available, and none
+ -- needed. A more precise test should be used ???
+
+ if No (Inst_Node) then
+ return;
+ end if;
+
+ exit;
+ else
+ True_Parent := Parent (True_Parent);
+ end if;
+ end loop;
+
+ if Present (Inst_Node) then
+
+ if Nkind (Parent (True_Parent)) = N_Compilation_Unit then
+
+ -- Instantiation node and declaration of instantiated package
+ -- were exchanged when only the declaration was needed.
+ -- Restore instantiation node before proceeding with body.
+
+ Set_Unit (Parent (True_Parent), Inst_Node);
+ end if;
+
+ -- Now complete instantiation of enclosing body, if it appears
+ -- in some other unit. If it appears in the current unit, the
+ -- body will have been instantiated already.
+
+ if No (Corresponding_Body (Instance_Spec (Inst_Node))) then
+ Instantiate_Package_Body
+ (Pending_Body_Info'(
+ Inst_Node, True_Parent, Expander_Active,
+ Get_Code_Unit (Sloc (Inst_Node))));
+ end if;
+
+ else
+ Opt.Style_Check := False;
+ Load_Needed_Body (Comp_Unit, OK);
+ Opt.Style_Check := Save_Style_Check;
+
+ if not OK
+ and then Unit_Requires_Body (Defining_Entity (Spec))
+ then
+ declare
+ Bname : constant Unit_Name_Type :=
+ Get_Body_Name (Get_Unit_Name (Unit (Comp_Unit)));
+
+ begin
+ Error_Msg_Unit_1 := Bname;
+ Error_Msg_N ("this instantiation requires$!", N);
+ Error_Msg_Name_1 :=
+ Get_File_Name (Bname, Subunit => False);
+ Error_Msg_N ("\but file{ was not found!", N);
+ raise Unrecoverable_Error;
+ end;
+ end if;
+ end if;
+ end if;
+
+ -- If loading the parent of the generic caused an instantiation
+ -- circularity, we abandon compilation at this point, because
+ -- otherwise in some cases we get into trouble with infinite
+ -- recursions after this point.
+
+ if Circularity_Detected then
+ raise Unrecoverable_Error;
+ end if;
+
+ end Load_Parent_Of_Generic;
+
+ -----------------------
+ -- Move_Freeze_Nodes --
+ -----------------------
+
+ procedure Move_Freeze_Nodes
+ (Out_Of : Entity_Id;
+ After : Node_Id;
+ L : List_Id)
+ is
+ Decl : Node_Id;
+ Next_Decl : Node_Id;
+ Next_Node : Node_Id := After;
+ Spec : Node_Id;
+
+ function Is_Outer_Type (T : Entity_Id) return Boolean;
+ -- Check whether entity is declared in a scope external to that
+ -- of the generic unit.
+
+ -------------------
+ -- Is_Outer_Type --
+ -------------------
+
+ function Is_Outer_Type (T : Entity_Id) return Boolean is
+ Scop : Entity_Id := Scope (T);
+
+ begin
+ if Scope_Depth (Scop) < Scope_Depth (Out_Of) then
+ return True;
+
+ else
+ while Scop /= Standard_Standard loop
+
+ if Scop = Out_Of then
+ return False;
+ else
+ Scop := Scope (Scop);
+ end if;
+ end loop;
+
+ return True;
+ end if;
+ end Is_Outer_Type;
+
+ -- Start of processing for Move_Freeze_Nodes
+
+ begin
+ if No (L) then
+ return;
+ end if;
+
+ -- First remove the freeze nodes that may appear before all other
+ -- declarations.
+
+ Decl := First (L);
+ while Present (Decl)
+ and then Nkind (Decl) = N_Freeze_Entity
+ and then Is_Outer_Type (Entity (Decl))
+ loop
+ Decl := Remove_Head (L);
+ Insert_After (Next_Node, Decl);
+ Set_Analyzed (Decl, False);
+ Next_Node := Decl;
+ Decl := First (L);
+ end loop;
+
+ -- Next scan the list of declarations and remove each freeze node that
+ -- appears ahead of the current node.
+
+ while Present (Decl) loop
+ while Present (Next (Decl))
+ and then Nkind (Next (Decl)) = N_Freeze_Entity
+ and then Is_Outer_Type (Entity (Next (Decl)))
+ loop
+ Next_Decl := Remove_Next (Decl);
+ Insert_After (Next_Node, Next_Decl);
+ Set_Analyzed (Next_Decl, False);
+ Next_Node := Next_Decl;
+ end loop;
+
+ -- If the declaration is a nested package or concurrent type, then
+ -- recurse. Nested generic packages will have been processed from the
+ -- inside out.
+
+ if Nkind (Decl) = N_Package_Declaration then
+ Spec := Specification (Decl);
+
+ elsif Nkind (Decl) = N_Task_Type_Declaration then
+ Spec := Task_Definition (Decl);
+
+ elsif Nkind (Decl) = N_Protected_Type_Declaration then
+ Spec := Protected_Definition (Decl);
+
+ else
+ Spec := Empty;
+ end if;
+
+ if Present (Spec) then
+ Move_Freeze_Nodes (Out_Of, Next_Node,
+ Visible_Declarations (Spec));
+ Move_Freeze_Nodes (Out_Of, Next_Node,
+ Private_Declarations (Spec));
+ end if;
+
+ Next (Decl);
+ end loop;
+ end Move_Freeze_Nodes;
+
+ ----------------
+ -- Next_Assoc --
+ ----------------
+
+ function Next_Assoc (E : Assoc_Ptr) return Assoc_Ptr is
+ begin
+ return Generic_Renamings.Table (E).Next_In_HTable;
+ end Next_Assoc;
+
+ ------------------------
+ -- Preanalyze_Actuals --
+ ------------------------
+
+ procedure Pre_Analyze_Actuals (N : Node_Id) is
+ Assoc : Node_Id;
+ Act : Node_Id;
+ Errs : Int := Errors_Detected;
+
+ begin
+ Assoc := First (Generic_Associations (N));
+
+ while Present (Assoc) loop
+ Act := Explicit_Generic_Actual_Parameter (Assoc);
+
+ -- Within a nested instantiation, a defaulted actual is an
+ -- empty association, so nothing to analyze. If the actual for
+ -- a subprogram is an attribute, analyze prefix only, because
+ -- actual is not a complete attribute reference.
+ -- String literals may be operators, but at this point we do not
+ -- know whether the actual is a formal subprogram or a string.
+
+ if No (Act) then
+ null;
+
+ elsif Nkind (Act) = N_Attribute_Reference then
+ Analyze (Prefix (Act));
+
+ elsif Nkind (Act) = N_Explicit_Dereference then
+ Analyze (Prefix (Act));
+
+ elsif Nkind (Act) /= N_Operator_Symbol then
+ Analyze (Act);
+ end if;
+
+ if Errs /= Errors_Detected then
+ Abandon_Instantiation (Act);
+ end if;
+
+ Next (Assoc);
+ end loop;
+ end Pre_Analyze_Actuals;
+
+ -------------------
+ -- Remove_Parent --
+ -------------------
+
+ procedure Remove_Parent (In_Body : Boolean := False) is
+ S : Entity_Id := Current_Scope;
+ E : Entity_Id;
+ P : Entity_Id;
+ Hidden : Elmt_Id;
+
+ begin
+ -- After child instantiation is complete, remove from scope stack
+ -- the extra copy of the current scope, and then remove parent
+ -- instances.
+
+ if not In_Body then
+ Pop_Scope;
+
+ while Current_Scope /= S loop
+ P := Current_Scope;
+ End_Package_Scope (Current_Scope);
+
+ if In_Open_Scopes (P) then
+ E := First_Entity (P);
+
+ while Present (E) loop
+ Set_Is_Immediately_Visible (E, True);
+ Next_Entity (E);
+ end loop;
+
+ elsif not In_Open_Scopes (Scope (P)) then
+ Set_Is_Immediately_Visible (P, False);
+ end if;
+ end loop;
+
+ -- Reset visibility of entities in the enclosing scope.
+
+ Set_Is_Hidden_Open_Scope (Current_Scope, False);
+ Hidden := First_Elmt (Hidden_Entities);
+
+ while Present (Hidden) loop
+ Set_Is_Immediately_Visible (Node (Hidden), True);
+ Next_Elmt (Hidden);
+ end loop;
+
+ else
+ -- Each body is analyzed separately, and there is no context
+ -- that needs preserving from one body instance to the next,
+ -- so remove all parent scopes that have been installed.
+
+ while Present (S) loop
+ End_Package_Scope (S);
+ S := Current_Scope;
+ exit when S = Standard_Standard;
+ end loop;
+ end if;
+
+ end Remove_Parent;
+
+ -----------------
+ -- Restore_Env --
+ -----------------
+
+ procedure Restore_Env is
+ Saved : Instance_Env renames Instance_Envs.Table (Instance_Envs.Last);
+
+ begin
+ Ada_83 := Saved.Ada_83;
+
+ if No (Current_Instantiated_Parent.Act_Id) then
+
+ -- Restore environment after subprogram inlining
+
+ Restore_Private_Views (Empty);
+ end if;
+
+ Current_Instantiated_Parent := Saved.Instantiated_Parent;
+ Exchanged_Views := Saved.Exchanged_Views;
+ Hidden_Entities := Saved.Hidden_Entities;
+ Current_Sem_Unit := Saved.Current_Sem_Unit;
+
+ Instance_Envs.Decrement_Last;
+ end Restore_Env;
+
+ ---------------------------
+ -- Restore_Private_Views --
+ ---------------------------
+
+ procedure Restore_Private_Views
+ (Pack_Id : Entity_Id;
+ Is_Package : Boolean := True)
+ is
+ M : Elmt_Id;
+ E : Entity_Id;
+ Typ : Entity_Id;
+ Dep_Elmt : Elmt_Id;
+ Dep_Typ : Node_Id;
+
+ begin
+ M := First_Elmt (Exchanged_Views);
+ while Present (M) loop
+ Typ := Node (M);
+
+ -- Subtypes of types whose views have been exchanged, and that
+ -- are defined within the instance, were not on the list of
+ -- Private_Dependents on entry to the instance, so they have to
+ -- be exchanged explicitly now, in order to remain consistent with
+ -- the view of the parent type.
+
+ if Ekind (Typ) = E_Private_Type
+ or else Ekind (Typ) = E_Limited_Private_Type
+ or else Ekind (Typ) = E_Record_Type_With_Private
+ then
+ Dep_Elmt := First_Elmt (Private_Dependents (Typ));
+
+ while Present (Dep_Elmt) loop
+ Dep_Typ := Node (Dep_Elmt);
+
+ if Scope (Dep_Typ) = Pack_Id
+ and then Present (Full_View (Dep_Typ))
+ then
+ Replace_Elmt (Dep_Elmt, Full_View (Dep_Typ));
+ Exchange_Declarations (Dep_Typ);
+ end if;
+
+ Next_Elmt (Dep_Elmt);
+ end loop;
+ end if;
+
+ Exchange_Declarations (Node (M));
+ Next_Elmt (M);
+ end loop;
+
+ if No (Pack_Id) then
+ return;
+ end if;
+
+ -- Make the generic formal parameters private, and make the formal
+ -- types into subtypes of the actuals again.
+
+ E := First_Entity (Pack_Id);
+
+ while Present (E) loop
+ Set_Is_Hidden (E, True);
+
+ if Is_Type (E)
+ and then Nkind (Parent (E)) = N_Subtype_Declaration
+ then
+ Set_Is_Generic_Actual_Type (E, False);
+
+ -- An unusual case of aliasing: the actual may also be directly
+ -- visible in the generic, and be private there, while it is
+ -- fully visible in the context of the instance. The internal
+ -- subtype is private in the instance, but has full visibility
+ -- like its parent in the enclosing scope. This enforces the
+ -- invariant that the privacy status of all private dependents of
+ -- a type coincide with that of the parent type. This can only
+ -- happen when a generic child unit is instantiated within a
+ -- sibling.
+
+ if Is_Private_Type (E)
+ and then not Is_Private_Type (Etype (E))
+ then
+ Exchange_Declarations (E);
+ end if;
+
+ elsif Ekind (E) = E_Package then
+
+ -- The end of the renaming list is the renaming of the generic
+ -- package itself. If the instance is a subprogram, all entities
+ -- in the corresponding package are renamings. If this entity is
+ -- a formal package, make its own formals private as well. The
+ -- actual in this case is itself the renaming of an instantation.
+ -- If the entity is not a package renaming, it is the entity
+ -- created to validate formal package actuals: ignore.
+
+ -- If the actual is itself a formal package for the enclosing
+ -- generic, or the actual for such a formal package, it remains
+ -- visible after the current instance, and therefore nothing
+ -- needs to be done either, except to keep it accessible.
+
+ if Is_Package
+ and then Renamed_Object (E) = Pack_Id
+ then
+ exit;
+
+ elsif Nkind (Parent (E)) /= N_Package_Renaming_Declaration then
+ null;
+
+ elsif Denotes_Formal_Package (Renamed_Object (E)) then
+ Set_Is_Hidden (E, False);
+
+ else
+ declare
+ Act_P : Entity_Id := Renamed_Object (E);
+ Id : Entity_Id := First_Entity (Act_P);
+
+ begin
+ while Present (Id)
+ and then Id /= First_Private_Entity (Act_P)
+ loop
+ Set_Is_Hidden (Id, True);
+ Set_Is_Potentially_Use_Visible (Id, In_Use (Act_P));
+ exit when Ekind (Id) = E_Package
+ and then Renamed_Object (Id) = Act_P;
+
+ Next_Entity (Id);
+ end loop;
+ end;
+ null;
+ end if;
+ end if;
+
+ Next_Entity (E);
+ end loop;
+ end Restore_Private_Views;
+
+ --------------
+ -- Save_Env --
+ --------------
+
+ procedure Save_Env
+ (Gen_Unit : Entity_Id;
+ Act_Unit : Entity_Id)
+ is
+ Saved : Instance_Env;
+
+ begin
+ Saved.Ada_83 := Ada_83;
+ Saved.Instantiated_Parent := Current_Instantiated_Parent;
+ Saved.Exchanged_Views := Exchanged_Views;
+ Saved.Hidden_Entities := Hidden_Entities;
+ Saved.Current_Sem_Unit := Current_Sem_Unit;
+ Instance_Envs.Increment_Last;
+ Instance_Envs.Table (Instance_Envs.Last) := Saved;
+
+ -- Regardless of the current mode, predefined units are analyzed in
+ -- Ada95 mode, and Ada83 checks don't apply.
+
+ if Is_Internal_File_Name
+ (Fname => Unit_File_Name (Get_Source_Unit (Gen_Unit)),
+ Renamings_Included => True) then
+ Ada_83 := False;
+ end if;
+
+ Current_Instantiated_Parent := (Gen_Unit, Act_Unit, Assoc_Null);
+ Exchanged_Views := New_Elmt_List;
+ Hidden_Entities := New_Elmt_List;
+ end Save_Env;
+
+ ----------------------------
+ -- Save_Global_References --
+ ----------------------------
+
+ procedure Save_Global_References (N : Node_Id) is
+ Gen_Scope : Entity_Id;
+ E : Entity_Id;
+ N2 : Node_Id;
+
+ function Is_Global (E : Entity_Id) return Boolean;
+ -- Check whether entity is defined outside of generic unit.
+ -- Examine the scope of an entity, and the scope of the scope,
+ -- etc, until we find either Standard, in which case the entity
+ -- is global, or the generic unit itself, which indicates that
+ -- the entity is local. If the entity is the generic unit itself,
+ -- as in the case of a recursive call, or the enclosing generic unit,
+ -- if different from the current scope, then it is local as well,
+ -- because it will be replaced at the point of instantiation. On
+ -- the other hand, if it is a reference to a child unit of a common
+ -- ancestor, which appears in an instantiation, it is global because
+ -- it is used to denote a specific compilation unit at the time the
+ -- instantiations will be analyzed.
+
+ procedure Reset_Entity (N : Node_Id);
+ -- Save semantic information on global entity, so that it is not
+ -- resolved again at instantiation time.
+
+ procedure Save_Global_Defaults (N1, N2 : Node_Id);
+ -- Default actuals in nested instances must be handled specially
+ -- because there is no link to them from the original tree. When an
+ -- actual subprogram is given by a default, we add an explicit generic
+ -- association for it in the instantiation node. When we save the
+ -- global references on the name of the instance, we recover the list
+ -- of generic associations, and add an explicit one to the original
+ -- generic tree, through which a global actual can be preserved.
+ -- Similarly, if a child unit is instantiated within a sibling, in the
+ -- context of the parent, we must preserve the identifier of the parent
+ -- so that it can be properly resolved in a subsequent instantiation.
+
+ procedure Save_Global_Descendant (D : Union_Id);
+ -- Apply Save_Global_References recursively to the descendents of
+ -- current node.
+
+ procedure Save_References (N : Node_Id);
+ -- This is the recursive procedure that does the work, once the
+ -- enclosing generic scope has been established.
+
+ ---------------
+ -- Is_Global --
+ ---------------
+
+ function Is_Global (E : Entity_Id) return Boolean is
+ Se : Entity_Id := Scope (E);
+
+ function Is_Instance_Node (Decl : Node_Id) return Boolean;
+ -- Determine whether the parent node of a reference to a child unit
+ -- denotes an instantiation or a formal package, in which case the
+ -- reference to the child unit is global, even if it appears within
+ -- the current scope (e.g. when the instance appears within the body
+ -- of an ancestor).
+
+ function Is_Instance_Node (Decl : Node_Id) return Boolean is
+ begin
+ return (Nkind (Decl) in N_Generic_Instantiation
+ or else
+ Nkind (Original_Node (Decl)) = N_Formal_Package_Declaration);
+ end Is_Instance_Node;
+
+ -- Start of processing for Is_Global
+
+ begin
+ if E = Gen_Scope then
+ return False;
+
+ elsif E = Standard_Standard then
+ return True;
+
+ elsif Is_Child_Unit (E)
+ and then (Is_Instance_Node (Parent (N2))
+ or else (Nkind (Parent (N2)) = N_Expanded_Name
+ and then N2 = Selector_Name (Parent (N2))
+ and then Is_Instance_Node (Parent (Parent (N2)))))
+ then
+ return True;
+
+ else
+ while Se /= Gen_Scope loop
+ if Se = Standard_Standard then
+ return True;
+ else
+ Se := Scope (Se);
+ end if;
+ end loop;
+
+ return False;
+ end if;
+ end Is_Global;
+
+ ------------------
+ -- Reset_Entity --
+ ------------------
+
+ procedure Reset_Entity (N : Node_Id) is
+
+ procedure Set_Global_Type (N : Node_Id; N2 : Node_Id);
+ -- The type of N2 is global to the generic unit. Save the
+ -- type in the generic node.
+
+ procedure Set_Global_Type (N : Node_Id; N2 : Node_Id) is
+ Typ : constant Entity_Id := Etype (N2);
+
+ begin
+ Set_Etype (N, Typ);
+
+ if Entity (N) /= N2
+ and then Has_Private_View (Entity (N))
+ then
+ -- If the entity of N is not the associated node, this is
+ -- a nested generic and it has an associated node as well,
+ -- whose type is already the full view (see below). Indicate
+ -- that the original node has a private view.
+
+ Set_Has_Private_View (N);
+ end if;
+
+ -- If not a private type, nothing else to do
+
+ if not Is_Private_Type (Typ) then
+ if Is_Array_Type (Typ)
+ and then Is_Private_Type (Component_Type (Typ))
+ then
+ Set_Has_Private_View (N);
+ end if;
+
+ -- If it is a derivation of a private type in a context where
+ -- no full view is needed, nothing to do either.
+
+ elsif No (Full_View (Typ)) and then Typ /= Etype (Typ) then
+ null;
+
+ -- Otherwise mark the type for flipping and use the full_view
+ -- when available.
+
+ else
+ Set_Has_Private_View (N);
+
+ if Present (Full_View (Typ)) then
+ Set_Etype (N2, Full_View (Typ));
+ end if;
+ end if;
+ end Set_Global_Type;
+
+ -- Start of processing for Reset_Entity
+
+ begin
+ N2 := Associated_Node (N);
+ E := Entity (N2);
+
+ if Present (E) then
+ if Is_Global (E) then
+ Set_Global_Type (N, N2);
+
+ elsif Nkind (N) = N_Op_Concat
+ and then Is_Generic_Type (Etype (N2))
+ and then
+ (Base_Type (Etype (Right_Opnd (N2))) = Etype (N2)
+ or else Base_Type (Etype (Left_Opnd (N2))) = Etype (N2))
+ and then Is_Intrinsic_Subprogram (E)
+ then
+ null;
+
+ else
+ -- Entity is local. Mark generic node as unresolved.
+ -- Note that now it does not have an entity.
+
+ Set_Associated_Node (N, Empty);
+ Set_Etype (N, Empty);
+ end if;
+
+ if (Nkind (Parent (N)) = N_Package_Instantiation
+ or else Nkind (Parent (N)) = N_Function_Instantiation
+ or else Nkind (Parent (N)) = N_Procedure_Instantiation)
+ and then N = Name (Parent (N))
+ then
+ Save_Global_Defaults (Parent (N), Parent (N2));
+ end if;
+
+ elsif Nkind (Parent (N)) = N_Selected_Component
+ and then Nkind (Parent (N2)) = N_Expanded_Name
+ then
+
+ if Is_Global (Entity (Parent (N2))) then
+ Change_Selected_Component_To_Expanded_Name (Parent (N));
+ Set_Associated_Node (Parent (N), Parent (N2));
+ Set_Global_Type (Parent (N), Parent (N2));
+
+ Save_Global_Descendant (Field2 (N));
+ Save_Global_Descendant (Field3 (N));
+
+ -- If this is a reference to the current generic entity,
+ -- replace it with a simple name. This is to avoid anomalies
+ -- when the enclosing scope is also a generic unit, in which
+ -- case the selected component will not resolve to the current
+ -- unit within an instance of the outer one. Ditto if the
+ -- entity is an enclosing scope, e.g. a parent unit.
+
+ elsif In_Open_Scopes (Entity (Parent (N2)))
+ and then not Is_Generic_Unit (Entity (Prefix (Parent (N2))))
+ then
+ Rewrite (Parent (N),
+ Make_Identifier (Sloc (N),
+ Chars => Chars (Selector_Name (Parent (N2)))));
+ end if;
+
+ if (Nkind (Parent (Parent (N))) = N_Package_Instantiation
+ or else Nkind (Parent (Parent (N)))
+ = N_Function_Instantiation
+ or else Nkind (Parent (Parent (N)))
+ = N_Procedure_Instantiation)
+ and then Parent (N) = Name (Parent (Parent (N)))
+ then
+ Save_Global_Defaults
+ (Parent (Parent (N)), Parent (Parent ((N2))));
+ end if;
+
+ -- A selected component may denote a static constant that has
+ -- been folded. Make the same replacement in original tree.
+
+ elsif Nkind (Parent (N)) = N_Selected_Component
+ and then (Nkind (Parent (N2)) = N_Integer_Literal
+ or else Nkind (Parent (N2)) = N_Real_Literal)
+ then
+ Rewrite (Parent (N),
+ New_Copy (Parent (N2)));
+ Set_Analyzed (Parent (N), False);
+
+ -- a selected component may be transformed into a parameterless
+ -- function call. If the called entity is global, rewrite the
+ -- node appropriately, i.e. as an extended name for the global
+ -- entity.
+
+ elsif Nkind (Parent (N)) = N_Selected_Component
+ and then Nkind (Parent (N2)) = N_Function_Call
+ and then Is_Global (Entity (Name (Parent (N2))))
+ then
+ Change_Selected_Component_To_Expanded_Name (Parent (N));
+ Set_Associated_Node (Parent (N), Name (Parent (N2)));
+ Set_Global_Type (Parent (N), Name (Parent (N2)));
+
+ Save_Global_Descendant (Field2 (N));
+ Save_Global_Descendant (Field3 (N));
+
+ else
+ -- Entity is local. Reset in generic unit, so that node
+ -- is resolved anew at the point of instantiation.
+
+ Set_Associated_Node (N, Empty);
+ Set_Etype (N, Empty);
+ end if;
+ end Reset_Entity;
+
+ --------------------------
+ -- Save_Global_Defaults --
+ --------------------------
+
+ procedure Save_Global_Defaults (N1, N2 : Node_Id) is
+ Loc : constant Source_Ptr := Sloc (N1);
+ Assoc1 : List_Id := Generic_Associations (N1);
+ Assoc2 : List_Id := Generic_Associations (N2);
+ Act1 : Node_Id;
+ Act2 : Node_Id;
+ Def : Node_Id;
+ Gen_Id : Entity_Id := Entity (Name (N2));
+ Ndec : Node_Id;
+ Subp : Entity_Id;
+ Actual : Entity_Id;
+
+ begin
+ if Present (Assoc1) then
+ Act1 := First (Assoc1);
+ else
+ Act1 := Empty;
+ Set_Generic_Associations (N1, New_List);
+ Assoc1 := Generic_Associations (N1);
+ end if;
+
+ if Present (Assoc2) then
+ Act2 := First (Assoc2);
+ else
+ return;
+ end if;
+
+ while Present (Act1) and then Present (Act2) loop
+ Next (Act1);
+ Next (Act2);
+ end loop;
+
+ -- Find the associations added for default suprograms.
+
+ if Present (Act2) then
+ while Nkind (Act2) /= N_Generic_Association
+ or else No (Entity (Selector_Name (Act2)))
+ or else not Is_Overloadable (Entity (Selector_Name (Act2)))
+ loop
+ Next (Act2);
+ end loop;
+
+ -- Add a similar association if the default is global. The
+ -- renaming declaration for the actual has been analyzed, and
+ -- its alias is the program it renames. Link the actual in the
+ -- original generic tree with the node in the analyzed tree.
+
+ while Present (Act2) loop
+ Subp := Entity (Selector_Name (Act2));
+ Def := Explicit_Generic_Actual_Parameter (Act2);
+
+ -- Following test is defence against rubbish errors
+
+ if No (Alias (Subp)) then
+ return;
+ end if;
+
+ -- Retrieve the resolved actual from the renaming declaration
+ -- created for the instantiated formal.
+
+ Actual := Entity (Name (Parent (Parent (Subp))));
+ Set_Entity (Def, Actual);
+ Set_Etype (Def, Etype (Actual));
+
+ if Is_Global (Actual) then
+ Ndec :=
+ Make_Generic_Association (Loc,
+ Selector_Name => New_Occurrence_Of (Subp, Loc),
+ Explicit_Generic_Actual_Parameter =>
+ New_Occurrence_Of (Actual, Loc));
+
+ Set_Associated_Node
+ (Explicit_Generic_Actual_Parameter (Ndec), Def);
+
+ Append (Ndec, Assoc1);
+
+ -- If there are other defaults, add a dummy association
+ -- in case there are other defaulted formals with the same
+ -- name.
+
+ elsif Present (Next (Act2)) then
+ Ndec :=
+ Make_Generic_Association (Loc,
+ Selector_Name => New_Occurrence_Of (Subp, Loc),
+ Explicit_Generic_Actual_Parameter => Empty);
+
+ Append (Ndec, Assoc1);
+ end if;
+
+ Next (Act2);
+ end loop;
+ end if;
+
+ if Nkind (Name (N1)) = N_Identifier
+ and then Is_Child_Unit (Gen_Id)
+ and then Is_Global (Gen_Id)
+ and then Is_Generic_Unit (Scope (Gen_Id))
+ and then In_Open_Scopes (Scope (Gen_Id))
+ then
+ -- This is an instantiation of a child unit within a sibling,
+ -- so that the generic parent is in scope. An eventual instance
+ -- must occur within the scope of an instance of the parent.
+ -- Make name in instance into an expanded name, to preserve the
+ -- identifier of the parent, so it can be resolved subsequently.
+
+ Rewrite (Name (N2),
+ Make_Expanded_Name (Loc,
+ Chars => Chars (Gen_Id),
+ Prefix => New_Occurrence_Of (Scope (Gen_Id), Loc),
+ Selector_Name => New_Occurrence_Of (Gen_Id, Loc)));
+ Set_Entity (Name (N2), Gen_Id);
+
+ Rewrite (Name (N1),
+ Make_Expanded_Name (Loc,
+ Chars => Chars (Gen_Id),
+ Prefix => New_Occurrence_Of (Scope (Gen_Id), Loc),
+ Selector_Name => New_Occurrence_Of (Gen_Id, Loc)));
+
+ Set_Associated_Node (Name (N1), Name (N2));
+ Set_Associated_Node (Prefix (Name (N1)), Empty);
+ Set_Associated_Node
+ (Selector_Name (Name (N1)), Selector_Name (Name (N2)));
+ Set_Etype (Name (N1), Etype (Gen_Id));
+ end if;
+
+ end Save_Global_Defaults;
+
+ ----------------------------
+ -- Save_Global_Descendant --
+ ----------------------------
+
+ procedure Save_Global_Descendant (D : Union_Id) is
+ N1 : Node_Id;
+
+ begin
+ if D in Node_Range then
+ if D = Union_Id (Empty) then
+ null;
+
+ elsif Nkind (Node_Id (D)) /= N_Compilation_Unit then
+ Save_References (Node_Id (D));
+ end if;
+
+ elsif D in List_Range then
+ if D = Union_Id (No_List)
+ or else Is_Empty_List (List_Id (D))
+ then
+ null;
+
+ else
+ N1 := First (List_Id (D));
+ while Present (N1) loop
+ Save_References (N1);
+ Next (N1);
+ end loop;
+ end if;
+
+ -- Element list or other non-node field, nothing to do
+
+ else
+ null;
+ end if;
+ end Save_Global_Descendant;
+
+ ---------------------
+ -- Save_References --
+ ---------------------
+
+ -- This is the recursive procedure that does the work, once the
+ -- enclosing generic scope has been established. We have to treat
+ -- specially a number of node rewritings that are required by semantic
+ -- processing and which change the kind of nodes in the generic copy:
+ -- typically constant-folding, replacing an operator node by a string
+ -- literal, or a selected component by an expanded name. In each of
+ -- those cases, the transformation is propagated to the generic unit.
+
+ procedure Save_References (N : Node_Id) is
+ begin
+ if N = Empty then
+ null;
+
+ elsif (Nkind (N) = N_Character_Literal
+ or else Nkind (N) = N_Operator_Symbol)
+ then
+ if Nkind (N) = Nkind (Associated_Node (N)) then
+ Reset_Entity (N);
+
+ elsif Nkind (N) = N_Operator_Symbol
+ and then Nkind (Associated_Node (N)) = N_String_Literal
+ then
+ Change_Operator_Symbol_To_String_Literal (N);
+ end if;
+
+ elsif Nkind (N) in N_Op then
+
+ if Nkind (N) = Nkind (Associated_Node (N)) then
+
+ if Nkind (N) = N_Op_Concat then
+ Set_Is_Component_Left_Opnd (N,
+ Is_Component_Left_Opnd (Associated_Node (N)));
+
+ Set_Is_Component_Right_Opnd (N,
+ Is_Component_Right_Opnd (Associated_Node (N)));
+ end if;
+
+ Reset_Entity (N);
+ else
+ -- Node may be transformed into call to a user-defined operator
+
+ N2 := Associated_Node (N);
+
+ if Nkind (N2) = N_Function_Call then
+ E := Entity (Name (N2));
+
+ if Present (E)
+ and then Is_Global (E)
+ then
+ Set_Etype (N, Etype (N2));
+ else
+ Set_Associated_Node (N, Empty);
+ Set_Etype (N, Empty);
+ end if;
+
+ elsif Nkind (N2) = N_Integer_Literal
+ or else Nkind (N2) = N_Real_Literal
+ or else Nkind (N2) = N_String_Literal
+ or else (Nkind (N2) = N_Identifier
+ and then
+ Ekind (Entity (N2)) = E_Enumeration_Literal)
+ then
+ -- Operation was constant-folded, perform the same
+ -- replacement in generic.
+
+ -- Note: we do a Replace here rather than a Rewrite,
+ -- which is a definite violation of the standard rules
+ -- with regard to retrievability of the original tree,
+ -- and likely ASIS bugs or at least irregularities are
+ -- caused by this choice.
+
+ -- The reason we do this is that the appropriate original
+ -- nodes are never constructed (we don't go applying the
+ -- generic instantiation to rewritten nodes in general).
+ -- We could try to create an appropriate copy but it would
+ -- be hard work and does not seem worth while, because
+ -- the original expression is accessible in the generic,
+ -- and ASIS rules for traversing instances are fuzzy.
+
+ Replace (N, New_Copy (N2));
+ Set_Analyzed (N, False);
+ end if;
+ end if;
+
+ -- Complete the check on operands.
+
+ Save_Global_Descendant (Field2 (N));
+ Save_Global_Descendant (Field3 (N));
+
+ elsif Nkind (N) = N_Identifier then
+ if Nkind (N) = Nkind (Associated_Node (N)) then
+
+ -- If this is a discriminant reference, always save it.
+ -- It is used in the instance to find the corresponding
+ -- discriminant positionally rather than by name.
+
+ Set_Original_Discriminant
+ (N, Original_Discriminant (Associated_Node (N)));
+ Reset_Entity (N);
+
+ else
+ N2 := Associated_Node (N);
+
+ if Nkind (N2) = N_Function_Call then
+ E := Entity (Name (N2));
+
+ -- Name resolves to a call to parameterless function.
+ -- If original entity is global, mark node as resolved.
+
+ if Present (E)
+ and then Is_Global (E)
+ then
+ Set_Etype (N, Etype (N2));
+ else
+ Set_Associated_Node (N, Empty);
+ Set_Etype (N, Empty);
+ end if;
+
+ elsif
+ Nkind (N2) = N_Integer_Literal or else
+ Nkind (N2) = N_Real_Literal or else
+ Nkind (N2) = N_String_Literal
+ then
+ -- Name resolves to named number that is constant-folded,
+ -- or to string literal from concatenation.
+ -- Perform the same replacement in generic.
+
+ Rewrite (N, New_Copy (N2));
+ Set_Analyzed (N, False);
+
+ elsif Nkind (N2) = N_Explicit_Dereference then
+
+ -- An identifier is rewritten as a dereference if it is
+ -- the prefix in a selected component, and it denotes an
+ -- access to a composite type, or a parameterless function
+ -- call that returns an access type.
+
+ -- Check whether corresponding entity in prefix is global.
+
+ if Is_Entity_Name (Prefix (N2))
+ and then Present (Entity (Prefix (N2)))
+ and then Is_Global (Entity (Prefix (N2)))
+ then
+ Rewrite (N,
+ Make_Explicit_Dereference (Sloc (N),
+ Prefix => Make_Identifier (Sloc (N),
+ Chars => Chars (N))));
+ Set_Associated_Node (Prefix (N), Prefix (N2));
+
+ elsif Nkind (Prefix (N2)) = N_Function_Call
+ and then Is_Global (Entity (Name (Prefix (N2))))
+ then
+ Rewrite (N,
+ Make_Explicit_Dereference (Sloc (N),
+ Prefix => Make_Function_Call (Sloc (N),
+ Name =>
+ Make_Identifier (Sloc (N),
+ Chars => Chars (N)))));
+
+ Set_Associated_Node
+ (Name (Prefix (N)), Name (Prefix (N2)));
+
+ else
+ Set_Associated_Node (N, Empty);
+ Set_Etype (N, Empty);
+ end if;
+
+ -- The subtype mark of a nominally unconstrained object
+ -- is rewritten as a subtype indication using the bounds
+ -- of the expression. Recover the original subtype mark.
+
+ elsif Nkind (N2) = N_Subtype_Indication
+ and then Is_Entity_Name (Original_Node (N2))
+ then
+ Set_Associated_Node (N, Original_Node (N2));
+ Reset_Entity (N);
+
+ else
+ null;
+ end if;
+ end if;
+
+ elsif Nkind (N) in N_Entity then
+ null;
+
+ elsif Nkind (N) = N_Aggregate
+ or else Nkind (N) = N_Extension_Aggregate
+ then
+ N2 := Associated_Node (N);
+ if No (N2)
+ or else No (Etype (N2))
+ or else not Is_Global (Etype (N2))
+ then
+ Set_Associated_Node (N, Empty);
+ end if;
+
+ Save_Global_Descendant (Field1 (N));
+ Save_Global_Descendant (Field2 (N));
+ Save_Global_Descendant (Field3 (N));
+ Save_Global_Descendant (Field5 (N));
+
+ else
+ Save_Global_Descendant (Field1 (N));
+ Save_Global_Descendant (Field2 (N));
+ Save_Global_Descendant (Field3 (N));
+ Save_Global_Descendant (Field4 (N));
+ Save_Global_Descendant (Field5 (N));
+
+ end if;
+ end Save_References;
+
+ -- Start of processing for Save_Global_References
+
+ begin
+ Gen_Scope := Current_Scope;
+
+ -- If the generic unit is a child unit, references to entities in
+ -- the parent are treated as local, because they will be resolved
+ -- anew in the context of the instance of the parent.
+
+ while Is_Child_Unit (Gen_Scope)
+ and then Ekind (Scope (Gen_Scope)) = E_Generic_Package
+ loop
+ Gen_Scope := Scope (Gen_Scope);
+ end loop;
+
+ Save_References (N);
+ end Save_Global_References;
+
+ -------------------------
+ -- Set_Associated_Node --
+ -------------------------
+
+ -- Note from RBKD: the uncommented use of Set_Node4 below is ugly ???
+
+ procedure Set_Associated_Node
+ (Gen_Node : Node_Id;
+ Copy_Node : Node_Id)
+ is
+ begin
+ Set_Node4 (Gen_Node, Copy_Node);
+ end Set_Associated_Node;
+
+ ---------------------
+ -- Set_Copied_Sloc --
+ ---------------------
+
+ procedure Set_Copied_Sloc (N : Node_Id; E : Entity_Id) is
+ begin
+ Create_Instantiation_Source (N, E, S_Adjustment);
+ end Set_Copied_Sloc;
+
+ ---------------------
+ -- Set_Instance_Of --
+ ---------------------
+
+ procedure Set_Instance_Of (A : Entity_Id; B : Entity_Id) is
+ begin
+ Generic_Renamings.Table (Generic_Renamings.Last) := (A, B, Assoc_Null);
+ Generic_Renamings_HTable.Set (Generic_Renamings.Last);
+ Generic_Renamings.Increment_Last;
+ end Set_Instance_Of;
+
+ --------------------
+ -- Set_Next_Assoc --
+ --------------------
+
+ procedure Set_Next_Assoc (E : Assoc_Ptr; Next : Assoc_Ptr) is
+ begin
+ Generic_Renamings.Table (E).Next_In_HTable := Next;
+ end Set_Next_Assoc;
+
+ -------------------
+ -- Start_Generic --
+ -------------------
+
+ procedure Start_Generic is
+ begin
+ -- ??? I am sure more things could be factored out in this
+ -- routine. Should probably be done at a later stage.
+
+ Generic_Flags.Increment_Last;
+ Generic_Flags.Table (Generic_Flags.Last) := Inside_A_Generic;
+ Inside_A_Generic := True;
+
+ Expander_Mode_Save_And_Set (False);
+ end Start_Generic;
+
+ -----------------
+ -- Switch_View --
+ -----------------
+
+ procedure Switch_View (T : Entity_Id) is
+ Priv_Elmt : Elmt_Id := No_Elmt;
+ Priv_Sub : Entity_Id;
+ BT : Entity_Id := Base_Type (T);
+
+ begin
+ -- T may be private but its base type may have been exchanged through
+ -- some other occurrence, in which case there is nothing to switch.
+
+ if not Is_Private_Type (BT) then
+ return;
+ end if;
+
+ Priv_Elmt := First_Elmt (Private_Dependents (BT));
+
+ if Present (Full_View (BT)) then
+ Append_Elmt (Full_View (BT), Exchanged_Views);
+ Exchange_Declarations (BT);
+ end if;
+
+ while Present (Priv_Elmt) loop
+ Priv_Sub := (Node (Priv_Elmt));
+
+ -- We avoid flipping the subtype if the Etype of its full
+ -- view is private because this would result in a malformed
+ -- subtype. This occurs when the Etype of the subtype full
+ -- view is the full view of the base type (and since the
+ -- base types were just switched, the subtype is pointing
+ -- to the wrong view). This is currently the case for
+ -- tagged record types, access types (maybe more?) and
+ -- needs to be resolved. ???
+
+ if Present (Full_View (Priv_Sub))
+ and then not Is_Private_Type (Etype (Full_View (Priv_Sub)))
+ then
+ Append_Elmt (Full_View (Priv_Sub), Exchanged_Views);
+ Exchange_Declarations (Priv_Sub);
+ end if;
+
+ Next_Elmt (Priv_Elmt);
+ end loop;
+ end Switch_View;
+
+ -----------------------------
+ -- Valid_Default_Attribute --
+ -----------------------------
+
+ procedure Valid_Default_Attribute (Nam : Entity_Id; Def : Node_Id) is
+ Attr_Id : constant Attribute_Id :=
+ Get_Attribute_Id (Attribute_Name (Def));
+ F : Entity_Id;
+ Num_F : Int;
+ T : Entity_Id := Entity (Prefix (Def));
+ OK : Boolean;
+ Is_Fun : constant Boolean := (Ekind (Nam) = E_Function);
+
+ begin
+ if No (T)
+ or else T = Any_Id
+ then
+ return;
+ end if;
+
+ Num_F := 0;
+ F := First_Formal (Nam);
+ while Present (F) loop
+ Num_F := Num_F + 1;
+ Next_Formal (F);
+ end loop;
+
+ case Attr_Id is
+ when Attribute_Adjacent | Attribute_Ceiling | Attribute_Copy_Sign |
+ Attribute_Floor | Attribute_Fraction | Attribute_Machine |
+ Attribute_Model | Attribute_Remainder | Attribute_Rounding |
+ Attribute_Unbiased_Rounding =>
+ OK := (Is_Fun and then Num_F = 1 and then Is_Floating_Point_Type (T));
+
+ when Attribute_Image | Attribute_Pred | Attribute_Succ |
+ Attribute_Value | Attribute_Wide_Image |
+ Attribute_Wide_Value =>
+ OK := (Is_Fun and then Num_F = 1 and then Is_Scalar_Type (T));
+
+ when Attribute_Max | Attribute_Min =>
+ OK := (Is_Fun and then Num_F = 2 and then Is_Scalar_Type (T));
+
+ when Attribute_Input =>
+ OK := (Is_Fun and then Num_F = 1);
+
+ when Attribute_Output | Attribute_Read | Attribute_Write =>
+ OK := (not Is_Fun and then Num_F = 2);
+
+ when others => OK := False;
+ end case;
+
+ if not OK then
+ Error_Msg_N ("attribute reference has wrong profile for subprogram",
+ Def);
+ end if;
+ end Valid_Default_Attribute;
+
+end Sem_Ch12;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S E M _ C H 1 2 --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.19 $
+-- --
+-- 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). --
+-- --
+------------------------------------------------------------------------------
+
+with Inline; use Inline;
+with Types; use Types;
+
+package Sem_Ch12 is
+ procedure Analyze_Generic_Package_Declaration (N : Node_Id);
+ procedure Analyze_Generic_Subprogram_Declaration (N : Node_Id);
+ procedure Analyze_Package_Instantiation (N : Node_Id);
+ procedure Analyze_Procedure_Instantiation (N : Node_Id);
+ procedure Analyze_Function_Instantiation (N : Node_Id);
+ procedure Analyze_Formal_Object_Declaration (N : Node_Id);
+ procedure Analyze_Formal_Type_Declaration (N : Node_Id);
+ procedure Analyze_Formal_Subprogram (N : Node_Id);
+ procedure Analyze_Formal_Package (N : Node_Id);
+
+ procedure Start_Generic;
+ -- Must be invoked before starting to process a generic spec or body.
+
+ procedure End_Generic;
+ -- Must be invoked just at the end of the end of the processing of a
+ -- generic spec or body.
+
+ procedure Check_Generic_Child_Unit
+ (Gen_Id : Node_Id;
+ Parent_Installed : in out Boolean);
+ -- If the name of the generic unit in an instantiation or a renaming
+ -- is a selected component, then the prefix may be an instance and the
+ -- selector may designate a child unit. Retrieve the parent generic
+ -- and search for the child unit that must be declared within. Similarly,
+ -- if this is the name of a generic child unit within an instantiation of
+ -- its own parent, retrieve the parent generic.
+
+ function Copy_Generic_Node
+ (N : Node_Id;
+ Parent_Id : Node_Id;
+ Instantiating : Boolean)
+ return Node_Id;
+ -- Copy the tree for a generic unit or its body. The unit is copied
+ -- repeatedly: once to produce a copy on which semantic analysis of
+ -- the generic is performed, and once for each instantiation. The tree
+ -- being copied is not semantically analyzed, except that references to
+ -- global entities are marked on terminal nodes.
+
+ function Get_Instance_Of (A : Entity_Id) return Entity_Id;
+ -- Retrieve actual associated with given generic parameter.
+ -- If A is uninstantiated or not a generic parameter, return A.
+
+ procedure Instantiate_Package_Body
+ (Body_Info : Pending_Body_Info);
+ -- Called after semantic analysis, to complete the instantiation of
+ -- package instances.
+
+ procedure Instantiate_Subprogram_Body
+ (Body_Info : Pending_Body_Info);
+ -- Called after semantic analysis, to complete the instantiation of
+ -- function and procedure instances.
+
+ procedure Save_Global_References (N : Node_Id);
+ -- Traverse the original generic unit, and capture all references to
+ -- entities that are defined outside of the generic in the analyzed
+ -- tree for the template. These references are copied into the original
+ -- tree, so that they appear automatically in every instantiation.
+ -- A critical invariant in this approach is that if an id in the generic
+ -- resolves to a local entity, the corresponding id in the instance
+ -- will resolve to the homologous entity in the instance, even though
+ -- the enclosing context for resolution is different, as long as the
+ -- global references have been captured as described here.
+
+ -- Because instantiations can be nested, the environment of the instance,
+ -- involving the actuals and other data-structures, must be saved and
+ -- restored in stack-like fashion. Front-end inlining also uses these
+ -- structures for the management of private/full views.
+
+ procedure Set_Copied_Sloc (N : Node_Id; E : Entity_Id);
+
+ procedure Save_Env
+ (Gen_Unit : Entity_Id;
+ Act_Unit : Entity_Id);
+
+ procedure Restore_Env;
+
+end Sem_Ch12;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S E M _ C H 1 3 --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.390 $
+-- --
+-- 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). --
+-- --
+------------------------------------------------------------------------------
+
+with Atree; use Atree;
+with Einfo; use Einfo;
+with Errout; use Errout;
+with Exp_Tss; use Exp_Tss;
+with Exp_Util; use Exp_Util;
+with Hostparm; use Hostparm;
+with Lib; use Lib;
+with Nlists; use Nlists;
+with Nmake; use Nmake;
+with Opt; use Opt;
+with Rtsfind; use Rtsfind;
+with Sem; use Sem;
+with Sem_Ch8; use Sem_Ch8;
+with Sem_Eval; use Sem_Eval;
+with Sem_Res; use Sem_Res;
+with Sem_Type; use Sem_Type;
+with Sem_Util; use Sem_Util;
+with Stand; use Stand;
+with Sinfo; use Sinfo;
+with Snames; use Snames;
+with Table;
+with Ttypes; use Ttypes;
+with Tbuild; use Tbuild;
+with Urealp; use Urealp;
+
+with GNAT.Heap_Sort_A; use GNAT.Heap_Sort_A;
+
+package body Sem_Ch13 is
+
+ SSU : constant Pos := System_Storage_Unit;
+ -- Convenient short hand for commonly used constant
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ procedure Alignment_Check_For_Esize_Change (Typ : Entity_Id);
+ -- This routine is called after setting the Esize of type entity Typ.
+ -- The purpose is to deal with the situation where an aligment has been
+ -- inherited from a derived type that is no longer appropriate for the
+ -- new Esize value. In this case, we reset the Alignment to unknown.
+
+ procedure Check_Address_Alignment (E : Entity_Id; Expr : Node_Id);
+ -- Given an object entity E, for which the alignment is known, checks
+ -- to see if Expr (the expression from an Address clause) is a known
+ -- at compile time value, and if so posts a warning if the value is
+ -- not consistent with the known alignment requirement. This is not
+ -- an error, but rather leads to erroneous behavior, but we certainly
+ -- may as well give a warning if we detect this situation.
+
+ procedure Check_Component_Overlap (C1_Ent, C2_Ent : Entity_Id);
+ -- Given two entities for record components or discriminants, checks
+ -- if they hav overlapping component clauses and issues errors if so.
+
+ function Get_Alignment_Value (Expr : Node_Id) return Uint;
+ -- Given the expression for an alignment value, returns the corresponding
+ -- Uint value. If the value is inappropriate, then error messages are
+ -- posted as required, and a value of No_Uint is returned.
+
+ function Is_Operational_Item (N : Node_Id) return Boolean;
+ -- A specification for a stream attribute is allowed before the full
+ -- type is declared, as explained in AI-00137 and the corrigendum.
+ -- Attributes that do not specify a representation characteristic are
+ -- operational attributes.
+
+ procedure New_Stream_Function
+ (N : Node_Id;
+ Ent : Entity_Id;
+ Subp : Entity_Id;
+ Nam : Name_Id);
+ -- Create a function renaming of a given stream attribute to the
+ -- designated subprogram and then in the tagged case, provide this as
+ -- a primitive operation, or in the non-tagged case make an appropriate
+ -- TSS entry. Used for Input. This is more properly an expansion activity
+ -- than just semantics, but the presence of user-defined stream functions
+ -- for limited types is a legality check, which is why this takes place
+ -- here rather than in exp_ch13, where it was previously.
+
+ procedure New_Stream_Procedure
+ (N : Node_Id;
+ Ent : Entity_Id;
+ Subp : Entity_Id;
+ Nam : Name_Id;
+ Out_P : Boolean := False);
+ -- Create a procedure renaming of a given stream attribute to the
+ -- designated subprogram and then in the tagged case, provide this as
+ -- a primitive operation, or in the non-tagged case make an appropriate
+ -- TSS entry. Used for Read, Output, Write.
+
+ procedure Check_Constant_Address_Clause (Expr : Node_Id; U_Ent : Entity_Id);
+ -- Expr is an expression for an address clause. This procedure checks
+ -- that the expression is constant, in the limited sense that it is safe
+ -- to evaluate it at the point the object U_Ent is declared, rather than
+ -- at the point of the address clause. The condition for this to be true
+ -- is that the expression has no variables, no constants declared after
+ -- U_Ent, and no calls to non-pure functions. If this condition is not
+ -- met, then an appropriate error message is posted.
+
+ procedure Warn_Overlay
+ (Expr : Node_Id;
+ Typ : Entity_Id;
+ Nam : Node_Id);
+ -- Expr is the expression for an address clause for entity Nam whose type
+ -- is Typ. If Typ has a default initialization, check whether the address
+ -- clause might overlay two entities, and emit a warning on the side effect
+ -- that the initialization will cause.
+
+ ----------------------------------------------
+ -- Table for Validate_Unchecked_Conversions --
+ ----------------------------------------------
+
+ -- The following table collects unchecked conversions for validation.
+ -- Entries are made by Validate_Unchecked_Conversion and then the
+ -- call to Validate_Unchecked_Conversions does the actual error
+ -- checking and posting of warnings. The reason for this delayed
+ -- processing is to take advantage of back-annotations of size and
+ -- alignment values peformed by the back end.
+
+ type UC_Entry is record
+ Enode : Node_Id; -- node used for posting warnings
+ Source : Entity_Id; -- source type for unchecked conversion
+ Target : Entity_Id; -- target type for unchecked conversion
+ end record;
+
+ package Unchecked_Conversions is new Table.Table (
+ Table_Component_Type => UC_Entry,
+ Table_Index_Type => Int,
+ Table_Low_Bound => 1,
+ Table_Initial => 50,
+ Table_Increment => 200,
+ Table_Name => "Unchecked_Conversions");
+
+ --------------------------------------
+ -- Alignment_Check_For_Esize_Change --
+ --------------------------------------
+
+ procedure Alignment_Check_For_Esize_Change (Typ : Entity_Id) is
+ begin
+ -- If the alignment is known, and not set by a rep clause, and is
+ -- inconsistent with the size being set, then reset it to unknown,
+ -- we assume in this case that the size overrides the inherited
+ -- alignment, and that the alignment must be recomputed.
+
+ if Known_Alignment (Typ)
+ and then not Has_Alignment_Clause (Typ)
+ and then Esize (Typ) mod (Alignment (Typ) * SSU) /= 0
+ then
+ Init_Alignment (Typ);
+ end if;
+ end Alignment_Check_For_Esize_Change;
+
+ -----------------------
+ -- Analyze_At_Clause --
+ -----------------------
+
+ -- An at clause is replaced by the corresponding Address attribute
+ -- definition clause that is the preferred approach in Ada 95.
+
+ procedure Analyze_At_Clause (N : Node_Id) is
+ begin
+ Rewrite (N,
+ Make_Attribute_Definition_Clause (Sloc (N),
+ Name => Identifier (N),
+ Chars => Name_Address,
+ Expression => Expression (N)));
+ Analyze_Attribute_Definition_Clause (N);
+ end Analyze_At_Clause;
+
+ -----------------------------------------
+ -- Analyze_Attribute_Definition_Clause --
+ -----------------------------------------
+
+ procedure Analyze_Attribute_Definition_Clause (N : Node_Id) is
+ Loc : constant Source_Ptr := Sloc (N);
+ Nam : constant Node_Id := Name (N);
+ Attr : constant Name_Id := Chars (N);
+ Expr : constant Node_Id := Expression (N);
+ Id : constant Attribute_Id := Get_Attribute_Id (Attr);
+ Ent : Entity_Id;
+ U_Ent : Entity_Id;
+
+ FOnly : Boolean := False;
+ -- Reset to True for subtype specific attribute (Alignment, Size)
+ -- and for stream attributes, i.e. those cases where in the call
+ -- to Rep_Item_Too_Late, FOnly is set True so that only the freezing
+ -- rules are checked. Note that the case of stream attributes is not
+ -- clear from the RM, but see AI95-00137. Also, the RM seems to
+ -- disallow Storage_Size for derived task types, but that is also
+ -- clearly unintentional.
+
+ begin
+ Analyze (Nam);
+ Ent := Entity (Nam);
+
+ if Rep_Item_Too_Early (Ent, N) then
+ return;
+ end if;
+
+ -- Rep clause applies to full view of incomplete type or private type
+ -- if we have one (if not, this is a premature use of the type).
+ -- However, certain semantic checks need to be done on the specified
+ -- entity (i.e. the private view), so we save it in Ent.
+
+ if Is_Private_Type (Ent)
+ and then Is_Derived_Type (Ent)
+ and then not Is_Tagged_Type (Ent)
+ and then No (Full_View (Ent))
+ then
+ -- If this is a private type whose completion is a derivation
+ -- from another private type, there is no full view, and the
+ -- attribute belongs to the type itself, not its underlying parent.
+
+ U_Ent := Ent;
+
+ elsif Ekind (Ent) = E_Incomplete_Type then
+ Ent := Underlying_Type (Ent);
+ U_Ent := Ent;
+ else
+ U_Ent := Underlying_Type (Ent);
+ end if;
+
+ -- Complete other routine error checks
+
+ if Etype (Nam) = Any_Type then
+ return;
+
+ elsif Scope (Ent) /= Current_Scope then
+ Error_Msg_N ("entity must be declared in this scope", Nam);
+ return;
+
+ elsif Is_Type (U_Ent)
+ and then not Is_First_Subtype (U_Ent)
+ and then Id /= Attribute_Object_Size
+ and then Id /= Attribute_Value_Size
+ and then not From_At_Mod (N)
+ then
+ Error_Msg_N ("cannot specify attribute for subtype", Nam);
+ return;
+
+ end if;
+
+ -- Switch on particular attribute
+
+ case Id is
+
+ -------------
+ -- Address --
+ -------------
+
+ -- Address attribute definition clause
+
+ when Attribute_Address => Address : begin
+ Analyze_And_Resolve (Expr, RTE (RE_Address));
+
+ if Present (Address_Clause (U_Ent)) then
+ Error_Msg_N ("address already given for &", Nam);
+
+ -- Case of address clause for subprogram
+
+ elsif Is_Subprogram (U_Ent) then
+
+ if Has_Homonym (U_Ent) then
+ Error_Msg_N
+ ("address clause cannot be given " &
+ "for overloaded subprogram",
+ Nam);
+ end if;
+
+ -- For subprograms, all address clauses are permitted,
+ -- and we mark the subprogram as having a deferred freeze
+ -- so that Gigi will not elaborate it too soon.
+
+ -- Above needs more comments, what is too soon about???
+
+ Set_Has_Delayed_Freeze (U_Ent);
+
+ -- Case of address clause for entry
+
+ elsif Ekind (U_Ent) = E_Entry then
+
+ if Nkind (Parent (N)) = N_Task_Body then
+ Error_Msg_N
+ ("entry address must be specified in task spec", Nam);
+ end if;
+
+ -- For entries, we require a constant address
+
+ Check_Constant_Address_Clause (Expr, U_Ent);
+
+ -- Case of address clause for variable or constant
+
+ elsif
+ Ekind (U_Ent) = E_Variable
+ or else
+ Ekind (U_Ent) = E_Constant
+ then
+ declare
+ Decl : constant Node_Id := Declaration_Node (U_Ent);
+ Expr : constant Node_Id := Expression (N);
+ Typ : constant Entity_Id := Etype (U_Ent);
+
+ begin
+ -- Exported variables cannot have an address clause,
+ -- because this cancels the effect of the pragma Export
+
+ if Is_Exported (U_Ent) then
+ Error_Msg_N
+ ("cannot export object with address clause", Nam);
+
+ -- Imported variables can have an address clause, but then
+ -- the import is pretty meaningless except to suppress
+ -- initializations, so we do not need such variables to
+ -- be statically allocated (and in fact it causes trouble
+ -- if the address clause is a local value).
+
+ elsif Is_Imported (U_Ent) then
+ Set_Is_Statically_Allocated (U_Ent, False);
+ end if;
+
+ -- We mark a possible modification of a variable with an
+ -- address clause, since it is likely aliasing is occurring.
+
+ Note_Possible_Modification (Nam);
+
+ -- If we have no initialization of any kind, then we can
+ -- safely defer the elaboration of the variable to its
+ -- freezing point, so that the address clause will be
+ -- computed at the proper point.
+
+ -- The same processing applies to all initialized scalar
+ -- types and all access types. Packed bit arrays of size
+ -- up to 64 are represented using a modular type with an
+ -- initialization (to zero) and can be processed like
+ -- other initialized scalar types.
+
+ if (No (Expression (Decl))
+ and then not Has_Non_Null_Base_Init_Proc (Typ))
+
+ or else
+ (Present (Expression (Decl))
+ and then Is_Scalar_Type (Typ))
+
+ or else
+ Is_Access_Type (Typ)
+
+ or else
+ (Is_Bit_Packed_Array (Base_Type (Typ))
+ and then
+ Is_Modular_Integer_Type (Packed_Array_Type (Typ)))
+ then
+ Set_Has_Delayed_Freeze (U_Ent);
+
+ -- Otherwise, we require the address clause to be constant
+
+ else
+ Check_Constant_Address_Clause (Expr, U_Ent);
+ end if;
+
+ if Is_Exported (U_Ent) then
+ Error_Msg_N
+ ("& cannot be exported if an address clause is given",
+ Nam);
+ Error_Msg_N
+ ("\define and export a variable " &
+ "that holds its address instead",
+ Nam);
+ end if;
+
+ if not Error_Posted (Expr) then
+ Warn_Overlay (Expr, Typ, Nam);
+ end if;
+
+ -- Check for bad alignment
+
+ if Known_Alignment (U_Ent) then
+ Check_Address_Alignment (U_Ent, Expr);
+ end if;
+
+ -- Kill the size check code, since we are not allocating
+ -- the variable, it is somewhere else.
+
+ Kill_Size_Check_Code (U_Ent);
+ end;
+
+ -- Not a valid entity for an address clause
+
+ else
+ Error_Msg_N ("address cannot be given for &", Nam);
+ end if;
+ end Address;
+
+ ---------------
+ -- Alignment --
+ ---------------
+
+ -- Alignment attribute definition clause
+
+ when Attribute_Alignment => Alignment_Block : declare
+ Align : Uint := Get_Alignment_Value (Expr);
+
+ begin
+ FOnly := True;
+
+ if not Is_Type (U_Ent)
+ and then Ekind (U_Ent) /= E_Variable
+ and then Ekind (U_Ent) /= E_Constant
+ then
+ Error_Msg_N ("alignment cannot be given for &", Nam);
+
+ elsif Has_Alignment_Clause (U_Ent) then
+ Error_Msg_Sloc := Sloc (Alignment_Clause (U_Ent));
+ Error_Msg_N ("alignment clause previously given#", N);
+
+ elsif Align /= No_Uint then
+ Set_Has_Alignment_Clause (U_Ent);
+ Set_Alignment (U_Ent, Align);
+ end if;
+ end Alignment_Block;
+
+ ---------------
+ -- Bit_Order --
+ ---------------
+
+ -- Bit_Order attribute definition clause
+
+ when Attribute_Bit_Order => Bit_Order : declare
+ begin
+ if not Is_Record_Type (U_Ent) then
+ Error_Msg_N
+ ("Bit_Order can only be defined for record type", Nam);
+
+ else
+ Analyze_And_Resolve (Expr, RTE (RE_Bit_Order));
+
+ if Etype (Expr) = Any_Type then
+ return;
+
+ elsif not Is_Static_Expression (Expr) then
+ Error_Msg_N ("Bit_Order requires static expression", Expr);
+
+ else
+ if (Expr_Value (Expr) = 0) /= Bytes_Big_Endian then
+ Set_Reverse_Bit_Order (U_Ent, True);
+ end if;
+ end if;
+ end if;
+ end Bit_Order;
+
+ --------------------
+ -- Component_Size --
+ --------------------
+
+ -- Component_Size attribute definition clause
+
+ when Attribute_Component_Size => Component_Size_Case : declare
+ Csize : constant Uint := Static_Integer (Expr);
+ Btype : Entity_Id;
+ Biased : Boolean;
+ New_Ctyp : Entity_Id;
+ Decl : Node_Id;
+
+ begin
+ if not Is_Array_Type (U_Ent) then
+ Error_Msg_N ("component size requires array type", Nam);
+ return;
+ end if;
+
+ Btype := Base_Type (U_Ent);
+
+ if Has_Component_Size_Clause (Btype) then
+ Error_Msg_N
+ ("component size clase for& previously given", Nam);
+
+ elsif Csize /= No_Uint then
+ Check_Size (Expr, Component_Type (Btype), Csize, Biased);
+
+ if Has_Aliased_Components (Btype)
+ and then Csize < 32
+ and then Csize /= 8
+ and then Csize /= 16
+ then
+ Error_Msg_N
+ ("component size incorrect for aliased components", N);
+ return;
+ end if;
+
+ -- For the biased case, build a declaration for a subtype
+ -- that will be used to represent the biased subtype that
+ -- reflects the biased representation of components. We need
+ -- this subtype to get proper conversions on referencing
+ -- elements of the array.
+
+ if Biased then
+ New_Ctyp :=
+ Make_Defining_Identifier (Loc,
+ Chars => New_External_Name (Chars (U_Ent), 'C', 0, 'T'));
+
+ Decl :=
+ Make_Subtype_Declaration (Loc,
+ Defining_Identifier => New_Ctyp,
+ Subtype_Indication =>
+ New_Occurrence_Of (Component_Type (Btype), Loc));
+
+ Set_Parent (Decl, N);
+ Analyze (Decl, Suppress => All_Checks);
+
+ Set_Has_Delayed_Freeze (New_Ctyp, False);
+ Set_Esize (New_Ctyp, Csize);
+ Set_RM_Size (New_Ctyp, Csize);
+ Init_Alignment (New_Ctyp);
+ Set_Has_Biased_Representation (New_Ctyp, True);
+ Set_Is_Itype (New_Ctyp, True);
+ Set_Associated_Node_For_Itype (New_Ctyp, U_Ent);
+
+ Set_Component_Type (Btype, New_Ctyp);
+ end if;
+
+ Set_Component_Size (Btype, Csize);
+ Set_Has_Component_Size_Clause (Btype, True);
+ Set_Has_Non_Standard_Rep (Btype, True);
+ end if;
+ end Component_Size_Case;
+
+ ------------------
+ -- External_Tag --
+ ------------------
+
+ when Attribute_External_Tag => External_Tag :
+ begin
+ if not Is_Tagged_Type (U_Ent) then
+ Error_Msg_N ("should be a tagged type", Nam);
+ end if;
+
+ Analyze_And_Resolve (Expr, Standard_String);
+
+ if not Is_Static_Expression (Expr) then
+ Error_Msg_N ("must be a static string", Nam);
+ end if;
+
+ Set_Has_External_Tag_Rep_Clause (U_Ent);
+ end External_Tag;
+
+ -----------
+ -- Input --
+ -----------
+
+ when Attribute_Input => Input : declare
+ Subp : Entity_Id := Empty;
+ I : Interp_Index;
+ It : Interp;
+ Pnam : Entity_Id;
+
+ function Has_Good_Profile (Subp : Entity_Id) return Boolean;
+ -- Return true if the entity is a function with an appropriate
+ -- profile for the Input attribute.
+
+ function Has_Good_Profile (Subp : Entity_Id) return Boolean is
+ F : Entity_Id;
+ Ok : Boolean := False;
+
+ begin
+ if Ekind (Subp) = E_Function then
+ F := First_Formal (Subp);
+
+ if Present (F) and then No (Next_Formal (F)) then
+ if Ekind (Etype (F)) = E_Anonymous_Access_Type
+ and then
+ Designated_Type (Etype (F)) =
+ Class_Wide_Type (RTE (RE_Root_Stream_Type))
+ then
+ Ok := Base_Type (Etype (Subp)) = Base_Type (Ent);
+ end if;
+ end if;
+ end if;
+
+ return Ok;
+ end Has_Good_Profile;
+
+ -- Start of processing for Input attribute definition
+
+ begin
+ FOnly := True;
+
+ if not Is_Type (U_Ent) then
+ Error_Msg_N ("local name must be a subtype", Nam);
+ return;
+
+ else
+ Pnam := TSS (Base_Type (U_Ent), Name_uInput);
+
+ if Present (Pnam)
+ and then Base_Type (Etype (Pnam)) = Base_Type (U_Ent)
+ then
+ Error_Msg_Sloc := Sloc (Pnam);
+ Error_Msg_N ("input attribute already defined #", Nam);
+ return;
+ end if;
+ end if;
+
+ Analyze (Expr);
+
+ if Is_Entity_Name (Expr) then
+ if not Is_Overloaded (Expr) then
+ if Has_Good_Profile (Entity (Expr)) then
+ Subp := Entity (Expr);
+ end if;
+
+ else
+ Get_First_Interp (Expr, I, It);
+
+ while Present (It.Nam) loop
+ if Has_Good_Profile (It.Nam) then
+ Subp := It.Nam;
+ exit;
+ end if;
+
+ Get_Next_Interp (I, It);
+ end loop;
+ end if;
+ end if;
+
+ if Present (Subp) then
+ Set_Entity (Expr, Subp);
+ Set_Etype (Expr, Etype (Subp));
+ New_Stream_Function (N, U_Ent, Subp, Name_uInput);
+ else
+ Error_Msg_N ("incorrect expression for input attribute", Expr);
+ return;
+ end if;
+ end Input;
+
+ -------------------
+ -- Machine_Radix --
+ -------------------
+
+ -- Machine radix attribute definition clause
+
+ when Attribute_Machine_Radix => Machine_Radix : declare
+ Radix : constant Uint := Static_Integer (Expr);
+
+ begin
+ if not Is_Decimal_Fixed_Point_Type (U_Ent) then
+ Error_Msg_N ("decimal fixed-point type expected for &", Nam);
+
+ elsif Has_Machine_Radix_Clause (U_Ent) then
+ Error_Msg_Sloc := Sloc (Alignment_Clause (U_Ent));
+ Error_Msg_N ("machine radix clause previously given#", N);
+
+ elsif Radix /= No_Uint then
+ Set_Has_Machine_Radix_Clause (U_Ent);
+ Set_Has_Non_Standard_Rep (Base_Type (U_Ent));
+
+ if Radix = 2 then
+ null;
+ elsif Radix = 10 then
+ Set_Machine_Radix_10 (U_Ent);
+ else
+ Error_Msg_N ("machine radix value must be 2 or 10", Expr);
+ end if;
+ end if;
+ end Machine_Radix;
+
+ -----------------
+ -- Object_Size --
+ -----------------
+
+ -- Object_Size attribute definition clause
+
+ when Attribute_Object_Size => Object_Size : declare
+ Size : constant Uint := Static_Integer (Expr);
+ Biased : Boolean;
+
+ begin
+ if not Is_Type (U_Ent) then
+ Error_Msg_N ("Object_Size cannot be given for &", Nam);
+
+ elsif Has_Object_Size_Clause (U_Ent) then
+ Error_Msg_N ("Object_Size already given for &", Nam);
+
+ else
+ Check_Size (Expr, U_Ent, Size, Biased);
+
+ if Size /= 8
+ and then
+ Size /= 16
+ and then
+ Size /= 32
+ and then
+ UI_Mod (Size, 64) /= 0
+ then
+ Error_Msg_N
+ ("Object_Size must be 8, 16, 32, or multiple of 64",
+ Expr);
+ end if;
+
+ Set_Esize (U_Ent, Size);
+ Set_Has_Object_Size_Clause (U_Ent);
+ Alignment_Check_For_Esize_Change (U_Ent);
+ end if;
+ end Object_Size;
+
+ ------------
+ -- Output --
+ ------------
+
+ when Attribute_Output => Output : declare
+ Subp : Entity_Id := Empty;
+ I : Interp_Index;
+ It : Interp;
+ Pnam : Entity_Id;
+
+ function Has_Good_Profile (Subp : Entity_Id) return Boolean;
+ -- Return true if the entity is a procedure with an
+ -- appropriate profile for the output attribute.
+
+ function Has_Good_Profile (Subp : Entity_Id) return Boolean is
+ F : Entity_Id;
+ Ok : Boolean := False;
+
+ begin
+ if Ekind (Subp) = E_Procedure then
+ F := First_Formal (Subp);
+
+ if Present (F) then
+ if Ekind (Etype (F)) = E_Anonymous_Access_Type
+ and then
+ Designated_Type (Etype (F)) =
+ Class_Wide_Type (RTE (RE_Root_Stream_Type))
+ then
+ Next_Formal (F);
+ Ok := Present (F)
+ and then Parameter_Mode (F) = E_In_Parameter
+ and then Base_Type (Etype (F)) = Base_Type (Ent)
+ and then No (Next_Formal (F));
+ end if;
+ end if;
+ end if;
+
+ return Ok;
+ end Has_Good_Profile;
+
+ begin
+ FOnly := True;
+
+ if not Is_Type (U_Ent) then
+ Error_Msg_N ("local name must be a subtype", Nam);
+ return;
+
+ else
+ Pnam := TSS (Base_Type (U_Ent), Name_uOutput);
+
+ if Present (Pnam)
+ and then
+ Base_Type (Etype (Next_Formal (First_Formal (Pnam))))
+ = Base_Type (U_Ent)
+ then
+ Error_Msg_Sloc := Sloc (Pnam);
+ Error_Msg_N ("output attribute already defined #", Nam);
+ return;
+ end if;
+ end if;
+
+ Analyze (Expr);
+
+ if Is_Entity_Name (Expr) then
+ if not Is_Overloaded (Expr) then
+ if Has_Good_Profile (Entity (Expr)) then
+ Subp := Entity (Expr);
+ end if;
+
+ else
+ Get_First_Interp (Expr, I, It);
+
+ while Present (It.Nam) loop
+ if Has_Good_Profile (It.Nam) then
+ Subp := It.Nam;
+ exit;
+ end if;
+
+ Get_Next_Interp (I, It);
+ end loop;
+ end if;
+ end if;
+
+ if Present (Subp) then
+ Set_Entity (Expr, Subp);
+ Set_Etype (Expr, Etype (Subp));
+ New_Stream_Procedure (N, U_Ent, Subp, Name_uOutput);
+ else
+ Error_Msg_N ("incorrect expression for output attribute", Expr);
+ return;
+ end if;
+ end Output;
+
+ ----------
+ -- Read --
+ ----------
+
+ when Attribute_Read => Read : declare
+ Subp : Entity_Id := Empty;
+ I : Interp_Index;
+ It : Interp;
+ Pnam : Entity_Id;
+
+ function Has_Good_Profile (Subp : Entity_Id) return Boolean;
+ -- Return true if the entity is a procedure with an appropriate
+ -- profile for the Read attribute.
+
+ function Has_Good_Profile (Subp : Entity_Id) return Boolean is
+ F : Entity_Id;
+ Ok : Boolean := False;
+
+ begin
+ if Ekind (Subp) = E_Procedure then
+ F := First_Formal (Subp);
+
+ if Present (F) then
+ if Ekind (Etype (F)) = E_Anonymous_Access_Type
+ and then
+ Designated_Type (Etype (F)) =
+ Class_Wide_Type (RTE (RE_Root_Stream_Type))
+ then
+ Next_Formal (F);
+ Ok := Present (F)
+ and then Parameter_Mode (F) = E_Out_Parameter
+ and then Base_Type (Etype (F)) = Base_Type (Ent)
+ and then No (Next_Formal (F));
+ end if;
+ end if;
+ end if;
+
+ return Ok;
+ end Has_Good_Profile;
+
+ -- Start of processing for Read attribute definition
+
+ begin
+ FOnly := True;
+
+ if not Is_Type (U_Ent) then
+ Error_Msg_N ("local name must be a subtype", Nam);
+ return;
+
+ else
+ Pnam := TSS (Base_Type (U_Ent), Name_uRead);
+
+ if Present (Pnam)
+ and then Base_Type (Etype (Next_Formal (First_Formal (Pnam))))
+ = Base_Type (U_Ent)
+ then
+ Error_Msg_Sloc := Sloc (Pnam);
+ Error_Msg_N ("read attribute already defined #", Nam);
+ return;
+ end if;
+ end if;
+
+ Analyze (Expr);
+
+ if Is_Entity_Name (Expr) then
+ if not Is_Overloaded (Expr) then
+ if Has_Good_Profile (Entity (Expr)) then
+ Subp := Entity (Expr);
+ end if;
+
+ else
+ Get_First_Interp (Expr, I, It);
+
+ while Present (It.Nam) loop
+ if Has_Good_Profile (It.Nam) then
+ Subp := It.Nam;
+ exit;
+ end if;
+
+ Get_Next_Interp (I, It);
+ end loop;
+ end if;
+ end if;
+
+ if Present (Subp) then
+ Set_Entity (Expr, Subp);
+ Set_Etype (Expr, Etype (Subp));
+ New_Stream_Procedure (N, U_Ent, Subp, Name_uRead, True);
+ else
+ Error_Msg_N ("incorrect expression for read attribute", Expr);
+ return;
+ end if;
+ end Read;
+
+ ----------
+ -- Size --
+ ----------
+
+ -- Size attribute definition clause
+
+ when Attribute_Size => Size : declare
+ Size : constant Uint := Static_Integer (Expr);
+ Etyp : Entity_Id;
+ Biased : Boolean;
+
+ begin
+ FOnly := True;
+
+ if Has_Size_Clause (U_Ent) then
+ Error_Msg_N ("size already given for &", Nam);
+
+ elsif not Is_Type (U_Ent)
+ and then Ekind (U_Ent) /= E_Variable
+ and then Ekind (U_Ent) /= E_Constant
+ then
+ Error_Msg_N ("size cannot be given for &", Nam);
+
+ elsif Is_Array_Type (U_Ent)
+ and then not Is_Constrained (U_Ent)
+ then
+ Error_Msg_N
+ ("size cannot be given for unconstrained array", Nam);
+
+ elsif Size /= No_Uint then
+
+ if Is_Type (U_Ent) then
+ Etyp := U_Ent;
+ else
+ Etyp := Etype (U_Ent);
+ end if;
+
+ -- Check size, note that Gigi is in charge of checking
+ -- that the size of an array or record type is OK. Also
+ -- we do not check the size in the ordinary fixed-point
+ -- case, since it is too early to do so (there may be a
+ -- subsequent small clause that affects the size). We can
+ -- check the size if a small clause has already been given.
+
+ if not Is_Ordinary_Fixed_Point_Type (U_Ent)
+ or else Has_Small_Clause (U_Ent)
+ then
+ Check_Size (Expr, Etyp, Size, Biased);
+ Set_Has_Biased_Representation (U_Ent, Biased);
+ end if;
+
+ -- For types set RM_Size and Esize if possible
+
+ if Is_Type (U_Ent) then
+ Set_RM_Size (U_Ent, Size);
+
+ -- For scalar types, increase Object_Size to power of 2,
+ -- but not less than 8 in any case, i.e. byte addressable.
+
+ if Is_Scalar_Type (U_Ent) then
+ if Size <= 8 then
+ Init_Esize (U_Ent, 8);
+ elsif Size <= 16 then
+ Init_Esize (U_Ent, 16);
+ elsif Size <= 32 then
+ Init_Esize (U_Ent, 32);
+ else
+ Set_Esize (U_Ent, (Size + 63) / 64 * 64);
+ end if;
+
+ -- For all other types, object size = value size. The
+ -- backend will adjust as needed.
+
+ else
+ Set_Esize (U_Ent, Size);
+ end if;
+
+ Alignment_Check_For_Esize_Change (U_Ent);
+
+ -- For objects, set Esize only
+
+ else
+ Set_Esize (U_Ent, Size);
+ end if;
+
+ Set_Has_Size_Clause (U_Ent);
+ end if;
+ end Size;
+
+ -----------
+ -- Small --
+ -----------
+
+ -- Small attribute definition clause
+
+ when Attribute_Small => Small : declare
+ Implicit_Base : constant Entity_Id := Base_Type (U_Ent);
+ Small : Ureal;
+
+ begin
+ Analyze_And_Resolve (Expr, Any_Real);
+
+ if Etype (Expr) = Any_Type then
+ return;
+
+ elsif not Is_Static_Expression (Expr) then
+ Error_Msg_N ("small requires static expression", Expr);
+ return;
+
+ else
+ Small := Expr_Value_R (Expr);
+
+ if Small <= Ureal_0 then
+ Error_Msg_N ("small value must be greater than zero", Expr);
+ return;
+ end if;
+
+ end if;
+
+ if not Is_Ordinary_Fixed_Point_Type (U_Ent) then
+ Error_Msg_N
+ ("small requires an ordinary fixed point type", Nam);
+
+ elsif Has_Small_Clause (U_Ent) then
+ Error_Msg_N ("small already given for &", Nam);
+
+ elsif Small > Delta_Value (U_Ent) then
+ Error_Msg_N
+ ("small value must not be greater then delta value", Nam);
+
+ else
+ Set_Small_Value (U_Ent, Small);
+ Set_Small_Value (Implicit_Base, Small);
+ Set_Has_Small_Clause (U_Ent);
+ Set_Has_Small_Clause (Implicit_Base);
+ Set_Has_Non_Standard_Rep (Implicit_Base);
+ end if;
+ end Small;
+
+ ------------------
+ -- Storage_Size --
+ ------------------
+
+ -- Storage_Size attribute definition clause
+
+ when Attribute_Storage_Size => Storage_Size : declare
+ Btype : constant Entity_Id := Base_Type (U_Ent);
+ Sprag : Node_Id;
+
+ begin
+ if Is_Task_Type (U_Ent) then
+ FOnly := True;
+ end if;
+
+ if not Is_Access_Type (U_Ent)
+ and then Ekind (U_Ent) /= E_Task_Type
+ then
+ Error_Msg_N ("storage size cannot be given for &", Nam);
+
+ elsif Is_Access_Type (U_Ent) and Is_Derived_Type (U_Ent) then
+ Error_Msg_N
+ ("storage size cannot be given for a derived access type",
+ Nam);
+
+ elsif Has_Storage_Size_Clause (Btype) then
+ Error_Msg_N ("storage size already given for &", Nam);
+
+ else
+ Analyze_And_Resolve (Expr, Any_Integer);
+
+ if Is_Access_Type (U_Ent) then
+
+ if Present (Associated_Storage_Pool (U_Ent)) then
+ Error_Msg_N ("storage pool already given for &", Nam);
+ return;
+ end if;
+
+ if Compile_Time_Known_Value (Expr)
+ and then Expr_Value (Expr) = 0
+ then
+ Set_No_Pool_Assigned (Btype);
+ end if;
+
+ else -- Is_Task_Type (U_Ent)
+ Sprag := Get_Rep_Pragma (Btype, Name_Storage_Size);
+
+ if Present (Sprag) then
+ Error_Msg_Sloc := Sloc (Sprag);
+ Error_Msg_N
+ ("Storage_Size already specified#", Nam);
+ return;
+ end if;
+ end if;
+
+ Set_Has_Storage_Size_Clause (Btype);
+ end if;
+ end Storage_Size;
+
+ ------------------
+ -- Storage_Pool --
+ ------------------
+
+ -- Storage_Pool attribute definition clause
+
+ when Attribute_Storage_Pool => Storage_Pool : declare
+ Pool : Entity_Id;
+
+ begin
+ if Ekind (U_Ent) /= E_Access_Type
+ and then Ekind (U_Ent) /= E_General_Access_Type
+ then
+ Error_Msg_N (
+ "storage pool can only be given for access types", Nam);
+ return;
+
+ elsif Is_Derived_Type (U_Ent) then
+ Error_Msg_N
+ ("storage pool cannot be given for a derived access type",
+ Nam);
+
+ elsif Has_Storage_Size_Clause (U_Ent) then
+ Error_Msg_N ("storage size already given for &", Nam);
+ return;
+
+ elsif Present (Associated_Storage_Pool (U_Ent)) then
+ Error_Msg_N ("storage pool already given for &", Nam);
+ return;
+ end if;
+
+ Analyze_And_Resolve
+ (Expr, Class_Wide_Type (RTE (RE_Root_Storage_Pool)));
+
+ -- If the argument is a name that is not an entity name, then
+ -- we construct a renaming operation to define an entity of
+ -- type storage pool.
+
+ if not Is_Entity_Name (Expr)
+ and then Is_Object_Reference (Expr)
+ then
+ Pool :=
+ Make_Defining_Identifier (Loc,
+ Chars => New_Internal_Name ('P'));
+
+ declare
+ Rnode : constant Node_Id :=
+ Make_Object_Renaming_Declaration (Loc,
+ Defining_Identifier => Pool,
+ Subtype_Mark =>
+ New_Occurrence_Of (Etype (Expr), Loc),
+ Name => Expr);
+
+ begin
+ Insert_Before (N, Rnode);
+ Analyze (Rnode);
+ Set_Associated_Storage_Pool (U_Ent, Pool);
+ end;
+
+ elsif Is_Entity_Name (Expr) then
+ Pool := Entity (Expr);
+
+ -- If pool is a renamed object, get original one. This can
+ -- happen with an explicit renaming, and within instances.
+
+ while Present (Renamed_Object (Pool))
+ and then Is_Entity_Name (Renamed_Object (Pool))
+ loop
+ Pool := Entity (Renamed_Object (Pool));
+ end loop;
+
+ if Present (Renamed_Object (Pool))
+ and then Nkind (Renamed_Object (Pool)) = N_Type_Conversion
+ and then Is_Entity_Name (Expression (Renamed_Object (Pool)))
+ then
+ Pool := Entity (Expression (Renamed_Object (Pool)));
+ end if;
+
+ if Present (Etype (Pool))
+ and then Etype (Pool) /= RTE (RE_Stack_Bounded_Pool)
+ and then Etype (Pool) /= RTE (RE_Unbounded_Reclaim_Pool)
+ then
+ Set_Associated_Storage_Pool (U_Ent, Pool);
+ else
+ Error_Msg_N ("Non sharable GNAT Pool", Expr);
+ end if;
+
+ -- The pool may be specified as the Storage_Pool of some other
+ -- type. It is rewritten as a class_wide conversion of the
+ -- corresponding pool entity.
+
+ elsif Nkind (Expr) = N_Type_Conversion
+ and then Is_Entity_Name (Expression (Expr))
+ and then Nkind (Original_Node (Expr)) = N_Attribute_Reference
+ then
+ Pool := Entity (Expression (Expr));
+
+ if Present (Etype (Pool))
+ and then Etype (Pool) /= RTE (RE_Stack_Bounded_Pool)
+ and then Etype (Pool) /= RTE (RE_Unbounded_Reclaim_Pool)
+ then
+ Set_Associated_Storage_Pool (U_Ent, Pool);
+ else
+ Error_Msg_N ("Non sharable GNAT Pool", Expr);
+ end if;
+
+ else
+ Error_Msg_N ("incorrect reference to a Storage Pool", Expr);
+ return;
+ end if;
+ end Storage_Pool;
+
+ ----------------
+ -- Value_Size --
+ ----------------
+
+ -- Value_Size attribute definition clause
+
+ when Attribute_Value_Size => Value_Size : declare
+ Size : constant Uint := Static_Integer (Expr);
+ Biased : Boolean;
+
+ begin
+ if not Is_Type (U_Ent) then
+ Error_Msg_N ("Value_Size cannot be given for &", Nam);
+
+ elsif Present
+ (Get_Attribute_Definition_Clause
+ (U_Ent, Attribute_Value_Size))
+ then
+ Error_Msg_N ("Value_Size already given for &", Nam);
+
+ else
+ if Is_Elementary_Type (U_Ent) then
+ Check_Size (Expr, U_Ent, Size, Biased);
+ Set_Has_Biased_Representation (U_Ent, Biased);
+ end if;
+
+ Set_RM_Size (U_Ent, Size);
+ end if;
+ end Value_Size;
+
+ -----------
+ -- Write --
+ -----------
+
+ -- Write attribute definition clause
+ -- check for class-wide case will be performed later
+
+ when Attribute_Write => Write : declare
+ Subp : Entity_Id := Empty;
+ I : Interp_Index;
+ It : Interp;
+ Pnam : Entity_Id;
+
+ function Has_Good_Profile (Subp : Entity_Id) return Boolean;
+ -- Return true if the entity is a procedure with an
+ -- appropriate profile for the write attribute.
+
+ function Has_Good_Profile (Subp : Entity_Id) return Boolean is
+ F : Entity_Id;
+ Ok : Boolean := False;
+
+ begin
+ if Ekind (Subp) = E_Procedure then
+ F := First_Formal (Subp);
+
+ if Present (F) then
+ if Ekind (Etype (F)) = E_Anonymous_Access_Type
+ and then
+ Designated_Type (Etype (F)) =
+ Class_Wide_Type (RTE (RE_Root_Stream_Type))
+ then
+ Next_Formal (F);
+ Ok := Present (F)
+ and then Parameter_Mode (F) = E_In_Parameter
+ and then Base_Type (Etype (F)) = Base_Type (Ent)
+ and then No (Next_Formal (F));
+ end if;
+ end if;
+ end if;
+
+ return Ok;
+ end Has_Good_Profile;
+
+ -- Start of processing for Write attribute definition
+
+ begin
+ FOnly := True;
+
+ if not Is_Type (U_Ent) then
+ Error_Msg_N ("local name must be a subtype", Nam);
+ return;
+ end if;
+
+ Pnam := TSS (Base_Type (U_Ent), Name_uWrite);
+
+ if Present (Pnam)
+ and then Base_Type (Etype (Next_Formal (First_Formal (Pnam))))
+ = Base_Type (U_Ent)
+ then
+ Error_Msg_Sloc := Sloc (Pnam);
+ Error_Msg_N ("write attribute already defined #", Nam);
+ return;
+ end if;
+
+ Analyze (Expr);
+
+ if Is_Entity_Name (Expr) then
+ if not Is_Overloaded (Expr) then
+ if Has_Good_Profile (Entity (Expr)) then
+ Subp := Entity (Expr);
+ end if;
+
+ else
+ Get_First_Interp (Expr, I, It);
+
+ while Present (It.Nam) loop
+ if Has_Good_Profile (It.Nam) then
+ Subp := It.Nam;
+ exit;
+ end if;
+
+ Get_Next_Interp (I, It);
+ end loop;
+ end if;
+ end if;
+
+ if Present (Subp) then
+ Set_Entity (Expr, Subp);
+ Set_Etype (Expr, Etype (Subp));
+ New_Stream_Procedure (N, U_Ent, Subp, Name_uWrite);
+ else
+ Error_Msg_N ("incorrect expression for write attribute", Expr);
+ return;
+ end if;
+ end Write;
+
+ -- All other attributes cannot be set
+
+ when others =>
+ Error_Msg_N
+ ("attribute& cannot be set with definition clause", N);
+
+ end case;
+
+ -- The test for the type being frozen must be performed after
+ -- any expression the clause has been analyzed since the expression
+ -- itself might cause freezing that makes the clause illegal.
+
+ if Rep_Item_Too_Late (U_Ent, N, FOnly) then
+ return;
+ end if;
+ end Analyze_Attribute_Definition_Clause;
+
+ ----------------------------
+ -- Analyze_Code_Statement --
+ ----------------------------
+
+ procedure Analyze_Code_Statement (N : Node_Id) is
+ HSS : constant Node_Id := Parent (N);
+ SBody : constant Node_Id := Parent (HSS);
+ Subp : constant Entity_Id := Current_Scope;
+ Stmt : Node_Id;
+ Decl : Node_Id;
+ StmtO : Node_Id;
+ DeclO : Node_Id;
+
+ begin
+ -- Analyze and check we get right type, note that this implements the
+ -- requirement (RM 13.8(1)) that Machine_Code be with'ed, since that
+ -- is the only way that Asm_Insn could possibly be visible.
+
+ Analyze_And_Resolve (Expression (N));
+
+ if Etype (Expression (N)) = Any_Type then
+ return;
+ elsif Etype (Expression (N)) /= RTE (RE_Asm_Insn) then
+ Error_Msg_N ("incorrect type for code statement", N);
+ return;
+ end if;
+
+ -- Make sure we appear in the handled statement sequence of a
+ -- subprogram (RM 13.8(3)).
+
+ if Nkind (HSS) /= N_Handled_Sequence_Of_Statements
+ or else Nkind (SBody) /= N_Subprogram_Body
+ then
+ Error_Msg_N
+ ("code statement can only appear in body of subprogram", N);
+ return;
+ end if;
+
+ -- Do remaining checks (RM 13.8(3)) if not already done
+
+ if not Is_Machine_Code_Subprogram (Subp) then
+ Set_Is_Machine_Code_Subprogram (Subp);
+
+ -- No exception handlers allowed
+
+ if Present (Exception_Handlers (HSS)) then
+ Error_Msg_N
+ ("exception handlers not permitted in machine code subprogram",
+ First (Exception_Handlers (HSS)));
+ end if;
+
+ -- No declarations other than use clauses and pragmas (we allow
+ -- certain internally generated declarations as well).
+
+ Decl := First (Declarations (SBody));
+ while Present (Decl) loop
+ DeclO := Original_Node (Decl);
+ if Comes_From_Source (DeclO)
+ and then Nkind (DeclO) /= N_Pragma
+ and then Nkind (DeclO) /= N_Use_Package_Clause
+ and then Nkind (DeclO) /= N_Use_Type_Clause
+ and then Nkind (DeclO) /= N_Implicit_Label_Declaration
+ then
+ Error_Msg_N
+ ("this declaration not allowed in machine code subprogram",
+ DeclO);
+ end if;
+
+ Next (Decl);
+ end loop;
+
+ -- No statements other than code statements, pragmas, and labels.
+ -- Again we allow certain internally generated statements.
+
+ Stmt := First (Statements (HSS));
+ while Present (Stmt) loop
+ StmtO := Original_Node (Stmt);
+ if Comes_From_Source (StmtO)
+ and then Nkind (StmtO) /= N_Pragma
+ and then Nkind (StmtO) /= N_Label
+ and then Nkind (StmtO) /= N_Code_Statement
+ then
+ Error_Msg_N
+ ("this statement is not allowed in machine code subprogram",
+ StmtO);
+ end if;
+
+ Next (Stmt);
+ end loop;
+ end if;
+
+ end Analyze_Code_Statement;
+
+ -----------------------------------------------
+ -- Analyze_Enumeration_Representation_Clause --
+ -----------------------------------------------
+
+ procedure Analyze_Enumeration_Representation_Clause (N : Node_Id) is
+ Ident : constant Node_Id := Identifier (N);
+ Aggr : constant Node_Id := Array_Aggregate (N);
+ Enumtype : Entity_Id;
+ Elit : Entity_Id;
+ Expr : Node_Id;
+ Assoc : Node_Id;
+ Choice : Node_Id;
+ Val : Uint;
+ Err : Boolean := False;
+
+ Lo : constant Uint := Expr_Value (Type_Low_Bound (Universal_Integer));
+ Hi : constant Uint := Expr_Value (Type_High_Bound (Universal_Integer));
+ Min : Uint;
+ Max : Uint;
+
+ begin
+ -- First some basic error checks
+
+ Find_Type (Ident);
+ Enumtype := Entity (Ident);
+
+ if Enumtype = Any_Type
+ or else Rep_Item_Too_Early (Enumtype, N)
+ then
+ return;
+ else
+ Enumtype := Underlying_Type (Enumtype);
+ end if;
+
+ if not Is_Enumeration_Type (Enumtype) then
+ Error_Msg_NE
+ ("enumeration type required, found}",
+ Ident, First_Subtype (Enumtype));
+ return;
+ end if;
+
+ if Scope (Enumtype) /= Current_Scope then
+ Error_Msg_N ("type must be declared in this scope", Ident);
+ return;
+
+ elsif not Is_First_Subtype (Enumtype) then
+ Error_Msg_N ("cannot give enumeration rep clause for subtype", N);
+ return;
+
+ elsif Has_Enumeration_Rep_Clause (Enumtype) then
+ Error_Msg_N ("duplicate enumeration rep clause ignored", N);
+ return;
+
+ elsif Root_Type (Enumtype) = Standard_Character
+ or else Root_Type (Enumtype) = Standard_Wide_Character
+ then
+ Error_Msg_N ("enumeration rep clause not allowed for this type", N);
+
+ else
+ Set_Has_Enumeration_Rep_Clause (Enumtype);
+ Set_Has_Enumeration_Rep_Clause (Base_Type (Enumtype));
+ end if;
+
+ -- Now we process the aggregate. Note that we don't use the normal
+ -- aggregate code for this purpose, because we don't want any of the
+ -- normal expansion activities, and a number of special semantic
+ -- rules apply (including the component type being any integer type)
+
+ -- Badent signals that we found some incorrect entries processing
+ -- the list. The final checks for completeness and ordering are
+ -- skipped in this case.
+
+ Elit := First_Literal (Enumtype);
+
+ -- First the positional entries if any
+
+ if Present (Expressions (Aggr)) then
+ Expr := First (Expressions (Aggr));
+ while Present (Expr) loop
+ if No (Elit) then
+ Error_Msg_N ("too many entries in aggregate", Expr);
+ return;
+ end if;
+
+ Val := Static_Integer (Expr);
+
+ if Val = No_Uint then
+ Err := True;
+
+ elsif Val < Lo or else Hi < Val then
+ Error_Msg_N ("value outside permitted range", Expr);
+ Err := True;
+ end if;
+
+ Set_Enumeration_Rep (Elit, Val);
+ Set_Enumeration_Rep_Expr (Elit, Expr);
+ Next (Expr);
+ Next (Elit);
+ end loop;
+ end if;
+
+ -- Now process the named entries if present
+
+ if Present (Component_Associations (Aggr)) then
+ Assoc := First (Component_Associations (Aggr));
+ while Present (Assoc) loop
+ Choice := First (Choices (Assoc));
+
+ if Present (Next (Choice)) then
+ Error_Msg_N
+ ("multiple choice not allowed here", Next (Choice));
+ Err := True;
+ end if;
+
+ if Nkind (Choice) = N_Others_Choice then
+ Error_Msg_N ("others choice not allowed here", Choice);
+ Err := True;
+
+ elsif Nkind (Choice) = N_Range then
+ -- ??? should allow zero/one element range here
+ Error_Msg_N ("range not allowed here", Choice);
+ Err := True;
+
+ else
+ Analyze_And_Resolve (Choice, Enumtype);
+
+ if Is_Entity_Name (Choice)
+ and then Is_Type (Entity (Choice))
+ then
+ Error_Msg_N ("subtype name not allowed here", Choice);
+ Err := True;
+ -- ??? should allow static subtype with zero/one entry
+
+ elsif Etype (Choice) = Base_Type (Enumtype) then
+ if not Is_Static_Expression (Choice) then
+ Error_Msg_N
+ ("non-static expression used for choice", Choice);
+ Err := True;
+
+ else
+ Elit := Expr_Value_E (Choice);
+
+ if Present (Enumeration_Rep_Expr (Elit)) then
+ Error_Msg_Sloc := Sloc (Enumeration_Rep_Expr (Elit));
+ Error_Msg_NE
+ ("representation for& previously given#",
+ Choice, Elit);
+ Err := True;
+ end if;
+
+ Set_Enumeration_Rep_Expr (Elit, Choice);
+
+ Expr := Expression (Assoc);
+ Val := Static_Integer (Expr);
+
+ if Val = No_Uint then
+ Err := True;
+
+ elsif Val < Lo or else Hi < Val then
+ Error_Msg_N ("value outside permitted range", Expr);
+ Err := True;
+ end if;
+
+ Set_Enumeration_Rep (Elit, Val);
+ end if;
+ end if;
+ end if;
+
+ Next (Assoc);
+ end loop;
+ end if;
+
+ -- Aggregate is fully processed. Now we check that a full set of
+ -- representations was given, and that they are in range and in order.
+ -- These checks are only done if no other errors occurred.
+
+ if not Err then
+ Min := No_Uint;
+ Max := No_Uint;
+
+ Elit := First_Literal (Enumtype);
+ while Present (Elit) loop
+ if No (Enumeration_Rep_Expr (Elit)) then
+ Error_Msg_NE ("missing representation for&!", N, Elit);
+
+ else
+ Val := Enumeration_Rep (Elit);
+
+ if Min = No_Uint then
+ Min := Val;
+ end if;
+
+ if Val /= No_Uint then
+ if Max /= No_Uint and then Val <= Max then
+ Error_Msg_NE
+ ("enumeration value for& not ordered!",
+ Enumeration_Rep_Expr (Elit), Elit);
+ end if;
+
+ Max := Val;
+ end if;
+
+ -- If there is at least one literal whose representation
+ -- is not equal to the Pos value, then note that this
+ -- enumeration type has a non-standard representation.
+
+ if Val /= Enumeration_Pos (Elit) then
+ Set_Has_Non_Standard_Rep (Base_Type (Enumtype));
+ end if;
+ end if;
+
+ Next (Elit);
+ end loop;
+
+ -- Now set proper size information
+
+ declare
+ Minsize : Uint := UI_From_Int (Minimum_Size (Enumtype));
+
+ begin
+ if Has_Size_Clause (Enumtype) then
+ if Esize (Enumtype) >= Minsize then
+ null;
+
+ else
+ Minsize :=
+ UI_From_Int (Minimum_Size (Enumtype, Biased => True));
+
+ if Esize (Enumtype) < Minsize then
+ Error_Msg_N ("previously given size is too small", N);
+
+ else
+ Set_Has_Biased_Representation (Enumtype);
+ end if;
+ end if;
+
+ else
+ Set_RM_Size (Enumtype, Minsize);
+ Set_Enum_Esize (Enumtype);
+ end if;
+
+ Set_RM_Size (Base_Type (Enumtype), RM_Size (Enumtype));
+ Set_Esize (Base_Type (Enumtype), Esize (Enumtype));
+ Set_Alignment (Base_Type (Enumtype), Alignment (Enumtype));
+ end;
+ end if;
+
+ -- We repeat the too late test in case it froze itself!
+
+ if Rep_Item_Too_Late (Enumtype, N) then
+ null;
+ end if;
+
+ end Analyze_Enumeration_Representation_Clause;
+
+ ----------------------------
+ -- Analyze_Free_Statement --
+ ----------------------------
+
+ procedure Analyze_Free_Statement (N : Node_Id) is
+ begin
+ Analyze (Expression (N));
+ end Analyze_Free_Statement;
+
+ ------------------------------------------
+ -- Analyze_Record_Representation_Clause --
+ ------------------------------------------
+
+ procedure Analyze_Record_Representation_Clause (N : Node_Id) is
+ Loc : constant Source_Ptr := Sloc (N);
+ Ident : constant Node_Id := Identifier (N);
+ Rectype : Entity_Id;
+ Fent : Entity_Id;
+ CC : Node_Id;
+ Posit : Uint;
+ Fbit : Uint;
+ Lbit : Uint;
+ Hbit : Uint := Uint_0;
+ Comp : Entity_Id;
+ Ocomp : Entity_Id;
+ Biased : Boolean;
+
+ Max_Bit_So_Far : Uint;
+ -- Records the maximum bit position so far. If all field positoins
+ -- are monotonically increasing, then we can skip the circuit for
+ -- checking for overlap, since no overlap is possible.
+
+ Overlap_Check_Required : Boolean;
+ -- Used to keep track of whether or not an overlap check is required
+
+ Ccount : Natural := 0;
+ -- Number of component clauses in record rep clause
+
+ begin
+ Find_Type (Ident);
+ Rectype := Entity (Ident);
+
+ if Rectype = Any_Type
+ or else Rep_Item_Too_Early (Rectype, N)
+ then
+ return;
+ else
+ Rectype := Underlying_Type (Rectype);
+ end if;
+
+ -- First some basic error checks
+
+ if not Is_Record_Type (Rectype) then
+ Error_Msg_NE
+ ("record type required, found}", Ident, First_Subtype (Rectype));
+ return;
+
+ elsif Is_Unchecked_Union (Rectype) then
+ Error_Msg_N
+ ("record rep clause not allowed for Unchecked_Union", N);
+
+ elsif Scope (Rectype) /= Current_Scope then
+ Error_Msg_N ("type must be declared in this scope", N);
+ return;
+
+ elsif not Is_First_Subtype (Rectype) then
+ Error_Msg_N ("cannot give record rep clause for subtype", N);
+ return;
+
+ elsif Has_Record_Rep_Clause (Rectype) then
+ Error_Msg_N ("duplicate record rep clause ignored", N);
+ return;
+
+ elsif Rep_Item_Too_Late (Rectype, N) then
+ return;
+ end if;
+
+ if Present (Mod_Clause (N)) then
+ declare
+ Loc : constant Source_Ptr := Sloc (N);
+ M : constant Node_Id := Mod_Clause (N);
+ P : constant List_Id := Pragmas_Before (M);
+ Mod_Val : Uint;
+ AtM_Nod : Node_Id;
+
+ begin
+ if Present (P) then
+ Analyze_List (P);
+ end if;
+
+ -- In Tree_Output mode, expansion is disabled, but we must
+ -- convert the Mod clause into an alignment clause anyway, so
+ -- that the back-end can compute and back-annotate properly the
+ -- size and alignment of types that may include this record.
+
+ if Operating_Mode = Check_Semantics
+ and then Tree_Output
+ then
+ AtM_Nod :=
+ Make_Attribute_Definition_Clause (Loc,
+ Name => New_Reference_To (Base_Type (Rectype), Loc),
+ Chars => Name_Alignment,
+ Expression => Relocate_Node (Expression (M)));
+
+ Set_From_At_Mod (AtM_Nod);
+ Insert_After (N, AtM_Nod);
+ Mod_Val := Get_Alignment_Value (Expression (AtM_Nod));
+ Set_Mod_Clause (N, Empty);
+
+ else
+ -- Get the alignment value to perform error checking
+
+ Mod_Val := Get_Alignment_Value (Expression (M));
+
+ end if;
+ end;
+ end if;
+
+ -- Clear any existing component clauses for the type (this happens
+ -- with derived types, where we are now overriding the original)
+
+ Fent := First_Entity (Rectype);
+
+ Comp := Fent;
+ while Present (Comp) loop
+ if Ekind (Comp) = E_Component
+ or else Ekind (Comp) = E_Discriminant
+ then
+ Set_Component_Clause (Comp, Empty);
+ end if;
+
+ Next_Entity (Comp);
+ end loop;
+
+ -- All done if no component clauses
+
+ CC := First (Component_Clauses (N));
+
+ if No (CC) then
+ return;
+ end if;
+
+ -- If a tag is present, then create a component clause that places
+ -- it at the start of the record (otherwise gigi may place it after
+ -- other fields that have rep clauses).
+
+ if Nkind (Fent) = N_Defining_Identifier
+ and then Chars (Fent) = Name_uTag
+ then
+ Set_Component_Bit_Offset (Fent, Uint_0);
+ Set_Normalized_Position (Fent, Uint_0);
+ Set_Normalized_First_Bit (Fent, Uint_0);
+ Set_Normalized_Position_Max (Fent, Uint_0);
+ Init_Esize (Fent, System_Address_Size);
+
+ Set_Component_Clause (Fent,
+ Make_Component_Clause (Loc,
+ Component_Name =>
+ Make_Identifier (Loc,
+ Chars => Name_uTag),
+
+ Position =>
+ Make_Integer_Literal (Loc,
+ Intval => Uint_0),
+
+ First_Bit =>
+ Make_Integer_Literal (Loc,
+ Intval => Uint_0),
+
+ Last_Bit =>
+ Make_Integer_Literal (Loc,
+ UI_From_Int (System_Address_Size))));
+
+ Ccount := Ccount + 1;
+ end if;
+
+ Set_Has_Record_Rep_Clause (Rectype);
+ Set_Has_Specified_Layout (Rectype);
+
+ -- A representation like this applies to the base type as well
+
+ Set_Has_Record_Rep_Clause (Base_Type (Rectype));
+ Set_Has_Non_Standard_Rep (Base_Type (Rectype));
+ Set_Has_Specified_Layout (Base_Type (Rectype));
+
+ Max_Bit_So_Far := Uint_Minus_1;
+ Overlap_Check_Required := False;
+
+ -- Process the component clauses
+
+ while Present (CC) loop
+
+ -- If pragma, just analyze it
+
+ if Nkind (CC) = N_Pragma then
+ Analyze (CC);
+
+ -- Processing for real component clause
+
+ else
+ Ccount := Ccount + 1;
+ Posit := Static_Integer (Position (CC));
+ Fbit := Static_Integer (First_Bit (CC));
+ Lbit := Static_Integer (Last_Bit (CC));
+
+ if Posit /= No_Uint
+ and then Fbit /= No_Uint
+ and then Lbit /= No_Uint
+ then
+ if Posit < 0 then
+ Error_Msg_N
+ ("position cannot be negative", Position (CC));
+
+ elsif Fbit < 0 then
+ Error_Msg_N
+ ("first bit cannot be negative", First_Bit (CC));
+
+ -- Values look OK, so find the corresponding record component
+ -- Even though the syntax allows an attribute reference for
+ -- implementation-defined components, GNAT does not allow the
+ -- tag to get an explicit position.
+
+ elsif Nkind (Component_Name (CC)) = N_Attribute_Reference then
+
+ if Attribute_Name (Component_Name (CC)) = Name_Tag then
+ Error_Msg_N ("position of tag cannot be specified", CC);
+ else
+ Error_Msg_N ("illegal component name", CC);
+ end if;
+
+ else
+ Comp := First_Entity (Rectype);
+ while Present (Comp) loop
+ exit when Chars (Comp) = Chars (Component_Name (CC));
+ Next_Entity (Comp);
+ end loop;
+
+ if No (Comp) then
+
+ -- Maybe component of base type that is absent from
+ -- statically constrained first subtype.
+
+ Comp := First_Entity (Base_Type (Rectype));
+ while Present (Comp) loop
+ exit when Chars (Comp) = Chars (Component_Name (CC));
+ Next_Entity (Comp);
+ end loop;
+ end if;
+
+ if No (Comp) then
+ Error_Msg_N
+ ("component clause is for non-existent field", CC);
+
+ elsif Present (Component_Clause (Comp)) then
+ Error_Msg_Sloc := Sloc (Component_Clause (Comp));
+ Error_Msg_N
+ ("component clause previously given#", CC);
+
+ else
+ -- Update Fbit and Lbit to the actual bit number.
+
+ Fbit := Fbit + UI_From_Int (SSU) * Posit;
+ Lbit := Lbit + UI_From_Int (SSU) * Posit;
+
+ if Fbit <= Max_Bit_So_Far then
+ Overlap_Check_Required := True;
+ else
+ Max_Bit_So_Far := Lbit;
+ end if;
+
+ if Has_Size_Clause (Rectype)
+ and then Esize (Rectype) <= Lbit
+ then
+ Error_Msg_N
+ ("bit number out of range of specified size",
+ Last_Bit (CC));
+ else
+ Set_Component_Clause (Comp, CC);
+ Set_Component_Bit_Offset (Comp, Fbit);
+ Set_Esize (Comp, 1 + (Lbit - Fbit));
+ Set_Normalized_First_Bit (Comp, Fbit mod SSU);
+ Set_Normalized_Position (Comp, Fbit / SSU);
+
+ Set_Normalized_Position_Max
+ (Fent, Normalized_Position (Fent));
+
+ if Is_Tagged_Type (Rectype)
+ and then Fbit < System_Address_Size
+ then
+ Error_Msg_NE
+ ("component overlaps tag field of&",
+ CC, Rectype);
+ end if;
+
+ -- Test for large object that is not on a byte
+ -- boundary, defined as a large packed array not
+ -- represented by a modular type, or an object for
+ -- which a size of greater than 64 bits is specified.
+
+ if Fbit mod SSU /= 0 then
+ if (Is_Packed_Array_Type (Etype (Comp))
+ and then Is_Array_Type
+ (Packed_Array_Type (Etype (Comp))))
+ or else Esize (Etype (Comp)) > 64
+ then
+ Error_Msg_N
+ ("large component must be on byte boundary",
+ First_Bit (CC));
+ end if;
+ end if;
+
+ -- This information is also set in the
+ -- corresponding component of the base type,
+ -- found by accessing the Original_Record_Component
+ -- link if it is present.
+
+ Ocomp := Original_Record_Component (Comp);
+
+ if Hbit < Lbit then
+ Hbit := Lbit;
+ end if;
+
+ Check_Size
+ (Component_Name (CC),
+ Etype (Comp),
+ Esize (Comp),
+ Biased);
+
+ Set_Has_Biased_Representation (Comp, Biased);
+
+ if Present (Ocomp) then
+ Set_Component_Clause (Ocomp, CC);
+ Set_Component_Bit_Offset (Ocomp, Fbit);
+ Set_Normalized_First_Bit (Ocomp, Fbit mod SSU);
+ Set_Normalized_Position (Ocomp, Fbit / SSU);
+ Set_Esize (Ocomp, 1 + (Lbit - Fbit));
+
+ Set_Normalized_Position_Max
+ (Ocomp, Normalized_Position (Ocomp));
+
+ Set_Has_Biased_Representation
+ (Ocomp, Has_Biased_Representation (Comp));
+ end if;
+
+ if Esize (Comp) < 0 then
+ Error_Msg_N ("component size is negative", CC);
+ end if;
+ end if;
+ end if;
+ end if;
+ end if;
+ end if;
+
+ Next (CC);
+ end loop;
+
+ -- Now that we have processed all the component clauses, check for
+ -- overlap. We have to leave this till last, since the components
+ -- can appear in any arbitrary order in the representation clause.
+
+ -- We do not need this check if all specified ranges were monotonic,
+ -- as recorded by Overlap_Check_Required being False at this stage.
+
+ -- This first section checks if there are any overlapping entries
+ -- at all. It does this by sorting all entries and then seeing if
+ -- there are any overlaps. If there are none, then that is decisive,
+ -- but if there are overlaps, they may still be OK (they may result
+ -- from fields in different variants).
+
+ if Overlap_Check_Required then
+ Overlap_Check1 : declare
+
+ OC_Fbit : array (0 .. Ccount) of Uint;
+ -- First-bit values for component clauses, the value is the
+ -- offset of the first bit of the field from start of record.
+ -- The zero entry is for use in sorting.
+
+ OC_Lbit : array (0 .. Ccount) of Uint;
+ -- Last-bit values for component clauses, the value is the
+ -- offset of the last bit of the field from start of record.
+ -- The zero entry is for use in sorting.
+
+ OC_Count : Natural := 0;
+ -- Count of entries in OC_Fbit and OC_Lbit
+
+ function OC_Lt (Op1, Op2 : Natural) return Boolean;
+ -- Compare routine for Sort (See GNAT.Heap_Sort_A)
+
+ procedure OC_Move (From : Natural; To : Natural);
+ -- Move routine for Sort (see GNAT.Heap_Sort_A)
+
+ function OC_Lt (Op1, Op2 : Natural) return Boolean is
+ begin
+ return OC_Fbit (Op1) < OC_Fbit (Op2);
+ end OC_Lt;
+
+ procedure OC_Move (From : Natural; To : Natural) is
+ begin
+ OC_Fbit (To) := OC_Fbit (From);
+ OC_Lbit (To) := OC_Lbit (From);
+ end OC_Move;
+
+ begin
+ CC := First (Component_Clauses (N));
+ while Present (CC) loop
+ if Nkind (CC) /= N_Pragma then
+ Posit := Static_Integer (Position (CC));
+ Fbit := Static_Integer (First_Bit (CC));
+ Lbit := Static_Integer (Last_Bit (CC));
+
+ if Posit /= No_Uint
+ and then Fbit /= No_Uint
+ and then Lbit /= No_Uint
+ then
+ OC_Count := OC_Count + 1;
+ Posit := Posit * SSU;
+ OC_Fbit (OC_Count) := Fbit + Posit;
+ OC_Lbit (OC_Count) := Lbit + Posit;
+ end if;
+ end if;
+
+ Next (CC);
+ end loop;
+
+ Sort
+ (OC_Count,
+ OC_Move'Unrestricted_Access,
+ OC_Lt'Unrestricted_Access);
+
+ Overlap_Check_Required := False;
+ for J in 1 .. OC_Count - 1 loop
+ if OC_Lbit (J) >= OC_Fbit (J + 1) then
+ Overlap_Check_Required := True;
+ exit;
+ end if;
+ end loop;
+ end Overlap_Check1;
+ end if;
+
+ -- If Overlap_Check_Required is still True, then we have to do
+ -- the full scale overlap check, since we have at least two fields
+ -- that do overlap, and we need to know if that is OK since they
+ -- are in the same variant, or whether we have a definite problem
+
+ if Overlap_Check_Required then
+ Overlap_Check2 : declare
+ C1_Ent, C2_Ent : Entity_Id;
+ -- Entities of components being checked for overlap
+
+ Clist : Node_Id;
+ -- Component_List node whose Component_Items are being checked
+
+ Citem : Node_Id;
+ -- Component declaration for component being checked
+
+ begin
+ C1_Ent := First_Entity (Base_Type (Rectype));
+
+ -- Loop through all components in record. For each component check
+ -- for overlap with any of the preceding elements on the component
+ -- list containing the component, and also, if the component is in
+ -- a variant, check against components outside the case structure.
+ -- This latter test is repeated recursively up the variant tree.
+
+ Main_Component_Loop : while Present (C1_Ent) loop
+ if Ekind (C1_Ent) /= E_Component
+ and then Ekind (C1_Ent) /= E_Discriminant
+ then
+ goto Continue_Main_Component_Loop;
+ end if;
+
+ -- Skip overlap check if entity has no declaration node. This
+ -- happens with discriminants in constrained derived types.
+ -- Probably we are missing some checks as a result, but that
+ -- does not seem terribly serious ???
+
+ if No (Declaration_Node (C1_Ent)) then
+ goto Continue_Main_Component_Loop;
+ end if;
+
+ Clist := Parent (List_Containing (Declaration_Node (C1_Ent)));
+
+ -- Loop through component lists that need checking. Check the
+ -- current component list and all lists in variants above us.
+
+ Component_List_Loop : loop
+
+ -- If derived type definition, go to full declaration
+ -- If at outer level, check discriminants if there are any
+
+ if Nkind (Clist) = N_Derived_Type_Definition then
+ Clist := Parent (Clist);
+ end if;
+
+ -- Outer level of record definition, check discriminants
+
+ if Nkind (Clist) = N_Full_Type_Declaration
+ or else Nkind (Clist) = N_Private_Type_Declaration
+ then
+ if Has_Discriminants (Defining_Identifier (Clist)) then
+ C2_Ent :=
+ First_Discriminant (Defining_Identifier (Clist));
+
+ while Present (C2_Ent) loop
+ exit when C1_Ent = C2_Ent;
+ Check_Component_Overlap (C1_Ent, C2_Ent);
+ Next_Discriminant (C2_Ent);
+ end loop;
+ end if;
+
+ -- Record extension case
+
+ elsif Nkind (Clist) = N_Derived_Type_Definition then
+ Clist := Empty;
+
+ -- Otherwise check one component list
+
+ else
+ Citem := First (Component_Items (Clist));
+
+ while Present (Citem) loop
+ if Nkind (Citem) = N_Component_Declaration then
+ C2_Ent := Defining_Identifier (Citem);
+ exit when C1_Ent = C2_Ent;
+ Check_Component_Overlap (C1_Ent, C2_Ent);
+ end if;
+
+ Next (Citem);
+ end loop;
+ end if;
+
+ -- Check for variants above us (the parent of the Clist can
+ -- be a variant, in which case its parent is a variant part,
+ -- and the parent of the variant part is a component list
+ -- whose components must all be checked against the current
+ -- component for overlap.
+
+ if Nkind (Parent (Clist)) = N_Variant then
+ Clist := Parent (Parent (Parent (Clist)));
+
+ -- Check for possible discriminant part in record, this is
+ -- treated essentially as another level in the recursion.
+ -- For this case we have the parent of the component list
+ -- is the record definition, and its parent is the full
+ -- type declaration which contains the discriminant
+ -- specifications.
+
+ elsif Nkind (Parent (Clist)) = N_Record_Definition then
+ Clist := Parent (Parent ((Clist)));
+
+ -- If neither of these two cases, we are at the top of
+ -- the tree
+
+ else
+ exit Component_List_Loop;
+ end if;
+ end loop Component_List_Loop;
+
+ <<Continue_Main_Component_Loop>>
+ Next_Entity (C1_Ent);
+
+ end loop Main_Component_Loop;
+ end Overlap_Check2;
+ end if;
+
+ -- For records that have component clauses for all components, and
+ -- whose size is less than or equal to 32, we need to know the size
+ -- in the front end to activate possible packed array processing
+ -- where the component type is a record.
+
+ -- At this stage Hbit + 1 represents the first unused bit from all
+ -- the component clauses processed, so if the component clauses are
+ -- complete, then this is the length of the record.
+
+ -- For records longer than System.Storage_Unit, and for those where
+ -- not all components have component clauses, the back end determines
+ -- the length (it may for example be appopriate to round up the size
+ -- to some convenient boundary, based on alignment considerations etc).
+
+ if Unknown_RM_Size (Rectype)
+ and then Hbit + 1 <= 32
+ then
+ -- Nothing to do if at least one component with no component clause
+
+ Comp := First_Entity (Rectype);
+ while Present (Comp) loop
+ if Ekind (Comp) = E_Component
+ or else Ekind (Comp) = E_Discriminant
+ then
+ if No (Component_Clause (Comp)) then
+ return;
+ end if;
+ end if;
+
+ Next_Entity (Comp);
+ end loop;
+
+ -- If we fall out of loop, all components have component clauses
+ -- and so we can set the size to the maximum value.
+
+ Set_RM_Size (Rectype, Hbit + 1);
+ end if;
+
+ end Analyze_Record_Representation_Clause;
+
+ -----------------------------
+ -- Check_Address_Alignment --
+ -----------------------------
+
+ procedure Check_Address_Alignment (E : Entity_Id; Expr : Node_Id) is
+ Arg : Node_Id;
+
+ begin
+ if Nkind (Expr) = N_Unchecked_Type_Conversion then
+ Arg := Expression (Expr);
+
+ elsif Nkind (Expr) = N_Function_Call
+ and then Is_RTE (Entity (Name (Expr)), RE_To_Address)
+ then
+ Arg := First (Parameter_Associations (Expr));
+
+ if Nkind (Arg) = N_Parameter_Association then
+ Arg := Explicit_Actual_Parameter (Arg);
+ end if;
+
+ else
+ return;
+ end if;
+
+ -- Here Arg is the address value
+
+ if Compile_Time_Known_Value (Arg) then
+ if Expr_Value (Arg) mod Alignment (E) /= 0 then
+ Error_Msg_NE
+ ("?specified address for& not consistent with alignment",
+ Arg, E);
+ end if;
+ end if;
+ end Check_Address_Alignment;
+
+ -----------------------------
+ -- Check_Component_Overlap --
+ -----------------------------
+
+ procedure Check_Component_Overlap (C1_Ent, C2_Ent : Entity_Id) is
+ begin
+ if Present (Component_Clause (C1_Ent))
+ and then Present (Component_Clause (C2_Ent))
+ then
+ -- Exclude odd case where we have two tag fields in the same
+ -- record, both at location zero. This seems a bit strange,
+ -- but it seems to happen in some circumstances ???
+
+ if Chars (C1_Ent) = Name_uTag
+ and then Chars (C2_Ent) = Name_uTag
+ then
+ return;
+ end if;
+
+ -- Here we check if the two fields overlap
+
+ declare
+ S1 : constant Uint := Component_Bit_Offset (C1_Ent);
+ S2 : constant Uint := Component_Bit_Offset (C2_Ent);
+ E1 : constant Uint := S1 + Esize (C1_Ent);
+ E2 : constant Uint := S2 + Esize (C2_Ent);
+
+ begin
+ if E2 <= S1 or else E1 <= S2 then
+ null;
+ else
+ Error_Msg_Node_2 :=
+ Component_Name (Component_Clause (C2_Ent));
+ Error_Msg_Sloc := Sloc (Error_Msg_Node_2);
+ Error_Msg_Node_1 :=
+ Component_Name (Component_Clause (C1_Ent));
+ Error_Msg_N
+ ("component& overlaps & #",
+ Component_Name (Component_Clause (C1_Ent)));
+ end if;
+ end;
+ end if;
+ end Check_Component_Overlap;
+
+ -----------------------------------
+ -- Check_Constant_Address_Clause --
+ -----------------------------------
+
+ procedure Check_Constant_Address_Clause
+ (Expr : Node_Id;
+ U_Ent : Entity_Id)
+ is
+ procedure Check_At_Constant_Address (Nod : Node_Id);
+ -- Checks that the given node N represents a name whose 'Address
+ -- is constant (in the same sense as OK_Constant_Address_Clause,
+ -- i.e. the address value is the same at the point of declaration
+ -- of U_Ent and at the time of elaboration of the address clause.
+
+ procedure Check_Expr_Constants (Nod : Node_Id);
+ -- Checks that Nod meets the requirements for a constant address
+ -- clause in the sense of the enclosing procedure.
+
+ procedure Check_List_Constants (Lst : List_Id);
+ -- Check that all elements of list Lst meet the requirements for a
+ -- constant address clause in the sense of the enclosing procedure.
+
+ -------------------------------
+ -- Check_At_Constant_Address --
+ -------------------------------
+
+ procedure Check_At_Constant_Address (Nod : Node_Id) is
+ begin
+ if Is_Entity_Name (Nod) then
+ if Present (Address_Clause (Entity ((Nod)))) then
+ Error_Msg_NE
+ ("invalid address clause for initialized object &!",
+ Nod, U_Ent);
+ Error_Msg_NE
+ ("address for& cannot" &
+ " depend on another address clause! ('R'M 13.1(22))!",
+ Nod, U_Ent);
+
+ elsif In_Same_Source_Unit (Entity (Nod), U_Ent)
+ and then Sloc (U_Ent) < Sloc (Entity (Nod))
+ then
+ Error_Msg_NE
+ ("invalid address clause for initialized object &!",
+ Nod, U_Ent);
+ Error_Msg_Name_1 := Chars (Entity (Nod));
+ Error_Msg_Name_2 := Chars (U_Ent);
+ Error_Msg_N
+ ("\% must be defined before % ('R'M 13.1(22))!",
+ Nod);
+ end if;
+
+ elsif Nkind (Nod) = N_Selected_Component then
+ declare
+ T : constant Entity_Id := Etype (Prefix (Nod));
+
+ begin
+ if (Is_Record_Type (T)
+ and then Has_Discriminants (T))
+ or else
+ (Is_Access_Type (T)
+ and then Is_Record_Type (Designated_Type (T))
+ and then Has_Discriminants (Designated_Type (T)))
+ then
+ Error_Msg_NE
+ ("invalid address clause for initialized object &!",
+ Nod, U_Ent);
+ Error_Msg_N
+ ("\address cannot depend on component" &
+ " of discriminated record ('R'M 13.1(22))!",
+ Nod);
+ else
+ Check_At_Constant_Address (Prefix (Nod));
+ end if;
+ end;
+
+ elsif Nkind (Nod) = N_Indexed_Component then
+ Check_At_Constant_Address (Prefix (Nod));
+ Check_List_Constants (Expressions (Nod));
+
+ else
+ Check_Expr_Constants (Nod);
+ end if;
+ end Check_At_Constant_Address;
+
+ --------------------------
+ -- Check_Expr_Constants --
+ --------------------------
+
+ procedure Check_Expr_Constants (Nod : Node_Id) is
+ begin
+ if Nkind (Nod) in N_Has_Etype
+ and then Etype (Nod) = Any_Type
+ then
+ return;
+ end if;
+
+ case Nkind (Nod) is
+ when N_Empty | N_Error =>
+ return;
+
+ when N_Identifier | N_Expanded_Name =>
+ declare
+ Ent : constant Entity_Id := Entity (Nod);
+ Loc_Ent : constant Source_Ptr := Sloc (Ent);
+ Loc_U_Ent : constant Source_Ptr := Sloc (U_Ent);
+
+ begin
+ if Ekind (Ent) = E_Named_Integer
+ or else
+ Ekind (Ent) = E_Named_Real
+ or else
+ Is_Type (Ent)
+ then
+ return;
+
+ elsif
+ Ekind (Ent) = E_Constant
+ or else
+ Ekind (Ent) = E_In_Parameter
+ then
+ -- This is the case where we must have Ent defined
+ -- before U_Ent. Clearly if they are in different
+ -- units this requirement is met since the unit
+ -- containing Ent is already processed.
+
+ if not In_Same_Source_Unit (Ent, U_Ent) then
+ return;
+
+ -- Otherwise location of Ent must be before the
+ -- location of U_Ent, that's what prior defined means.
+
+ elsif Loc_Ent < Loc_U_Ent then
+ return;
+
+ else
+ Error_Msg_NE
+ ("invalid address clause for initialized object &!",
+ Nod, U_Ent);
+ Error_Msg_Name_1 := Chars (Ent);
+ Error_Msg_Name_2 := Chars (U_Ent);
+ Error_Msg_N
+ ("\% must be defined before % ('R'M 13.1(22))!",
+ Nod);
+ end if;
+
+ elsif Nkind (Original_Node (Nod)) = N_Function_Call then
+ Check_Expr_Constants (Original_Node (Nod));
+
+ else
+ Error_Msg_NE
+ ("invalid address clause for initialized object &!",
+ Nod, U_Ent);
+ Error_Msg_Name_1 := Chars (Ent);
+ Error_Msg_N
+ ("\reference to variable% not allowed ('R'M 13.1(22))!",
+ Nod);
+ end if;
+ end;
+
+ when N_Integer_Literal |
+ N_Real_Literal |
+ N_String_Literal |
+ N_Character_Literal =>
+ return;
+
+ when N_Range =>
+ Check_Expr_Constants (Low_Bound (Nod));
+ Check_Expr_Constants (High_Bound (Nod));
+
+ when N_Explicit_Dereference =>
+ Check_Expr_Constants (Prefix (Nod));
+
+ when N_Indexed_Component =>
+ Check_Expr_Constants (Prefix (Nod));
+ Check_List_Constants (Expressions (Nod));
+
+ when N_Slice =>
+ Check_Expr_Constants (Prefix (Nod));
+ Check_Expr_Constants (Discrete_Range (Nod));
+
+ when N_Selected_Component =>
+ Check_Expr_Constants (Prefix (Nod));
+
+ when N_Attribute_Reference =>
+
+ if (Attribute_Name (Nod) = Name_Address
+ or else
+ Attribute_Name (Nod) = Name_Access
+ or else
+ Attribute_Name (Nod) = Name_Unchecked_Access
+ or else
+ Attribute_Name (Nod) = Name_Unrestricted_Access)
+ then
+ Check_At_Constant_Address (Prefix (Nod));
+
+ else
+ Check_Expr_Constants (Prefix (Nod));
+ Check_List_Constants (Expressions (Nod));
+ end if;
+
+ when N_Aggregate =>
+ Check_List_Constants (Component_Associations (Nod));
+ Check_List_Constants (Expressions (Nod));
+
+ when N_Component_Association =>
+ Check_Expr_Constants (Expression (Nod));
+
+ when N_Extension_Aggregate =>
+ Check_Expr_Constants (Ancestor_Part (Nod));
+ Check_List_Constants (Component_Associations (Nod));
+ Check_List_Constants (Expressions (Nod));
+
+ when N_Null =>
+ return;
+
+ when N_Binary_Op | N_And_Then | N_Or_Else | N_In | N_Not_In =>
+ Check_Expr_Constants (Left_Opnd (Nod));
+ Check_Expr_Constants (Right_Opnd (Nod));
+
+ when N_Unary_Op =>
+ Check_Expr_Constants (Right_Opnd (Nod));
+
+ when N_Type_Conversion |
+ N_Qualified_Expression |
+ N_Allocator =>
+ Check_Expr_Constants (Expression (Nod));
+
+ when N_Unchecked_Type_Conversion =>
+ Check_Expr_Constants (Expression (Nod));
+
+ -- If this is a rewritten unchecked conversion, subtypes
+ -- in this node are those created within the instance.
+ -- To avoid order of elaboration issues, replace them
+ -- with their base types. Note that address clauses can
+ -- cause order of elaboration problems because they are
+ -- elaborated by the back-end at the point of definition,
+ -- and may mention entities declared in between (as long
+ -- as everything is static). It is user-friendly to allow
+ -- unchecked conversions in this context.
+
+ if Nkind (Original_Node (Nod)) = N_Function_Call then
+ Set_Etype (Expression (Nod),
+ Base_Type (Etype (Expression (Nod))));
+ Set_Etype (Nod, Base_Type (Etype (Nod)));
+ end if;
+
+ when N_Function_Call =>
+ if not Is_Pure (Entity (Name (Nod))) then
+ Error_Msg_NE
+ ("invalid address clause for initialized object &!",
+ Nod, U_Ent);
+
+ Error_Msg_NE
+ ("\function & is not pure ('R'M 13.1(22))!",
+ Nod, Entity (Name (Nod)));
+
+ else
+ Check_List_Constants (Parameter_Associations (Nod));
+ end if;
+
+ when N_Parameter_Association =>
+ Check_Expr_Constants (Explicit_Actual_Parameter (Nod));
+
+ when others =>
+ Error_Msg_NE
+ ("invalid address clause for initialized object &!",
+ Nod, U_Ent);
+ Error_Msg_NE
+ ("\must be constant defined before& ('R'M 13.1(22))!",
+ Nod, U_Ent);
+ end case;
+ end Check_Expr_Constants;
+
+ --------------------------
+ -- Check_List_Constants --
+ --------------------------
+
+ procedure Check_List_Constants (Lst : List_Id) is
+ Nod1 : Node_Id;
+
+ begin
+ if Present (Lst) then
+ Nod1 := First (Lst);
+ while Present (Nod1) loop
+ Check_Expr_Constants (Nod1);
+ Next (Nod1);
+ end loop;
+ end if;
+ end Check_List_Constants;
+
+ -- Start of processing for Check_Constant_Address_Clause
+
+ begin
+ Check_Expr_Constants (Expr);
+ end Check_Constant_Address_Clause;
+
+ ----------------
+ -- Check_Size --
+ ----------------
+
+ procedure Check_Size
+ (N : Node_Id;
+ T : Entity_Id;
+ Siz : Uint;
+ Biased : out Boolean)
+ is
+ UT : constant Entity_Id := Underlying_Type (T);
+ M : Uint;
+
+ begin
+ Biased := False;
+
+ -- Immediate return if size is same as standard size or if composite
+ -- item, or generic type, or type with previous errors.
+
+ if No (UT)
+ or else UT = Any_Type
+ or else Is_Generic_Type (UT)
+ or else Is_Generic_Type (Root_Type (UT))
+ or else Is_Composite_Type (UT)
+ or else (Known_Esize (UT) and then Siz = Esize (UT))
+ then
+ return;
+
+ -- For fixed-point types, don't check minimum if type is not frozen,
+ -- since type is not known till then
+ -- at freeze time.
+
+ elsif Is_Fixed_Point_Type (UT)
+ and then not Is_Frozen (UT)
+ then
+ null;
+
+ -- Cases for which a minimum check is required
+
+ else
+ M := UI_From_Int (Minimum_Size (UT));
+
+ if Siz < M then
+
+ -- Size is less than minimum size, but one possibility remains
+ -- that we can manage with the new size if we bias the type
+
+ M := UI_From_Int (Minimum_Size (UT, Biased => True));
+
+ if Siz < M then
+ Error_Msg_Uint_1 := M;
+ Error_Msg_NE
+ ("size for& too small, minimum allowed is ^", N, T);
+ else
+ Biased := True;
+ end if;
+ end if;
+ end if;
+ end Check_Size;
+
+ -------------------------
+ -- Get_Alignment_Value --
+ -------------------------
+
+ function Get_Alignment_Value (Expr : Node_Id) return Uint is
+ Align : constant Uint := Static_Integer (Expr);
+
+ begin
+ if Align = No_Uint then
+ return No_Uint;
+
+ elsif Align <= 0 then
+ Error_Msg_N ("alignment value must be positive", Expr);
+ return No_Uint;
+
+ else
+ for J in Int range 0 .. 64 loop
+ declare
+ M : constant Uint := Uint_2 ** J;
+
+ begin
+ exit when M = Align;
+
+ if M > Align then
+ Error_Msg_N
+ ("alignment value must be power of 2", Expr);
+ return No_Uint;
+ end if;
+ end;
+ end loop;
+
+ return Align;
+ end if;
+ end Get_Alignment_Value;
+
+ -------------------------------------
+ -- Get_Attribute_Definition_Clause --
+ -------------------------------------
+
+ function Get_Attribute_Definition_Clause
+ (E : Entity_Id;
+ Id : Attribute_Id)
+ return Node_Id
+ is
+ N : Node_Id;
+
+ begin
+ N := First_Rep_Item (E);
+ while Present (N) loop
+ if Nkind (N) = N_Attribute_Definition_Clause
+ and then Get_Attribute_Id (Chars (N)) = Id
+ then
+ return N;
+ else
+ Next_Rep_Item (N);
+ end if;
+ end loop;
+
+ return Empty;
+ end Get_Attribute_Definition_Clause;
+
+ --------------------
+ -- Get_Rep_Pragma --
+ --------------------
+
+ function Get_Rep_Pragma (E : Entity_Id; Nam : Name_Id) return Node_Id is
+ N : Node_Id;
+ Typ : Entity_Id;
+
+ begin
+ N := First_Rep_Item (E);
+
+ while Present (N) loop
+ if Nkind (N) = N_Pragma and then Chars (N) = Nam then
+
+ if Nam = Name_Stream_Convert then
+
+ -- For tagged types this pragma is not inherited, so we
+ -- must verify that it is defined for the given type and
+ -- not an ancestor.
+
+ Typ := Entity (Expression
+ (First (Pragma_Argument_Associations (N))));
+
+ if not Is_Tagged_Type (E)
+ or else E = Typ
+ or else (Is_Private_Type (Typ)
+ and then E = Full_View (Typ))
+ then
+ return N;
+ else
+ Next_Rep_Item (N);
+ end if;
+
+ else
+ return N;
+ end if;
+ else
+ Next_Rep_Item (N);
+ end if;
+ end loop;
+
+ return Empty;
+ end Get_Rep_Pragma;
+
+ ----------------
+ -- Initialize --
+ ----------------
+
+ procedure Initialize is
+ begin
+ Unchecked_Conversions.Init;
+ end Initialize;
+
+ -------------------------
+ -- Is_Operational_Item --
+ -------------------------
+
+ function Is_Operational_Item (N : Node_Id) return Boolean is
+ begin
+ if Nkind (N) /= N_Attribute_Definition_Clause then
+ return False;
+ else
+ declare
+ Id : constant Attribute_Id := Get_Attribute_Id (Chars (N));
+
+ begin
+ return Id = Attribute_Input
+ or else Id = Attribute_Output
+ or else Id = Attribute_Read
+ or else Id = Attribute_Write;
+ end;
+ end if;
+ end Is_Operational_Item;
+
+ ------------------
+ -- Minimum_Size --
+ ------------------
+
+ function Minimum_Size
+ (T : Entity_Id;
+ Biased : Boolean := False)
+ return Nat
+ is
+ Lo : Uint := No_Uint;
+ Hi : Uint := No_Uint;
+ LoR : Ureal := No_Ureal;
+ HiR : Ureal := No_Ureal;
+ LoSet : Boolean := False;
+ HiSet : Boolean := False;
+ B : Uint;
+ S : Nat;
+ Ancest : Entity_Id;
+
+ begin
+ -- If bad type, return 0
+
+ if T = Any_Type then
+ return 0;
+
+ -- For generic types, just return zero. There cannot be any legitimate
+ -- need to know such a size, but this routine may be called with a
+ -- generic type as part of normal processing.
+
+ elsif Is_Generic_Type (Root_Type (T)) then
+ return 0;
+
+ -- Access types
+
+ elsif Is_Access_Type (T) then
+ return System_Address_Size;
+
+ -- Floating-point types
+
+ elsif Is_Floating_Point_Type (T) then
+ return UI_To_Int (Esize (Root_Type (T)));
+
+ -- Discrete types
+
+ elsif Is_Discrete_Type (T) then
+
+ -- The following loop is looking for the nearest compile time
+ -- known bounds following the ancestor subtype chain. The idea
+ -- is to find the most restrictive known bounds information.
+
+ Ancest := T;
+ loop
+ if Ancest = Any_Type or else Etype (Ancest) = Any_Type then
+ return 0;
+ end if;
+
+ if not LoSet then
+ if Compile_Time_Known_Value (Type_Low_Bound (Ancest)) then
+ Lo := Expr_Rep_Value (Type_Low_Bound (Ancest));
+ LoSet := True;
+ exit when HiSet;
+ end if;
+ end if;
+
+ if not HiSet then
+ if Compile_Time_Known_Value (Type_High_Bound (Ancest)) then
+ Hi := Expr_Rep_Value (Type_High_Bound (Ancest));
+ HiSet := True;
+ exit when LoSet;
+ end if;
+ end if;
+
+ Ancest := Ancestor_Subtype (Ancest);
+
+ if No (Ancest) then
+ Ancest := Base_Type (T);
+
+ if Is_Generic_Type (Ancest) then
+ return 0;
+ end if;
+ end if;
+ end loop;
+
+ -- Fixed-point types. We can't simply use Expr_Value to get the
+ -- Corresponding_Integer_Value values of the bounds, since these
+ -- do not get set till the type is frozen, and this routine can
+ -- be called before the type is frozen. Similarly the test for
+ -- bounds being static needs to include the case where we have
+ -- unanalyzed real literals for the same reason.
+
+ elsif Is_Fixed_Point_Type (T) then
+
+ -- The following loop is looking for the nearest compile time
+ -- known bounds following the ancestor subtype chain. The idea
+ -- is to find the most restrictive known bounds information.
+
+ Ancest := T;
+ loop
+ if Ancest = Any_Type or else Etype (Ancest) = Any_Type then
+ return 0;
+ end if;
+
+ if not LoSet then
+ if Nkind (Type_Low_Bound (Ancest)) = N_Real_Literal
+ or else Compile_Time_Known_Value (Type_Low_Bound (Ancest))
+ then
+ LoR := Expr_Value_R (Type_Low_Bound (Ancest));
+ LoSet := True;
+ exit when HiSet;
+ end if;
+ end if;
+
+ if not HiSet then
+ if Nkind (Type_High_Bound (Ancest)) = N_Real_Literal
+ or else Compile_Time_Known_Value (Type_High_Bound (Ancest))
+ then
+ HiR := Expr_Value_R (Type_High_Bound (Ancest));
+ HiSet := True;
+ exit when LoSet;
+ end if;
+ end if;
+
+ Ancest := Ancestor_Subtype (Ancest);
+
+ if No (Ancest) then
+ Ancest := Base_Type (T);
+
+ if Is_Generic_Type (Ancest) then
+ return 0;
+ end if;
+ end if;
+ end loop;
+
+ Lo := UR_To_Uint (LoR / Small_Value (T));
+ Hi := UR_To_Uint (HiR / Small_Value (T));
+
+ -- No other types allowed
+
+ else
+ raise Program_Error;
+ end if;
+
+ -- Fall through with Hi and Lo set. Deal with biased case.
+
+ if (Biased and then not Is_Fixed_Point_Type (T))
+ or else Has_Biased_Representation (T)
+ then
+ Hi := Hi - Lo;
+ Lo := Uint_0;
+ end if;
+
+ -- Signed case. Note that we consider types like range 1 .. -1 to be
+ -- signed for the purpose of computing the size, since the bounds
+ -- have to be accomodated in the base type.
+
+ if Lo < 0 or else Hi < 0 then
+ S := 1;
+ B := Uint_1;
+
+ -- S = size, B = 2 ** (size - 1) (can accomodate -B .. +(B - 1))
+ -- Note that we accomodate the case where the bounds cross. This
+ -- can happen either because of the way the bounds are declared
+ -- or because of the algorithm in Freeze_Fixed_Point_Type.
+
+ while Lo < -B
+ or else Hi < -B
+ or else Lo >= B
+ or else Hi >= B
+ loop
+ B := Uint_2 ** S;
+ S := S + 1;
+ end loop;
+
+ -- Unsigned case
+
+ else
+ -- If both bounds are positive, make sure that both are represen-
+ -- table in the case where the bounds are crossed. This can happen
+ -- either because of the way the bounds are declared, or because of
+ -- the algorithm in Freeze_Fixed_Point_Type.
+
+ if Lo > Hi then
+ Hi := Lo;
+ end if;
+
+ -- S = size, (can accomodate 0 .. (2**size - 1))
+
+ S := 0;
+ while Hi >= Uint_2 ** S loop
+ S := S + 1;
+ end loop;
+ end if;
+
+ return S;
+ end Minimum_Size;
+
+ -------------------------
+ -- New_Stream_Function --
+ -------------------------
+
+ procedure New_Stream_Function
+ (N : Node_Id;
+ Ent : Entity_Id;
+ Subp : Entity_Id;
+ Nam : Name_Id)
+ is
+ Loc : constant Source_Ptr := Sloc (N);
+ Subp_Id : Entity_Id := Make_Defining_Identifier (Loc, Nam);
+ Subp_Decl : Node_Id;
+ F : Entity_Id;
+ Etyp : Entity_Id;
+
+ begin
+ F := First_Formal (Subp);
+ Etyp := Etype (Subp);
+
+ Subp_Decl :=
+ Make_Subprogram_Renaming_Declaration (Loc,
+ Specification =>
+
+ Make_Function_Specification (Loc,
+ Defining_Unit_Name => Subp_Id,
+ Parameter_Specifications =>
+ New_List (
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc, Name_S),
+ Parameter_Type =>
+ Make_Access_Definition (Loc,
+ Subtype_Mark =>
+ New_Reference_To (
+ Designated_Type (Etype (F)), Loc)))),
+
+ Subtype_Mark =>
+ New_Reference_To (Etyp, Loc)),
+
+ Name => New_Reference_To (Subp, Loc));
+
+ if Is_Tagged_Type (Ent) and then not Is_Limited_Type (Ent) then
+ Set_TSS (Base_Type (Ent), Subp_Id);
+ else
+ Insert_Action (N, Subp_Decl);
+ Copy_TSS (Subp_Id, Base_Type (Ent));
+ end if;
+
+ end New_Stream_Function;
+
+ --------------------------
+ -- New_Stream_Procedure --
+ --------------------------
+
+ procedure New_Stream_Procedure
+ (N : Node_Id;
+ Ent : Entity_Id;
+ Subp : Entity_Id;
+ Nam : Name_Id;
+ Out_P : Boolean := False)
+ is
+ Loc : constant Source_Ptr := Sloc (N);
+ Subp_Id : Entity_Id := Make_Defining_Identifier (Loc, Nam);
+ Subp_Decl : Node_Id;
+ F : Entity_Id;
+ Etyp : Entity_Id;
+
+ begin
+ F := First_Formal (Subp);
+ Etyp := Etype (Next_Formal (F));
+
+ Subp_Decl :=
+ Make_Subprogram_Renaming_Declaration (Loc,
+ Specification =>
+
+ Make_Procedure_Specification (Loc,
+ Defining_Unit_Name => Subp_Id,
+ Parameter_Specifications =>
+ New_List (
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc, Name_S),
+ Parameter_Type =>
+ Make_Access_Definition (Loc,
+ Subtype_Mark =>
+ New_Reference_To (
+ Designated_Type (Etype (F)), Loc))),
+
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc, Name_V),
+ Out_Present => Out_P,
+ Parameter_Type =>
+ New_Reference_To (Etyp, Loc)))),
+ Name => New_Reference_To (Subp, Loc));
+
+ if Is_Tagged_Type (Ent) and then not Is_Limited_Type (Ent) then
+ Set_TSS (Base_Type (Ent), Subp_Id);
+ else
+ Insert_Action (N, Subp_Decl);
+ Copy_TSS (Subp_Id, Base_Type (Ent));
+ end if;
+
+ end New_Stream_Procedure;
+
+ ---------------------
+ -- Record_Rep_Item --
+ ---------------------
+
+ procedure Record_Rep_Item (T : Entity_Id; N : Node_Id) is
+ begin
+ Set_Next_Rep_Item (N, First_Rep_Item (T));
+ Set_First_Rep_Item (T, N);
+ end Record_Rep_Item;
+
+ ------------------------
+ -- Rep_Item_Too_Early --
+ ------------------------
+
+ function Rep_Item_Too_Early
+ (T : Entity_Id;
+ N : Node_Id)
+ return Boolean
+ is
+ begin
+ -- Cannot apply rep items to generic types
+
+ if Is_Type (T)
+ and then Is_Generic_Type (Root_Type (T))
+ then
+ Error_Msg_N
+ ("representation item not allowed for generic type", N);
+ return True;
+ end if;
+
+ -- Otherwise check for incompleted type
+
+ if Is_Incomplete_Or_Private_Type (T)
+ and then No (Underlying_Type (T))
+ then
+ Error_Msg_N
+ ("representation item must be after full type declaration", N);
+ return True;
+
+ -- If the type has incompleted components, a representation clause is
+ -- illegal but stream attributes and Convention pragmas are correct.
+
+ elsif Has_Private_Component (T) then
+ if (Nkind (N) = N_Pragma or else Is_Operational_Item (N)) then
+ return False;
+ else
+ Error_Msg_N
+ ("representation item must appear after type is fully defined",
+ N);
+ return True;
+ end if;
+ else
+ return False;
+ end if;
+ end Rep_Item_Too_Early;
+
+ -----------------------
+ -- Rep_Item_Too_Late --
+ -----------------------
+
+ function Rep_Item_Too_Late
+ (T : Entity_Id;
+ N : Node_Id;
+ FOnly : Boolean := False)
+ return Boolean
+ is
+ S : Entity_Id;
+ Parent_Type : Entity_Id;
+
+ procedure Too_Late;
+ -- Output the too late message
+
+ procedure Too_Late is
+ begin
+ Error_Msg_N ("representation item appears too late!", N);
+ end Too_Late;
+
+ -- Start of processing for Rep_Item_Too_Late
+
+ begin
+ -- First make sure entity is not frozen (RM 13.1(9)). Exclude imported
+ -- types, which may be frozen if they appear in a representation clause
+ -- for a local type.
+
+ if Is_Frozen (T)
+ and then not From_With_Type (T)
+ then
+ Too_Late;
+ S := First_Subtype (T);
+
+ if Present (Freeze_Node (S)) then
+ Error_Msg_NE
+ ("?no more representation items for }!", Freeze_Node (S), S);
+ end if;
+
+ return True;
+
+ -- Check for case of non-tagged derived type whose parent either has
+ -- primitive operations, or is a by reference type (RM 13.1(10)).
+
+ elsif Is_Type (T)
+ and then not FOnly
+ and then Is_Derived_Type (T)
+ and then not Is_Tagged_Type (T)
+ then
+ Parent_Type := Etype (Base_Type (T));
+
+ if Has_Primitive_Operations (Parent_Type) then
+ Too_Late;
+ Error_Msg_NE
+ ("primitive operations already defined for&!", N, Parent_Type);
+ return True;
+
+ elsif Is_By_Reference_Type (Parent_Type) then
+ Too_Late;
+ Error_Msg_NE
+ ("parent type & is a by reference type!", N, Parent_Type);
+ return True;
+ end if;
+ end if;
+
+ -- No error, link item into head of chain of rep items for the entity
+
+ Record_Rep_Item (T, N);
+ return False;
+ end Rep_Item_Too_Late;
+
+ -------------------------
+ -- Same_Representation --
+ -------------------------
+
+ function Same_Representation (Typ1, Typ2 : Entity_Id) return Boolean is
+ T1 : constant Entity_Id := Underlying_Type (Typ1);
+ T2 : constant Entity_Id := Underlying_Type (Typ2);
+
+ begin
+ -- A quick check, if base types are the same, then we definitely have
+ -- the same representation, because the subtype specific representation
+ -- attributes (Size and Alignment) do not affect representation from
+ -- the point of view of this test.
+
+ if Base_Type (T1) = Base_Type (T2) then
+ return True;
+
+ elsif Is_Private_Type (Base_Type (T2))
+ and then Base_Type (T1) = Full_View (Base_Type (T2))
+ then
+ return True;
+ end if;
+
+ -- Tagged types never have differing representations
+
+ if Is_Tagged_Type (T1) then
+ return True;
+ end if;
+
+ -- Representations are definitely different if conventions differ
+
+ if Convention (T1) /= Convention (T2) then
+ return False;
+ end if;
+
+ -- Representations are different if component alignments differ
+
+ if (Is_Record_Type (T1) or else Is_Array_Type (T1))
+ and then
+ (Is_Record_Type (T2) or else Is_Array_Type (T2))
+ and then Component_Alignment (T1) /= Component_Alignment (T2)
+ then
+ return False;
+ end if;
+
+ -- For arrays, the only real issue is component size. If we know the
+ -- component size for both arrays, and it is the same, then that's
+ -- good enough to know we don't have a change of representation.
+
+ if Is_Array_Type (T1) then
+ if Known_Component_Size (T1)
+ and then Known_Component_Size (T2)
+ and then Component_Size (T1) = Component_Size (T2)
+ then
+ return True;
+ end if;
+ end if;
+
+ -- Types definitely have same representation if neither has non-standard
+ -- representation since default representations are always consistent.
+ -- If only one has non-standard representation, and the other does not,
+ -- then we consider that they do not have the same representation. They
+ -- might, but there is no way of telling early enough.
+
+ if Has_Non_Standard_Rep (T1) then
+ if not Has_Non_Standard_Rep (T2) then
+ return False;
+ end if;
+ else
+ return not Has_Non_Standard_Rep (T2);
+ end if;
+
+ -- Here the two types both have non-standard representation, and we
+ -- need to determine if they have the same non-standard representation
+
+ -- For arrays, we simply need to test if the component sizes are the
+ -- same. Pragma Pack is reflected in modified component sizes, so this
+ -- check also deals with pragma Pack.
+
+ if Is_Array_Type (T1) then
+ return Component_Size (T1) = Component_Size (T2);
+
+ -- Tagged types always have the same representation, because it is not
+ -- possible to specify different representations for common fields.
+
+ elsif Is_Tagged_Type (T1) then
+ return True;
+
+ -- Case of record types
+
+ elsif Is_Record_Type (T1) then
+
+ -- Packed status must conform
+
+ if Is_Packed (T1) /= Is_Packed (T2) then
+ return False;
+
+ -- Otherwise we must check components. Typ2 maybe a constrained
+ -- subtype with fewer components, so we compare the components
+ -- of the base types.
+
+ else
+ Record_Case : declare
+ CD1, CD2 : Entity_Id;
+
+ function Same_Rep return Boolean;
+ -- CD1 and CD2 are either components or discriminants. This
+ -- function tests whether the two have the same representation
+
+ function Same_Rep return Boolean is
+ begin
+ if No (Component_Clause (CD1)) then
+ return No (Component_Clause (CD2));
+
+ else
+ return
+ Present (Component_Clause (CD2))
+ and then
+ Component_Bit_Offset (CD1) = Component_Bit_Offset (CD2)
+ and then
+ Esize (CD1) = Esize (CD2);
+ end if;
+ end Same_Rep;
+
+ -- Start processing for Record_Case
+
+ begin
+ if Has_Discriminants (T1) then
+ CD1 := First_Discriminant (T1);
+ CD2 := First_Discriminant (T2);
+
+ while Present (CD1) loop
+ if not Same_Rep then
+ return False;
+ else
+ Next_Discriminant (CD1);
+ Next_Discriminant (CD2);
+ end if;
+ end loop;
+ end if;
+
+ CD1 := First_Component (Underlying_Type (Base_Type (T1)));
+ CD2 := First_Component (Underlying_Type (Base_Type (T2)));
+
+ while Present (CD1) loop
+ if not Same_Rep then
+ return False;
+ else
+ Next_Component (CD1);
+ Next_Component (CD2);
+ end if;
+ end loop;
+
+ return True;
+ end Record_Case;
+ end if;
+
+ -- For enumeration types, we must check each literal to see if the
+ -- representation is the same. Note that we do not permit enumeration
+ -- reprsentation clauses for Character and Wide_Character, so these
+ -- cases were already dealt with.
+
+ elsif Is_Enumeration_Type (T1) then
+
+ Enumeration_Case : declare
+ L1, L2 : Entity_Id;
+
+ begin
+ L1 := First_Literal (T1);
+ L2 := First_Literal (T2);
+
+ while Present (L1) loop
+ if Enumeration_Rep (L1) /= Enumeration_Rep (L2) then
+ return False;
+ else
+ Next_Literal (L1);
+ Next_Literal (L2);
+ end if;
+ end loop;
+
+ return True;
+
+ end Enumeration_Case;
+
+ -- Any other types have the same representation for these purposes
+
+ else
+ return True;
+ end if;
+
+ end Same_Representation;
+
+ --------------------
+ -- Set_Enum_Esize --
+ --------------------
+
+ procedure Set_Enum_Esize (T : Entity_Id) is
+ Lo : Uint;
+ Hi : Uint;
+ Sz : Nat;
+
+ begin
+ Init_Alignment (T);
+
+ -- Find the minimum standard size (8,16,32,64) that fits
+
+ Lo := Enumeration_Rep (Entity (Type_Low_Bound (T)));
+ Hi := Enumeration_Rep (Entity (Type_High_Bound (T)));
+
+ if Lo < 0 then
+ if Lo >= -Uint_2**07 and then Hi < Uint_2**07 then
+ Sz := 8;
+
+ elsif Lo >= -Uint_2**15 and then Hi < Uint_2**15 then
+ Sz := 16;
+
+ elsif Lo >= -Uint_2**31 and then Hi < Uint_2**31 then
+ Sz := 32;
+
+ else pragma Assert (Lo >= -Uint_2**63 and then Hi < Uint_2**63);
+ Sz := 64;
+ end if;
+
+ else
+ if Hi < Uint_2**08 then
+ Sz := 8;
+
+ elsif Hi < Uint_2**16 then
+ Sz := 16;
+
+ elsif Hi < Uint_2**32 then
+ Sz := 32;
+
+ else pragma Assert (Hi < Uint_2**63);
+ Sz := 64;
+ end if;
+ end if;
+
+ -- That minimum is the proper size unless we have a foreign convention
+ -- and the size required is 32 or less, in which case we bump the size
+ -- up to 32. This is required for C and C++ and seems reasonable for
+ -- all other foreign conventions.
+
+ if Has_Foreign_Convention (T)
+ and then Esize (T) < Standard_Integer_Size
+ then
+ Init_Esize (T, Standard_Integer_Size);
+
+ else
+ Init_Esize (T, Sz);
+ end if;
+
+ end Set_Enum_Esize;
+
+ -----------------------------------
+ -- Validate_Unchecked_Conversion --
+ -----------------------------------
+
+ procedure Validate_Unchecked_Conversion
+ (N : Node_Id;
+ Act_Unit : Entity_Id)
+ is
+ Source : Entity_Id;
+ Target : Entity_Id;
+ Vnode : Node_Id;
+
+ begin
+ -- Obtain source and target types. Note that we call Ancestor_Subtype
+ -- here because the processing for generic instantiation always makes
+ -- subtypes, and we want the original frozen actual types.
+
+ -- If we are dealing with private types, then do the check on their
+ -- fully declared counterparts if the full declarations have been
+ -- encountered (they don't have to be visible, but they must exist!)
+
+ Source := Ancestor_Subtype (Etype (First_Formal (Act_Unit)));
+
+ if Is_Private_Type (Source)
+ and then Present (Underlying_Type (Source))
+ then
+ Source := Underlying_Type (Source);
+ end if;
+
+ Target := Ancestor_Subtype (Etype (Act_Unit));
+
+ -- If either type is generic, the instantiation happens within a
+ -- generic unit, and there is nothing to check. The proper check
+ -- will happen when the enclosing generic is instantiated.
+
+ if Is_Generic_Type (Source) or else Is_Generic_Type (Target) then
+ return;
+ end if;
+
+ if Is_Private_Type (Target)
+ and then Present (Underlying_Type (Target))
+ then
+ Target := Underlying_Type (Target);
+ end if;
+
+ -- Source may be unconstrained array, but not target
+
+ if Is_Array_Type (Target)
+ and then not Is_Constrained (Target)
+ then
+ Error_Msg_N
+ ("unchecked conversion to unconstrained array not allowed", N);
+ return;
+ end if;
+
+ -- Make entry in unchecked conversion table for later processing
+ -- by Validate_Unchecked_Conversions, which will check sizes and
+ -- alignments (using values set by the back-end where possible).
+
+ Unchecked_Conversions.Append
+ (New_Val => UC_Entry'
+ (Enode => N,
+ Source => Source,
+ Target => Target));
+
+ -- Generate N_Validate_Unchecked_Conversion node for back end if
+ -- the back end needs to perform special validation checks. At the
+ -- current time, only the JVM version requires such checks.
+
+ if Java_VM then
+ Vnode :=
+ Make_Validate_Unchecked_Conversion (Sloc (N));
+ Set_Source_Type (Vnode, Source);
+ Set_Target_Type (Vnode, Target);
+ Insert_After (N, Vnode);
+ end if;
+ end Validate_Unchecked_Conversion;
+
+ ------------------------------------
+ -- Validate_Unchecked_Conversions --
+ ------------------------------------
+
+ procedure Validate_Unchecked_Conversions is
+ begin
+ for N in Unchecked_Conversions.First .. Unchecked_Conversions.Last loop
+ declare
+ T : UC_Entry renames Unchecked_Conversions.Table (N);
+
+ Enode : constant Node_Id := T.Enode;
+ Source : constant Entity_Id := T.Source;
+ Target : constant Entity_Id := T.Target;
+
+ Source_Siz : Uint;
+ Target_Siz : Uint;
+
+ begin
+ -- This validation check, which warns if we have unequal sizes
+ -- for unchecked conversion, and thus potentially implementation
+ -- dependent semantics, is one of the few occasions on which we
+ -- use the official RM size instead of Esize. See description
+ -- in Einfo "Handling of Type'Size Values" for details.
+
+ if Errors_Detected = 0
+ and then Known_Static_RM_Size (Source)
+ and then Known_Static_RM_Size (Target)
+ then
+ Source_Siz := RM_Size (Source);
+ Target_Siz := RM_Size (Target);
+
+ if Source_Siz /= Target_Siz then
+ Warn_On_Instance := True;
+ Error_Msg_N
+ ("types for unchecked conversion have different sizes?",
+ Enode);
+
+ if All_Errors_Mode then
+ Error_Msg_Name_1 := Chars (Source);
+ Error_Msg_Uint_1 := Source_Siz;
+ Error_Msg_Name_2 := Chars (Target);
+ Error_Msg_Uint_2 := Target_Siz;
+ Error_Msg_N
+ ("\size of % is ^, size of % is ^?", Enode);
+
+ Error_Msg_Uint_1 := UI_Abs (Source_Siz - Target_Siz);
+
+ if Is_Discrete_Type (Source)
+ and then Is_Discrete_Type (Target)
+ then
+ if Source_Siz > Target_Siz then
+ Error_Msg_N
+ ("\^ high order bits of source will be ignored?",
+ Enode);
+
+ elsif Is_Modular_Integer_Type (Source) then
+ Error_Msg_N
+ ("\source will be extended with ^ high order " &
+ "zero bits?", Enode);
+
+ else
+ Error_Msg_N
+ ("\source will be extended with ^ high order " &
+ "sign bits?",
+ Enode);
+ end if;
+
+ elsif Source_Siz < Target_Siz then
+ if Is_Discrete_Type (Target) then
+ if Bytes_Big_Endian then
+ Error_Msg_N
+ ("\target value will include ^ undefined " &
+ "low order bits?",
+ Enode);
+ else
+ Error_Msg_N
+ ("\target value will include ^ undefined " &
+ "high order bits?",
+ Enode);
+ end if;
+
+ else
+ Error_Msg_N
+ ("\^ trailing bits of target value will be " &
+ "undefined?", Enode);
+ end if;
+
+ else pragma Assert (Source_Siz > Target_Siz);
+ Error_Msg_N
+ ("\^ trailing bits of source will be ignored?",
+ Enode);
+ end if;
+ end if;
+
+ Warn_On_Instance := False;
+ end if;
+ end if;
+
+ -- If both types are access types, we need to check the alignment.
+ -- If the alignment of both is specified, we can do it here.
+
+ if Errors_Detected = 0
+ and then Ekind (Source) in Access_Kind
+ and then Ekind (Target) in Access_Kind
+ and then Target_Strict_Alignment
+ and then Present (Designated_Type (Source))
+ and then Present (Designated_Type (Target))
+ then
+ declare
+ D_Source : constant Entity_Id := Designated_Type (Source);
+ D_Target : constant Entity_Id := Designated_Type (Target);
+
+ begin
+ if Known_Alignment (D_Source)
+ and then Known_Alignment (D_Target)
+ then
+ declare
+ Source_Align : constant Uint := Alignment (D_Source);
+ Target_Align : constant Uint := Alignment (D_Target);
+
+ begin
+ if Source_Align < Target_Align
+ and then not Is_Tagged_Type (D_Source)
+ then
+ Warn_On_Instance := True;
+ Error_Msg_Uint_1 := Target_Align;
+ Error_Msg_Uint_2 := Source_Align;
+ Error_Msg_Node_2 := D_Source;
+ Error_Msg_NE
+ ("alignment of & (^) is stricter than " &
+ "alignment of & (^)?", Enode, D_Target);
+
+ if All_Errors_Mode then
+ Error_Msg_N
+ ("\resulting access value may have invalid " &
+ "alignment?", Enode);
+ end if;
+
+ Warn_On_Instance := False;
+ end if;
+ end;
+ end if;
+ end;
+ end if;
+ end;
+ end loop;
+ end Validate_Unchecked_Conversions;
+
+ ------------------
+ -- Warn_Overlay --
+ ------------------
+
+ procedure Warn_Overlay
+ (Expr : Node_Id;
+ Typ : Entity_Id;
+ Nam : Node_Id)
+ is
+ Old : Entity_Id := Empty;
+ Decl : Node_Id;
+
+ begin
+ if not Address_Clause_Overlay_Warnings then
+ return;
+ end if;
+
+ if Present (Expr)
+ and then (Has_Non_Null_Base_Init_Proc (Typ)
+ or else Is_Access_Type (Typ))
+ and then not Is_Imported (Entity (Nam))
+ then
+ if Nkind (Expr) = N_Attribute_Reference
+ and then Is_Entity_Name (Prefix (Expr))
+ then
+ Old := Entity (Prefix (Expr));
+
+ elsif Is_Entity_Name (Expr)
+ and then Ekind (Entity (Expr)) = E_Constant
+ then
+ Decl := Declaration_Node (Entity (Expr));
+
+ if Nkind (Decl) = N_Object_Declaration
+ and then Present (Expression (Decl))
+ and then Nkind (Expression (Decl)) = N_Attribute_Reference
+ and then Is_Entity_Name (Prefix (Expression (Decl)))
+ then
+ Old := Entity (Prefix (Expression (Decl)));
+
+ elsif Nkind (Expr) = N_Function_Call then
+ return;
+ end if;
+
+ -- A function call (most likely to To_Address) is probably not
+ -- an overlay, so skip warning. Ditto if the function call was
+ -- inlined and transformed into an entity.
+
+ elsif Nkind (Original_Node (Expr)) = N_Function_Call then
+ return;
+ end if;
+
+ Decl := Next (Parent (Expr));
+
+ -- If a pragma Import follows, we assume that it is for the current
+ -- target of the address clause, and skip the warning.
+
+ if Present (Decl)
+ and then Nkind (Decl) = N_Pragma
+ and then Chars (Decl) = Name_Import
+ then
+ return;
+ end if;
+
+ if Present (Old) then
+ Error_Msg_Node_2 := Old;
+ Error_Msg_N
+ ("default initialization of & may modify &?",
+ Nam);
+ else
+ Error_Msg_N
+ ("default initialization of & may modify overlaid storage?",
+ Nam);
+ end if;
+
+ -- Add friendly warning if initialization comes from a packed array
+ -- component.
+
+ if Is_Record_Type (Typ) then
+ declare
+ Comp : Entity_Id;
+
+ begin
+ Comp := First_Component (Typ);
+
+ while Present (Comp) loop
+ if Nkind (Parent (Comp)) = N_Component_Declaration
+ and then Present (Expression (Parent (Comp)))
+ then
+ exit;
+ elsif Is_Array_Type (Etype (Comp))
+ and then Present (Packed_Array_Type (Etype (Comp)))
+ then
+ Error_Msg_NE
+ ("packed array component& will be initialized to zero?",
+ Nam, Comp);
+ exit;
+ else
+ Next_Component (Comp);
+ end if;
+ end loop;
+ end;
+ end if;
+
+ Error_Msg_N
+ ("use pragma Import for & to " &
+ "suppress initialization ('R'M B.1(24))?",
+ Nam);
+ end if;
+ end Warn_Overlay;
+
+end Sem_Ch13;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S E M _ C H 1 3 --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.39 $
+-- --
+-- 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). --
+-- --
+------------------------------------------------------------------------------
+
+with Snames; use Snames;
+with Types; use Types;
+with Uintp; use Uintp;
+
+package Sem_Ch13 is
+ procedure Analyze_At_Clause (N : Node_Id);
+ procedure Analyze_Attribute_Definition_Clause (N : Node_Id);
+ procedure Analyze_Enumeration_Representation_Clause (N : Node_Id);
+ procedure Analyze_Free_Statement (N : Node_Id);
+ procedure Analyze_Record_Representation_Clause (N : Node_Id);
+ procedure Analyze_Code_Statement (N : Node_Id);
+
+ procedure Initialize;
+ -- Initialize internal tables for new compilation
+
+ procedure Set_Enum_Esize (T : Entity_Id);
+ -- This routine sets the Esize field for an enumeration type T, based
+ -- on the current representation information available for T. Note that
+ -- the setting of the RM_Size field is not affected. This routine also
+ -- initializes the alignment field to zero.
+
+ function Minimum_Size
+ (T : Entity_Id;
+ Biased : Boolean := False)
+ return Nat;
+ -- Given a primitive type, determines the minimum number of bits required
+ -- to represent all values of the type. This function may not be called
+ -- with any other types. If the flag Biased is set True, then the minimum
+ -- size calculation that biased representation is used in the case of a
+ -- discrete type, e.g. the range 7..8 gives a minimum size of 4 with
+ -- Biased set to False, and 1 with Biased set to True. Note that the
+ -- biased parameter only has an effect if the type is not biased, it
+ -- causes Minimum_Size to indicate the minimum size of an object with
+ -- the given type, of the size the type would have if it were biased. If
+ -- the type is already biased, then Minimum_Size returns the biased size,
+ -- regardless of the setting of Biased. Also, fixed-point types are never
+ -- biased in the current implementation.
+
+ procedure Check_Size
+ (N : Node_Id;
+ T : Entity_Id;
+ Siz : Uint;
+ Biased : out Boolean);
+ -- Called when size Siz is specified for subtype T. This subprogram checks
+ -- that the size is appropriate, posting errors on node N as required.
+ -- For non-elementary types, a check is only made if an explicit size
+ -- has been given for the type (and the specified size must match). The
+ -- parameter Biased is set False if the size specified did not require
+ -- the use of biased representation, and True if biased representation
+ -- was required to meet the size requirement. Note that Biased is only
+ -- set if the type is not currently biased, but biasing it is the only
+ -- way to meet the requirement. If the type is currently biased, then
+ -- this biased size is used in the initial check, and Biased is False.
+
+ function Get_Rep_Pragma (E : Entity_Id; Nam : Name_Id) return Node_Id;
+ -- Searches the Rep_Item chain for the given entity E, for an instance
+ -- of a representation pragma with the given name Nam. If found then
+ -- the value returned is the N_Pragma node, otherwise Empty is returned.
+
+ function Get_Attribute_Definition_Clause
+ (E : Entity_Id;
+ Id : Attribute_Id)
+ return Node_Id;
+ -- Searches the Rep_Item chain for a given entity E, for an instance
+ -- of an attribute definition clause with the given attibute Id Id. If
+ -- found, the value returned is the N_Attribute_Definition_Clause node,
+ -- otherwise Empty is returned.
+
+ procedure Record_Rep_Item (T : Entity_Id; N : Node_Id);
+ -- N is the node for either a representation pragma or an attribute
+ -- definition clause that applies to type T. This procedure links
+ -- the node N onto the Rep_Item chain for the type T.
+
+ function Rep_Item_Too_Early
+ (T : Entity_Id;
+ N : Node_Id)
+ return Boolean;
+ -- Called at the start of processing a representation clause or a
+ -- representation pragma. Used to check that the representation item
+ -- is not being applied to an incompleted type or to a generic formal
+ -- type or a type derived from a generic formal type. Returns False if
+ -- no such error occurs. If this error does occur, appropriate error
+ -- messages are posted on node N, and True is returned.
+
+ function Rep_Item_Too_Late
+ (T : Entity_Id;
+ N : Node_Id;
+ FOnly : Boolean := False)
+ return Boolean;
+ -- Called at the start of processing a representation clause or a
+ -- representation pragma. Used to check that a representation item
+ -- for entity T does not appear too late (according to the rules in
+ -- RM 13.1(9) and RM 13.1(10)). N is the associated node, which in
+ -- the pragma case is the pragma or representation clause itself, used
+ -- for placing error messages if the item is too late.
+ --
+ -- Fonly is a flag that causes only the freezing rule (para 9) to be
+ -- applied, and the tests of para 10 are skipped. This is appropriate
+ -- for both subtype related attributes (Alignment and Size) and for
+ -- stream attributes, which, although certainly not subtype related
+ -- attributes, clearly should not be subject to the para 10 restrictions
+ -- (see AI95-00137). Similarly, we also skip the para 10 restrictions for
+ -- the Storage_Size case where they also clearly do not apply.
+ --
+ -- If the rep item is too late, an appropriate message is output and
+ -- True is returned, which is a signal that the caller should abandon
+ -- processing for the item. If the item is not too late, then False
+ -- is returned, and the caller can continue processing the item.
+ --
+ -- If no error is detected, this call also as a side effect links the
+ -- representation item onto the head of the representation item chain
+ -- (referenced by the First_Rep_Item field of the entity).
+ --
+ -- Note: Rep_Item_Too_Late must be called with the underlying type in
+ -- the case of a private or incomplete type. The protocol is to first
+ -- check for Rep_Item_Too_Early using the initial entity, then take the
+ -- underlying type, then call Rep_Item_Too_Late on the result.
+
+ function Same_Representation (Typ1, Typ2 : Entity_Id) return Boolean;
+ -- Given two types, where the two types are related by possible derivation,
+ -- determines if the two types have the same representation, or different
+ -- representations, requiring the special processing for representation
+ -- change. A False result is possible only for array, enumeration or
+ -- record types.
+
+ procedure Validate_Unchecked_Conversion
+ (N : Node_Id;
+ Act_Unit : Entity_Id);
+ -- Validate a call to unchecked conversion. N is the node for the actual
+ -- instantiation, which is used only for error messages. Act_Unit is the
+ -- entity for the instantiation, from which the actual types etc for this
+ -- instantiation can be determined. This procedure makes an entry in a
+ -- table and/or generates an N_Validate_Unchecked_Conversion node. The
+ -- actual checking is done in Validate_Unchecked_Conversions or in the
+ -- back end as required.
+
+ procedure Validate_Unchecked_Conversions;
+ -- This routine is called after calling the backend to validate
+ -- unchecked conversions for size and alignment appropriateness.
+ -- The reason it is called that late is to take advantage of any
+ -- back-annotation of size and alignment performed by the backend.
+
+end Sem_Ch13;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S E M _ C H 2 --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.8 $ --
+-- --
+-- Copyright (C) 1992-1999, 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 Atree; use Atree;
+with Opt; use Opt;
+with Restrict; use Restrict;
+with Sem_Ch8; use Sem_Ch8;
+with Sinfo; use Sinfo;
+with Stand; use Stand;
+
+package body Sem_Ch2 is
+
+ -------------------------------
+ -- Analyze_Character_Literal --
+ -------------------------------
+
+ procedure Analyze_Character_Literal (N : Node_Id) is
+ begin
+
+ -- The type is eventually inherited from the context. If expansion
+ -- has already established the proper type, do not modify it.
+
+ if No (Etype (N)) then
+ Set_Etype (N, Any_Character);
+ end if;
+
+ Set_Is_Static_Expression (N);
+
+ if Comes_From_Source (N)
+ and then not In_Character_Range (Char_Literal_Value (N))
+ then
+ Check_Restriction (No_Wide_Characters, N);
+ end if;
+ end Analyze_Character_Literal;
+
+ ------------------------
+ -- Analyze_Identifier --
+ ------------------------
+
+ procedure Analyze_Identifier (N : Node_Id) is
+ begin
+ Find_Direct_Name (N);
+ end Analyze_Identifier;
+
+ -----------------------------
+ -- Analyze_Integer_Literal --
+ -----------------------------
+
+ procedure Analyze_Integer_Literal (N : Node_Id) is
+ begin
+ Set_Etype (N, Universal_Integer);
+ Set_Is_Static_Expression (N);
+ end Analyze_Integer_Literal;
+
+ --------------------------
+ -- Analyze_Real_Literal --
+ --------------------------
+
+ procedure Analyze_Real_Literal (N : Node_Id) is
+ begin
+ Set_Etype (N, Universal_Real);
+ Set_Is_Static_Expression (N);
+ end Analyze_Real_Literal;
+
+ ----------------------------
+ -- Analyze_String_Literal --
+ ----------------------------
+
+ procedure Analyze_String_Literal (N : Node_Id) is
+ begin
+
+ -- The type is eventually inherited from the context. If expansion
+ -- has already established the proper type, do not modify it.
+
+ if No (Etype (N)) then
+ Set_Etype (N, Any_String);
+ end if;
+
+ -- String literals are static in Ada 95. Note that if the subtype
+ -- turns out to be non-static, then the Is_Static_Expression flag
+ -- will be reset in Eval_String_Literal.
+
+ if Ada_95 then
+ Set_Is_Static_Expression (N);
+ end if;
+
+ if Comes_From_Source (N) and then Has_Wide_Character (N) then
+ Check_Restriction (No_Wide_Characters, N);
+ end if;
+ end Analyze_String_Literal;
+
+end Sem_Ch2;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S E M _ C H 2 --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.3 $ --
+-- --
+-- 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). --
+-- --
+------------------------------------------------------------------------------
+
+with Types; use Types;
+
+package Sem_Ch2 is
+
+ procedure Analyze_Character_Literal (N : Node_Id);
+ procedure Analyze_Identifier (N : Node_Id);
+ procedure Analyze_Integer_Literal (N : Node_Id);
+ procedure Analyze_Real_Literal (N : Node_Id);
+ procedure Analyze_String_Literal (N : Node_Id);
+
+private
+ pragma Inline (Analyze_Character_Literal);
+ pragma Inline (Analyze_Identifier);
+ pragma Inline (Analyze_Integer_Literal);
+ pragma Inline (Analyze_Real_Literal);
+ pragma Inline (Analyze_String_Literal);
+
+end Sem_Ch2;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S E M _ C H 3 --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.1354 $
+-- --
+-- 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). --
+-- --
+------------------------------------------------------------------------------
+
+with Atree; use Atree;
+with Checks; use Checks;
+with Elists; use Elists;
+with Einfo; use Einfo;
+with Errout; use Errout;
+with Eval_Fat; use Eval_Fat;
+with Exp_Ch3; use Exp_Ch3;
+with Exp_Dist; use Exp_Dist;
+with Exp_Util; use Exp_Util;
+with Freeze; use Freeze;
+with Itypes; use Itypes;
+with Layout; use Layout;
+with Lib; use Lib;
+with Lib.Xref; use Lib.Xref;
+with Namet; use Namet;
+with Nmake; use Nmake;
+with Opt; use Opt;
+with Restrict; use Restrict;
+with Rtsfind; use Rtsfind;
+with Sem; use Sem;
+with Sem_Case; use Sem_Case;
+with Sem_Cat; use Sem_Cat;
+with Sem_Ch6; use Sem_Ch6;
+with Sem_Ch7; use Sem_Ch7;
+with Sem_Ch8; use Sem_Ch8;
+with Sem_Ch13; use Sem_Ch13;
+with Sem_Disp; use Sem_Disp;
+with Sem_Dist; use Sem_Dist;
+with Sem_Elim; use Sem_Elim;
+with Sem_Eval; use Sem_Eval;
+with Sem_Mech; use Sem_Mech;
+with Sem_Res; use Sem_Res;
+with Sem_Smem; use Sem_Smem;
+with Sem_Type; use Sem_Type;
+with Sem_Util; use Sem_Util;
+with Stand; use Stand;
+with Sinfo; use Sinfo;
+with Snames; use Snames;
+with Tbuild; use Tbuild;
+with Ttypes; use Ttypes;
+with Uintp; use Uintp;
+with Urealp; use Urealp;
+
+package body Sem_Ch3 is
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ procedure Build_Derived_Type
+ (N : Node_Id;
+ Parent_Type : Entity_Id;
+ Derived_Type : Entity_Id;
+ Is_Completion : Boolean;
+ Derive_Subps : Boolean := True);
+ -- Create and decorate a Derived_Type given the Parent_Type entity.
+ -- N is the N_Full_Type_Declaration node containing the derived type
+ -- definition. Parent_Type is the entity for the parent type in the derived
+ -- type definition and Derived_Type the actual derived type. Is_Completion
+ -- must be set to False if Derived_Type is the N_Defining_Identifier node
+ -- in N (ie Derived_Type = Defining_Identifier (N)). In this case N is not
+ -- the completion of a private type declaration. If Is_Completion is
+ -- set to True, N is the completion of a private type declaration and
+ -- Derived_Type is different from the defining identifier inside N (i.e.
+ -- Derived_Type /= Defining_Identifier (N)). Derive_Subps indicates whether
+ -- the parent subprograms should be derived. The only case where this
+ -- parameter is False is when Build_Derived_Type is recursively called to
+ -- process an implicit derived full type for a type derived from a private
+ -- type (in that case the subprograms must only be derived for the private
+ -- view of the type).
+ -- ??? These flags need a bit of re-examination and re-documentaion:
+ -- ??? are they both necessary (both seem related to the recursion)?
+
+ procedure Build_Derived_Access_Type
+ (N : Node_Id;
+ Parent_Type : Entity_Id;
+ Derived_Type : Entity_Id);
+ -- Subsidiary procedure to Build_Derived_Type. For a derived access type,
+ -- create an implicit base if the parent type is constrained or if the
+ -- subtype indication has a constraint.
+
+ procedure Build_Derived_Array_Type
+ (N : Node_Id;
+ Parent_Type : Entity_Id;
+ Derived_Type : Entity_Id);
+ -- Subsidiary procedure to Build_Derived_Type. For a derived array type,
+ -- create an implicit base if the parent type is constrained or if the
+ -- subtype indication has a constraint.
+
+ procedure Build_Derived_Concurrent_Type
+ (N : Node_Id;
+ Parent_Type : Entity_Id;
+ Derived_Type : Entity_Id);
+ -- Subsidiary procedure to Build_Derived_Type. For a derived task or pro-
+ -- tected type, inherit entries and protected subprograms, check legality
+ -- of discriminant constraints if any.
+
+ procedure Build_Derived_Enumeration_Type
+ (N : Node_Id;
+ Parent_Type : Entity_Id;
+ Derived_Type : Entity_Id);
+ -- Subsidiary procedure to Build_Derived_Type. For a derived enumeration
+ -- type, we must create a new list of literals. Types derived from
+ -- Character and Wide_Character are special-cased.
+
+ procedure Build_Derived_Numeric_Type
+ (N : Node_Id;
+ Parent_Type : Entity_Id;
+ Derived_Type : Entity_Id);
+ -- Subsidiary procedure to Build_Derived_Type. For numeric types, create
+ -- an anonymous base type, and propagate constraint to subtype if needed.
+
+ procedure Build_Derived_Private_Type
+ (N : Node_Id;
+ Parent_Type : Entity_Id;
+ Derived_Type : Entity_Id;
+ Is_Completion : Boolean;
+ Derive_Subps : Boolean := True);
+ -- Substidiary procedure to Build_Derived_Type. This procedure is complex
+ -- because the parent may or may not have a completion, and the derivation
+ -- may itself be a completion.
+
+ procedure Build_Derived_Record_Type
+ (N : Node_Id;
+ Parent_Type : Entity_Id;
+ Derived_Type : Entity_Id;
+ Derive_Subps : Boolean := True);
+ -- Subsidiary procedure to Build_Derived_Type and
+ -- Analyze_Private_Extension_Declaration used for tagged and untagged
+ -- record types. All parameters are as in Build_Derived_Type except that
+ -- N, in addition to being an N_Full_Type_Declaration node, can also be an
+ -- N_Private_Extension_Declaration node. See the definition of this routine
+ -- for much more info. Derive_Subps indicates whether subprograms should
+ -- be derived from the parent type. The only case where Derive_Subps is
+ -- False is for an implicit derived full type for a type derived from a
+ -- private type (see Build_Derived_Type).
+
+ function Inherit_Components
+ (N : Node_Id;
+ Parent_Base : Entity_Id;
+ Derived_Base : Entity_Id;
+ Is_Tagged : Boolean;
+ Inherit_Discr : Boolean;
+ Discs : Elist_Id)
+ return Elist_Id;
+ -- Called from Build_Derived_Record_Type to inherit the components of
+ -- Parent_Base (a base type) into the Derived_Base (the derived base type).
+ -- For more information on derived types and component inheritance please
+ -- consult the comment above the body of Build_Derived_Record_Type.
+ --
+ -- N is the original derived type declaration.
+ -- Is_Tagged is set if we are dealing with tagged types.
+ -- If Inherit_Discr is set, Derived_Base inherits its discriminants from
+ -- Parent_Base, otherwise no discriminants are inherited.
+ -- Discs gives the list of constraints that apply to Parent_Base in the
+ -- derived type declaration. If Discs is set to No_Elist, then we have the
+ -- following situation:
+ --
+ -- type Parent (D1..Dn : ..) is [tagged] record ...;
+ -- type Derived is new Parent [with ...];
+ --
+ -- which gets treated as
+ --
+ -- type Derived (D1..Dn : ..) is new Parent (D1,..,Dn) [with ...];
+ --
+ -- For untagged types the returned value is an association list:
+ -- (Old_Component => New_Component), where Old_Component is the Entity_Id
+ -- of a component in Parent_Base and New_Component is the Entity_Id of the
+ -- corresponding component in Derived_Base. For untagged records, this
+ -- association list is needed when copying the record declaration for the
+ -- derived base. In the tagged case the value returned is irrelevant.
+
+ procedure Build_Discriminal (Discrim : Entity_Id);
+ -- Create the discriminal corresponding to discriminant Discrim, that is
+ -- the parameter corresponding to Discrim to be used in initialization
+ -- procedures for the type where Discrim is a discriminant. Discriminals
+ -- are not used during semantic analysis, and are not fully defined
+ -- entities until expansion. Thus they are not given a scope until
+ -- intialization procedures are built.
+
+ function Build_Discriminant_Constraints
+ (T : Entity_Id;
+ Def : Node_Id;
+ Derived_Def : Boolean := False)
+ return Elist_Id;
+ -- Validate discriminant constraints, and return the list of the
+ -- constraints in order of discriminant declarations. T is the
+ -- discriminated unconstrained type. Def is the N_Subtype_Indication
+ -- node where the discriminants constraints for T are specified.
+ -- Derived_Def is True if we are building the discriminant constraints
+ -- in a derived type definition of the form "type D (...) is new T (xxx)".
+ -- In this case T is the parent type and Def is the constraint "(xxx)" on
+ -- T and this routine sets the Corresponding_Discriminant field of the
+ -- discriminants in the derived type D to point to the corresponding
+ -- discriminants in the parent type T.
+
+ procedure Build_Discriminated_Subtype
+ (T : Entity_Id;
+ Def_Id : Entity_Id;
+ Elist : Elist_Id;
+ Related_Nod : Node_Id;
+ For_Access : Boolean := False);
+ -- Subsidiary procedure to Constrain_Discriminated_Type and to
+ -- Process_Incomplete_Dependents. Given
+ --
+ -- T (a possibly discriminated base type)
+ -- Def_Id (a very partially built subtype for T),
+ --
+ -- the call completes Def_Id to be the appropriate E_*_Subtype.
+ --
+ -- The Elist is the list of discriminant constraints if any (it is set to
+ -- No_Elist if T is not a discriminated type, and to an empty list if
+ -- T has discriminants but there are no discriminant constraints). The
+ -- Related_Nod is the same as Decl_Node in Create_Constrained_Components.
+ -- The For_Access says whether or not this subtype is really constraining
+ -- an access type. That is its sole purpose is the designated type of an
+ -- access type -- in which case a Private_Subtype Is_For_Access_Subtype
+ -- is built to avoid freezing T when the access subtype is frozen.
+
+ function Build_Scalar_Bound
+ (Bound : Node_Id;
+ Par_T : Entity_Id;
+ Der_T : Entity_Id;
+ Loc : Source_Ptr)
+ return Node_Id;
+ -- The bounds of a derived scalar type are conversions of the bounds of
+ -- the parent type. Optimize the representation if the bounds are literals.
+ -- Needs a more complete spec--what are the parameters exactly, and what
+ -- exactly is the returned value, and how is Bound affected???
+
+ procedure Build_Underlying_Full_View
+ (N : Node_Id;
+ Typ : Entity_Id;
+ Par : Entity_Id);
+ -- If the completion of a private type is itself derived from a private
+ -- type, or if the full view of a private subtype is itself private, the
+ -- back-end has no way to compute the actual size of this type. We build
+ -- an internal subtype declaration of the proper parent type to convey
+ -- this information. This extra mechanism is needed because a full
+ -- view cannot itself have a full view (it would get clobbered during
+ -- view exchanges).
+
+ procedure Check_Access_Discriminant_Requires_Limited
+ (D : Node_Id;
+ Loc : Node_Id);
+ -- Check the restriction that the type to which an access discriminant
+ -- belongs must be a concurrent type or a descendant of a type with
+ -- the reserved word 'limited' in its declaration.
+
+ procedure Check_Delta_Expression (E : Node_Id);
+ -- Check that the expression represented by E is suitable for use as
+ -- a delta expression, i.e. it is of real type and is static.
+
+ procedure Check_Digits_Expression (E : Node_Id);
+ -- Check that the expression represented by E is suitable for use as
+ -- a digits expression, i.e. it is of integer type, positive and static.
+
+ procedure Check_Incomplete (T : Entity_Id);
+ -- Called to verify that an incomplete type is not used prematurely
+
+ procedure Check_Initialization (T : Entity_Id; Exp : Node_Id);
+ -- Validate the initialization of an object declaration. T is the
+ -- required type, and Exp is the initialization expression.
+
+ procedure Check_Or_Process_Discriminants (N : Node_Id; T : Entity_Id);
+ -- If T is the full declaration of an incomplete or private type, check
+ -- the conformance of the discriminants, otherwise process them.
+
+ procedure Check_Real_Bound (Bound : Node_Id);
+ -- Check given bound for being of real type and static. If not, post an
+ -- appropriate message, and rewrite the bound with the real literal zero.
+
+ procedure Constant_Redeclaration
+ (Id : Entity_Id;
+ N : Node_Id;
+ T : out Entity_Id);
+ -- Various checks on legality of full declaration of deferred constant.
+ -- Id is the entity for the redeclaration, N is the N_Object_Declaration,
+ -- node. The caller has not yet set any attributes of this entity.
+
+ procedure Convert_Scalar_Bounds
+ (N : Node_Id;
+ Parent_Type : Entity_Id;
+ Derived_Type : Entity_Id;
+ Loc : Source_Ptr);
+ -- For derived scalar types, convert the bounds in the type definition
+ -- to the derived type, and complete their analysis.
+
+ procedure Copy_Array_Base_Type_Attributes (T1, T2 : Entity_Id);
+ -- Copies attributes from array base type T2 to array base type T1.
+ -- Copies only attributes that apply to base types, but not subtypes.
+
+ procedure Copy_Array_Subtype_Attributes (T1, T2 : Entity_Id);
+ -- Copies attributes from array subtype T2 to array subtype T1. Copies
+ -- attributes that apply to both subtypes and base types.
+
+ procedure Create_Constrained_Components
+ (Subt : Entity_Id;
+ Decl_Node : Node_Id;
+ Typ : Entity_Id;
+ Constraints : Elist_Id);
+ -- Build the list of entities for a constrained discriminated record
+ -- subtype. If a component depends on a discriminant, replace its subtype
+ -- using the discriminant values in the discriminant constraint.
+ -- Subt is the defining identifier for the subtype whose list of
+ -- constrained entities we will create. Decl_Node is the type declaration
+ -- node where we will attach all the itypes created. Typ is the base
+ -- discriminated type for the subtype Subt. Constraints is the list of
+ -- discriminant constraints for Typ.
+
+ function Constrain_Component_Type
+ (Compon_Type : Entity_Id;
+ Constrained_Typ : Entity_Id;
+ Related_Node : Node_Id;
+ Typ : Entity_Id;
+ Constraints : Elist_Id)
+ return Entity_Id;
+ -- Given a discriminated base type Typ, a list of discriminant constraint
+ -- Constraints for Typ and the type of a component of Typ, Compon_Type,
+ -- create and return the type corresponding to Compon_type where all
+ -- discriminant references are replaced with the corresponding
+ -- constraint. If no discriminant references occurr in Compon_Typ then
+ -- return it as is. Constrained_Typ is the final constrained subtype to
+ -- which the constrained Compon_Type belongs. Related_Node is the node
+ -- where we will attach all the itypes created.
+
+ procedure Constrain_Access
+ (Def_Id : in out Entity_Id;
+ S : Node_Id;
+ Related_Nod : Node_Id);
+ -- Apply a list of constraints to an access type. If Def_Id is empty,
+ -- it is an anonymous type created for a subtype indication. In that
+ -- case it is created in the procedure and attached to Related_Nod.
+
+ procedure Constrain_Array
+ (Def_Id : in out Entity_Id;
+ SI : Node_Id;
+ Related_Nod : Node_Id;
+ Related_Id : Entity_Id;
+ Suffix : Character);
+ -- Apply a list of index constraints to an unconstrained array type. The
+ -- first parameter is the entity for the resulting subtype. A value of
+ -- Empty for Def_Id indicates that an implicit type must be created, but
+ -- creation is delayed (and must be done by this procedure) because other
+ -- subsidiary implicit types must be created first (which is why Def_Id
+ -- is an in/out parameter). Related_Nod gives the place where this type has
+ -- to be inserted in the tree. The Related_Id and Suffix parameters are
+ -- used to build the associated Implicit type name.
+
+ procedure Constrain_Concurrent
+ (Def_Id : in out Entity_Id;
+ SI : Node_Id;
+ Related_Nod : Node_Id;
+ Related_Id : Entity_Id;
+ Suffix : Character);
+ -- Apply list of discriminant constraints to an unconstrained concurrent
+ -- type.
+ --
+ -- SI is the N_Subtype_Indication node containing the constraint and
+ -- the unconstrained type to constrain.
+ --
+ -- Def_Id is the entity for the resulting constrained subtype. A
+ -- value of Empty for Def_Id indicates that an implicit type must be
+ -- created, but creation is delayed (and must be done by this procedure)
+ -- because other subsidiary implicit types must be created first (which
+ -- is why Def_Id is an in/out parameter).
+ --
+ -- Related_Nod gives the place where this type has to be inserted
+ -- in the tree
+ --
+ -- The last two arguments are used to create its external name if needed.
+
+ function Constrain_Corresponding_Record
+ (Prot_Subt : Entity_Id;
+ Corr_Rec : Entity_Id;
+ Related_Nod : Node_Id;
+ Related_Id : Entity_Id)
+ return Entity_Id;
+ -- When constraining a protected type or task type with discriminants,
+ -- constrain the corresponding record with the same discriminant values.
+
+ procedure Constrain_Decimal
+ (Def_Id : Node_Id;
+ S : Node_Id;
+ Related_Nod : Node_Id);
+ -- Constrain a decimal fixed point type with a digits constraint and/or a
+ -- range constraint, and build E_Decimal_Fixed_Point_Subtype entity.
+
+ procedure Constrain_Discriminated_Type
+ (Def_Id : Entity_Id;
+ S : Node_Id;
+ Related_Nod : Node_Id;
+ For_Access : Boolean := False);
+ -- Process discriminant constraints of composite type. Verify that values
+ -- have been provided for all discriminants, that the original type is
+ -- unconstrained, and that the types of the supplied expressions match
+ -- the discriminant types. The first three parameters are like in routine
+ -- Constrain_Concurrent. See Build_Discrimated_Subtype for an explanation
+ -- of For_Access.
+
+ procedure Constrain_Enumeration
+ (Def_Id : Node_Id;
+ S : Node_Id;
+ Related_Nod : Node_Id);
+ -- Constrain an enumeration type with a range constraint. This is
+ -- identical to Constrain_Integer, but for the Ekind of the
+ -- resulting subtype.
+
+ procedure Constrain_Float
+ (Def_Id : Node_Id;
+ S : Node_Id;
+ Related_Nod : Node_Id);
+ -- Constrain a floating point type with either a digits constraint
+ -- and/or a range constraint, building a E_Floating_Point_Subtype.
+
+ procedure Constrain_Index
+ (Index : Node_Id;
+ S : Node_Id;
+ Related_Nod : Node_Id;
+ Related_Id : Entity_Id;
+ Suffix : Character;
+ Suffix_Index : Nat);
+ -- Process an index constraint in a constrained array declaration.
+ -- The constraint can be a subtype name, or a range with or without
+ -- an explicit subtype mark. The index is the corresponding index of the
+ -- unconstrained array. The Related_Id and Suffix parameters are used to
+ -- build the associated Implicit type name.
+
+ procedure Constrain_Integer
+ (Def_Id : Node_Id;
+ S : Node_Id;
+ Related_Nod : Node_Id);
+ -- Build subtype of a signed or modular integer type.
+
+ procedure Constrain_Ordinary_Fixed
+ (Def_Id : Node_Id;
+ S : Node_Id;
+ Related_Nod : Node_Id);
+ -- Constrain an ordinary fixed point type with a range constraint, and
+ -- build an E_Ordinary_Fixed_Point_Subtype entity.
+
+ procedure Copy_And_Swap (Privat, Full : Entity_Id);
+ -- Copy the Privat entity into the entity of its full declaration
+ -- then swap the two entities in such a manner that the former private
+ -- type is now seen as a full type.
+
+ procedure Copy_Private_To_Full (Priv, Full : Entity_Id);
+ -- Initialize the full view declaration with the relevant fields
+ -- from the private view.
+
+ procedure Decimal_Fixed_Point_Type_Declaration
+ (T : Entity_Id;
+ Def : Node_Id);
+ -- Create a new decimal fixed point type, and apply the constraint to
+ -- obtain a subtype of this new type.
+
+ procedure Complete_Private_Subtype
+ (Priv : Entity_Id;
+ Full : Entity_Id;
+ Full_Base : Entity_Id;
+ Related_Nod : Node_Id);
+ -- Complete the implicit full view of a private subtype by setting
+ -- the appropriate semantic fields. If the full view of the parent is
+ -- a record type, build constrained components of subtype.
+
+ procedure Derived_Standard_Character
+ (N : Node_Id;
+ Parent_Type : Entity_Id;
+ Derived_Type : Entity_Id);
+ -- Subsidiary procedure to Build_Derived_Enumeration_Type which handles
+ -- derivations from types Standard.Character and Standard.Wide_Character.
+
+ procedure Derived_Type_Declaration
+ (T : Entity_Id;
+ N : Node_Id;
+ Is_Completion : Boolean);
+ -- Process a derived type declaration. This routine will invoke
+ -- Build_Derived_Type to process the actual derived type definition.
+ -- Parameters N and Is_Completion have the same meaning as in
+ -- Build_Derived_Type. T is the N_Defining_Identifier for the entity
+ -- defined in the N_Full_Type_Declaration node N, that is T is the
+ -- derived type.
+
+ function Find_Type_Of_Subtype_Indic (S : Node_Id) return Entity_Id;
+ -- Given a subtype indication S (which is really an N_Subtype_Indication
+ -- node or a plain N_Identifier), find the type of the subtype mark.
+
+ procedure Enumeration_Type_Declaration (T : Entity_Id; Def : Node_Id);
+ -- Insert each literal in symbol table, as an overloadable identifier
+ -- Each enumeration type is mapped into a sequence of integers, and
+ -- each literal is defined as a constant with integer value. If any
+ -- of the literals are character literals, the type is a character
+ -- type, which means that strings are legal aggregates for arrays of
+ -- components of the type.
+
+ procedure Expand_Others_Choice
+ (Case_Table : Choice_Table_Type;
+ Others_Choice : Node_Id;
+ Choice_Type : Entity_Id);
+ -- In the case of a variant part of a record type that has an OTHERS
+ -- choice, this procedure expands the OTHERS into the actual choices
+ -- that it represents. This new list of choice nodes is attached to
+ -- the OTHERS node via the Others_Discrete_Choices field. The Case_Table
+ -- contains all choices that have been given explicitly in the variant.
+
+ function Find_Type_Of_Object
+ (Obj_Def : Node_Id;
+ Related_Nod : Node_Id)
+ return Entity_Id;
+ -- Get type entity for object referenced by Obj_Def, attaching the
+ -- implicit types generated to Related_Nod
+
+ procedure Floating_Point_Type_Declaration (T : Entity_Id; Def : Node_Id);
+ -- Create a new float, and apply the constraint to obtain subtype of it
+
+ function Has_Range_Constraint (N : Node_Id) return Boolean;
+ -- Given an N_Subtype_Indication node N, return True if a range constraint
+ -- is present, either directly, or as part of a digits or delta constraint.
+ -- In addition, a digits constraint in the decimal case returns True, since
+ -- it establishes a default range if no explicit range is present.
+
+ function Is_Valid_Constraint_Kind
+ (T_Kind : Type_Kind;
+ Constraint_Kind : Node_Kind)
+ return Boolean;
+ -- Returns True if it is legal to apply the given kind of constraint
+ -- to the given kind of type (index constraint to an array type,
+ -- for example).
+
+ procedure Modular_Type_Declaration (T : Entity_Id; Def : Node_Id);
+ -- Create new modular type. Verify that modulus is in bounds and is
+ -- a power of two (implementation restriction).
+
+ procedure New_Binary_Operator (Op_Name : Name_Id; Typ : Entity_Id);
+ -- Create an abbreviated declaration for an operator in order to
+ -- materialize minimally operators on derived types.
+
+ procedure Ordinary_Fixed_Point_Type_Declaration
+ (T : Entity_Id;
+ Def : Node_Id);
+ -- Create a new ordinary fixed point type, and apply the constraint
+ -- to obtain subtype of it.
+
+ procedure Prepare_Private_Subtype_Completion
+ (Id : Entity_Id;
+ Related_Nod : Node_Id);
+ -- Id is a subtype of some private type. Creates the full declaration
+ -- associated with Id whenever possible, i.e. when the full declaration
+ -- of the base type is already known. Records each subtype into
+ -- Private_Dependents of the base type.
+
+ procedure Process_Incomplete_Dependents
+ (N : Node_Id;
+ Full_T : Entity_Id;
+ Inc_T : Entity_Id);
+ -- Process all entities that depend on an incomplete type. There include
+ -- subtypes, subprogram types that mention the incomplete type in their
+ -- profiles, and subprogram with access parameters that designate the
+ -- incomplete type.
+
+ -- Inc_T is the defining identifier of an incomplete type declaration, its
+ -- Ekind is E_Incomplete_Type.
+ --
+ -- N is the corresponding N_Full_Type_Declaration for Inc_T.
+ --
+ -- Full_T is N's defining identifier.
+ --
+ -- Subtypes of incomplete types with discriminants are completed when the
+ -- parent type is. This is simpler than private subtypes, because they can
+ -- only appear in the same scope, and there is no need to exchange views.
+ -- Similarly, access_to_subprogram types may have a parameter or a return
+ -- type that is an incomplete type, and that must be replaced with the
+ -- full type.
+
+ -- If the full type is tagged, subprogram with access parameters that
+ -- designated the incomplete may be primitive operations of the full type,
+ -- and have to be processed accordingly.
+
+ procedure Process_Real_Range_Specification (Def : Node_Id);
+ -- Given the type definition for a real type, this procedure processes
+ -- and checks the real range specification of this type definition if
+ -- one is present. If errors are found, error messages are posted, and
+ -- the Real_Range_Specification of Def is reset to Empty.
+
+ procedure Record_Type_Declaration (T : Entity_Id; N : Node_Id);
+ -- Process a record type declaration (for both untagged and tagged
+ -- records). Parameters T and N are exactly like in procedure
+ -- Derived_Type_Declaration, except that no flag Is_Completion is
+ -- needed for this routine.
+
+ procedure Record_Type_Definition (Def : Node_Id; T : Entity_Id);
+ -- This routine is used to process the actual record type definition
+ -- (both for untagged and tagged records). Def is a record type
+ -- definition node. This procedure analyzes the components in this
+ -- record type definition. T is the entity for the enclosing record
+ -- type. It is provided so that its Has_Task flag can be set if any of
+ -- the component have Has_Task set.
+
+ procedure Set_Fixed_Range
+ (E : Entity_Id;
+ Loc : Source_Ptr;
+ Lo : Ureal;
+ Hi : Ureal);
+ -- Build a range node with the given bounds and set it as the Scalar_Range
+ -- of the given fixed-point type entity. Loc is the source location used
+ -- for the constructed range. See body for further details.
+
+ procedure Set_Scalar_Range_For_Subtype
+ (Def_Id : Entity_Id;
+ R : Node_Id;
+ Subt : Entity_Id;
+ Related_Nod : Node_Id);
+ -- This routine is used to set the scalar range field for a subtype
+ -- given Def_Id, the entity for the subtype, and R, the range expression
+ -- for the scalar range. Subt provides the parent subtype to be used
+ -- to analyze, resolve, and check the given range.
+
+ procedure Signed_Integer_Type_Declaration (T : Entity_Id; Def : Node_Id);
+ -- Create a new signed integer entity, and apply the constraint to obtain
+ -- the required first named subtype of this type.
+
+ -----------------------
+ -- Access_Definition --
+ -----------------------
+
+ function Access_Definition
+ (Related_Nod : Node_Id;
+ N : Node_Id)
+ return Entity_Id
+ is
+ Anon_Type : constant Entity_Id :=
+ Create_Itype (E_Anonymous_Access_Type, Related_Nod,
+ Scope_Id => Scope (Current_Scope));
+ Desig_Type : Entity_Id;
+
+ begin
+ if Is_Entry (Current_Scope)
+ and then Is_Task_Type (Etype (Scope (Current_Scope)))
+ then
+ Error_Msg_N ("task entries cannot have access parameters", N);
+ end if;
+
+ Find_Type (Subtype_Mark (N));
+ Desig_Type := Entity (Subtype_Mark (N));
+
+ Set_Directly_Designated_Type
+ (Anon_Type, Desig_Type);
+ Set_Etype (Anon_Type, Anon_Type);
+ Init_Size_Align (Anon_Type);
+ Set_Depends_On_Private (Anon_Type, Has_Private_Component (Anon_Type));
+
+ -- The anonymous access type is as public as the discriminated type or
+ -- subprogram that defines it. It is imported (for back-end purposes)
+ -- if the designated type is.
+
+ Set_Is_Public (Anon_Type, Is_Public (Scope (Anon_Type)));
+ Set_From_With_Type (Anon_Type, From_With_Type (Desig_Type));
+
+ -- The context is either a subprogram declaration or an access
+ -- discriminant, in a private or a full type declaration. In
+ -- the case of a subprogram, If the designated type is incomplete,
+ -- the operation will be a primitive operation of the full type, to
+ -- be updated subsequently.
+
+ if Ekind (Desig_Type) = E_Incomplete_Type
+ and then Is_Overloadable (Current_Scope)
+ then
+ Append_Elmt (Current_Scope, Private_Dependents (Desig_Type));
+ Set_Has_Delayed_Freeze (Current_Scope);
+ end if;
+
+ return Anon_Type;
+ end Access_Definition;
+
+ -----------------------------------
+ -- Access_Subprogram_Declaration --
+ -----------------------------------
+
+ procedure Access_Subprogram_Declaration
+ (T_Name : Entity_Id;
+ T_Def : Node_Id)
+ is
+ Formals : constant List_Id := Parameter_Specifications (T_Def);
+ Formal : Entity_Id;
+ Desig_Type : constant Entity_Id :=
+ Create_Itype (E_Subprogram_Type, Parent (T_Def));
+
+ begin
+ if Nkind (T_Def) = N_Access_Function_Definition then
+ Analyze (Subtype_Mark (T_Def));
+ Set_Etype (Desig_Type, Entity (Subtype_Mark (T_Def)));
+ else
+ Set_Etype (Desig_Type, Standard_Void_Type);
+ end if;
+
+ if Present (Formals) then
+ New_Scope (Desig_Type);
+ Process_Formals (Desig_Type, Formals, Parent (T_Def));
+
+ -- A bit of a kludge here, End_Scope requires that the parent
+ -- pointer be set to something reasonable, but Itypes don't
+ -- have parent pointers. So we set it and then unset it ???
+ -- If and when Itypes have proper parent pointers to their
+ -- declarations, this kludge can be removed.
+
+ Set_Parent (Desig_Type, T_Name);
+ End_Scope;
+ Set_Parent (Desig_Type, Empty);
+ end if;
+
+ -- The return type and/or any parameter type may be incomplete. Mark
+ -- the subprogram_type as depending on the incomplete type, so that
+ -- it can be updated when the full type declaration is seen.
+
+ if Present (Formals) then
+ Formal := First_Formal (Desig_Type);
+
+ while Present (Formal) loop
+
+ if Ekind (Formal) /= E_In_Parameter
+ and then Nkind (T_Def) = N_Access_Function_Definition
+ then
+ Error_Msg_N ("functions can only have IN parameters", Formal);
+ end if;
+
+ if Ekind (Etype (Formal)) = E_Incomplete_Type then
+ Append_Elmt (Desig_Type, Private_Dependents (Etype (Formal)));
+ Set_Has_Delayed_Freeze (Desig_Type);
+ end if;
+
+ Next_Formal (Formal);
+ end loop;
+ end if;
+
+ if Ekind (Etype (Desig_Type)) = E_Incomplete_Type
+ and then not Has_Delayed_Freeze (Desig_Type)
+ then
+ Append_Elmt (Desig_Type, Private_Dependents (Etype (Desig_Type)));
+ Set_Has_Delayed_Freeze (Desig_Type);
+ end if;
+
+ Check_Delayed_Subprogram (Desig_Type);
+
+ if Protected_Present (T_Def) then
+ Set_Ekind (T_Name, E_Access_Protected_Subprogram_Type);
+ Set_Convention (Desig_Type, Convention_Protected);
+ else
+ Set_Ekind (T_Name, E_Access_Subprogram_Type);
+ end if;
+
+ Set_Etype (T_Name, T_Name);
+ Init_Size_Align (T_Name);
+ Set_Directly_Designated_Type (T_Name, Desig_Type);
+
+ Check_Restriction (No_Access_Subprograms, T_Def);
+ end Access_Subprogram_Declaration;
+
+ ----------------------------
+ -- Access_Type_Declaration --
+ ----------------------------
+
+ procedure Access_Type_Declaration (T : Entity_Id; Def : Node_Id) is
+ S : constant Node_Id := Subtype_Indication (Def);
+ P : constant Node_Id := Parent (Def);
+
+ begin
+ -- Check for permissible use of incomplete type
+
+ if Nkind (S) /= N_Subtype_Indication then
+ Analyze (S);
+
+ if Ekind (Root_Type (Entity (S))) = E_Incomplete_Type then
+ Set_Directly_Designated_Type (T, Entity (S));
+ else
+ Set_Directly_Designated_Type (T,
+ Process_Subtype (S, P, T, 'P'));
+ end if;
+
+ else
+ Set_Directly_Designated_Type (T,
+ Process_Subtype (S, P, T, 'P'));
+ end if;
+
+ if All_Present (Def) or Constant_Present (Def) then
+ Set_Ekind (T, E_General_Access_Type);
+ else
+ Set_Ekind (T, E_Access_Type);
+ end if;
+
+ if Base_Type (Designated_Type (T)) = T then
+ Error_Msg_N ("access type cannot designate itself", S);
+ end if;
+
+ Set_Etype (T, T);
+
+ -- If the type has appeared already in a with_type clause, it is
+ -- frozen and the pointer size is already set. Else, initialize.
+
+ if not From_With_Type (T) then
+ Init_Size_Align (T);
+ end if;
+
+ Set_Is_Access_Constant (T, Constant_Present (Def));
+
+ -- If designated type is an imported tagged type, indicate that the
+ -- access type is also imported, and therefore restricted in its use.
+ -- The access type may already be imported, so keep setting otherwise.
+
+ if From_With_Type (Designated_Type (T)) then
+ Set_From_With_Type (T);
+ end if;
+
+ -- Note that Has_Task is always false, since the access type itself
+ -- is not a task type. See Einfo for more description on this point.
+ -- Exactly the same consideration applies to Has_Controlled_Component.
+
+ Set_Has_Task (T, False);
+ Set_Has_Controlled_Component (T, False);
+ end Access_Type_Declaration;
+
+ -----------------------------------
+ -- Analyze_Component_Declaration --
+ -----------------------------------
+
+ procedure Analyze_Component_Declaration (N : Node_Id) is
+ Id : constant Entity_Id := Defining_Identifier (N);
+ T : Entity_Id;
+ P : Entity_Id;
+
+ begin
+ Generate_Definition (Id);
+ Enter_Name (Id);
+ T := Find_Type_Of_Object (Subtype_Indication (N), N);
+
+ -- If the component declaration includes a default expression, then we
+ -- check that the component is not of a limited type (RM 3.7(5)),
+ -- and do the special preanalysis of the expression (see section on
+ -- "Handling of Default Expressions" in the spec of package Sem).
+
+ if Present (Expression (N)) then
+ Analyze_Default_Expression (Expression (N), T);
+ Check_Initialization (T, Expression (N));
+ end if;
+
+ -- The parent type may be a private view with unknown discriminants,
+ -- and thus unconstrained. Regular components must be constrained.
+
+ if Is_Indefinite_Subtype (T) and then Chars (Id) /= Name_uParent then
+ Error_Msg_N
+ ("unconstrained subtype in component declaration",
+ Subtype_Indication (N));
+
+ -- Components cannot be abstract, except for the special case of
+ -- the _Parent field (case of extending an abstract tagged type)
+
+ elsif Is_Abstract (T) and then Chars (Id) /= Name_uParent then
+ Error_Msg_N ("type of a component cannot be abstract", N);
+ end if;
+
+ Set_Etype (Id, T);
+ Set_Is_Aliased (Id, Aliased_Present (N));
+
+ -- If the this component is private (or depends on a private type),
+ -- flag the record type to indicate that some operations are not
+ -- available.
+
+ P := Private_Component (T);
+
+ if Present (P) then
+ -- Check for circular definitions.
+
+ if P = Any_Type then
+ Set_Etype (Id, Any_Type);
+
+ -- There is a gap in the visibility of operations only if the
+ -- component type is not defined in the scope of the record type.
+
+ elsif Scope (P) = Scope (Current_Scope) then
+ null;
+
+ elsif Is_Limited_Type (P) then
+ Set_Is_Limited_Composite (Current_Scope);
+
+ else
+ Set_Is_Private_Composite (Current_Scope);
+ end if;
+ end if;
+
+ if P /= Any_Type
+ and then Is_Limited_Type (T)
+ and then Chars (Id) /= Name_uParent
+ and then Is_Tagged_Type (Current_Scope)
+ then
+ if Is_Derived_Type (Current_Scope)
+ and then not Is_Limited_Record (Root_Type (Current_Scope))
+ then
+ Error_Msg_N
+ ("extension of nonlimited type cannot have limited components",
+ N);
+ Set_Etype (Id, Any_Type);
+ Set_Is_Limited_Composite (Current_Scope, False);
+
+ elsif not Is_Derived_Type (Current_Scope)
+ and then not Is_Limited_Record (Current_Scope)
+ then
+ Error_Msg_N ("nonlimited type cannot have limited components", N);
+ Set_Etype (Id, Any_Type);
+ Set_Is_Limited_Composite (Current_Scope, False);
+ end if;
+ end if;
+
+ Set_Original_Record_Component (Id, Id);
+ end Analyze_Component_Declaration;
+
+ --------------------------
+ -- Analyze_Declarations --
+ --------------------------
+
+ procedure Analyze_Declarations (L : List_Id) is
+ D : Node_Id;
+ Next_Node : Node_Id;
+ Freeze_From : Entity_Id := Empty;
+
+ procedure Adjust_D;
+ -- Adjust D not to include implicit label declarations, since these
+ -- have strange Sloc values that result in elaboration check problems.
+
+ procedure Adjust_D is
+ begin
+ while Present (Prev (D))
+ and then Nkind (D) = N_Implicit_Label_Declaration
+ loop
+ Prev (D);
+ end loop;
+ end Adjust_D;
+
+ -- Start of processing for Analyze_Declarations
+
+ begin
+ D := First (L);
+ while Present (D) loop
+
+ -- Complete analysis of declaration
+
+ Analyze (D);
+ Next_Node := Next (D);
+
+ if No (Freeze_From) then
+ Freeze_From := First_Entity (Current_Scope);
+ end if;
+
+ -- At the end of a declarative part, freeze remaining entities
+ -- declared in it. The end of the visible declarations of a
+ -- package specification is not the end of a declarative part
+ -- if private declarations are present. The end of a package
+ -- declaration is a freezing point only if it a library package.
+ -- A task definition or protected type definition is not a freeze
+ -- point either. Finally, we do not freeze entities in generic
+ -- scopes, because there is no code generated for them and freeze
+ -- nodes will be generated for the instance.
+
+ -- The end of a package instantiation is not a freeze point, but
+ -- for now we make it one, because the generic body is inserted
+ -- (currently) immediately after. Generic instantiations will not
+ -- be a freeze point once delayed freezing of bodies is implemented.
+ -- (This is needed in any case for early instantiations ???).
+
+ if No (Next_Node) then
+ if Nkind (Parent (L)) = N_Component_List
+ or else Nkind (Parent (L)) = N_Task_Definition
+ or else Nkind (Parent (L)) = N_Protected_Definition
+ then
+ null;
+
+ elsif Nkind (Parent (L)) /= N_Package_Specification then
+
+ if Nkind (Parent (L)) = N_Package_Body then
+ Freeze_From := First_Entity (Current_Scope);
+ end if;
+
+ Adjust_D;
+ Freeze_All (Freeze_From, D);
+ Freeze_From := Last_Entity (Current_Scope);
+
+ elsif Scope (Current_Scope) /= Standard_Standard
+ and then not Is_Child_Unit (Current_Scope)
+ and then No (Generic_Parent (Parent (L)))
+ then
+ null;
+
+ elsif L /= Visible_Declarations (Parent (L))
+ or else No (Private_Declarations (Parent (L)))
+ or else Is_Empty_List (Private_Declarations (Parent (L)))
+ then
+ Adjust_D;
+ Freeze_All (Freeze_From, D);
+ Freeze_From := Last_Entity (Current_Scope);
+ end if;
+
+ -- If next node is a body then freeze all types before the body.
+ -- An exception occurs for expander generated bodies, which can
+ -- be recognized by their already being analyzed. The expander
+ -- ensures that all types needed by these bodies have been frozen
+ -- but it is not necessary to freeze all types (and would be wrong
+ -- since it would not correspond to an RM defined freeze point).
+
+ elsif not Analyzed (Next_Node)
+ and then (Nkind (Next_Node) = N_Subprogram_Body
+ or else Nkind (Next_Node) = N_Entry_Body
+ or else Nkind (Next_Node) = N_Package_Body
+ or else Nkind (Next_Node) = N_Protected_Body
+ or else Nkind (Next_Node) = N_Task_Body
+ or else Nkind (Next_Node) in N_Body_Stub)
+ then
+ Adjust_D;
+ Freeze_All (Freeze_From, D);
+ Freeze_From := Last_Entity (Current_Scope);
+ end if;
+
+ D := Next_Node;
+ end loop;
+
+ end Analyze_Declarations;
+
+ --------------------------------
+ -- Analyze_Default_Expression --
+ --------------------------------
+
+ procedure Analyze_Default_Expression (N : Node_Id; T : Entity_Id) is
+ Save_In_Default_Expression : constant Boolean := In_Default_Expression;
+
+ begin
+ In_Default_Expression := True;
+ Pre_Analyze_And_Resolve (N, T);
+ In_Default_Expression := Save_In_Default_Expression;
+ end Analyze_Default_Expression;
+
+ ----------------------------------
+ -- Analyze_Incomplete_Type_Decl --
+ ----------------------------------
+
+ procedure Analyze_Incomplete_Type_Decl (N : Node_Id) is
+ F : constant Boolean := Is_Pure (Current_Scope);
+ T : Entity_Id;
+
+ begin
+ Generate_Definition (Defining_Identifier (N));
+
+ -- Process an incomplete declaration. The identifier must not have been
+ -- declared already in the scope. However, an incomplete declaration may
+ -- appear in the private part of a package, for a private type that has
+ -- already been declared.
+
+ -- In this case, the discriminants (if any) must match.
+
+ T := Find_Type_Name (N);
+
+ Set_Ekind (T, E_Incomplete_Type);
+ Init_Size_Align (T);
+ Set_Is_First_Subtype (T, True);
+ Set_Etype (T, T);
+ New_Scope (T);
+
+ Set_Girder_Constraint (T, No_Elist);
+
+ if Present (Discriminant_Specifications (N)) then
+ Process_Discriminants (N);
+ end if;
+
+ End_Scope;
+
+ -- If the type has discriminants, non-trivial subtypes may be
+ -- be declared before the full view of the type. The full views
+ -- of those subtypes will be built after the full view of the type.
+
+ Set_Private_Dependents (T, New_Elmt_List);
+ Set_Is_Pure (T, F);
+ end Analyze_Incomplete_Type_Decl;
+
+ -----------------------------
+ -- Analyze_Itype_Reference --
+ -----------------------------
+
+ -- Nothing to do. This node is placed in the tree only for the benefit
+ -- of Gigi processing, and has no effect on the semantic processing.
+
+ procedure Analyze_Itype_Reference (N : Node_Id) is
+ begin
+ pragma Assert (Is_Itype (Itype (N)));
+ null;
+ end Analyze_Itype_Reference;
+
+ --------------------------------
+ -- Analyze_Number_Declaration --
+ --------------------------------
+
+ procedure Analyze_Number_Declaration (N : Node_Id) is
+ Id : constant Entity_Id := Defining_Identifier (N);
+ E : constant Node_Id := Expression (N);
+ T : Entity_Id;
+ Index : Interp_Index;
+ It : Interp;
+
+ begin
+ Generate_Definition (Id);
+ Enter_Name (Id);
+
+ -- This is an optimization of a common case of an integer literal
+
+ if Nkind (E) = N_Integer_Literal then
+ Set_Is_Static_Expression (E, True);
+ Set_Etype (E, Universal_Integer);
+
+ Set_Etype (Id, Universal_Integer);
+ Set_Ekind (Id, E_Named_Integer);
+ Set_Is_Frozen (Id, True);
+ return;
+ end if;
+
+ Set_Is_Pure (Id, Is_Pure (Current_Scope));
+
+ Analyze (E);
+
+ -- Verify that the expression is static and numeric. If
+ -- the expression is overloaded, we apply the preference
+ -- rule that favors root numeric types.
+
+ if not Is_Overloaded (E) then
+ T := Etype (E);
+
+ else
+ T := Any_Type;
+ Get_First_Interp (E, Index, It);
+
+ while Present (It.Typ) loop
+ if (Is_Integer_Type (It.Typ)
+ or else Is_Real_Type (It.Typ))
+ and then (Scope (Base_Type (It.Typ))) = Standard_Standard
+ then
+ if T = Any_Type then
+ T := It.Typ;
+
+ elsif It.Typ = Universal_Real
+ or else It.Typ = Universal_Integer
+ then
+ -- Choose universal interpretation over any other.
+
+ T := It.Typ;
+ exit;
+ end if;
+ end if;
+
+ Get_Next_Interp (Index, It);
+ end loop;
+ end if;
+
+ if Is_Integer_Type (T) then
+ Resolve (E, T);
+ Set_Etype (Id, Universal_Integer);
+ Set_Ekind (Id, E_Named_Integer);
+
+ elsif Is_Real_Type (T) then
+
+ -- Because the real value is converted to universal_real, this
+ -- is a legal context for a universal fixed expression.
+
+ if T = Universal_Fixed then
+ declare
+ Loc : constant Source_Ptr := Sloc (N);
+ Conv : constant Node_Id := Make_Type_Conversion (Loc,
+ Subtype_Mark =>
+ New_Occurrence_Of (Universal_Real, Loc),
+ Expression => Relocate_Node (E));
+
+ begin
+ Rewrite (E, Conv);
+ Analyze (E);
+ end;
+
+ elsif T = Any_Fixed then
+ Error_Msg_N ("illegal context for mixed mode operation", E);
+
+ -- Expression is of the form : universal_fixed * integer.
+ -- Try to resolve as universal_real.
+
+ T := Universal_Real;
+ Set_Etype (E, T);
+ end if;
+
+ Resolve (E, T);
+ Set_Etype (Id, Universal_Real);
+ Set_Ekind (Id, E_Named_Real);
+
+ else
+ Wrong_Type (E, Any_Numeric);
+ Resolve (E, T);
+ Set_Etype (Id, T);
+ Set_Ekind (Id, E_Constant);
+ Set_Not_Source_Assigned (Id, True);
+ Set_Is_True_Constant (Id, True);
+ return;
+ end if;
+
+ if Nkind (E) = N_Integer_Literal
+ or else Nkind (E) = N_Real_Literal
+ then
+ Set_Etype (E, Etype (Id));
+ end if;
+
+ if not Is_OK_Static_Expression (E) then
+ Error_Msg_N ("non-static expression used in number declaration", E);
+ Rewrite (E, Make_Integer_Literal (Sloc (N), 1));
+ Set_Etype (E, Any_Type);
+ end if;
+
+ end Analyze_Number_Declaration;
+
+ --------------------------------
+ -- Analyze_Object_Declaration --
+ --------------------------------
+
+ procedure Analyze_Object_Declaration (N : Node_Id) is
+ Loc : constant Source_Ptr := Sloc (N);
+ Id : constant Entity_Id := Defining_Identifier (N);
+ T : Entity_Id;
+ Act_T : Entity_Id;
+
+ E : Node_Id := Expression (N);
+ -- E is set to Expression (N) throughout this routine. When
+ -- Expression (N) is modified, E is changed accordingly.
+
+ Prev_Entity : Entity_Id := Empty;
+
+ function Build_Default_Subtype return Entity_Id;
+ -- If the object is limited or aliased, and if the type is unconstrained
+ -- and there is no expression, the discriminants cannot be modified and
+ -- the subtype of the object is constrained by the defaults, so it is
+ -- worthile building the corresponding subtype.
+
+ ---------------------------
+ -- Build_Default_Subtype --
+ ---------------------------
+
+ function Build_Default_Subtype return Entity_Id is
+ Act : Entity_Id;
+ Constraints : List_Id := New_List;
+ Decl : Node_Id;
+ Disc : Entity_Id;
+
+ begin
+ Disc := First_Discriminant (T);
+
+ if No (Discriminant_Default_Value (Disc)) then
+ return T; -- previous error.
+ end if;
+
+ Act := Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
+ while Present (Disc) loop
+ Append (
+ New_Copy_Tree (
+ Discriminant_Default_Value (Disc)), Constraints);
+ Next_Discriminant (Disc);
+ end loop;
+
+ Decl :=
+ Make_Subtype_Declaration (Loc,
+ Defining_Identifier => Act,
+ Subtype_Indication =>
+ Make_Subtype_Indication (Loc,
+ Subtype_Mark => New_Occurrence_Of (T, Loc),
+ Constraint =>
+ Make_Index_Or_Discriminant_Constraint
+ (Loc, Constraints)));
+
+ Insert_Before (N, Decl);
+ Analyze (Decl);
+ return Act;
+ end Build_Default_Subtype;
+
+ -- Start of processing for Analyze_Object_Declaration
+
+ begin
+ -- There are three kinds of implicit types generated by an
+ -- object declaration:
+
+ -- 1. Those for generated by the original Object Definition
+
+ -- 2. Those generated by the Expression
+
+ -- 3. Those used to constrained the Object Definition with the
+ -- expression constraints when it is unconstrained
+
+ -- They must be generated in this order to avoid order of elaboration
+ -- issues. Thus the first step (after entering the name) is to analyze
+ -- the object definition.
+
+ if Constant_Present (N) then
+ Prev_Entity := Current_Entity_In_Scope (Id);
+
+ -- If homograph is an implicit subprogram, it is overridden by the
+ -- current declaration.
+
+ if Present (Prev_Entity)
+ and then Is_Overloadable (Prev_Entity)
+ and then Is_Inherited_Operation (Prev_Entity)
+ then
+ Prev_Entity := Empty;
+ end if;
+ end if;
+
+ if Present (Prev_Entity) then
+ Constant_Redeclaration (Id, N, T);
+
+ Generate_Reference (Prev_Entity, Id, 'c');
+
+ -- If in main unit, set as referenced, so we do not complain about
+ -- the full declaration being an unreferenced entity.
+
+ if In_Extended_Main_Source_Unit (Id) then
+ Set_Referenced (Id);
+ end if;
+
+ if Error_Posted (N) then
+ -- Type mismatch or illegal redeclaration, Do not analyze
+ -- expression to avoid cascaded errors.
+
+ T := Find_Type_Of_Object (Object_Definition (N), N);
+ Set_Etype (Id, T);
+ Set_Ekind (Id, E_Variable);
+ return;
+ end if;
+
+ -- In the normal case, enter identifier at the start to catch
+ -- premature usage in the initialization expression.
+
+ else
+ Generate_Definition (Id);
+ Enter_Name (Id);
+
+ T := Find_Type_Of_Object (Object_Definition (N), N);
+
+ if Error_Posted (Id) then
+ Set_Etype (Id, T);
+ Set_Ekind (Id, E_Variable);
+ return;
+ end if;
+ end if;
+
+ Set_Is_Pure (Id, Is_Pure (Current_Scope));
+
+ -- If deferred constant, make sure context is appropriate. We detect
+ -- a deferred constant as a constant declaration with no expression.
+
+ if Constant_Present (N)
+ and then No (E)
+ then
+ if not Is_Package (Current_Scope)
+ or else In_Private_Part (Current_Scope)
+ then
+ Error_Msg_N
+ ("invalid context for deferred constant declaration", N);
+ Set_Constant_Present (N, False);
+
+ -- In Ada 83, deferred constant must be of private type
+
+ elsif not Is_Private_Type (T) then
+ if Ada_83 and then Comes_From_Source (N) then
+ Error_Msg_N
+ ("(Ada 83) deferred constant must be private type", N);
+ end if;
+ end if;
+
+ -- If not a deferred constant, then object declaration freezes its type
+
+ else
+ Check_Fully_Declared (T, N);
+ Freeze_Before (N, T);
+ end if;
+
+ -- If the object was created by a constrained array definition, then
+ -- set the link in both the anonymous base type and anonymous subtype
+ -- that are built to represent the array type to point to the object.
+
+ if Nkind (Object_Definition (Declaration_Node (Id))) =
+ N_Constrained_Array_Definition
+ then
+ Set_Related_Array_Object (T, Id);
+ Set_Related_Array_Object (Base_Type (T), Id);
+ end if;
+
+ -- Special checks for protected objects not at library level
+
+ if Is_Protected_Type (T)
+ and then not Is_Library_Level_Entity (Id)
+ then
+ Check_Restriction (No_Local_Protected_Objects, Id);
+
+ -- Protected objects with interrupt handlers must be at library level
+
+ if Has_Interrupt_Handler (T) then
+ Error_Msg_N
+ ("interrupt object can only be declared at library level", Id);
+ end if;
+ end if;
+
+ -- The actual subtype of the object is the nominal subtype, unless
+ -- the nominal one is unconstrained and obtained from the expression.
+
+ Act_T := T;
+
+ -- Process initialization expression if present and not in error
+
+ if Present (E) and then E /= Error then
+ Analyze (E);
+
+ if not Assignment_OK (N) then
+ Check_Initialization (T, E);
+ end if;
+
+ Resolve (E, T);
+
+ -- Check for library level object that will require implicit
+ -- heap allocation.
+
+ if Is_Array_Type (T)
+ and then not Size_Known_At_Compile_Time (T)
+ and then Is_Library_Level_Entity (Id)
+ then
+ -- String literals are always allowed
+
+ if T = Standard_String
+ and then Nkind (E) = N_String_Literal
+ then
+ null;
+
+ -- Otherwise we do not allow this since it may cause an
+ -- implicit heap allocation.
+
+ else
+ Check_Restriction
+ (No_Implicit_Heap_Allocations, Object_Definition (N));
+ end if;
+ end if;
+
+ -- Check incorrect use of dynamically tagged expressions. Note
+ -- the use of Is_Tagged_Type (T) which seems redundant but is in
+ -- fact important to avoid spurious errors due to expanded code
+ -- for dispatching functions over an anonymous access type
+
+ if (Is_Class_Wide_Type (Etype (E)) or else Is_Dynamically_Tagged (E))
+ and then Is_Tagged_Type (T)
+ and then not Is_Class_Wide_Type (T)
+ then
+ Error_Msg_N ("dynamically tagged expression not allowed!", E);
+ end if;
+
+ Apply_Scalar_Range_Check (E, T);
+ Apply_Static_Length_Check (E, T);
+ end if;
+
+ -- Abstract type is never permitted for a variable or constant.
+ -- Note: we inhibit this check for objects that do not come from
+ -- source because there is at least one case (the expansion of
+ -- x'class'input where x is abstract) where we legitimately
+ -- generate an abstract object.
+
+ if Is_Abstract (T) and then Comes_From_Source (N) then
+ Error_Msg_N ("type of object cannot be abstract",
+ Object_Definition (N));
+ if Is_CPP_Class (T) then
+ Error_Msg_NE ("\} may need a cpp_constructor",
+ Object_Definition (N), T);
+ end if;
+
+ -- Case of unconstrained type
+
+ elsif Is_Indefinite_Subtype (T) then
+
+ -- Nothing to do in deferred constant case
+
+ if Constant_Present (N) and then No (E) then
+ null;
+
+ -- Case of no initialization present
+
+ elsif No (E) then
+ if No_Initialization (N) then
+ null;
+
+ elsif Is_Class_Wide_Type (T) then
+ Error_Msg_N
+ ("initialization required in class-wide declaration ", N);
+
+ else
+ Error_Msg_N
+ ("unconstrained subtype not allowed (need initialization)",
+ Object_Definition (N));
+ end if;
+
+ -- Case of initialization present but in error. Set initial
+ -- expression as absent (but do not make above complaints)
+
+ elsif E = Error then
+ Set_Expression (N, Empty);
+ E := Empty;
+
+ -- Case of initialization present
+
+ else
+ -- Not allowed in Ada 83
+
+ if not Constant_Present (N) then
+ if Ada_83
+ and then Comes_From_Source (Object_Definition (N))
+ then
+ Error_Msg_N
+ ("(Ada 83) unconstrained variable not allowed",
+ Object_Definition (N));
+ end if;
+ end if;
+
+ -- Now we constrain the variable from the initializing expression
+
+ -- If the expression is an aggregate, it has been expanded into
+ -- individual assignments. Retrieve the actual type from the
+ -- expanded construct.
+
+ if Is_Array_Type (T)
+ and then No_Initialization (N)
+ and then Nkind (Original_Node (E)) = N_Aggregate
+ then
+ Act_T := Etype (E);
+
+ else
+ Expand_Subtype_From_Expr (N, T, Object_Definition (N), E);
+ Act_T := Find_Type_Of_Object (Object_Definition (N), N);
+ end if;
+
+ Set_Is_Constr_Subt_For_U_Nominal (Act_T);
+
+ if Aliased_Present (N) then
+ Set_Is_Constr_Subt_For_UN_Aliased (Act_T);
+ end if;
+
+ Freeze_Before (N, Act_T);
+ Freeze_Before (N, T);
+ end if;
+
+ elsif Is_Array_Type (T)
+ and then No_Initialization (N)
+ and then Nkind (Original_Node (E)) = N_Aggregate
+ then
+ if not Is_Entity_Name (Object_Definition (N)) then
+ Act_T := Etype (E);
+
+ if Aliased_Present (N) then
+ Set_Is_Constr_Subt_For_UN_Aliased (Act_T);
+ end if;
+ end if;
+
+ -- When the given object definition and the aggregate are specified
+ -- independently, and their lengths might differ do a length check.
+ -- This cannot happen if the aggregate is of the form (others =>...)
+
+ if not Is_Constrained (T) then
+ null;
+
+ elsif T = Etype (E) then
+ null;
+
+ elsif Nkind (E) = N_Aggregate
+ and then Present (Component_Associations (E))
+ and then Present (Choices (First (Component_Associations (E))))
+ and then Nkind (First
+ (Choices (First (Component_Associations (E))))) = N_Others_Choice
+ then
+ null;
+
+ else
+ Apply_Length_Check (E, T);
+ end if;
+
+ elsif (Is_Limited_Record (T)
+ or else Is_Concurrent_Type (T))
+ and then not Is_Constrained (T)
+ and then Has_Discriminants (T)
+ then
+ Act_T := Build_Default_Subtype;
+ Rewrite (Object_Definition (N), New_Occurrence_Of (Act_T, Loc));
+
+ elsif not Is_Constrained (T)
+ and then Has_Discriminants (T)
+ and then Constant_Present (N)
+ and then Nkind (E) = N_Function_Call
+ then
+ -- The back-end has problems with constants of a discriminated type
+ -- with defaults, if the initial value is a function call. We
+ -- generate an intermediate temporary for the result of the call.
+ -- It is unclear why this should make it acceptable to gcc. ???
+
+ Remove_Side_Effects (E);
+ end if;
+
+ if T = Standard_Wide_Character
+ or else Root_Type (T) = Standard_Wide_String
+ then
+ Check_Restriction (No_Wide_Characters, Object_Definition (N));
+ end if;
+
+ -- Now establish the proper kind and type of the object
+
+ if Constant_Present (N) then
+ Set_Ekind (Id, E_Constant);
+ Set_Not_Source_Assigned (Id, True);
+ Set_Is_True_Constant (Id, True);
+
+ else
+ Set_Ekind (Id, E_Variable);
+
+ -- A variable is set as shared passive if it appears in a shared
+ -- passive package, and is at the outer level. This is not done
+ -- for entities generated during expansion, because those are
+ -- always manipulated locally.
+
+ if Is_Shared_Passive (Current_Scope)
+ and then Is_Library_Level_Entity (Id)
+ and then Comes_From_Source (Id)
+ then
+ Set_Is_Shared_Passive (Id);
+ Check_Shared_Var (Id, T, N);
+ end if;
+
+ -- If an initializing expression is present, then the variable
+ -- is potentially a true constant if no further assignments are
+ -- present. The code generator can use this for optimization.
+ -- The flag will be reset if there are any assignments. We only
+ -- set this flag for non library level entities, since for any
+ -- library level entities, assignments could exist in other units.
+
+ if Present (E) then
+ if not Is_Library_Level_Entity (Id) then
+
+ -- For now we omit this, because it seems to cause some
+ -- problems. In particular, if you uncomment this out, then
+ -- test case 4427-002 will fail for unclear reasons ???
+
+ if False then
+ Set_Is_True_Constant (Id);
+ end if;
+ end if;
+
+ -- Case of no initializing expression present. If the type is not
+ -- fully initialized, then we set Not_Source_Assigned, since this
+ -- is a case of a potentially uninitialized object. Note that we
+ -- do not consider access variables to be fully initialized for
+ -- this purpose, since it still seems dubious if someone declares
+ -- an access variable and never assigns to it.
+
+ else
+ if Is_Access_Type (T)
+ or else not Is_Fully_Initialized_Type (T)
+ then
+ Set_Not_Source_Assigned (Id);
+ end if;
+ end if;
+ end if;
+
+ Init_Alignment (Id);
+ Init_Esize (Id);
+
+ if Aliased_Present (N) then
+ Set_Is_Aliased (Id);
+
+ if No (E)
+ and then Is_Record_Type (T)
+ and then not Is_Constrained (T)
+ and then Has_Discriminants (T)
+ then
+ Set_Actual_Subtype (Id, Build_Default_Subtype);
+ end if;
+ end if;
+
+ Set_Etype (Id, Act_T);
+
+ if Has_Controlled_Component (Etype (Id))
+ or else Is_Controlled (Etype (Id))
+ then
+ if not Is_Library_Level_Entity (Id) then
+ Check_Restriction (No_Nested_Finalization, N);
+
+ else
+ Validate_Controlled_Object (Id);
+ end if;
+
+ -- Generate a warning when an initialization causes an obvious
+ -- ABE violation. If the init expression is a simple aggregate
+ -- there shouldn't be any initialize/adjust call generated. This
+ -- will be true as soon as aggregates are built in place when
+ -- possible. ??? at the moment we do not generate warnings for
+ -- temporaries created for those aggregates although a
+ -- Program_Error might be generated if compiled with -gnato
+
+ if Is_Controlled (Etype (Id))
+ and then Comes_From_Source (Id)
+ then
+ declare
+ BT : constant Entity_Id := Base_Type (Etype (Id));
+ Implicit_Call : Entity_Id;
+
+ function Is_Aggr (N : Node_Id) return Boolean;
+ -- Check that N is an aggregate
+
+ function Is_Aggr (N : Node_Id) return Boolean is
+ begin
+ case Nkind (Original_Node (N)) is
+ when N_Aggregate | N_Extension_Aggregate =>
+ return True;
+
+ when N_Qualified_Expression |
+ N_Type_Conversion |
+ N_Unchecked_Type_Conversion =>
+ return Is_Aggr (Expression (Original_Node (N)));
+
+ when others =>
+ return False;
+ end case;
+ end Is_Aggr;
+
+ begin
+ -- If no underlying type, we already are in an error situation
+ -- don't try to add a warning since we do not have access
+ -- prim-op list.
+
+ if No (Underlying_Type (BT)) then
+ Implicit_Call := Empty;
+
+ -- A generic type does not have usable primitive operators.
+ -- Initialization calls are built for instances.
+
+ elsif Is_Generic_Type (BT) then
+ Implicit_Call := Empty;
+
+ -- if the init expression is not an aggregate, an adjust
+ -- call will be generated
+
+ elsif Present (E) and then not Is_Aggr (E) then
+ Implicit_Call := Find_Prim_Op (BT, Name_Adjust);
+
+ -- if no init expression and we are not in the deferred
+ -- constant case, an Initialize call will be generated
+
+ elsif No (E) and then not Constant_Present (N) then
+ Implicit_Call := Find_Prim_Op (BT, Name_Initialize);
+
+ else
+ Implicit_Call := Empty;
+ end if;
+ end;
+ end if;
+ end if;
+
+ if Has_Task (Etype (Id)) then
+ if not Is_Library_Level_Entity (Id) then
+ Check_Restriction (No_Task_Hierarchy, N);
+ Check_Potentially_Blocking_Operation (N);
+ end if;
+ end if;
+
+ -- Some simple constant-propagation: if the expression is a constant
+ -- string initialized with a literal, share the literal. This avoids
+ -- a run-time copy.
+
+ if Present (E)
+ and then Is_Entity_Name (E)
+ and then Ekind (Entity (E)) = E_Constant
+ and then Base_Type (Etype (E)) = Standard_String
+ then
+ declare
+ Val : constant Node_Id := Constant_Value (Entity (E));
+
+ begin
+ if Present (Val)
+ and then Nkind (Val) = N_String_Literal
+ then
+ Rewrite (E, New_Copy (Val));
+ end if;
+ end;
+ end if;
+
+ -- Another optimization: if the nominal subtype is unconstrained and
+ -- the expression is a function call that returns and unconstrained
+ -- type, rewrite the declararation as a renaming of the result of the
+ -- call. The exceptions below are cases where the copy is expected,
+ -- either by the back end (Aliased case) or by the semantics, as for
+ -- initializing controlled types or copying tags for classwide types.
+
+ if Present (E)
+ and then Nkind (E) = N_Explicit_Dereference
+ and then Nkind (Original_Node (E)) = N_Function_Call
+ and then not Is_Library_Level_Entity (Id)
+ and then not Is_Constrained (T)
+ and then not Is_Aliased (Id)
+ and then not Is_Class_Wide_Type (T)
+ and then not Is_Controlled (T)
+ and then not Has_Controlled_Component (Base_Type (T))
+ and then Expander_Active
+ then
+ Rewrite (N,
+ Make_Object_Renaming_Declaration (Loc,
+ Defining_Identifier => Id,
+ Subtype_Mark => New_Occurrence_Of
+ (Base_Type (Etype (Id)), Loc),
+ Name => E));
+
+ Set_Renamed_Object (Id, E);
+ end if;
+
+ if Present (Prev_Entity)
+ and then Is_Frozen (Prev_Entity)
+ and then not Error_Posted (Id)
+ then
+ Error_Msg_N ("full constant declaration appears too late", N);
+ end if;
+
+ Check_Eliminated (Id);
+ end Analyze_Object_Declaration;
+
+ ---------------------------
+ -- Analyze_Others_Choice --
+ ---------------------------
+
+ -- Nothing to do for the others choice node itself, the semantic analysis
+ -- of the others choice will occur as part of the processing of the parent
+
+ procedure Analyze_Others_Choice (N : Node_Id) is
+ begin
+ null;
+ end Analyze_Others_Choice;
+
+ -------------------------------------------
+ -- Analyze_Private_Extension_Declaration --
+ -------------------------------------------
+
+ procedure Analyze_Private_Extension_Declaration (N : Node_Id) is
+ T : Entity_Id := Defining_Identifier (N);
+ Indic : constant Node_Id := Subtype_Indication (N);
+ Parent_Type : Entity_Id;
+ Parent_Base : Entity_Id;
+
+ begin
+ Generate_Definition (T);
+ Enter_Name (T);
+
+ Parent_Type := Find_Type_Of_Subtype_Indic (Indic);
+ Parent_Base := Base_Type (Parent_Type);
+
+ if Parent_Type = Any_Type
+ or else Etype (Parent_Type) = Any_Type
+ then
+ Set_Ekind (T, Ekind (Parent_Type));
+ Set_Etype (T, Any_Type);
+ return;
+
+ elsif not Is_Tagged_Type (Parent_Type) then
+ Error_Msg_N
+ ("parent of type extension must be a tagged type ", Indic);
+ return;
+
+ elsif Ekind (Parent_Type) = E_Void
+ or else Ekind (Parent_Type) = E_Incomplete_Type
+ then
+ Error_Msg_N ("premature derivation of incomplete type", Indic);
+ return;
+ end if;
+
+ -- Perhaps the parent type should be changed to the class-wide type's
+ -- specific type in this case to prevent cascading errors ???
+
+ if Is_Class_Wide_Type (Parent_Type) then
+ Error_Msg_N
+ ("parent of type extension must not be a class-wide type", Indic);
+ return;
+ end if;
+
+ if (not Is_Package (Current_Scope)
+ and then Nkind (Parent (N)) /= N_Generic_Subprogram_Declaration)
+ or else In_Private_Part (Current_Scope)
+
+ then
+ Error_Msg_N ("invalid context for private extension", N);
+ end if;
+
+ -- Set common attributes
+
+ Set_Is_Pure (T, Is_Pure (Current_Scope));
+ Set_Scope (T, Current_Scope);
+ Set_Ekind (T, E_Record_Type_With_Private);
+ Init_Size_Align (T);
+
+ Set_Etype (T, Parent_Base);
+ Set_Has_Task (T, Has_Task (Parent_Base));
+
+ Set_Convention (T, Convention (Parent_Type));
+ Set_First_Rep_Item (T, First_Rep_Item (Parent_Type));
+ Set_Is_First_Subtype (T);
+ Make_Class_Wide_Type (T);
+
+ Build_Derived_Record_Type (N, Parent_Type, T);
+ end Analyze_Private_Extension_Declaration;
+
+ ---------------------------------
+ -- Analyze_Subtype_Declaration --
+ ---------------------------------
+
+ procedure Analyze_Subtype_Declaration (N : Node_Id) is
+ Id : constant Entity_Id := Defining_Identifier (N);
+ T : Entity_Id;
+ R_Checks : Check_Result;
+
+ begin
+ Generate_Definition (Id);
+ Set_Is_Pure (Id, Is_Pure (Current_Scope));
+ Init_Size_Align (Id);
+
+ -- The following guard condition on Enter_Name is to handle cases
+ -- where the defining identifier has already been entered into the
+ -- scope but the declaration as a whole needs to be analyzed.
+
+ -- This case in particular happens for derived enumeration types.
+ -- The derived enumeration type is processed as an inserted enumeration
+ -- type declaration followed by a rewritten subtype declaration. The
+ -- defining identifier, however, is entered into the name scope very
+ -- early in the processing of the original type declaration and
+ -- therefore needs to be avoided here, when the created subtype
+ -- declaration is analyzed. (See Build_Derived_Types)
+
+ -- This also happens when the full view of a private type is a
+ -- derived type with constraints. In this case the entity has been
+ -- introduced in the private declaration.
+
+ if Present (Etype (Id))
+ and then (Is_Private_Type (Etype (Id))
+ or else Is_Task_Type (Etype (Id))
+ or else Is_Rewrite_Substitution (N))
+ then
+ null;
+
+ else
+ Enter_Name (Id);
+ end if;
+
+ T := Process_Subtype (Subtype_Indication (N), N, Id, 'P');
+
+ -- Inherit common attributes
+
+ Set_Is_Generic_Type (Id, Is_Generic_Type (Base_Type (T)));
+ Set_Is_Volatile (Id, Is_Volatile (T));
+ Set_Is_Atomic (Id, Is_Atomic (T));
+
+ -- In the case where there is no constraint given in the subtype
+ -- indication, Process_Subtype just returns the Subtype_Mark,
+ -- so its semantic attributes must be established here.
+
+ if Nkind (Subtype_Indication (N)) /= N_Subtype_Indication then
+ Set_Etype (Id, Base_Type (T));
+
+ case Ekind (T) is
+ when Array_Kind =>
+ Set_Ekind (Id, E_Array_Subtype);
+
+ -- Shouldn't we call Copy_Array_Subtype_Attributes here???
+
+ Set_First_Index (Id, First_Index (T));
+ Set_Is_Aliased (Id, Is_Aliased (T));
+ Set_Is_Constrained (Id, Is_Constrained (T));
+
+ when Decimal_Fixed_Point_Kind =>
+ Set_Ekind (Id, E_Decimal_Fixed_Point_Subtype);
+ Set_Digits_Value (Id, Digits_Value (T));
+ Set_Delta_Value (Id, Delta_Value (T));
+ Set_Scale_Value (Id, Scale_Value (T));
+ Set_Small_Value (Id, Small_Value (T));
+ Set_Scalar_Range (Id, Scalar_Range (T));
+ Set_Machine_Radix_10 (Id, Machine_Radix_10 (T));
+ Set_Is_Constrained (Id, Is_Constrained (T));
+ Set_RM_Size (Id, RM_Size (T));
+
+ when Enumeration_Kind =>
+ Set_Ekind (Id, E_Enumeration_Subtype);
+ Set_First_Literal (Id, First_Literal (Base_Type (T)));
+ Set_Scalar_Range (Id, Scalar_Range (T));
+ Set_Is_Character_Type (Id, Is_Character_Type (T));
+ Set_Is_Constrained (Id, Is_Constrained (T));
+ Set_RM_Size (Id, RM_Size (T));
+
+ when Ordinary_Fixed_Point_Kind =>
+ Set_Ekind (Id, E_Ordinary_Fixed_Point_Subtype);
+ Set_Scalar_Range (Id, Scalar_Range (T));
+ Set_Small_Value (Id, Small_Value (T));
+ Set_Delta_Value (Id, Delta_Value (T));
+ Set_Is_Constrained (Id, Is_Constrained (T));
+ Set_RM_Size (Id, RM_Size (T));
+
+ when Float_Kind =>
+ Set_Ekind (Id, E_Floating_Point_Subtype);
+ Set_Scalar_Range (Id, Scalar_Range (T));
+ Set_Digits_Value (Id, Digits_Value (T));
+ Set_Is_Constrained (Id, Is_Constrained (T));
+
+ when Signed_Integer_Kind =>
+ Set_Ekind (Id, E_Signed_Integer_Subtype);
+ Set_Scalar_Range (Id, Scalar_Range (T));
+ Set_Is_Constrained (Id, Is_Constrained (T));
+ Set_RM_Size (Id, RM_Size (T));
+
+ when Modular_Integer_Kind =>
+ Set_Ekind (Id, E_Modular_Integer_Subtype);
+ Set_Scalar_Range (Id, Scalar_Range (T));
+ Set_Is_Constrained (Id, Is_Constrained (T));
+ Set_RM_Size (Id, RM_Size (T));
+
+ when Class_Wide_Kind =>
+ Set_Ekind (Id, E_Class_Wide_Subtype);
+ Set_First_Entity (Id, First_Entity (T));
+ Set_Last_Entity (Id, Last_Entity (T));
+ Set_Class_Wide_Type (Id, Class_Wide_Type (T));
+ Set_Cloned_Subtype (Id, T);
+ Set_Is_Tagged_Type (Id, True);
+ Set_Has_Unknown_Discriminants
+ (Id, True);
+
+ if Ekind (T) = E_Class_Wide_Subtype then
+ Set_Equivalent_Type (Id, Equivalent_Type (T));
+ end if;
+
+ when E_Record_Type | E_Record_Subtype =>
+ Set_Ekind (Id, E_Record_Subtype);
+
+ if Ekind (T) = E_Record_Subtype
+ and then Present (Cloned_Subtype (T))
+ then
+ Set_Cloned_Subtype (Id, Cloned_Subtype (T));
+ else
+ Set_Cloned_Subtype (Id, T);
+ end if;
+
+ Set_First_Entity (Id, First_Entity (T));
+ Set_Last_Entity (Id, Last_Entity (T));
+ Set_Has_Discriminants (Id, Has_Discriminants (T));
+ Set_Is_Constrained (Id, Is_Constrained (T));
+ Set_Is_Limited_Record (Id, Is_Limited_Record (T));
+ Set_Has_Unknown_Discriminants
+ (Id, Has_Unknown_Discriminants (T));
+
+ if Has_Discriminants (T) then
+ Set_Discriminant_Constraint
+ (Id, Discriminant_Constraint (T));
+ Set_Girder_Constraint_From_Discriminant_Constraint (Id);
+
+ elsif Has_Unknown_Discriminants (Id) then
+ Set_Discriminant_Constraint (Id, No_Elist);
+ end if;
+
+ if Is_Tagged_Type (T) then
+ Set_Is_Tagged_Type (Id);
+ Set_Is_Abstract (Id, Is_Abstract (T));
+ Set_Primitive_Operations
+ (Id, Primitive_Operations (T));
+ Set_Class_Wide_Type (Id, Class_Wide_Type (T));
+ end if;
+
+ when Private_Kind =>
+ Set_Ekind (Id, Subtype_Kind (Ekind (T)));
+ Set_Has_Discriminants (Id, Has_Discriminants (T));
+ Set_Is_Constrained (Id, Is_Constrained (T));
+ Set_First_Entity (Id, First_Entity (T));
+ Set_Last_Entity (Id, Last_Entity (T));
+ Set_Private_Dependents (Id, New_Elmt_List);
+ Set_Is_Limited_Record (Id, Is_Limited_Record (T));
+ Set_Has_Unknown_Discriminants
+ (Id, Has_Unknown_Discriminants (T));
+
+ if Is_Tagged_Type (T) then
+ Set_Is_Tagged_Type (Id);
+ Set_Is_Abstract (Id, Is_Abstract (T));
+ Set_Class_Wide_Type (Id, Class_Wide_Type (T));
+ end if;
+
+ -- In general the attributes of the subtype of a private
+ -- type are the attributes of the partial view of parent.
+ -- However, the full view may be a discriminated type,
+ -- and the subtype must share the discriminant constraint
+ -- to generate correct calls to initialization procedures.
+
+ if Has_Discriminants (T) then
+ Set_Discriminant_Constraint
+ (Id, Discriminant_Constraint (T));
+ Set_Girder_Constraint_From_Discriminant_Constraint (Id);
+
+ elsif Present (Full_View (T))
+ and then Has_Discriminants (Full_View (T))
+ then
+ Set_Discriminant_Constraint
+ (Id, Discriminant_Constraint (Full_View (T)));
+ Set_Girder_Constraint_From_Discriminant_Constraint (Id);
+
+ -- This would seem semantically correct, but apparently
+ -- confuses the back-end (4412-009). To be explained ???
+
+ -- Set_Has_Discriminants (Id);
+ end if;
+
+ Prepare_Private_Subtype_Completion (Id, N);
+
+ when Access_Kind =>
+ Set_Ekind (Id, E_Access_Subtype);
+ Set_Is_Constrained (Id, Is_Constrained (T));
+ Set_Is_Access_Constant
+ (Id, Is_Access_Constant (T));
+ Set_Directly_Designated_Type
+ (Id, Designated_Type (T));
+
+ -- A Pure library_item must not contain the declaration of a
+ -- named access type, except within a subprogram, generic
+ -- subprogram, task unit, or protected unit (RM 10.2.1(16)).
+
+ if Comes_From_Source (Id)
+ and then In_Pure_Unit
+ and then not In_Subprogram_Task_Protected_Unit
+ then
+ Error_Msg_N
+ ("named access types not allowed in pure unit", N);
+ end if;
+
+ when Concurrent_Kind =>
+
+ Set_Ekind (Id, Subtype_Kind (Ekind (T)));
+ Set_Corresponding_Record_Type (Id,
+ Corresponding_Record_Type (T));
+ Set_First_Entity (Id, First_Entity (T));
+ Set_First_Private_Entity (Id, First_Private_Entity (T));
+ Set_Has_Discriminants (Id, Has_Discriminants (T));
+ Set_Is_Constrained (Id, Is_Constrained (T));
+ Set_Last_Entity (Id, Last_Entity (T));
+
+ if Has_Discriminants (T) then
+ Set_Discriminant_Constraint (Id,
+ Discriminant_Constraint (T));
+ Set_Girder_Constraint_From_Discriminant_Constraint (Id);
+ end if;
+
+ -- If the subtype name denotes an incomplete type
+ -- an error was already reported by Process_Subtype.
+
+ when E_Incomplete_Type =>
+ Set_Etype (Id, Any_Type);
+
+ when others =>
+ raise Program_Error;
+ end case;
+ end if;
+
+ if Etype (Id) = Any_Type then
+ return;
+ end if;
+
+ -- Some common processing on all types
+
+ Set_Size_Info (Id, T);
+ Set_First_Rep_Item (Id, First_Rep_Item (T));
+
+ T := Etype (Id);
+
+ Set_Is_Immediately_Visible (Id, True);
+ Set_Depends_On_Private (Id, Has_Private_Component (T));
+
+ if Present (Generic_Parent_Type (N))
+ and then
+ (Nkind
+ (Parent (Generic_Parent_Type (N))) /= N_Formal_Type_Declaration
+ or else Nkind
+ (Formal_Type_Definition (Parent (Generic_Parent_Type (N))))
+ /= N_Formal_Private_Type_Definition)
+ then
+ if Is_Tagged_Type (Id) then
+ if Is_Class_Wide_Type (Id) then
+ Derive_Subprograms (Generic_Parent_Type (N), Id, Etype (T));
+ else
+ Derive_Subprograms (Generic_Parent_Type (N), Id, T);
+ end if;
+
+ elsif Scope (Etype (Id)) /= Standard_Standard then
+ Derive_Subprograms (Generic_Parent_Type (N), Id);
+ end if;
+ end if;
+
+ if Is_Private_Type (T)
+ and then Present (Full_View (T))
+ then
+ Conditional_Delay (Id, Full_View (T));
+
+ -- The subtypes of components or subcomponents of protected types
+ -- do not need freeze nodes, which would otherwise appear in the
+ -- wrong scope (before the freeze node for the protected type). The
+ -- proper subtypes are those of the subcomponents of the corresponding
+ -- record.
+
+ elsif Ekind (Scope (Id)) /= E_Protected_Type
+ and then Present (Scope (Scope (Id))) -- error defense!
+ and then Ekind (Scope (Scope (Id))) /= E_Protected_Type
+ then
+ Conditional_Delay (Id, T);
+ end if;
+
+ -- Check that constraint_error is raised for a scalar subtype
+ -- indication when the lower or upper bound of a non-null range
+ -- lies outside the range of the type mark.
+
+ if Nkind (Subtype_Indication (N)) = N_Subtype_Indication then
+ if Is_Scalar_Type (Etype (Id))
+ and then Scalar_Range (Id) /=
+ Scalar_Range (Etype (Subtype_Mark
+ (Subtype_Indication (N))))
+ then
+ Apply_Range_Check
+ (Scalar_Range (Id),
+ Etype (Subtype_Mark (Subtype_Indication (N))));
+
+ elsif Is_Array_Type (Etype (Id))
+ and then Present (First_Index (Id))
+ then
+ -- This really should be a subprogram that finds the indications
+ -- to check???
+
+ if ((Nkind (First_Index (Id)) = N_Identifier
+ and then Ekind (Entity (First_Index (Id))) in Scalar_Kind)
+ or else Nkind (First_Index (Id)) = N_Subtype_Indication)
+ and then
+ Nkind (Scalar_Range (Etype (First_Index (Id)))) = N_Range
+ then
+ declare
+ Target_Typ : Entity_Id :=
+ Etype
+ (First_Index
+ (Etype (Subtype_Mark (Subtype_Indication (N)))));
+ begin
+ R_Checks :=
+ Range_Check
+ (Scalar_Range (Etype (First_Index (Id))),
+ Target_Typ,
+ Etype (First_Index (Id)),
+ Defining_Identifier (N));
+
+ Insert_Range_Checks
+ (R_Checks,
+ N,
+ Target_Typ,
+ Sloc (Defining_Identifier (N)));
+ end;
+ end if;
+ end if;
+ end if;
+
+ Check_Eliminated (Id);
+ end Analyze_Subtype_Declaration;
+
+ --------------------------------
+ -- Analyze_Subtype_Indication --
+ --------------------------------
+
+ procedure Analyze_Subtype_Indication (N : Node_Id) is
+ T : constant Entity_Id := Subtype_Mark (N);
+ R : constant Node_Id := Range_Expression (Constraint (N));
+
+ begin
+ Analyze (T);
+ Analyze (R);
+ Set_Etype (N, Etype (R));
+ end Analyze_Subtype_Indication;
+
+ ------------------------------
+ -- Analyze_Type_Declaration --
+ ------------------------------
+
+ procedure Analyze_Type_Declaration (N : Node_Id) is
+ Def : constant Node_Id := Type_Definition (N);
+ Def_Id : constant Entity_Id := Defining_Identifier (N);
+ T : Entity_Id;
+ Prev : Entity_Id;
+
+ begin
+ Prev := Find_Type_Name (N);
+
+ if Ekind (Prev) = E_Incomplete_Type then
+ T := Full_View (Prev);
+ else
+ T := Prev;
+ end if;
+
+ Set_Is_Pure (T, Is_Pure (Current_Scope));
+
+ -- We set the flag Is_First_Subtype here. It is needed to set the
+ -- corresponding flag for the Implicit class-wide-type created
+ -- during tagged types processing.
+
+ Set_Is_First_Subtype (T, True);
+
+ -- Only composite types other than array types are allowed to have
+ -- discriminants.
+
+ case Nkind (Def) is
+
+ -- For derived types, the rule will be checked once we've figured
+ -- out the parent type.
+
+ when N_Derived_Type_Definition =>
+ null;
+
+ -- For record types, discriminants are allowed.
+
+ when N_Record_Definition =>
+ null;
+
+ when others =>
+ if Present (Discriminant_Specifications (N)) then
+ Error_Msg_N
+ ("elementary or array type cannot have discriminants",
+ Defining_Identifier
+ (First (Discriminant_Specifications (N))));
+ end if;
+ end case;
+
+ -- Elaborate the type definition according to kind, and generate
+ -- susbsidiary (implicit) subtypes where needed. We skip this if
+ -- it was already done (this happens during the reanalysis that
+ -- follows a call to the high level optimizer).
+
+ if not Analyzed (T) then
+ Set_Analyzed (T);
+
+ case Nkind (Def) is
+
+ when N_Access_To_Subprogram_Definition =>
+ Access_Subprogram_Declaration (T, Def);
+
+ -- If this is a remote access to subprogram, we must create
+ -- the equivalent fat pointer type, and related subprograms.
+
+ if Is_Remote_Types (Current_Scope)
+ or else Is_Remote_Call_Interface (Current_Scope)
+ then
+ Validate_Remote_Access_To_Subprogram_Type (N);
+ Process_Remote_AST_Declaration (N);
+ end if;
+
+ -- Validate categorization rule against access type declaration
+ -- usually a violation in Pure unit, Shared_Passive unit.
+
+ Validate_Access_Type_Declaration (T, N);
+
+ when N_Access_To_Object_Definition =>
+ Access_Type_Declaration (T, Def);
+
+ -- Validate categorization rule against access type declaration
+ -- usually a violation in Pure unit, Shared_Passive unit.
+
+ Validate_Access_Type_Declaration (T, N);
+
+ -- If we are in a Remote_Call_Interface package and define
+ -- a RACW, Read and Write attribute must be added.
+
+ if (Is_Remote_Call_Interface (Current_Scope)
+ or else Is_Remote_Types (Current_Scope))
+ and then Is_Remote_Access_To_Class_Wide_Type (Def_Id)
+ then
+ Add_RACW_Features (Def_Id);
+ end if;
+
+ when N_Array_Type_Definition =>
+ Array_Type_Declaration (T, Def);
+
+ when N_Derived_Type_Definition =>
+ Derived_Type_Declaration (T, N, T /= Def_Id);
+
+ when N_Enumeration_Type_Definition =>
+ Enumeration_Type_Declaration (T, Def);
+
+ when N_Floating_Point_Definition =>
+ Floating_Point_Type_Declaration (T, Def);
+
+ when N_Decimal_Fixed_Point_Definition =>
+ Decimal_Fixed_Point_Type_Declaration (T, Def);
+
+ when N_Ordinary_Fixed_Point_Definition =>
+ Ordinary_Fixed_Point_Type_Declaration (T, Def);
+
+ when N_Signed_Integer_Type_Definition =>
+ Signed_Integer_Type_Declaration (T, Def);
+
+ when N_Modular_Type_Definition =>
+ Modular_Type_Declaration (T, Def);
+
+ when N_Record_Definition =>
+ Record_Type_Declaration (T, N);
+
+ when others =>
+ raise Program_Error;
+
+ end case;
+ end if;
+
+ if Etype (T) = Any_Type then
+ return;
+ end if;
+
+ -- Some common processing for all types
+
+ Set_Depends_On_Private (T, Has_Private_Component (T));
+
+ -- Both the declared entity, and its anonymous base type if one
+ -- was created, need freeze nodes allocated.
+
+ declare
+ B : constant Entity_Id := Base_Type (T);
+
+ begin
+ -- In the case where the base type is different from the first
+ -- subtype, we pre-allocate a freeze node, and set the proper
+ -- link to the first subtype. Freeze_Entity will use this
+ -- preallocated freeze node when it freezes the entity.
+
+ if B /= T then
+ Ensure_Freeze_Node (B);
+ Set_First_Subtype_Link (Freeze_Node (B), T);
+ end if;
+
+ if not From_With_Type (T) then
+ Set_Has_Delayed_Freeze (T);
+ end if;
+ end;
+
+ -- Case of T is the full declaration of some private type which has
+ -- been swapped in Defining_Identifier (N).
+
+ if T /= Def_Id and then Is_Private_Type (Def_Id) then
+ Process_Full_View (N, T, Def_Id);
+
+ -- Record the reference. The form of this is a little strange,
+ -- since the full declaration has been swapped in. So the first
+ -- parameter here represents the entity to which a reference is
+ -- made which is the "real" entity, i.e. the one swapped in,
+ -- and the second parameter provides the reference location.
+
+ Generate_Reference (T, T, 'c');
+
+ -- If in main unit, set as referenced, so we do not complain about
+ -- the full declaration being an unreferenced entity.
+
+ if In_Extended_Main_Source_Unit (Def_Id) then
+ Set_Referenced (Def_Id);
+ end if;
+
+ -- For completion of incomplete type, process incomplete dependents
+ -- and always mark the full type as referenced (it is the incomplete
+ -- type that we get for any real reference).
+
+ elsif Ekind (Prev) = E_Incomplete_Type then
+ Process_Incomplete_Dependents (N, T, Prev);
+ Generate_Reference (Prev, Def_Id, 'c');
+
+ -- If in main unit, set as referenced, so we do not complain about
+ -- the full declaration being an unreferenced entity.
+
+ if In_Extended_Main_Source_Unit (Def_Id) then
+ Set_Referenced (Def_Id);
+ end if;
+
+ -- If not private type or incomplete type completion, this is a real
+ -- definition of a new entity, so record it.
+
+ else
+ Generate_Definition (Def_Id);
+ end if;
+
+ Check_Eliminated (Def_Id);
+ end Analyze_Type_Declaration;
+
+ --------------------------
+ -- Analyze_Variant_Part --
+ --------------------------
+
+ procedure Analyze_Variant_Part (N : Node_Id) is
+
+ procedure Non_Static_Choice_Error (Choice : Node_Id);
+ -- Error routine invoked by the generic instantiation below when
+ -- the variant part has a non static choice.
+
+ procedure Process_Declarations (Variant : Node_Id);
+ -- Analyzes all the declarations associated with a Variant.
+ -- Needed by the generic instantiation below.
+
+ package Variant_Choices_Processing is new
+ Generic_Choices_Processing
+ (Get_Alternatives => Variants,
+ Get_Choices => Discrete_Choices,
+ Process_Empty_Choice => No_OP,
+ Process_Non_Static_Choice => Non_Static_Choice_Error,
+ Process_Associated_Node => Process_Declarations);
+ use Variant_Choices_Processing;
+ -- Instantiation of the generic choice processing package.
+
+ -----------------------------
+ -- Non_Static_Choice_Error --
+ -----------------------------
+
+ procedure Non_Static_Choice_Error (Choice : Node_Id) is
+ begin
+ Error_Msg_N ("choice given in variant part is not static", Choice);
+ end Non_Static_Choice_Error;
+
+ --------------------------
+ -- Process_Declarations --
+ --------------------------
+
+ procedure Process_Declarations (Variant : Node_Id) is
+ begin
+ if not Null_Present (Component_List (Variant)) then
+ Analyze_Declarations (Component_Items (Component_List (Variant)));
+
+ if Present (Variant_Part (Component_List (Variant))) then
+ Analyze (Variant_Part (Component_List (Variant)));
+ end if;
+ end if;
+ end Process_Declarations;
+
+ -- Variables local to Analyze_Case_Statement.
+
+ Others_Choice : Node_Id;
+
+ Discr_Name : Node_Id;
+ Discr_Type : Entity_Id;
+
+ Case_Table : Choice_Table_Type (1 .. Number_Of_Choices (N));
+ Last_Choice : Nat;
+ Dont_Care : Boolean;
+ Others_Present : Boolean := False;
+
+ -- Start of processing for Analyze_Variant_Part
+
+ begin
+ Discr_Name := Name (N);
+ Analyze (Discr_Name);
+
+ if Ekind (Entity (Discr_Name)) /= E_Discriminant then
+ Error_Msg_N ("invalid discriminant name in variant part", Discr_Name);
+ end if;
+
+ Discr_Type := Etype (Entity (Discr_Name));
+
+ -- Call the instantiated Analyze_Choices which does the rest of the work
+
+ Analyze_Choices
+ (N, Discr_Type, Case_Table, Last_Choice, Dont_Care, Others_Present);
+
+ if Others_Present then
+ -- Fill in Others_Discrete_Choices field of the OTHERS choice
+
+ Others_Choice := First (Discrete_Choices (Last (Variants (N))));
+ Expand_Others_Choice
+ (Case_Table (1 .. Last_Choice), Others_Choice, Discr_Type);
+ end if;
+
+ end Analyze_Variant_Part;
+
+ ----------------------------
+ -- Array_Type_Declaration --
+ ----------------------------
+
+ procedure Array_Type_Declaration (T : in out Entity_Id; Def : Node_Id) is
+ Component_Def : constant Node_Id := Subtype_Indication (Def);
+ Element_Type : Entity_Id;
+ Implicit_Base : Entity_Id;
+ Index : Node_Id;
+ Related_Id : Entity_Id := Empty;
+ Nb_Index : Nat;
+ P : constant Node_Id := Parent (Def);
+ Priv : Entity_Id;
+
+ begin
+ if Nkind (Def) = N_Constrained_Array_Definition then
+
+ Index := First (Discrete_Subtype_Definitions (Def));
+
+ -- Find proper names for the implicit types which may be public.
+ -- in case of anonymous arrays we use the name of the first object
+ -- of that type as prefix.
+
+ if No (T) then
+ Related_Id := Defining_Identifier (P);
+ else
+ Related_Id := T;
+ end if;
+
+ else
+ Index := First (Subtype_Marks (Def));
+ end if;
+
+ Nb_Index := 1;
+
+ while Present (Index) loop
+ Analyze (Index);
+ Make_Index (Index, P, Related_Id, Nb_Index);
+ Next_Index (Index);
+ Nb_Index := Nb_Index + 1;
+ end loop;
+
+ Element_Type := Process_Subtype (Component_Def, P, Related_Id, 'C');
+
+ -- Constrained array case
+
+ if No (T) then
+ T := Create_Itype (E_Void, P, Related_Id, 'T');
+ end if;
+
+ if Nkind (Def) = N_Constrained_Array_Definition then
+
+ -- Establish Implicit_Base as unconstrained base type
+
+ Implicit_Base := Create_Itype (E_Array_Type, P, Related_Id, 'B');
+
+ Init_Size_Align (Implicit_Base);
+ Set_Etype (Implicit_Base, Implicit_Base);
+ Set_Scope (Implicit_Base, Current_Scope);
+ Set_Has_Delayed_Freeze (Implicit_Base);
+
+ -- The constrained array type is a subtype of the unconstrained one
+
+ Set_Ekind (T, E_Array_Subtype);
+ Init_Size_Align (T);
+ Set_Etype (T, Implicit_Base);
+ Set_Scope (T, Current_Scope);
+ Set_Is_Constrained (T, True);
+ Set_First_Index (T, First (Discrete_Subtype_Definitions (Def)));
+ Set_Has_Delayed_Freeze (T);
+
+ -- Complete setup of implicit base type
+
+ Set_First_Index (Implicit_Base, First_Index (T));
+ Set_Component_Type (Implicit_Base, Element_Type);
+ Set_Has_Task (Implicit_Base, Has_Task (Element_Type));
+ Set_Component_Size (Implicit_Base, Uint_0);
+ Set_Has_Controlled_Component (Implicit_Base,
+ Has_Controlled_Component (Element_Type)
+ or else Is_Controlled (Element_Type));
+ Set_Finalize_Storage_Only (Implicit_Base,
+ Finalize_Storage_Only (Element_Type));
+
+ -- Unconstrained array case
+
+ else
+ Set_Ekind (T, E_Array_Type);
+ Init_Size_Align (T);
+ Set_Etype (T, T);
+ Set_Scope (T, Current_Scope);
+ Set_Component_Size (T, Uint_0);
+ Set_Is_Constrained (T, False);
+ Set_First_Index (T, First (Subtype_Marks (Def)));
+ Set_Has_Delayed_Freeze (T, True);
+ Set_Has_Task (T, Has_Task (Element_Type));
+ Set_Has_Controlled_Component (T,
+ Has_Controlled_Component (Element_Type)
+ or else Is_Controlled (Element_Type));
+ Set_Finalize_Storage_Only (T,
+ Finalize_Storage_Only (Element_Type));
+ end if;
+
+ Set_Component_Type (T, Element_Type);
+
+ if Aliased_Present (Def) then
+ Set_Has_Aliased_Components (Etype (T));
+ end if;
+
+ Priv := Private_Component (Element_Type);
+
+ if Present (Priv) then
+ -- Check for circular definitions.
+
+ if Priv = Any_Type then
+ Set_Component_Type (T, Any_Type);
+ Set_Component_Type (Etype (T), Any_Type);
+
+ -- There is a gap in the visiblity of operations on the composite
+ -- type only if the component type is defined in a different scope.
+
+ elsif Scope (Priv) = Current_Scope then
+ null;
+
+ elsif Is_Limited_Type (Priv) then
+ Set_Is_Limited_Composite (Etype (T));
+ Set_Is_Limited_Composite (T);
+ else
+ Set_Is_Private_Composite (Etype (T));
+ Set_Is_Private_Composite (T);
+ end if;
+ end if;
+
+ -- Create a concatenation operator for the new type. Internal
+ -- array types created for packed entities do not need such, they
+ -- are compatible with the user-defined type.
+
+ if Number_Dimensions (T) = 1
+ and then not Is_Packed_Array_Type (T)
+ then
+ New_Binary_Operator (Name_Op_Concat, T);
+ end if;
+
+ -- In the case of an unconstrained array the parser has already
+ -- verified that all the indices are unconstrained but we still
+ -- need to make sure that the element type is constrained.
+
+ if Is_Indefinite_Subtype (Element_Type) then
+ Error_Msg_N
+ ("unconstrained element type in array declaration ",
+ Component_Def);
+
+ elsif Is_Abstract (Element_Type) then
+ Error_Msg_N ("The type of a component cannot be abstract ",
+ Component_Def);
+ end if;
+
+ end Array_Type_Declaration;
+
+ -------------------------------
+ -- Build_Derived_Access_Type --
+ -------------------------------
+
+ procedure Build_Derived_Access_Type
+ (N : Node_Id;
+ Parent_Type : Entity_Id;
+ Derived_Type : Entity_Id)
+ is
+ S : constant Node_Id := Subtype_Indication (Type_Definition (N));
+
+ Desig_Type : Entity_Id;
+ Discr : Entity_Id;
+ Discr_Con_Elist : Elist_Id;
+ Discr_Con_El : Elmt_Id;
+
+ Subt : Entity_Id;
+
+ begin
+ -- Set the designated type so it is available in case this is
+ -- an access to a self-referential type, e.g. a standard list
+ -- type with a next pointer. Will be reset after subtype is built.
+
+ Set_Directly_Designated_Type (Derived_Type,
+ Designated_Type (Parent_Type));
+
+ Subt := Process_Subtype (S, N);
+
+ if Nkind (S) /= N_Subtype_Indication
+ and then Subt /= Base_Type (Subt)
+ then
+ Set_Ekind (Derived_Type, E_Access_Subtype);
+ end if;
+
+ if Ekind (Derived_Type) = E_Access_Subtype then
+ declare
+ Pbase : constant Entity_Id := Base_Type (Parent_Type);
+ Ibase : constant Entity_Id :=
+ Create_Itype (Ekind (Pbase), N, Derived_Type, 'B');
+ Svg_Chars : constant Name_Id := Chars (Ibase);
+ Svg_Next_E : constant Entity_Id := Next_Entity (Ibase);
+
+ begin
+ Copy_Node (Pbase, Ibase);
+
+ Set_Chars (Ibase, Svg_Chars);
+ Set_Next_Entity (Ibase, Svg_Next_E);
+ Set_Sloc (Ibase, Sloc (Derived_Type));
+ Set_Scope (Ibase, Scope (Derived_Type));
+ Set_Freeze_Node (Ibase, Empty);
+ Set_Is_Frozen (Ibase, False);
+
+ Set_Etype (Ibase, Pbase);
+ Set_Etype (Derived_Type, Ibase);
+ end;
+ end if;
+
+ Set_Directly_Designated_Type
+ (Derived_Type, Designated_Type (Subt));
+
+ Set_Is_Constrained (Derived_Type, Is_Constrained (Subt));
+ Set_Is_Access_Constant (Derived_Type, Is_Access_Constant (Parent_Type));
+ Set_Size_Info (Derived_Type, Parent_Type);
+ Set_RM_Size (Derived_Type, RM_Size (Parent_Type));
+ Set_Depends_On_Private (Derived_Type,
+ Has_Private_Component (Derived_Type));
+ Conditional_Delay (Derived_Type, Subt);
+
+ -- Note: we do not copy the Storage_Size_Variable, since
+ -- we always go to the root type for this information.
+
+ -- Apply range checks to discriminants for derived record case
+ -- ??? THIS CODE SHOULD NOT BE HERE REALLY.
+
+ Desig_Type := Designated_Type (Derived_Type);
+ if Is_Composite_Type (Desig_Type)
+ and then (not Is_Array_Type (Desig_Type))
+ and then Has_Discriminants (Desig_Type)
+ and then Base_Type (Desig_Type) /= Desig_Type
+ then
+ Discr_Con_Elist := Discriminant_Constraint (Desig_Type);
+ Discr_Con_El := First_Elmt (Discr_Con_Elist);
+
+ Discr := First_Discriminant (Base_Type (Desig_Type));
+ while Present (Discr_Con_El) loop
+ Apply_Range_Check (Node (Discr_Con_El), Etype (Discr));
+ Next_Elmt (Discr_Con_El);
+ Next_Discriminant (Discr);
+ end loop;
+ end if;
+ end Build_Derived_Access_Type;
+
+ ------------------------------
+ -- Build_Derived_Array_Type --
+ ------------------------------
+
+ procedure Build_Derived_Array_Type
+ (N : Node_Id;
+ Parent_Type : Entity_Id;
+ Derived_Type : Entity_Id)
+ is
+ Loc : constant Source_Ptr := Sloc (N);
+ Tdef : constant Node_Id := Type_Definition (N);
+ Indic : constant Node_Id := Subtype_Indication (Tdef);
+ Parent_Base : constant Entity_Id := Base_Type (Parent_Type);
+ Implicit_Base : Entity_Id;
+ New_Indic : Node_Id;
+
+ procedure Make_Implicit_Base;
+ -- If the parent subtype is constrained, the derived type is a
+ -- subtype of an implicit base type derived from the parent base.
+
+ ------------------------
+ -- Make_Implicit_Base --
+ ------------------------
+
+ procedure Make_Implicit_Base is
+ begin
+ Implicit_Base :=
+ Create_Itype (Ekind (Parent_Base), N, Derived_Type, 'B');
+
+ Set_Ekind (Implicit_Base, Ekind (Parent_Base));
+ Set_Etype (Implicit_Base, Parent_Base);
+
+ Copy_Array_Subtype_Attributes (Implicit_Base, Parent_Base);
+ Copy_Array_Base_Type_Attributes (Implicit_Base, Parent_Base);
+
+ Set_Has_Delayed_Freeze (Implicit_Base, True);
+ end Make_Implicit_Base;
+
+ -- Start of processing for Build_Derived_Array_Type
+
+ begin
+ if not Is_Constrained (Parent_Type) then
+ if Nkind (Indic) /= N_Subtype_Indication then
+ Set_Ekind (Derived_Type, E_Array_Type);
+
+ Copy_Array_Subtype_Attributes (Derived_Type, Parent_Type);
+ Copy_Array_Base_Type_Attributes (Derived_Type, Parent_Type);
+
+ Set_Has_Delayed_Freeze (Derived_Type, True);
+
+ else
+ Make_Implicit_Base;
+ Set_Etype (Derived_Type, Implicit_Base);
+
+ New_Indic :=
+ Make_Subtype_Declaration (Loc,
+ Defining_Identifier => Derived_Type,
+ Subtype_Indication =>
+ Make_Subtype_Indication (Loc,
+ Subtype_Mark => New_Reference_To (Implicit_Base, Loc),
+ Constraint => Constraint (Indic)));
+
+ Rewrite (N, New_Indic);
+ Analyze (N);
+ end if;
+
+ else
+ if Nkind (Indic) /= N_Subtype_Indication then
+ Make_Implicit_Base;
+
+ Set_Ekind (Derived_Type, Ekind (Parent_Type));
+ Set_Etype (Derived_Type, Implicit_Base);
+ Copy_Array_Subtype_Attributes (Derived_Type, Parent_Type);
+
+ else
+ Error_Msg_N ("illegal constraint on constrained type", Indic);
+ end if;
+ end if;
+
+ -- If the parent type is not a derived type itself, and is
+ -- declared in a closed scope (e.g., a subprogram), then we
+ -- need to explicitly introduce the new type's concatenation
+ -- operator since Derive_Subprograms will not inherit the
+ -- parent's operator.
+
+ if Number_Dimensions (Parent_Type) = 1
+ and then not Is_Limited_Type (Parent_Type)
+ and then not Is_Derived_Type (Parent_Type)
+ and then not Is_Package (Scope (Base_Type (Parent_Type)))
+ then
+ New_Binary_Operator (Name_Op_Concat, Derived_Type);
+ end if;
+ end Build_Derived_Array_Type;
+
+ -----------------------------------
+ -- Build_Derived_Concurrent_Type --
+ -----------------------------------
+
+ procedure Build_Derived_Concurrent_Type
+ (N : Node_Id;
+ Parent_Type : Entity_Id;
+ Derived_Type : Entity_Id)
+ is
+ D_Constraint : Node_Id;
+ Disc_Spec : Node_Id;
+ Old_Disc : Entity_Id;
+ New_Disc : Entity_Id;
+ Constraint_Present : constant Boolean :=
+ Nkind (Subtype_Indication (Type_Definition (N))) =
+ N_Subtype_Indication;
+
+ begin
+ Set_Girder_Constraint (Derived_Type, No_Elist);
+
+ if Is_Task_Type (Parent_Type) then
+ Set_Storage_Size_Variable (Derived_Type,
+ Storage_Size_Variable (Parent_Type));
+ end if;
+
+ if Present (Discriminant_Specifications (N)) then
+ New_Scope (Derived_Type);
+ Check_Or_Process_Discriminants (N, Derived_Type);
+ End_Scope;
+ end if;
+
+ -- All attributes are inherited from parent. In particular,
+ -- entries and the corresponding record type are the same.
+ -- Discriminants may be renamed, and must be treated separately.
+
+ Set_Has_Discriminants
+ (Derived_Type, Has_Discriminants (Parent_Type));
+ Set_Corresponding_Record_Type
+ (Derived_Type, Corresponding_Record_Type
+ (Parent_Type));
+
+ if Constraint_Present then
+
+ if not Has_Discriminants (Parent_Type) then
+ Error_Msg_N ("untagged parent must have discriminants", N);
+
+ elsif Present (Discriminant_Specifications (N)) then
+
+ -- Verify that new discriminants are used to constrain
+ -- the old ones.
+
+ Old_Disc := First_Discriminant (Parent_Type);
+ New_Disc := First_Discriminant (Derived_Type);
+ Disc_Spec := First (Discriminant_Specifications (N));
+ D_Constraint :=
+ First (Constraints (
+ Constraint (Subtype_Indication (Type_Definition (N)))));
+
+ while Present (Old_Disc) and then Present (Disc_Spec) loop
+
+ if Nkind (Discriminant_Type (Disc_Spec)) /=
+ N_Access_Definition
+ then
+ Analyze (Discriminant_Type (Disc_Spec));
+ if not Subtypes_Statically_Compatible (
+ Etype (Discriminant_Type (Disc_Spec)),
+ Etype (Old_Disc))
+ then
+ Error_Msg_N
+ ("not statically compatible with parent discriminant",
+ Discriminant_Type (Disc_Spec));
+ end if;
+ end if;
+
+ if Nkind (D_Constraint) = N_Identifier
+ and then Chars (D_Constraint) /=
+ Chars (Defining_Identifier (Disc_Spec))
+ then
+ Error_Msg_N ("new discriminants must constrain old ones",
+ D_Constraint);
+ else
+ Set_Corresponding_Discriminant (New_Disc, Old_Disc);
+ end if;
+
+ Next_Discriminant (Old_Disc);
+ Next_Discriminant (New_Disc);
+ Next (Disc_Spec);
+ end loop;
+
+ if Present (Old_Disc) or else Present (Disc_Spec) then
+ Error_Msg_N ("discriminant mismatch in derivation", N);
+ end if;
+
+ end if;
+
+ elsif Present (Discriminant_Specifications (N)) then
+ Error_Msg_N
+ ("missing discriminant constraint in untagged derivation",
+ N);
+ end if;
+
+ if Present (Discriminant_Specifications (N)) then
+
+ Old_Disc := First_Discriminant (Parent_Type);
+
+ while Present (Old_Disc) loop
+
+ if No (Next_Entity (Old_Disc))
+ or else Ekind (Next_Entity (Old_Disc)) /= E_Discriminant
+ then
+ Set_Next_Entity (Last_Entity (Derived_Type),
+ Next_Entity (Old_Disc));
+ exit;
+ end if;
+
+ Next_Discriminant (Old_Disc);
+ end loop;
+
+ else
+ Set_First_Entity (Derived_Type, First_Entity (Parent_Type));
+ end if;
+
+ Set_Last_Entity (Derived_Type, Last_Entity (Parent_Type));
+
+ Set_Has_Completion (Derived_Type);
+ end Build_Derived_Concurrent_Type;
+
+ ------------------------------------
+ -- Build_Derived_Enumeration_Type --
+ ------------------------------------
+
+ procedure Build_Derived_Enumeration_Type
+ (N : Node_Id;
+ Parent_Type : Entity_Id;
+ Derived_Type : Entity_Id)
+ is
+ Loc : constant Source_Ptr := Sloc (N);
+ Def : constant Node_Id := Type_Definition (N);
+ Indic : constant Node_Id := Subtype_Indication (Def);
+ Implicit_Base : Entity_Id;
+ Literal : Entity_Id;
+ New_Lit : Entity_Id;
+ Literals_List : List_Id;
+ Type_Decl : Node_Id;
+ Hi, Lo : Node_Id;
+ Rang_Expr : Node_Id;
+
+ begin
+ -- Since types Standard.Character and Standard.Wide_Character do
+ -- not have explicit literals lists we need to process types derived
+ -- from them specially. This is handled by Derived_Standard_Character.
+ -- If the parent type is a generic type, there are no literals either,
+ -- and we construct the same skeletal representation as for the generic
+ -- parent type.
+
+ if Root_Type (Parent_Type) = Standard_Character
+ or else Root_Type (Parent_Type) = Standard_Wide_Character
+ then
+ Derived_Standard_Character (N, Parent_Type, Derived_Type);
+
+ elsif Is_Generic_Type (Root_Type (Parent_Type)) then
+ declare
+ Lo : Node_Id;
+ Hi : Node_Id;
+
+ begin
+ Lo :=
+ Make_Attribute_Reference (Loc,
+ Attribute_Name => Name_First,
+ Prefix => New_Reference_To (Derived_Type, Loc));
+ Set_Etype (Lo, Derived_Type);
+
+ Hi :=
+ Make_Attribute_Reference (Loc,
+ Attribute_Name => Name_Last,
+ Prefix => New_Reference_To (Derived_Type, Loc));
+ Set_Etype (Hi, Derived_Type);
+
+ Set_Scalar_Range (Derived_Type,
+ Make_Range (Loc,
+ Low_Bound => Lo,
+ High_Bound => Hi));
+ end;
+
+ else
+ -- If a constraint is present, analyze the bounds to catch
+ -- premature usage of the derived literals.
+
+ if Nkind (Indic) = N_Subtype_Indication
+ and then Nkind (Range_Expression (Constraint (Indic))) = N_Range
+ then
+ Analyze (Low_Bound (Range_Expression (Constraint (Indic))));
+ Analyze (High_Bound (Range_Expression (Constraint (Indic))));
+ end if;
+
+ -- Introduce an implicit base type for the derived type even
+ -- if there is no constraint attached to it, since this seems
+ -- closer to the Ada semantics. Build a full type declaration
+ -- tree for the derived type using the implicit base type as
+ -- the defining identifier. The build a subtype declaration
+ -- tree which applies the constraint (if any) have it replace
+ -- the derived type declaration.
+
+ Literal := First_Literal (Parent_Type);
+ Literals_List := New_List;
+
+ while Present (Literal)
+ and then Ekind (Literal) = E_Enumeration_Literal
+ loop
+ -- Literals of the derived type have the same representation as
+ -- those of the parent type, but this representation can be
+ -- overridden by an explicit representation clause. Indicate
+ -- that there is no explicit representation given yet. These
+ -- derived literals are implicit operations of the new type,
+ -- and can be overriden by explicit ones.
+
+ if Nkind (Literal) = N_Defining_Character_Literal then
+ New_Lit :=
+ Make_Defining_Character_Literal (Loc, Chars (Literal));
+ else
+ New_Lit := Make_Defining_Identifier (Loc, Chars (Literal));
+ end if;
+
+ Set_Ekind (New_Lit, E_Enumeration_Literal);
+ Set_Enumeration_Pos (New_Lit, Enumeration_Pos (Literal));
+ Set_Enumeration_Rep (New_Lit, Enumeration_Rep (Literal));
+ Set_Enumeration_Rep_Expr (New_Lit, Empty);
+ Set_Alias (New_Lit, Literal);
+ Set_Is_Known_Valid (New_Lit, True);
+
+ Append (New_Lit, Literals_List);
+ Next_Literal (Literal);
+ end loop;
+
+ Implicit_Base :=
+ Make_Defining_Identifier (Sloc (Derived_Type),
+ New_External_Name (Chars (Derived_Type), 'B'));
+
+ -- Indicate the proper nature of the derived type. This must
+ -- be done before analysis of the literals, to recognize cases
+ -- when a literal may be hidden by a previous explicit function
+ -- definition (cf. c83031a).
+
+ Set_Ekind (Derived_Type, E_Enumeration_Subtype);
+ Set_Etype (Derived_Type, Implicit_Base);
+
+ Type_Decl :=
+ Make_Full_Type_Declaration (Loc,
+ Defining_Identifier => Implicit_Base,
+ Discriminant_Specifications => No_List,
+ Type_Definition =>
+ Make_Enumeration_Type_Definition (Loc, Literals_List));
+
+ Mark_Rewrite_Insertion (Type_Decl);
+ Insert_Before (N, Type_Decl);
+ Analyze (Type_Decl);
+
+ -- After the implicit base is analyzed its Etype needs to be
+ -- changed to reflect the fact that it is derived from the
+ -- parent type which was ignored during analysis. We also set
+ -- the size at this point.
+
+ Set_Etype (Implicit_Base, Parent_Type);
+
+ Set_Size_Info (Implicit_Base, Parent_Type);
+ Set_RM_Size (Implicit_Base, RM_Size (Parent_Type));
+ Set_First_Rep_Item (Implicit_Base, First_Rep_Item (Parent_Type));
+
+ Set_Has_Non_Standard_Rep
+ (Implicit_Base, Has_Non_Standard_Rep
+ (Parent_Type));
+ Set_Has_Delayed_Freeze (Implicit_Base);
+
+ -- Process the subtype indication including a validation check
+ -- on the constraint, if any. If a constraint is given, its bounds
+ -- must be implicitly converted to the new type.
+
+ if Nkind (Indic) = N_Subtype_Indication then
+
+ declare
+ R : constant Node_Id :=
+ Range_Expression (Constraint (Indic));
+
+ begin
+ if Nkind (R) = N_Range then
+ Hi := Build_Scalar_Bound
+ (High_Bound (R), Parent_Type, Implicit_Base, Loc);
+ Lo := Build_Scalar_Bound
+ (Low_Bound (R), Parent_Type, Implicit_Base, Loc);
+
+ else
+ -- Constraint is a Range attribute. Replace with the
+ -- explicit mention of the bounds of the prefix, which
+ -- must be a subtype.
+
+ Analyze (Prefix (R));
+ Hi :=
+ Convert_To (Implicit_Base,
+ Make_Attribute_Reference (Loc,
+ Attribute_Name => Name_Last,
+ Prefix =>
+ New_Occurrence_Of (Entity (Prefix (R)), Loc)));
+
+ Lo :=
+ Convert_To (Implicit_Base,
+ Make_Attribute_Reference (Loc,
+ Attribute_Name => Name_First,
+ Prefix =>
+ New_Occurrence_Of (Entity (Prefix (R)), Loc)));
+ end if;
+
+ end;
+
+ else
+ Hi :=
+ Build_Scalar_Bound
+ (Type_High_Bound (Parent_Type),
+ Parent_Type, Implicit_Base, Loc);
+ Lo :=
+ Build_Scalar_Bound
+ (Type_Low_Bound (Parent_Type),
+ Parent_Type, Implicit_Base, Loc);
+ end if;
+
+ Rang_Expr :=
+ Make_Range (Loc,
+ Low_Bound => Lo,
+ High_Bound => Hi);
+
+ -- If we constructed a default range for the case where no range
+ -- was given, then the expressions in the range must not freeze
+ -- since they do not correspond to expressions in the source.
+
+ if Nkind (Indic) /= N_Subtype_Indication then
+ Set_Must_Not_Freeze (Lo);
+ Set_Must_Not_Freeze (Hi);
+ Set_Must_Not_Freeze (Rang_Expr);
+ end if;
+
+ Rewrite (N,
+ Make_Subtype_Declaration (Loc,
+ Defining_Identifier => Derived_Type,
+ Subtype_Indication =>
+ Make_Subtype_Indication (Loc,
+ Subtype_Mark => New_Occurrence_Of (Implicit_Base, Loc),
+ Constraint =>
+ Make_Range_Constraint (Loc,
+ Range_Expression => Rang_Expr))));
+
+ Analyze (N);
+
+ -- If pragma Discard_Names applies on the first subtype
+ -- of the parent type, then it must be applied on this
+ -- subtype as well.
+
+ if Einfo.Discard_Names (First_Subtype (Parent_Type)) then
+ Set_Discard_Names (Derived_Type);
+ end if;
+
+ -- Apply a range check. Since this range expression doesn't
+ -- have an Etype, we have to specifically pass the Source_Typ
+ -- parameter. Is this right???
+
+ if Nkind (Indic) = N_Subtype_Indication then
+ Apply_Range_Check (Range_Expression (Constraint (Indic)),
+ Parent_Type,
+ Source_Typ => Entity (Subtype_Mark (Indic)));
+ end if;
+ end if;
+
+ end Build_Derived_Enumeration_Type;
+
+ --------------------------------
+ -- Build_Derived_Numeric_Type --
+ --------------------------------
+
+ procedure Build_Derived_Numeric_Type
+ (N : Node_Id;
+ Parent_Type : Entity_Id;
+ Derived_Type : Entity_Id)
+ is
+ Loc : constant Source_Ptr := Sloc (N);
+ Tdef : constant Node_Id := Type_Definition (N);
+ Indic : constant Node_Id := Subtype_Indication (Tdef);
+ Parent_Base : constant Entity_Id := Base_Type (Parent_Type);
+ No_Constraint : constant Boolean := Nkind (Indic) /=
+ N_Subtype_Indication;
+ Implicit_Base : Entity_Id;
+
+ Lo : Node_Id;
+ Hi : Node_Id;
+ T : Entity_Id;
+
+ begin
+ -- Process the subtype indication including a validation check on
+ -- the constraint if any.
+
+ T := Process_Subtype (Indic, N);
+
+ -- Introduce an implicit base type for the derived type even if
+ -- there is no constraint attached to it, since this seems closer
+ -- to the Ada semantics.
+
+ Implicit_Base :=
+ Create_Itype (Ekind (Parent_Base), N, Derived_Type, 'B');
+
+ Set_Etype (Implicit_Base, Parent_Base);
+ Set_Ekind (Implicit_Base, Ekind (Parent_Base));
+ Set_Size_Info (Implicit_Base, Parent_Base);
+ Set_RM_Size (Implicit_Base, RM_Size (Parent_Base));
+ Set_First_Rep_Item (Implicit_Base, First_Rep_Item (Parent_Base));
+ Set_Parent (Implicit_Base, Parent (Derived_Type));
+
+ if Is_Discrete_Or_Fixed_Point_Type (Parent_Base) then
+ Set_RM_Size (Implicit_Base, RM_Size (Parent_Base));
+ end if;
+
+ Set_Has_Delayed_Freeze (Implicit_Base);
+
+ Lo := New_Copy_Tree (Type_Low_Bound (Parent_Base));
+ Hi := New_Copy_Tree (Type_High_Bound (Parent_Base));
+
+ Set_Scalar_Range (Implicit_Base,
+ Make_Range (Loc,
+ Low_Bound => Lo,
+ High_Bound => Hi));
+
+ if Has_Infinities (Parent_Base) then
+ Set_Includes_Infinities (Scalar_Range (Implicit_Base));
+ end if;
+
+ -- The Derived_Type, which is the entity of the declaration, is
+ -- a subtype of the implicit base. Its Ekind is a subtype, even
+ -- in the absence of an explicit constraint.
+
+ Set_Etype (Derived_Type, Implicit_Base);
+
+ -- If we did not have a constraint, then the Ekind is set from the
+ -- parent type (otherwise Process_Subtype has set the bounds)
+
+ if No_Constraint then
+ Set_Ekind (Derived_Type, Subtype_Kind (Ekind (Parent_Type)));
+ end if;
+
+ -- If we did not have a range constraint, then set the range
+ -- from the parent type. Otherwise, the call to Process_Subtype
+ -- has set the bounds.
+
+ if No_Constraint
+ or else not Has_Range_Constraint (Indic)
+ then
+ Set_Scalar_Range (Derived_Type,
+ Make_Range (Loc,
+ Low_Bound => New_Copy_Tree (Type_Low_Bound (Parent_Type)),
+ High_Bound => New_Copy_Tree (Type_High_Bound (Parent_Type))));
+ Set_Is_Constrained (Derived_Type, Is_Constrained (Parent_Type));
+
+ if Has_Infinities (Parent_Type) then
+ Set_Includes_Infinities (Scalar_Range (Derived_Type));
+ end if;
+ end if;
+
+ -- Set remaining type-specific fields, depending on numeric type
+
+ if Is_Modular_Integer_Type (Parent_Type) then
+ Set_Modulus (Implicit_Base, Modulus (Parent_Base));
+
+ Set_Non_Binary_Modulus
+ (Implicit_Base, Non_Binary_Modulus (Parent_Base));
+
+ elsif Is_Floating_Point_Type (Parent_Type) then
+
+ -- Digits of base type is always copied from the digits value of
+ -- the parent base type, but the digits of the derived type will
+ -- already have been set if there was a constraint present.
+
+ Set_Digits_Value (Implicit_Base, Digits_Value (Parent_Base));
+ Set_Vax_Float (Implicit_Base, Vax_Float (Parent_Base));
+
+ if No_Constraint then
+ Set_Digits_Value (Derived_Type, Digits_Value (Parent_Type));
+ end if;
+
+ elsif Is_Fixed_Point_Type (Parent_Type) then
+
+ -- Small of base type and derived type are always copied from
+ -- the parent base type, since smalls never change. The delta
+ -- of the base type is also copied from the parent base type.
+ -- However the delta of the derived type will have been set
+ -- already if a constraint was present.
+
+ Set_Small_Value (Derived_Type, Small_Value (Parent_Base));
+ Set_Small_Value (Implicit_Base, Small_Value (Parent_Base));
+ Set_Delta_Value (Implicit_Base, Delta_Value (Parent_Base));
+
+ if No_Constraint then
+ Set_Delta_Value (Derived_Type, Delta_Value (Parent_Type));
+ end if;
+
+ -- The scale and machine radix in the decimal case are always
+ -- copied from the parent base type.
+
+ if Is_Decimal_Fixed_Point_Type (Parent_Type) then
+ Set_Scale_Value (Derived_Type, Scale_Value (Parent_Base));
+ Set_Scale_Value (Implicit_Base, Scale_Value (Parent_Base));
+
+ Set_Machine_Radix_10
+ (Derived_Type, Machine_Radix_10 (Parent_Base));
+ Set_Machine_Radix_10
+ (Implicit_Base, Machine_Radix_10 (Parent_Base));
+
+ Set_Digits_Value (Implicit_Base, Digits_Value (Parent_Base));
+
+ if No_Constraint then
+ Set_Digits_Value (Derived_Type, Digits_Value (Parent_Base));
+
+ else
+ -- the analysis of the subtype_indication sets the
+ -- digits value of the derived type.
+
+ null;
+ end if;
+ end if;
+ end if;
+
+ -- The type of the bounds is that of the parent type, and they
+ -- must be converted to the derived type.
+
+ Convert_Scalar_Bounds (N, Parent_Type, Derived_Type, Loc);
+
+ -- The implicit_base should be frozen when the derived type is frozen,
+ -- but note that it is used in the conversions of the bounds. For
+ -- fixed types we delay the determination of the bounds until the proper
+ -- freezing point. For other numeric types this is rejected by GCC, for
+ -- reasons that are currently unclear (???), so we choose to freeze the
+ -- implicit base now. In the case of integers and floating point types
+ -- this is harmless because subsequent representation clauses cannot
+ -- affect anything, but it is still baffling that we cannot use the
+ -- same mechanism for all derived numeric types.
+
+ if Is_Fixed_Point_Type (Parent_Type) then
+ Conditional_Delay (Implicit_Base, Parent_Type);
+ else
+ Freeze_Before (N, Implicit_Base);
+ end if;
+
+ end Build_Derived_Numeric_Type;
+
+ --------------------------------
+ -- Build_Derived_Private_Type --
+ --------------------------------
+
+ procedure Build_Derived_Private_Type
+ (N : Node_Id;
+ Parent_Type : Entity_Id;
+ Derived_Type : Entity_Id;
+ Is_Completion : Boolean;
+ Derive_Subps : Boolean := True)
+ is
+ Der_Base : Entity_Id;
+ Discr : Entity_Id;
+ Full_Decl : Node_Id := Empty;
+ Full_Der : Entity_Id;
+ Full_P : Entity_Id;
+ Last_Discr : Entity_Id;
+ Par_Scope : constant Entity_Id := Scope (Base_Type (Parent_Type));
+ Swapped : Boolean := False;
+
+ procedure Copy_And_Build;
+ -- Copy derived type declaration, replace parent with its full view,
+ -- and analyze new declaration.
+
+ procedure Copy_And_Build is
+ Full_N : Node_Id;
+
+ begin
+ if Ekind (Parent_Type) in Record_Kind
+ or else (Ekind (Parent_Type) in Enumeration_Kind
+ and then Root_Type (Parent_Type) /= Standard_Character
+ and then Root_Type (Parent_Type) /= Standard_Wide_Character
+ and then not Is_Generic_Type (Root_Type (Parent_Type)))
+ then
+ Full_N := New_Copy_Tree (N);
+ Insert_After (N, Full_N);
+ Build_Derived_Type (
+ Full_N, Parent_Type, Full_Der, True, Derive_Subps => False);
+
+ else
+ Build_Derived_Type (
+ N, Parent_Type, Full_Der, True, Derive_Subps => False);
+ end if;
+ end Copy_And_Build;
+
+ -- Start of processing for Build_Derived_Private_Type
+
+ begin
+ if Is_Tagged_Type (Parent_Type) then
+ Build_Derived_Record_Type
+ (N, Parent_Type, Derived_Type, Derive_Subps);
+ return;
+
+ elsif Has_Discriminants (Parent_Type) then
+
+ if Present (Full_View (Parent_Type)) then
+ if not Is_Completion then
+
+ -- Copy declaration for subsequent analysis.
+
+ Full_Decl := New_Copy_Tree (N);
+ Full_Der := New_Copy (Derived_Type);
+ Insert_After (N, Full_Decl);
+
+ else
+ -- If this is a completion, the full view being built is
+ -- itself private. We build a subtype of the parent with
+ -- the same constraints as this full view, to convey to the
+ -- back end the constrained components and the size of this
+ -- subtype. If the parent is constrained, its full view can
+ -- serve as the underlying full view of the derived type.
+
+ if No (Discriminant_Specifications (N)) then
+
+ if Nkind (Subtype_Indication (Type_Definition (N)))
+ = N_Subtype_Indication
+ then
+ Build_Underlying_Full_View (N, Derived_Type, Parent_Type);
+
+ elsif Is_Constrained (Full_View (Parent_Type)) then
+ Set_Underlying_Full_View (Derived_Type,
+ Full_View (Parent_Type));
+ end if;
+
+ else
+ -- If there are new discriminants, the parent subtype is
+ -- constrained by them, but it is not clear how to build
+ -- the underlying_full_view in this case ???
+
+ null;
+ end if;
+ end if;
+ end if;
+
+ Build_Derived_Record_Type
+ (N, Parent_Type, Derived_Type, Derive_Subps);
+
+ if Present (Full_View (Parent_Type))
+ and then not Is_Completion
+ then
+ if not In_Open_Scopes (Par_Scope)
+ or else not In_Same_Source_Unit (N, Parent_Type)
+ then
+ -- Swap partial and full views temporarily
+
+ Install_Private_Declarations (Par_Scope);
+ Install_Visible_Declarations (Par_Scope);
+ Swapped := True;
+ end if;
+
+ -- Subprograms have been derived on the private view,
+ -- the completion does not derive them anew.
+
+ Build_Derived_Record_Type
+ (Full_Decl, Parent_Type, Full_Der, False);
+
+ if Swapped then
+ Uninstall_Declarations (Par_Scope);
+
+ if In_Open_Scopes (Par_Scope) then
+ Install_Visible_Declarations (Par_Scope);
+ end if;
+ end if;
+
+ Der_Base := Base_Type (Derived_Type);
+ Set_Full_View (Derived_Type, Full_Der);
+ Set_Full_View (Der_Base, Base_Type (Full_Der));
+
+ -- Copy the discriminant list from full view to
+ -- the partial views (base type and its subtype).
+ -- Gigi requires that the partial and full views
+ -- have the same discriminants.
+ -- ??? Note that since the partial view is pointing
+ -- to discriminants in the full view, their scope
+ -- will be that of the full view. This might
+ -- cause some front end problems and need
+ -- adustment?
+
+ Discr := First_Discriminant (Base_Type (Full_Der));
+ Set_First_Entity (Der_Base, Discr);
+
+ loop
+ Last_Discr := Discr;
+ Next_Discriminant (Discr);
+ exit when No (Discr);
+ end loop;
+
+ Set_Last_Entity (Der_Base, Last_Discr);
+
+ Set_First_Entity (Derived_Type, First_Entity (Der_Base));
+ Set_Last_Entity (Derived_Type, Last_Entity (Der_Base));
+
+ else
+ -- If this is a completion, the derived type stays private
+ -- and there is no need to create a further full view, except
+ -- in the unusual case when the derivation is nested within a
+ -- child unit, see below.
+
+ null;
+ end if;
+
+ elsif Present (Full_View (Parent_Type))
+ and then Has_Discriminants (Full_View (Parent_Type))
+ then
+ if Has_Unknown_Discriminants (Parent_Type)
+ and then Nkind (Subtype_Indication (Type_Definition (N)))
+ = N_Subtype_Indication
+ then
+ Error_Msg_N
+ ("cannot constrain type with unknown discriminants",
+ Subtype_Indication (Type_Definition (N)));
+ return;
+ end if;
+
+ -- Inherit the discriminants of the full view, but
+ -- keep the proper parent type.
+
+ -- ??? this looks wrong, we are replacing (and thus,
+ -- erasing) the partial view!
+
+ -- In any case, the primitive operations are inherited from
+ -- the parent type, not from the internal full view.
+
+ Build_Derived_Record_Type
+ (N, Full_View (Parent_Type), Derived_Type,
+ Derive_Subps => False);
+ Set_Etype (Base_Type (Derived_Type), Base_Type (Parent_Type));
+
+ if Derive_Subps then
+ Derive_Subprograms (Parent_Type, Derived_Type);
+ end if;
+
+ else
+
+ -- Untagged type, No discriminants on either view.
+
+ if Nkind (Subtype_Indication (Type_Definition (N)))
+ = N_Subtype_Indication
+ then
+ Error_Msg_N
+ ("illegal constraint on type without discriminants", N);
+ end if;
+
+ if Present (Discriminant_Specifications (N))
+ and then Present (Full_View (Parent_Type))
+ and then not Is_Tagged_Type (Full_View (Parent_Type))
+ then
+ Error_Msg_N
+ ("cannot add discriminants to untagged type", N);
+ end if;
+
+ Set_Girder_Constraint (Derived_Type, No_Elist);
+ Set_Is_Constrained (Derived_Type, Is_Constrained (Parent_Type));
+ Set_Is_Controlled (Derived_Type, Is_Controlled (Parent_Type));
+ Set_Has_Controlled_Component (Derived_Type,
+ Has_Controlled_Component (Parent_Type));
+
+ -- Direct controlled types do not inherit the Finalize_Storage_Only
+ -- flag.
+
+ if not Is_Controlled (Parent_Type) then
+ Set_Finalize_Storage_Only (Derived_Type,
+ Finalize_Storage_Only (Parent_Type));
+ end if;
+
+ -- Construct the implicit full view by deriving from full
+ -- view of the parent type. In order to get proper visiblity,
+ -- we install the parent scope and its declarations.
+
+ -- ??? if the parent is untagged private and its
+ -- completion is tagged, this mechanism will not
+ -- work because we cannot derive from the tagged
+ -- full view unless we have an extension
+
+ if Present (Full_View (Parent_Type))
+ and then not Is_Tagged_Type (Full_View (Parent_Type))
+ and then not Is_Completion
+ then
+ Full_Der := Make_Defining_Identifier (Sloc (Derived_Type),
+ Chars (Derived_Type));
+ Set_Is_Itype (Full_Der);
+ Set_Has_Private_Declaration (Full_Der);
+ Set_Has_Private_Declaration (Derived_Type);
+ Set_Associated_Node_For_Itype (Full_Der, N);
+ Set_Parent (Full_Der, Parent (Derived_Type));
+ Set_Full_View (Derived_Type, Full_Der);
+
+ if not In_Open_Scopes (Par_Scope) then
+ Install_Private_Declarations (Par_Scope);
+ Install_Visible_Declarations (Par_Scope);
+ Copy_And_Build;
+ Uninstall_Declarations (Par_Scope);
+
+ -- If parent scope is open and in another unit, and
+ -- parent has a completion, then the derivation is taking
+ -- place in the visible part of a child unit. In that
+ -- case retrieve the full view of the parent momentarily.
+
+ elsif not In_Same_Source_Unit (N, Parent_Type) then
+ Full_P := Full_View (Parent_Type);
+ Exchange_Declarations (Parent_Type);
+ Copy_And_Build;
+ Exchange_Declarations (Full_P);
+
+ -- Otherwise it is a local derivation.
+
+ else
+ Copy_And_Build;
+ end if;
+
+ Set_Scope (Full_Der, Current_Scope);
+ Set_Is_First_Subtype (Full_Der,
+ Is_First_Subtype (Derived_Type));
+ Set_Has_Size_Clause (Full_Der, False);
+ Set_Has_Alignment_Clause (Full_Der, False);
+ Set_Next_Entity (Full_Der, Empty);
+ Set_Has_Delayed_Freeze (Full_Der);
+ Set_Is_Frozen (Full_Der, False);
+ Set_Freeze_Node (Full_Der, Empty);
+ Set_Depends_On_Private (Full_Der,
+ Has_Private_Component (Full_Der));
+ end if;
+ end if;
+
+ Set_Has_Unknown_Discriminants (Derived_Type,
+ Has_Unknown_Discriminants (Parent_Type));
+
+ if Is_Private_Type (Derived_Type) then
+ Set_Private_Dependents (Derived_Type, New_Elmt_List);
+ end if;
+
+ if Is_Private_Type (Parent_Type)
+ and then Base_Type (Parent_Type) = Parent_Type
+ and then In_Open_Scopes (Scope (Parent_Type))
+ then
+ Append_Elmt (Derived_Type, Private_Dependents (Parent_Type));
+
+ if Is_Child_Unit (Scope (Current_Scope))
+ and then Is_Completion
+ and then In_Private_Part (Current_Scope)
+ then
+ -- This is the unusual case where a type completed by a private
+ -- derivation occurs within a package nested in a child unit,
+ -- and the parent is declared in an ancestor. In this case, the
+ -- full view of the parent type will become visible in the body
+ -- of the enclosing child, and only then will the current type
+ -- be possibly non-private. We build a underlying full view that
+ -- will be installed when the enclosing child body is compiled.
+
+ declare
+ IR : constant Node_Id := Make_Itype_Reference (Sloc (N));
+
+ begin
+ Full_Der :=
+ Make_Defining_Identifier (Sloc (Derived_Type),
+ Chars (Derived_Type));
+ Set_Is_Itype (Full_Der);
+ Set_Itype (IR, Full_Der);
+ Insert_After (N, IR);
+
+ -- The full view will be used to swap entities on entry/exit
+ -- to the body, and must appear in the entity list for the
+ -- package.
+
+ Append_Entity (Full_Der, Scope (Derived_Type));
+ Set_Has_Private_Declaration (Full_Der);
+ Set_Has_Private_Declaration (Derived_Type);
+ Set_Associated_Node_For_Itype (Full_Der, N);
+ Set_Parent (Full_Der, Parent (Derived_Type));
+ Full_P := Full_View (Parent_Type);
+ Exchange_Declarations (Parent_Type);
+ Copy_And_Build;
+ Exchange_Declarations (Full_P);
+ Set_Underlying_Full_View (Derived_Type, Full_Der);
+ end;
+ end if;
+ end if;
+ end Build_Derived_Private_Type;
+
+ -------------------------------
+ -- Build_Derived_Record_Type --
+ -------------------------------
+
+ -- 1. INTRODUCTION.
+
+ -- Ideally we would like to use the same model of type derivation for
+ -- tagged and untagged record types. Unfortunately this is not quite
+ -- possible because the semantics of representation clauses is different
+ -- for tagged and untagged records under inheritance. Consider the
+ -- following:
+
+ -- type R (...) is [tagged] record ... end record;
+ -- type T (...) is new R (...) [with ...];
+
+ -- The representation clauses of T can specify a completely different
+ -- record layout from R's. Hence a same component can be placed in two very
+ -- different positions in objects of type T and R. If R and T are tagged
+ -- types, representation clauses for T can only specify the layout of non
+ -- inherited components, thus components that are common in R and T have
+ -- the same position in objects of type R or T.
+
+ -- This has two implications. The first is that the entire tree for R's
+ -- declaration needs to be copied for T in the untagged case, so that
+ -- T can be viewd as a record type of its own with its own derivation
+ -- clauses. The second implication is the way we handle discriminants.
+ -- Specifically, in the untagged case we need a way to communicate to Gigi
+ -- what are the real discriminants in the record, while for the semantics
+ -- we need to consider those introduced by the user to rename the
+ -- discriminants in the parent type. This is handled by introducing the
+ -- notion of girder discriminants. See below for more.
+
+ -- Fortunately the way regular components are inherited can be handled in
+ -- the same way in tagged and untagged types.
+
+ -- To complicate things a bit more the private view of a private extension
+ -- cannot be handled in the same way as the full view (for one thing the
+ -- semantic rules are somewhat different). We will explain what differs
+ -- below.
+
+ -- 2. DISCRIMINANTS UNDER INHERITANCE.
+
+ -- The semantic rules governing the discriminants of derived types are
+ -- quite subtle.
+
+ -- type Derived_Type_Name [KNOWN_DISCRIMINANT_PART] is new
+ -- [abstract] Parent_Type_Name [CONSTRAINT] [RECORD_EXTENSION_PART]
+
+ -- If parent type has discriminants, then the discriminants that are
+ -- declared in the derived type are [3.4 (11)]:
+
+ -- o The discriminants specified by a new KNOWN_DISCRIMINANT_PART, if
+ -- there is one;
+
+ -- o Otherwise, each discriminant of the parent type (implicitely
+ -- declared in the same order with the same specifications). In this
+ -- case, the discriminants are said to be "inherited", or if unknown in
+ -- the parent are also unknown in the derived type.
+
+ -- Furthermore if a KNOWN_DISCRIMINANT_PART is provided, then [3.7(13-18)]:
+
+ -- o The parent subtype shall be constrained;
+
+ -- o If the parent type is not a tagged type, then each discriminant of
+ -- the derived type shall be used in the constraint defining a parent
+ -- subtype [Implementation note: this ensures that the new discriminant
+ -- can share storage with an existing discriminant.].
+
+ -- For the derived type each discriminant of the parent type is either
+ -- inherited, constrained to equal some new discriminant of the derived
+ -- type, or constrained to the value of an expression.
+
+ -- When inherited or constrained to equal some new discriminant, the
+ -- parent discriminant and the discriminant of the derived type are said
+ -- to "correspond".
+
+ -- If a discriminant of the parent type is constrained to a specific value
+ -- in the derived type definition, then the discriminant is said to be
+ -- "specified" by that derived type definition.
+
+ -- 3. DISCRIMINANTS IN DERIVED UNTAGGED RECORD TYPES.
+
+ -- We have spoken about girder discriminants in the point 1 (introduction)
+ -- above. There are two sort of girder discriminants: implicit and
+ -- explicit. As long as the derived type inherits the same discriminants as
+ -- the root record type, girder discriminants are the same as regular
+ -- discriminants, and are said to be implicit. However, if any discriminant
+ -- in the root type was renamed in the derived type, then the derived
+ -- type will contain explicit girder discriminants. Explicit girder
+ -- discriminants are discriminants in addition to the semantically visible
+ -- discriminants defined for the derived type. Girder discriminants are
+ -- used by Gigi to figure out what are the physical discriminants in
+ -- objects of the derived type (see precise definition in einfo.ads).
+ -- As an example, consider the following:
+
+ -- type R (D1, D2, D3 : Int) is record ... end record;
+ -- type T1 is new R;
+ -- type T2 (X1, X2: Int) is new T1 (X2, 88, X1);
+ -- type T3 is new T2;
+ -- type T4 (Y : Int) is new T3 (Y, 99);
+
+ -- The following table summarizes the discriminants and girder
+ -- discriminants in R and T1 through T4.
+
+ -- Type Discrim Girder Discrim Comment
+ -- R (D1, D2, D3) (D1, D2, D3) Gider discrims are implicit in R
+ -- T1 (D1, D2, D3) (D1, D2, D3) Gider discrims are implicit in T1
+ -- T2 (X1, X2) (D1, D2, D3) Gider discrims are EXPLICIT in T2
+ -- T3 (X1, X2) (D1, D2, D3) Gider discrims are EXPLICIT in T3
+ -- T4 (Y) (D1, D2, D3) Gider discrims are EXPLICIT in T4
+
+ -- Field Corresponding_Discriminant (abbreviated CD below) allows to find
+ -- the corresponding discriminant in the parent type, while
+ -- Original_Record_Component (abbreviated ORC below), the actual physical
+ -- component that is renamed. Finally the field Is_Completely_Hidden
+ -- (abbreaviated ICH below) is set for all explicit girder discriminants
+ -- (see einfo.ads for more info). For the above example this gives:
+
+ -- Discrim CD ORC ICH
+ -- ^^^^^^^ ^^ ^^^ ^^^
+ -- D1 in R empty itself no
+ -- D2 in R empty itself no
+ -- D3 in R empty itself no
+
+ -- D1 in T1 D1 in R itself no
+ -- D2 in T1 D2 in R itself no
+ -- D3 in T1 D3 in R itself no
+
+ -- X1 in T2 D3 in T1 D3 in T2 no
+ -- X2 in T2 D1 in T1 D1 in T2 no
+ -- D1 in T2 empty itself yes
+ -- D2 in T2 empty itself yes
+ -- D3 in T2 empty itself yes
+
+ -- X1 in T3 X1 in T2 D3 in T3 no
+ -- X2 in T3 X2 in T2 D1 in T3 no
+ -- D1 in T3 empty itself yes
+ -- D2 in T3 empty itself yes
+ -- D3 in T3 empty itself yes
+
+ -- Y in T4 X1 in T3 D3 in T3 no
+ -- D1 in T3 empty itself yes
+ -- D2 in T3 empty itself yes
+ -- D3 in T3 empty itself yes
+
+ -- 4. DISCRIMINANTS IN DERIVED TAGGED RECORD TYPES.
+
+ -- Type derivation for tagged types is fairly straightforward. if no
+ -- discriminants are specified by the derived type, these are inherited
+ -- from the parent. No explicit girder discriminants are ever necessary.
+ -- The only manipulation that is done to the tree is that of adding a
+ -- _parent field with parent type and constrained to the same constraint
+ -- specified for the parent in the derived type definition. For instance:
+
+ -- type R (D1, D2, D3 : Int) is tagged record ... end record;
+ -- type T1 is new R with null record;
+ -- type T2 (X1, X2: Int) is new T1 (X2, 88, X1) with null record;
+
+ -- are changed into :
+
+ -- type T1 (D1, D2, D3 : Int) is new R (D1, D2, D3) with record
+ -- _parent : R (D1, D2, D3);
+ -- end record;
+
+ -- type T2 (X1, X2: Int) is new T1 (X2, 88, X1) with record
+ -- _parent : T1 (X2, 88, X1);
+ -- end record;
+
+ -- The discriminants actually present in R, T1 and T2 as well as their CD,
+ -- ORC and ICH fields are:
+
+ -- Discrim CD ORC ICH
+ -- ^^^^^^^ ^^ ^^^ ^^^
+ -- D1 in R empty itself no
+ -- D2 in R empty itself no
+ -- D3 in R empty itself no
+
+ -- D1 in T1 D1 in R D1 in R no
+ -- D2 in T1 D2 in R D2 in R no
+ -- D3 in T1 D3 in R D3 in R no
+
+ -- X1 in T2 D3 in T1 D3 in R no
+ -- X2 in T2 D1 in T1 D1 in R no
+
+ -- 5. FIRST TRANSFORMATION FOR DERIVED RECORDS.
+ --
+ -- Regardless of whether we dealing with a tagged or untagged type
+ -- we will transform all derived type declarations of the form
+ --
+ -- type T is new R (...) [with ...];
+ -- or
+ -- subtype S is R (...);
+ -- type T is new S [with ...];
+ -- into
+ -- type BT is new R [with ...];
+ -- subtype T is BT (...);
+ --
+ -- That is, the base derived type is constrained only if it has no
+ -- discriminants. The reason for doing this is that GNAT's semantic model
+ -- assumes that a base type with discriminants is unconstrained.
+ --
+ -- Note that, strictly speaking, the above transformation is not always
+ -- correct. Consider for instance the following exercpt from ACVC b34011a:
+ --
+ -- procedure B34011A is
+ -- type REC (D : integer := 0) is record
+ -- I : Integer;
+ -- end record;
+
+ -- package P is
+ -- type T6 is new Rec;
+ -- function F return T6;
+ -- end P;
+
+ -- use P;
+ -- package Q6 is
+ -- type U is new T6 (Q6.F.I); -- ERROR: Q6.F.
+ -- end Q6;
+ --
+ -- The definition of Q6.U is illegal. However transforming Q6.U into
+
+ -- type BaseU is new T6;
+ -- subtype U is BaseU (Q6.F.I)
+
+ -- turns U into a legal subtype, which is incorrect. To avoid this problem
+ -- we always analyze the constraint (in this case (Q6.F.I)) before applying
+ -- the transformation described above.
+
+ -- There is another instance where the above transformation is incorrect.
+ -- Consider:
+
+ -- package Pack is
+ -- type Base (D : Integer) is tagged null record;
+ -- procedure P (X : Base);
+
+ -- type Der is new Base (2) with null record;
+ -- procedure P (X : Der);
+ -- end Pack;
+
+ -- Then the above transformation turns this into
+
+ -- type Der_Base is new Base with null record;
+ -- -- procedure P (X : Base) is implicitely inherited here
+ -- -- as procedure P (X : Der_Base).
+
+ -- subtype Der is Der_Base (2);
+ -- procedure P (X : Der);
+ -- -- The overriding of P (X : Der_Base) is illegal since we
+ -- -- have a parameter conformance problem.
+
+ -- To get around this problem, after having semantically processed Der_Base
+ -- and the rewritten subtype declaration for Der, we copy Der_Base field
+ -- Discriminant_Constraint from Der so that when parameter conformance is
+ -- checked when P is overridden, no sematic errors are flagged.
+
+ -- 6. SECOND TRANSFORMATION FOR DERIVED RECORDS.
+
+ -- Regardless of the fact that we dealing with a tagged or untagged type
+ -- we will transform all derived type declarations of the form
+
+ -- type R (D1, .., Dn : ...) is [tagged] record ...;
+ -- type T is new R [with ...];
+ -- into
+ -- type T (D1, .., Dn : ...) is new R (D1, .., Dn) [with ...];
+
+ -- The reason for such transformation is that it allows us to implement a
+ -- very clean form of component inheritance as explained below.
+
+ -- Note that this transformation is not achieved by direct tree rewriting
+ -- and manipulation, but rather by redoing the semantic actions that the
+ -- above transformation will entail. This is done directly in routine
+ -- Inherit_Components.
+
+ -- 7. TYPE DERIVATION AND COMPONENT INHERITANCE.
+
+ -- In both tagged and untagged derived types, regular non discriminant
+ -- components are inherited in the derived type from the parent type. In
+ -- the absence of discriminants component, inheritance is straightforward
+ -- as components can simply be copied from the parent.
+ -- If the parent has discriminants, inheriting components constrained with
+ -- these discriminants requires caution. Consider the following example:
+
+ -- type R (D1, D2 : Positive) is [tagged] record
+ -- S : String (D1 .. D2);
+ -- end record;
+
+ -- type T1 is new R [with null record];
+ -- type T2 (X : positive) is new R (1, X) [with null record];
+
+ -- As explained in 6. above, T1 is rewritten as
+
+ -- type T1 (D1, D2 : Positive) is new R (D1, D2) [with null record];
+
+ -- which makes the treatment for T1 and T2 identical.
+
+ -- What we want when inheriting S, is that references to D1 and D2 in R are
+ -- replaced with references to their correct constraints, ie D1 and D2 in
+ -- T1 and 1 and X in T2. So all R's discriminant references are replaced
+ -- with either discriminant references in the derived type or expressions.
+ -- This replacement is acheived as follows: before inheriting R's
+ -- components, a subtype R (D1, D2) for T1 (resp. R (1, X) for T2) is
+ -- created in the scope of T1 (resp. scope of T2) so that discriminants D1
+ -- and D2 of T1 are visible (resp. discriminant X of T2 is visible).
+ -- For T2, for instance, this has the effect of replacing String (D1 .. D2)
+ -- by String (1 .. X).
+
+ -- 8. TYPE DERIVATION IN PRIVATE TYPE EXTENSIONS.
+
+ -- We explain here the rules governing private type extensions relevant to
+ -- type derivation. These rules are explained on the following example:
+
+ -- type D [(...)] is new A [(...)] with private; <-- partial view
+ -- type D [(...)] is new P [(...)] with null record; <-- full view
+
+ -- Type A is called the ancestor subtype of the private extension.
+ -- Type P is the parent type of the full view of the private extension. It
+ -- must be A or a type derived from A.
+
+ -- The rules concerning the discriminants of private type extensions are
+ -- [7.3(10-13)]:
+
+ -- o If a private extension inherits known discriminants from the ancestor
+ -- subtype, then the full view shall also inherit its discriminants from
+ -- the ancestor subtype and the parent subtype of the full view shall be
+ -- constrained if and only if the ancestor subtype is constrained.
+
+ -- o If a partial view has unknown discriminants, then the full view may
+ -- define a definite or an indefinite subtype, with or without
+ -- discriminants.
+
+ -- o If a partial view has neither known nor unknown discriminants, then
+ -- the full view shall define a definite subtype.
+
+ -- o If the ancestor subtype of a private extension has constrained
+ -- discrimiants, then the parent subtype of the full view shall impose a
+ -- statically matching constraint on those discriminants.
+
+ -- This means that only the following forms of private extensions are
+ -- allowed:
+
+ -- type D is new A with private; <-- partial view
+ -- type D is new P with null record; <-- full view
+
+ -- If A has no discriminants than P has no discriminants, otherwise P must
+ -- inherit A's discriminants.
+
+ -- type D is new A (...) with private; <-- partial view
+ -- type D is new P (:::) with null record; <-- full view
+
+ -- P must inherit A's discriminants and (...) and (:::) must statically
+ -- match.
+
+ -- subtype A is R (...);
+ -- type D is new A with private; <-- partial view
+ -- type D is new P with null record; <-- full view
+
+ -- P must have inherited R's discriminants and must be derived from A or
+ -- any of its subtypes.
+
+ -- type D (..) is new A with private; <-- partial view
+ -- type D (..) is new P [(:::)] with null record; <-- full view
+
+ -- No specific constraints on P's discriminants or constraint (:::).
+ -- Note that A can be unconstrained, but the parent subtype P must either
+ -- be constrained or (:::) must be present.
+
+ -- type D (..) is new A [(...)] with private; <-- partial view
+ -- type D (..) is new P [(:::)] with null record; <-- full view
+
+ -- P's constraints on A's discriminants must statically match those
+ -- imposed by (...).
+
+ -- 9. IMPLEMENTATION OF TYPE DERIVATION FOR PRIVATE EXTENSIONS.
+
+ -- The full view of a private extension is handled exactly as described
+ -- above. The model chose for the private view of a private extension
+ -- is the same for what concerns discriminants (ie they receive the same
+ -- treatment as in the tagged case). However, the private view of the
+ -- private extension always inherits the components of the parent base,
+ -- without replacing any discriminant reference. Strictly speacking this
+ -- is incorrect. However, Gigi never uses this view to generate code so
+ -- this is a purely semantic issue. In theory, a set of transformations
+ -- similar to those given in 5. and 6. above could be applied to private
+ -- views of private extensions to have the same model of component
+ -- inheritance as for non private extensions. However, this is not done
+ -- because it would further complicate private type processing.
+ -- Semantically speaking, this leaves us in an uncomfortable
+ -- situation. As an example consider:
+
+ -- package Pack is
+ -- type R (D : integer) is tagged record
+ -- S : String (1 .. D);
+ -- end record;
+ -- procedure P (X : R);
+ -- type T is new R (1) with private;
+ -- private
+ -- type T is new R (1) with null record;
+ -- end;
+
+ -- This is transformed into:
+
+ -- package Pack is
+ -- type R (D : integer) is tagged record
+ -- S : String (1 .. D);
+ -- end record;
+ -- procedure P (X : R);
+ -- type T is new R (1) with private;
+ -- private
+ -- type BaseT is new R with null record;
+ -- subtype T is BaseT (1);
+ -- end;
+
+ -- (strictly speaking the above is incorrect Ada).
+
+ -- From the semantic standpoint the private view of private extension T
+ -- should be flagged as constrained since one can clearly have
+ --
+ -- Obj : T;
+ --
+ -- in a unit withing Pack. However, when deriving subprograms for the
+ -- private view of private extension T, T must be seen as unconstrained
+ -- since T has discriminants (this is a constraint of the current
+ -- subprogram derivation model). Thus, when processing the private view of
+ -- a private extension such as T, we first mark T as unconstrained, we
+ -- process it, we perform program derivation and just before returning from
+ -- Build_Derived_Record_Type we mark T as constrained.
+ -- ??? Are there are other unconfortable cases that we will have to
+ -- deal with.
+
+ -- 10. RECORD_TYPE_WITH_PRIVATE complications.
+
+ -- Types that are derived from a visible record type and have a private
+ -- extension present other peculiarities. They behave mostly like private
+ -- types, but if they have primitive operations defined, these will not
+ -- have the proper signatures for further inheritance, because other
+ -- primitive operations will use the implicit base that we define for
+ -- private derivations below. This affect subprogram inheritance (see
+ -- Derive_Subprograms for details). We also derive the implicit base from
+ -- the base type of the full view, so that the implicit base is a record
+ -- type and not another private type, This avoids infinite loops.
+
+ procedure Build_Derived_Record_Type
+ (N : Node_Id;
+ Parent_Type : Entity_Id;
+ Derived_Type : Entity_Id;
+ Derive_Subps : Boolean := True)
+ is
+ Loc : constant Source_Ptr := Sloc (N);
+ Parent_Base : Entity_Id;
+
+ Type_Def : Node_Id;
+ Indic : Node_Id;
+
+ Discrim : Entity_Id;
+ Last_Discrim : Entity_Id;
+ Constrs : Elist_Id;
+ Discs : Elist_Id := New_Elmt_List;
+ -- An empty Discs list means that there were no constraints in the
+ -- subtype indication or that there was an error processing it.
+
+ Assoc_List : Elist_Id;
+ New_Discrs : Elist_Id;
+
+ New_Base : Entity_Id;
+ New_Decl : Node_Id;
+ New_Indic : Node_Id;
+
+ Is_Tagged : constant Boolean := Is_Tagged_Type (Parent_Type);
+ Discriminant_Specs : constant Boolean
+ := Present (Discriminant_Specifications (N));
+ Private_Extension : constant Boolean
+ := (Nkind (N) = N_Private_Extension_Declaration);
+
+ Constraint_Present : Boolean;
+ Inherit_Discrims : Boolean := False;
+
+ Save_Etype : Entity_Id;
+ Save_Discr_Constr : Elist_Id;
+ Save_Next_Entity : Entity_Id;
+
+ begin
+ if Ekind (Parent_Type) = E_Record_Type_With_Private
+ and then Present (Full_View (Parent_Type))
+ and then Has_Discriminants (Parent_Type)
+ then
+ Parent_Base := Base_Type (Full_View (Parent_Type));
+ else
+ Parent_Base := Base_Type (Parent_Type);
+ end if;
+
+ -- Before we start the previously documented transformations, here is
+ -- a little fix for size and alignment of tagged types. Normally when
+ -- we derive type D from type P, we copy the size and alignment of P
+ -- as the default for D, and in the absence of explicit representation
+ -- clauses for D, the size and alignment are indeed the same as the
+ -- parent.
+
+ -- But this is wrong for tagged types, since fields may be added,
+ -- and the default size may need to be larger, and the default
+ -- alignment may need to be larger.
+
+ -- We therefore reset the size and alignment fields in the tagged
+ -- case. Note that the size and alignment will in any case be at
+ -- least as large as the parent type (since the derived type has
+ -- a copy of the parent type in the _parent field)
+
+ if Is_Tagged then
+ Init_Size_Align (Derived_Type);
+ end if;
+
+ -- STEP 0a: figure out what kind of derived type declaration we have.
+
+ if Private_Extension then
+ Type_Def := N;
+ Set_Ekind (Derived_Type, E_Record_Type_With_Private);
+
+ else
+ Type_Def := Type_Definition (N);
+
+ -- Ekind (Parent_Base) in not necessarily E_Record_Type since
+ -- Parent_Base can be a private type or private extension. However,
+ -- for tagged types with an extension the newly added fields are
+ -- visible and hence the Derived_Type is always an E_Record_Type.
+ -- (except that the parent may have its own private fields).
+ -- For untagged types we preserve the Ekind of the Parent_Base.
+
+ if Present (Record_Extension_Part (Type_Def)) then
+ Set_Ekind (Derived_Type, E_Record_Type);
+ else
+ Set_Ekind (Derived_Type, Ekind (Parent_Base));
+ end if;
+ end if;
+
+ -- Indic can either be an N_Identifier if the subtype indication
+ -- contains no constraint or an N_Subtype_Indication if the subtype
+ -- indication has a constraint.
+
+ Indic := Subtype_Indication (Type_Def);
+ Constraint_Present := (Nkind (Indic) = N_Subtype_Indication);
+
+ if Constraint_Present then
+ if not Has_Discriminants (Parent_Base) then
+ Error_Msg_N
+ ("invalid constraint: type has no discriminant",
+ Constraint (Indic));
+
+ Constraint_Present := False;
+ Rewrite (Indic, New_Copy_Tree (Subtype_Mark (Indic)));
+
+ elsif Is_Constrained (Parent_Type) then
+ Error_Msg_N
+ ("invalid constraint: parent type is already constrained",
+ Constraint (Indic));
+
+ Constraint_Present := False;
+ Rewrite (Indic, New_Copy_Tree (Subtype_Mark (Indic)));
+ end if;
+ end if;
+
+ -- STEP 0b: If needed, apply transformation given in point 5. above.
+
+ if not Private_Extension
+ and then Has_Discriminants (Parent_Type)
+ and then not Discriminant_Specs
+ and then (Is_Constrained (Parent_Type) or else Constraint_Present)
+ then
+ -- First, we must analyze the constraint (see comment in point 5.).
+
+ if Constraint_Present then
+ New_Discrs := Build_Discriminant_Constraints (Parent_Type, Indic);
+
+ if Has_Discriminants (Derived_Type)
+ and then Has_Private_Declaration (Derived_Type)
+ and then Present (Discriminant_Constraint (Derived_Type))
+ then
+ -- Verify that constraints of the full view conform to those
+ -- given in partial view.
+
+ declare
+ C1, C2 : Elmt_Id;
+
+ begin
+ C1 := First_Elmt (New_Discrs);
+ C2 := First_Elmt (Discriminant_Constraint (Derived_Type));
+
+ while Present (C1) and then Present (C2) loop
+ if not
+ Fully_Conformant_Expressions (Node (C1), Node (C2))
+ then
+ Error_Msg_N (
+ "constraint not conformant to previous declaration",
+ Node (C1));
+ end if;
+ Next_Elmt (C1);
+ Next_Elmt (C2);
+ end loop;
+ end;
+ end if;
+ end if;
+
+ -- Insert and analyze the declaration for the unconstrained base type
+
+ New_Base := Create_Itype (Ekind (Derived_Type), N, Derived_Type, 'B');
+
+ New_Decl :=
+ Make_Full_Type_Declaration (Loc,
+ Defining_Identifier => New_Base,
+ Type_Definition =>
+ Make_Derived_Type_Definition (Loc,
+ Abstract_Present => Abstract_Present (Type_Def),
+ Subtype_Indication =>
+ New_Occurrence_Of (Parent_Base, Loc),
+ Record_Extension_Part =>
+ Relocate_Node (Record_Extension_Part (Type_Def))));
+
+ Set_Parent (New_Decl, Parent (N));
+ Mark_Rewrite_Insertion (New_Decl);
+ Insert_Before (N, New_Decl);
+
+ -- Note that this call passes False for the Derive_Subps
+ -- parameter because subprogram derivation is deferred until
+ -- after creating the subtype (see below).
+
+ Build_Derived_Type
+ (New_Decl, Parent_Base, New_Base,
+ Is_Completion => True, Derive_Subps => False);
+
+ -- ??? This needs re-examination to determine whether the
+ -- above call can simply be replaced by a call to Analyze.
+
+ Set_Analyzed (New_Decl);
+
+ -- Insert and analyze the declaration for the constrained subtype
+
+ if Constraint_Present then
+ New_Indic :=
+ Make_Subtype_Indication (Loc,
+ Subtype_Mark => New_Occurrence_Of (New_Base, Loc),
+ Constraint => Relocate_Node (Constraint (Indic)));
+
+ else
+ declare
+ Expr : Node_Id;
+ Constr_List : List_Id := New_List;
+ C : Elmt_Id;
+
+ begin
+ C := First_Elmt (Discriminant_Constraint (Parent_Type));
+ while Present (C) loop
+ Expr := Node (C);
+
+ -- It is safe here to call New_Copy_Tree since
+ -- Force_Evaluation was called on each constraint in
+ -- Build_Discriminant_Constraints.
+
+ Append (New_Copy_Tree (Expr), To => Constr_List);
+
+ Next_Elmt (C);
+ end loop;
+
+ New_Indic :=
+ Make_Subtype_Indication (Loc,
+ Subtype_Mark => New_Occurrence_Of (New_Base, Loc),
+ Constraint =>
+ Make_Index_Or_Discriminant_Constraint (Loc, Constr_List));
+ end;
+ end if;
+
+ Rewrite (N,
+ Make_Subtype_Declaration (Loc,
+ Defining_Identifier => Derived_Type,
+ Subtype_Indication => New_Indic));
+
+ Analyze (N);
+
+ -- Derivation of subprograms must be delayed until the
+ -- full subtype has been established to ensure proper
+ -- overriding of subprograms inherited by full types.
+ -- If the derivations occurred as part of the call to
+ -- Build_Derived_Type above, then the check for type
+ -- conformance would fail because earlier primitive
+ -- subprograms could still refer to the full type prior
+ -- the change to the new subtype and hence wouldn't
+ -- match the new base type created here.
+
+ Derive_Subprograms (Parent_Type, Derived_Type);
+
+ -- For tagged types the Discriminant_Constraint of the new base itype
+ -- is inherited from the first subtype so that no subtype conformance
+ -- problem arise when the first subtype overrides primitive
+ -- operations inherited by the implicit base type.
+
+ if Is_Tagged then
+ Set_Discriminant_Constraint
+ (New_Base, Discriminant_Constraint (Derived_Type));
+ end if;
+
+ return;
+ end if;
+
+ -- If we get here Derived_Type will have no discriminants or it will be
+ -- a discriminated unconstrained base type.
+
+ -- STEP 1a: perform preliminary actions/checks for derived tagged types
+
+ if Is_Tagged then
+ -- The parent type is frozen for non-private extensions (RM 13.14(7))
+
+ if not Private_Extension then
+ Freeze_Before (N, Parent_Type);
+ end if;
+
+ if Type_Access_Level (Derived_Type) /= Type_Access_Level (Parent_Type)
+ and then not Is_Generic_Type (Derived_Type)
+ then
+ if Is_Controlled (Parent_Type) then
+ Error_Msg_N
+ ("controlled type must be declared at the library level",
+ Indic);
+ else
+ Error_Msg_N
+ ("type extension at deeper accessibility level than parent",
+ Indic);
+ end if;
+
+ else
+ declare
+ GB : constant Node_Id := Enclosing_Generic_Body (Derived_Type);
+
+ begin
+ if Present (GB)
+ and then GB /= Enclosing_Generic_Body (Parent_Base)
+ then
+ Error_Msg_N
+ ("parent type must not be outside generic body",
+ Indic);
+ end if;
+ end;
+ end if;
+ end if;
+
+ -- STEP 1b : preliminary cleanup of the full view of private types
+
+ -- If the type is already marked as having discriminants, then it's the
+ -- completion of a private type or private extension and we need to
+ -- retain the discriminants from the partial view if the current
+ -- declaration has Discriminant_Specifications so that we can verify
+ -- conformance. However, we must remove any existing components that
+ -- were inherited from the parent (and attached in Copy_Private_To_Full)
+ -- because the full type inherits all appropriate components anyway, and
+ -- we don't want the partial view's components interfering.
+
+ if Has_Discriminants (Derived_Type) and then Discriminant_Specs then
+ Discrim := First_Discriminant (Derived_Type);
+ loop
+ Last_Discrim := Discrim;
+ Next_Discriminant (Discrim);
+ exit when No (Discrim);
+ end loop;
+
+ Set_Last_Entity (Derived_Type, Last_Discrim);
+
+ -- In all other cases wipe out the list of inherited components (even
+ -- inherited discriminants), it will be properly rebuilt here.
+
+ else
+ Set_First_Entity (Derived_Type, Empty);
+ Set_Last_Entity (Derived_Type, Empty);
+ end if;
+
+ -- STEP 1c: Initialize some flags for the Derived_Type
+
+ -- The following flags must be initialized here so that
+ -- Process_Discriminants can check that discriminants of tagged types
+ -- do not have a default initial value and that access discriminants
+ -- are only specified for limited records. For completeness, these
+ -- flags are also initialized along with all the other flags below.
+
+ Set_Is_Tagged_Type (Derived_Type, Is_Tagged);
+ Set_Is_Limited_Record (Derived_Type, Is_Limited_Record (Parent_Type));
+
+ -- STEP 2a: process discriminants of derived type if any.
+
+ New_Scope (Derived_Type);
+
+ if Discriminant_Specs then
+ Set_Has_Unknown_Discriminants (Derived_Type, False);
+
+ -- The following call initializes fields Has_Discriminants and
+ -- Discriminant_Constraint, unless we are processing the completion
+ -- of a private type declaration.
+
+ Check_Or_Process_Discriminants (N, Derived_Type);
+
+ -- For non-tagged types the constraint on the Parent_Type must be
+ -- present and is used to rename the discriminants.
+
+ if not Is_Tagged and then not Has_Discriminants (Parent_Type) then
+ Error_Msg_N ("untagged parent must have discriminants", Indic);
+
+ elsif not Is_Tagged and then not Constraint_Present then
+ Error_Msg_N
+ ("discriminant constraint needed for derived untagged records",
+ Indic);
+
+ -- Otherwise the parent subtype must be constrained unless we have a
+ -- private extension.
+
+ elsif not Constraint_Present
+ and then not Private_Extension
+ and then not Is_Constrained (Parent_Type)
+ then
+ Error_Msg_N
+ ("unconstrained type not allowed in this context", Indic);
+
+ elsif Constraint_Present then
+ -- The following call sets the field Corresponding_Discriminant
+ -- for the discriminants in the Derived_Type.
+
+ Discs := Build_Discriminant_Constraints (Parent_Type, Indic, True);
+
+ -- For untagged types all new discriminants must rename
+ -- discriminants in the parent. For private extensions new
+ -- discriminants cannot rename old ones (implied by [7.3(13)]).
+
+ Discrim := First_Discriminant (Derived_Type);
+
+ while Present (Discrim) loop
+ if not Is_Tagged
+ and then not Present (Corresponding_Discriminant (Discrim))
+ then
+ Error_Msg_N
+ ("new discriminants must constrain old ones", Discrim);
+
+ elsif Private_Extension
+ and then Present (Corresponding_Discriminant (Discrim))
+ then
+ Error_Msg_N
+ ("Only static constraints allowed for parent"
+ & " discriminants in the partial view", Indic);
+
+ exit;
+ end if;
+
+ -- If a new discriminant is used in the constraint,
+ -- then its subtype must be statically compatible
+ -- with the parent discriminant's subtype (3.7(15)).
+
+ if Present (Corresponding_Discriminant (Discrim))
+ and then
+ not Subtypes_Statically_Compatible
+ (Etype (Discrim),
+ Etype (Corresponding_Discriminant (Discrim)))
+ then
+ Error_Msg_N
+ ("subtype must be compatible with parent discriminant",
+ Discrim);
+ end if;
+
+ Next_Discriminant (Discrim);
+ end loop;
+ end if;
+
+ -- STEP 2b: No new discriminants, inherit discriminants if any
+
+ else
+ if Private_Extension then
+ Set_Has_Unknown_Discriminants
+ (Derived_Type, Has_Unknown_Discriminants (Parent_Type)
+ or else Unknown_Discriminants_Present (N));
+ else
+ Set_Has_Unknown_Discriminants
+ (Derived_Type, Has_Unknown_Discriminants (Parent_Type));
+ end if;
+
+ if not Has_Unknown_Discriminants (Derived_Type)
+ and then Has_Discriminants (Parent_Type)
+ then
+ Inherit_Discrims := True;
+ Set_Has_Discriminants
+ (Derived_Type, True);
+ Set_Discriminant_Constraint
+ (Derived_Type, Discriminant_Constraint (Parent_Base));
+ end if;
+
+ -- The following test is true for private types (remember
+ -- transformation 5. is not applied to those) and in an error
+ -- situation.
+
+ if Constraint_Present then
+ Discs := Build_Discriminant_Constraints (Parent_Type, Indic);
+ end if;
+
+ -- For now mark a new derived type as cosntrained only if it has no
+ -- discriminants. At the end of Build_Derived_Record_Type we properly
+ -- set this flag in the case of private extensions. See comments in
+ -- point 9. just before body of Build_Derived_Record_Type.
+
+ Set_Is_Constrained
+ (Derived_Type,
+ not (Inherit_Discrims
+ or else Has_Unknown_Discriminants (Derived_Type)));
+ end if;
+
+ -- STEP 3: initialize fields of derived type.
+
+ Set_Is_Tagged_Type (Derived_Type, Is_Tagged);
+ Set_Girder_Constraint (Derived_Type, No_Elist);
+
+ -- Fields inherited from the Parent_Type
+
+ Set_Discard_Names
+ (Derived_Type, Einfo.Discard_Names (Parent_Type));
+ Set_Has_Specified_Layout
+ (Derived_Type, Has_Specified_Layout (Parent_Type));
+ Set_Is_Limited_Composite
+ (Derived_Type, Is_Limited_Composite (Parent_Type));
+ Set_Is_Limited_Record
+ (Derived_Type, Is_Limited_Record (Parent_Type));
+ Set_Is_Private_Composite
+ (Derived_Type, Is_Private_Composite (Parent_Type));
+
+ -- Fields inherited from the Parent_Base
+
+ Set_Has_Controlled_Component
+ (Derived_Type, Has_Controlled_Component (Parent_Base));
+ Set_Has_Non_Standard_Rep
+ (Derived_Type, Has_Non_Standard_Rep (Parent_Base));
+ Set_Has_Primitive_Operations
+ (Derived_Type, Has_Primitive_Operations (Parent_Base));
+
+ -- Direct controlled types do not inherit the Finalize_Storage_Only
+ -- flag.
+
+ if not Is_Controlled (Parent_Type) then
+ Set_Finalize_Storage_Only (Derived_Type,
+ Finalize_Storage_Only (Parent_Type));
+ end if;
+
+ -- Set fields for private derived types.
+
+ if Is_Private_Type (Derived_Type) then
+ Set_Depends_On_Private (Derived_Type, True);
+ Set_Private_Dependents (Derived_Type, New_Elmt_List);
+
+ -- Inherit fields from non private record types. If this is the
+ -- completion of a derivation from a private type, the parent itself
+ -- is private, and the attributes come from its full view, which must
+ -- be present.
+
+ else
+ if Is_Private_Type (Parent_Base)
+ and then not Is_Record_Type (Parent_Base)
+ then
+ Set_Component_Alignment
+ (Derived_Type, Component_Alignment (Full_View (Parent_Base)));
+ Set_C_Pass_By_Copy
+ (Derived_Type, C_Pass_By_Copy (Full_View (Parent_Base)));
+ else
+ Set_Component_Alignment
+ (Derived_Type, Component_Alignment (Parent_Base));
+
+ Set_C_Pass_By_Copy
+ (Derived_Type, C_Pass_By_Copy (Parent_Base));
+ end if;
+ end if;
+
+ -- Set fields for tagged types.
+
+ if Is_Tagged then
+ Set_Primitive_Operations (Derived_Type, New_Elmt_List);
+
+ -- All tagged types defined in Ada.Finalization are controlled
+
+ if Chars (Scope (Derived_Type)) = Name_Finalization
+ and then Chars (Scope (Scope (Derived_Type))) = Name_Ada
+ and then Scope (Scope (Scope (Derived_Type))) = Standard_Standard
+ then
+ Set_Is_Controlled (Derived_Type);
+ else
+ Set_Is_Controlled (Derived_Type, Is_Controlled (Parent_Base));
+ end if;
+
+ Make_Class_Wide_Type (Derived_Type);
+ Set_Is_Abstract (Derived_Type, Abstract_Present (Type_Def));
+
+ if Has_Discriminants (Derived_Type)
+ and then Constraint_Present
+ then
+ Set_Girder_Constraint
+ (Derived_Type, Expand_To_Girder_Constraint (Parent_Base, Discs));
+ end if;
+
+ else
+ Set_Is_Packed (Derived_Type, Is_Packed (Parent_Base));
+ Set_Has_Non_Standard_Rep
+ (Derived_Type, Has_Non_Standard_Rep (Parent_Base));
+ end if;
+
+ -- STEP 4: Inherit components from the parent base and constrain them.
+ -- Apply the second transformation described in point 6. above.
+
+ if (not Is_Empty_Elmt_List (Discs) or else Inherit_Discrims)
+ or else not Has_Discriminants (Parent_Type)
+ or else not Is_Constrained (Parent_Type)
+ then
+ Constrs := Discs;
+ else
+ Constrs := Discriminant_Constraint (Parent_Type);
+ end if;
+
+ Assoc_List := Inherit_Components (N,
+ Parent_Base, Derived_Type, Is_Tagged, Inherit_Discrims, Constrs);
+
+ -- STEP 5a: Copy the parent record declaration for untagged types
+
+ if not Is_Tagged then
+
+ -- Discriminant_Constraint (Derived_Type) has been properly
+ -- constructed. Save it and temporarily set it to Empty because we do
+ -- not want the call to New_Copy_Tree below to mess this list.
+
+ if Has_Discriminants (Derived_Type) then
+ Save_Discr_Constr := Discriminant_Constraint (Derived_Type);
+ Set_Discriminant_Constraint (Derived_Type, No_Elist);
+ else
+ Save_Discr_Constr := No_Elist;
+ end if;
+
+ -- Save the Etype field of Derived_Type. It is correctly set now, but
+ -- the call to New_Copy tree may remap it to point to itself, which
+ -- is not what we want. Ditto for the Next_Entity field.
+
+ Save_Etype := Etype (Derived_Type);
+ Save_Next_Entity := Next_Entity (Derived_Type);
+
+ -- Assoc_List maps all girder discriminants in the Parent_Base to
+ -- girder discriminants in the Derived_Type. It is fundamental that
+ -- no types or itypes with discriminants other than the girder
+ -- discriminants appear in the entities declared inside
+ -- Derived_Type. Gigi won't like it.
+
+ New_Decl :=
+ New_Copy_Tree
+ (Parent (Parent_Base), Map => Assoc_List, New_Sloc => Loc);
+
+ -- Restore the fields saved prior to the New_Copy_Tree call
+ -- and compute the girder constraint.
+
+ Set_Etype (Derived_Type, Save_Etype);
+ Set_Next_Entity (Derived_Type, Save_Next_Entity);
+
+ if Has_Discriminants (Derived_Type) then
+ Set_Discriminant_Constraint
+ (Derived_Type, Save_Discr_Constr);
+ Set_Girder_Constraint
+ (Derived_Type, Expand_To_Girder_Constraint (Parent_Base, Discs));
+ end if;
+
+ -- Insert the new derived type declaration
+
+ Rewrite (N, New_Decl);
+
+ -- STEP 5b: Complete the processing for record extensions in generics
+
+ -- There is no completion for record extensions declared in the
+ -- parameter part of a generic, so we need to complete processing for
+ -- these generic record extensions here. The call to
+ -- Record_Type_Definition will change the Ekind of the components
+ -- from E_Void to E_Component.
+
+ elsif Private_Extension and then Is_Generic_Type (Derived_Type) then
+ Record_Type_Definition (Empty, Derived_Type);
+
+ -- STEP 5c: Process the record extension for non private tagged types.
+
+ elsif not Private_Extension then
+ -- Add the _parent field in the derived type.
+
+ Expand_Derived_Record (Derived_Type, Type_Def);
+
+ -- Analyze the record extension
+
+ Record_Type_Definition
+ (Record_Extension_Part (Type_Def), Derived_Type);
+ end if;
+
+ End_Scope;
+
+ if Etype (Derived_Type) = Any_Type then
+ return;
+ end if;
+
+ -- Set delayed freeze and then derive subprograms, we need to do
+ -- this in this order so that derived subprograms inherit the
+ -- derived freeze if necessary.
+
+ Set_Has_Delayed_Freeze (Derived_Type);
+ if Derive_Subps then
+ Derive_Subprograms (Parent_Type, Derived_Type);
+ end if;
+
+ -- If we have a private extension which defines a constrained derived
+ -- type mark as constrained here after we have derived subprograms. See
+ -- comment on point 9. just above the body of Build_Derived_Record_Type.
+
+ if Private_Extension and then Inherit_Discrims then
+ if Constraint_Present and then not Is_Empty_Elmt_List (Discs) then
+ Set_Is_Constrained (Derived_Type, True);
+ Set_Discriminant_Constraint (Derived_Type, Discs);
+
+ elsif Is_Constrained (Parent_Type) then
+ Set_Is_Constrained
+ (Derived_Type, True);
+ Set_Discriminant_Constraint
+ (Derived_Type, Discriminant_Constraint (Parent_Type));
+ end if;
+ end if;
+
+ end Build_Derived_Record_Type;
+
+ ------------------------
+ -- Build_Derived_Type --
+ ------------------------
+
+ procedure Build_Derived_Type
+ (N : Node_Id;
+ Parent_Type : Entity_Id;
+ Derived_Type : Entity_Id;
+ Is_Completion : Boolean;
+ Derive_Subps : Boolean := True)
+ is
+ Parent_Base : constant Entity_Id := Base_Type (Parent_Type);
+
+ begin
+ -- Set common attributes
+
+ Set_Scope (Derived_Type, Current_Scope);
+
+ Set_Ekind (Derived_Type, Ekind (Parent_Base));
+ Set_Etype (Derived_Type, Parent_Base);
+ Set_Has_Task (Derived_Type, Has_Task (Parent_Base));
+
+ Set_Size_Info (Derived_Type, Parent_Type);
+ Set_RM_Size (Derived_Type, RM_Size (Parent_Type));
+ Set_Convention (Derived_Type, Convention (Parent_Type));
+ Set_First_Rep_Item (Derived_Type, First_Rep_Item (Parent_Type));
+
+ case Ekind (Parent_Type) is
+ when Numeric_Kind =>
+ Build_Derived_Numeric_Type (N, Parent_Type, Derived_Type);
+
+ when Array_Kind =>
+ Build_Derived_Array_Type (N, Parent_Type, Derived_Type);
+
+ when E_Record_Type
+ | E_Record_Subtype
+ | Class_Wide_Kind =>
+ Build_Derived_Record_Type
+ (N, Parent_Type, Derived_Type, Derive_Subps);
+ return;
+
+ when Enumeration_Kind =>
+ Build_Derived_Enumeration_Type (N, Parent_Type, Derived_Type);
+
+ when Access_Kind =>
+ Build_Derived_Access_Type (N, Parent_Type, Derived_Type);
+
+ when Incomplete_Or_Private_Kind =>
+ Build_Derived_Private_Type
+ (N, Parent_Type, Derived_Type, Is_Completion, Derive_Subps);
+
+ -- For discriminated types, the derivation includes deriving
+ -- primitive operations. For others it is done below.
+
+ if Is_Tagged_Type (Parent_Type)
+ or else Has_Discriminants (Parent_Type)
+ or else (Present (Full_View (Parent_Type))
+ and then Has_Discriminants (Full_View (Parent_Type)))
+ then
+ return;
+ end if;
+
+ when Concurrent_Kind =>
+ Build_Derived_Concurrent_Type (N, Parent_Type, Derived_Type);
+
+ when others =>
+ raise Program_Error;
+ end case;
+
+ if Etype (Derived_Type) = Any_Type then
+ return;
+ end if;
+
+ -- Set delayed freeze and then derive subprograms, we need to do
+ -- this in this order so that derived subprograms inherit the
+ -- derived freeze if necessary.
+
+ Set_Has_Delayed_Freeze (Derived_Type);
+ if Derive_Subps then
+ Derive_Subprograms (Parent_Type, Derived_Type);
+ end if;
+
+ Set_Has_Primitive_Operations
+ (Base_Type (Derived_Type), Has_Primitive_Operations (Parent_Type));
+ end Build_Derived_Type;
+
+ -----------------------
+ -- Build_Discriminal --
+ -----------------------
+
+ procedure Build_Discriminal (Discrim : Entity_Id) is
+ D_Minal : Entity_Id;
+ CR_Disc : Entity_Id;
+
+ begin
+ -- A discriminal has the same names as the discriminant.
+
+ D_Minal := Make_Defining_Identifier (Sloc (Discrim), Chars (Discrim));
+
+ Set_Ekind (D_Minal, E_In_Parameter);
+ Set_Mechanism (D_Minal, Default_Mechanism);
+ Set_Etype (D_Minal, Etype (Discrim));
+
+ Set_Discriminal (Discrim, D_Minal);
+ Set_Discriminal_Link (D_Minal, Discrim);
+
+ -- For task types, build at once the discriminants of the corresponding
+ -- record, which are needed if discriminants are used in entry defaults
+ -- and in family bounds.
+
+ if Is_Concurrent_Type (Current_Scope)
+ or else Is_Limited_Type (Current_Scope)
+ then
+ CR_Disc := Make_Defining_Identifier (Sloc (Discrim), Chars (Discrim));
+
+ Set_Ekind (CR_Disc, E_In_Parameter);
+ Set_Mechanism (CR_Disc, Default_Mechanism);
+ Set_Etype (CR_Disc, Etype (Discrim));
+ Set_CR_Discriminant (Discrim, CR_Disc);
+ end if;
+ end Build_Discriminal;
+
+ ------------------------------------
+ -- Build_Discriminant_Constraints --
+ ------------------------------------
+
+ function Build_Discriminant_Constraints
+ (T : Entity_Id;
+ Def : Node_Id;
+ Derived_Def : Boolean := False)
+ return Elist_Id
+ is
+ C : constant Node_Id := Constraint (Def);
+ Nb_Discr : constant Nat := Number_Discriminants (T);
+ Discr_Expr : array (1 .. Nb_Discr) of Node_Id := (others => Empty);
+ -- Saves the expression corresponding to a given discriminant in T.
+
+ function Pos_Of_Discr (T : Entity_Id; D : Entity_Id) return Nat;
+ -- Return the Position number within array Discr_Expr of a discriminant
+ -- D within the discriminant list of the discriminated type T.
+
+ ------------------
+ -- Pos_Of_Discr --
+ ------------------
+
+ function Pos_Of_Discr (T : Entity_Id; D : Entity_Id) return Nat is
+ Disc : Entity_Id;
+
+ begin
+ Disc := First_Discriminant (T);
+ for J in Discr_Expr'Range loop
+ if Disc = D then
+ return J;
+ end if;
+
+ Next_Discriminant (Disc);
+ end loop;
+
+ -- Note: Since this function is called on discriminants that are
+ -- known to belong to the discriminated type, falling through the
+ -- loop with no match signals an internal compiler error.
+
+ raise Program_Error;
+ end Pos_Of_Discr;
+
+ -- Variables local to Build_Discriminant_Constraints
+
+ Discr : Entity_Id;
+ E : Entity_Id;
+ Elist : Elist_Id := New_Elmt_List;
+
+ Constr : Node_Id;
+ Expr : Node_Id;
+ Id : Node_Id;
+ Position : Nat;
+ Found : Boolean;
+
+ Discrim_Present : Boolean := False;
+
+ -- Start of processing for Build_Discriminant_Constraints
+
+ begin
+ -- The following loop will process positional associations only.
+ -- For a positional association, the (single) discriminant is
+ -- implicitly specified by position, in textual order (RM 3.7.2).
+
+ Discr := First_Discriminant (T);
+ Constr := First (Constraints (C));
+
+ for D in Discr_Expr'Range loop
+ exit when Nkind (Constr) = N_Discriminant_Association;
+
+ if No (Constr) then
+ Error_Msg_N ("too few discriminants given in constraint", C);
+ return New_Elmt_List;
+
+ elsif Nkind (Constr) = N_Range
+ or else (Nkind (Constr) = N_Attribute_Reference
+ and then
+ Attribute_Name (Constr) = Name_Range)
+ then
+ Error_Msg_N
+ ("a range is not a valid discriminant constraint", Constr);
+ Discr_Expr (D) := Error;
+
+ else
+ Analyze_And_Resolve (Constr, Base_Type (Etype (Discr)));
+ Discr_Expr (D) := Constr;
+ end if;
+
+ Next_Discriminant (Discr);
+ Next (Constr);
+ end loop;
+
+ if No (Discr) and then Present (Constr) then
+ Error_Msg_N ("too many discriminants given in constraint", Constr);
+ return New_Elmt_List;
+ end if;
+
+ -- Named associations can be given in any order, but if both positional
+ -- and named associations are used in the same discriminant constraint,
+ -- then positional associations must occur first, at their normal
+ -- position. Hence once a named association is used, the rest of the
+ -- discriminant constraint must use only named associations.
+
+ while Present (Constr) loop
+
+ -- Positional association forbidden after a named association.
+
+ if Nkind (Constr) /= N_Discriminant_Association then
+ Error_Msg_N ("positional association follows named one", Constr);
+ return New_Elmt_List;
+
+ -- Otherwise it is a named association
+
+ else
+ -- E records the type of the discriminants in the named
+ -- association. All the discriminants specified in the same name
+ -- association must have the same type.
+
+ E := Empty;
+
+ -- Search the list of discriminants in T to see if the simple name
+ -- given in the constraint matches any of them.
+
+ Id := First (Selector_Names (Constr));
+ while Present (Id) loop
+ Found := False;
+
+ -- If Original_Discriminant is present, we are processing a
+ -- generic instantiation and this is an instance node. We need
+ -- to find the name of the corresponding discriminant in the
+ -- actual record type T and not the name of the discriminant in
+ -- the generic formal. Example:
+ --
+ -- generic
+ -- type G (D : int) is private;
+ -- package P is
+ -- subtype W is G (D => 1);
+ -- end package;
+ -- type Rec (X : int) is record ... end record;
+ -- package Q is new P (G => Rec);
+ --
+ -- At the point of the instantiation, formal type G is Rec
+ -- and therefore when reanalyzing "subtype W is G (D => 1);"
+ -- which really looks like "subtype W is Rec (D => 1);" at
+ -- the point of instantiation, we want to find the discriminant
+ -- that corresponds to D in Rec, ie X.
+
+ if Present (Original_Discriminant (Id)) then
+ Discr := Find_Corresponding_Discriminant (Id, T);
+ Found := True;
+
+ else
+ Discr := First_Discriminant (T);
+ while Present (Discr) loop
+ if Chars (Discr) = Chars (Id) then
+ Found := True;
+ exit;
+ end if;
+
+ Next_Discriminant (Discr);
+ end loop;
+
+ if not Found then
+ Error_Msg_N ("& does not match any discriminant", Id);
+ return New_Elmt_List;
+
+ -- The following is only useful for the benefit of generic
+ -- instances but it does not interfere with other
+ -- processsing for the non-generic case so we do it in all
+ -- cases (for generics this statement is executed when
+ -- processing the generic definition, see comment at the
+ -- begining of this if statement).
+
+ else
+ Set_Original_Discriminant (Id, Discr);
+ end if;
+ end if;
+
+ Position := Pos_Of_Discr (T, Discr);
+
+ if Present (Discr_Expr (Position)) then
+ Error_Msg_N ("duplicate constraint for discriminant&", Id);
+
+ else
+ -- Each discriminant specified in the same named association
+ -- must be associated with a separate copy of the
+ -- corresponding expression.
+
+ if Present (Next (Id)) then
+ Expr := New_Copy_Tree (Expression (Constr));
+ Set_Parent (Expr, Parent (Expression (Constr)));
+ else
+ Expr := Expression (Constr);
+ end if;
+
+ Discr_Expr (Position) := Expr;
+ Analyze_And_Resolve (Expr, Base_Type (Etype (Discr)));
+ end if;
+
+ -- A discriminant association with more than one discriminant
+ -- name is only allowed if the named discriminants are all of
+ -- the same type (RM 3.7.1(8)).
+
+ if E = Empty then
+ E := Base_Type (Etype (Discr));
+
+ elsif Base_Type (Etype (Discr)) /= E then
+ Error_Msg_N
+ ("all discriminants in an association " &
+ "must have the same type", Id);
+ end if;
+
+ Next (Id);
+ end loop;
+ end if;
+
+ Next (Constr);
+ end loop;
+
+ -- A discriminant constraint must provide exactly one value for each
+ -- discriminant of the type (RM 3.7.1(8)).
+
+ for J in Discr_Expr'Range loop
+ if No (Discr_Expr (J)) then
+ Error_Msg_N ("too few discriminants given in constraint", C);
+ return New_Elmt_List;
+ end if;
+ end loop;
+
+ -- Determine if there are discriminant expressions in the constraint.
+
+ for J in Discr_Expr'Range loop
+ if Denotes_Discriminant (Discr_Expr (J)) then
+ Discrim_Present := True;
+ end if;
+ end loop;
+
+ -- Build an element list consisting of the expressions given in the
+ -- discriminant constraint and apply the appropriate range
+ -- checks. The list is constructed after resolving any named
+ -- discriminant associations and therefore the expressions appear in
+ -- the textual order of the discriminants.
+
+ Discr := First_Discriminant (T);
+ for J in Discr_Expr'Range loop
+ if Discr_Expr (J) /= Error then
+
+ Append_Elmt (Discr_Expr (J), Elist);
+
+ -- If any of the discriminant constraints is given by a
+ -- discriminant and we are in a derived type declaration we
+ -- have a discriminant renaming. Establish link between new
+ -- and old discriminant.
+
+ if Denotes_Discriminant (Discr_Expr (J)) then
+ if Derived_Def then
+ Set_Corresponding_Discriminant
+ (Entity (Discr_Expr (J)), Discr);
+ end if;
+
+ -- Force the evaluation of non-discriminant expressions.
+ -- If we have found a discriminant in the constraint 3.4(26)
+ -- and 3.8(18) demand that no range checks are performed are
+ -- after evaluation. In all other cases perform a range check.
+
+ else
+ if not Discrim_Present then
+ Apply_Range_Check (Discr_Expr (J), Etype (Discr));
+ end if;
+
+ Force_Evaluation (Discr_Expr (J));
+ end if;
+
+ -- Check that the designated type of an access discriminant's
+ -- expression is not a class-wide type unless the discriminant's
+ -- designated type is also class-wide.
+
+ if Ekind (Etype (Discr)) = E_Anonymous_Access_Type
+ and then not Is_Class_Wide_Type
+ (Designated_Type (Etype (Discr)))
+ and then Etype (Discr_Expr (J)) /= Any_Type
+ and then Is_Class_Wide_Type
+ (Designated_Type (Etype (Discr_Expr (J))))
+ then
+ Wrong_Type (Discr_Expr (J), Etype (Discr));
+ end if;
+ end if;
+
+ Next_Discriminant (Discr);
+ end loop;
+
+ return Elist;
+ end Build_Discriminant_Constraints;
+
+ ---------------------------------
+ -- Build_Discriminated_Subtype --
+ ---------------------------------
+
+ procedure Build_Discriminated_Subtype
+ (T : Entity_Id;
+ Def_Id : Entity_Id;
+ Elist : Elist_Id;
+ Related_Nod : Node_Id;
+ For_Access : Boolean := False)
+ is
+ Has_Discrs : constant Boolean := Has_Discriminants (T);
+ Constrained : constant Boolean
+ := (Has_Discrs and then not Is_Empty_Elmt_List (Elist))
+ or else Is_Constrained (T);
+
+ begin
+ if Ekind (T) = E_Record_Type then
+ if For_Access then
+ Set_Ekind (Def_Id, E_Private_Subtype);
+ Set_Is_For_Access_Subtype (Def_Id, True);
+ else
+ Set_Ekind (Def_Id, E_Record_Subtype);
+ end if;
+
+ elsif Ekind (T) = E_Task_Type then
+ Set_Ekind (Def_Id, E_Task_Subtype);
+
+ elsif Ekind (T) = E_Protected_Type then
+ Set_Ekind (Def_Id, E_Protected_Subtype);
+
+ elsif Is_Private_Type (T) then
+ Set_Ekind (Def_Id, Subtype_Kind (Ekind (T)));
+
+ elsif Is_Class_Wide_Type (T) then
+ Set_Ekind (Def_Id, E_Class_Wide_Subtype);
+
+ else
+ -- Incomplete type. Attach subtype to list of dependents, to be
+ -- completed with full view of parent type.
+
+ Set_Ekind (Def_Id, Ekind (T));
+ Append_Elmt (Def_Id, Private_Dependents (T));
+ end if;
+
+ Set_Etype (Def_Id, T);
+ Init_Size_Align (Def_Id);
+ Set_Has_Discriminants (Def_Id, Has_Discrs);
+ Set_Is_Constrained (Def_Id, Constrained);
+
+ Set_First_Entity (Def_Id, First_Entity (T));
+ Set_Last_Entity (Def_Id, Last_Entity (T));
+ Set_First_Rep_Item (Def_Id, First_Rep_Item (T));
+
+ if Is_Tagged_Type (T) then
+ Set_Is_Tagged_Type (Def_Id);
+ Make_Class_Wide_Type (Def_Id);
+ end if;
+
+ Set_Girder_Constraint (Def_Id, No_Elist);
+
+ if Has_Discrs then
+ Set_Discriminant_Constraint (Def_Id, Elist);
+ Set_Girder_Constraint_From_Discriminant_Constraint (Def_Id);
+ end if;
+
+ if Is_Tagged_Type (T) then
+ Set_Primitive_Operations (Def_Id, Primitive_Operations (T));
+ Set_Is_Abstract (Def_Id, Is_Abstract (T));
+ end if;
+
+ -- Subtypes introduced by component declarations do not need to be
+ -- marked as delayed, and do not get freeze nodes, because the semantics
+ -- verifies that the parents of the subtypes are frozen before the
+ -- enclosing record is frozen.
+
+ if not Is_Type (Scope (Def_Id)) then
+ Set_Depends_On_Private (Def_Id, Depends_On_Private (T));
+
+ if Is_Private_Type (T)
+ and then Present (Full_View (T))
+ then
+ Conditional_Delay (Def_Id, Full_View (T));
+ else
+ Conditional_Delay (Def_Id, T);
+ end if;
+ end if;
+
+ if Is_Record_Type (T) then
+ Set_Is_Limited_Record (Def_Id, Is_Limited_Record (T));
+
+ if Has_Discrs
+ and then not Is_Empty_Elmt_List (Elist)
+ and then not For_Access
+ then
+ Create_Constrained_Components (Def_Id, Related_Nod, T, Elist);
+ elsif not For_Access then
+ Set_Cloned_Subtype (Def_Id, T);
+ end if;
+ end if;
+
+ end Build_Discriminated_Subtype;
+
+ ------------------------
+ -- Build_Scalar_Bound --
+ ------------------------
+
+ function Build_Scalar_Bound
+ (Bound : Node_Id;
+ Par_T : Entity_Id;
+ Der_T : Entity_Id;
+ Loc : Source_Ptr)
+ return Node_Id
+ is
+ New_Bound : Entity_Id;
+
+ begin
+ -- Note: not clear why this is needed, how can the original bound
+ -- be unanalyzed at this point? and if it is, what business do we
+ -- have messing around with it? and why is the base type of the
+ -- parent type the right type for the resolution. It probably is
+ -- not! It is OK for the new bound we are creating, but not for
+ -- the old one??? Still if it never happens, no problem!
+
+ Analyze_And_Resolve (Bound, Base_Type (Par_T));
+
+ if Nkind (Bound) = N_Integer_Literal
+ or else Nkind (Bound) = N_Real_Literal
+ then
+ New_Bound := New_Copy (Bound);
+ Set_Etype (New_Bound, Der_T);
+ Set_Analyzed (New_Bound);
+
+ elsif Is_Entity_Name (Bound) then
+ New_Bound := OK_Convert_To (Der_T, New_Copy (Bound));
+
+ -- The following is almost certainly wrong. What business do we have
+ -- relocating a node (Bound) that is presumably still attached to
+ -- the tree elsewhere???
+
+ else
+ New_Bound := OK_Convert_To (Der_T, Relocate_Node (Bound));
+ end if;
+
+ Set_Etype (New_Bound, Der_T);
+ return New_Bound;
+ end Build_Scalar_Bound;
+
+ --------------------------------
+ -- Build_Underlying_Full_View --
+ --------------------------------
+
+ procedure Build_Underlying_Full_View
+ (N : Node_Id;
+ Typ : Entity_Id;
+ Par : Entity_Id)
+ is
+ Loc : constant Source_Ptr := Sloc (N);
+ Subt : constant Entity_Id :=
+ Make_Defining_Identifier
+ (Loc, New_External_Name (Chars (Typ), 'S'));
+
+ Constr : Node_Id;
+ Indic : Node_Id;
+ C : Node_Id;
+ Id : Node_Id;
+
+ begin
+ if Nkind (N) = N_Full_Type_Declaration then
+ Constr := Constraint (Subtype_Indication (Type_Definition (N)));
+
+ -- ??? ??? is this assert right, I assume so otherwise Constr
+ -- would not be defined below (this used to be an elsif)
+
+ else pragma Assert (Nkind (N) = N_Subtype_Declaration);
+ Constr := New_Copy_Tree (Constraint (Subtype_Indication (N)));
+ end if;
+
+ -- If the constraint has discriminant associations, the discriminant
+ -- entity is already set, but it denotes a discriminant of the new
+ -- type, not the original parent, so it must be found anew.
+
+ C := First (Constraints (Constr));
+
+ while Present (C) loop
+
+ if Nkind (C) = N_Discriminant_Association then
+ Id := First (Selector_Names (C));
+
+ while Present (Id) loop
+ Set_Original_Discriminant (Id, Empty);
+ Next (Id);
+ end loop;
+ end if;
+
+ Next (C);
+ end loop;
+
+ Indic := Make_Subtype_Declaration (Loc,
+ Defining_Identifier => Subt,
+ Subtype_Indication =>
+ Make_Subtype_Indication (Loc,
+ Subtype_Mark => New_Reference_To (Par, Loc),
+ Constraint => New_Copy_Tree (Constr)));
+
+ Insert_Before (N, Indic);
+ Analyze (Indic);
+ Set_Underlying_Full_View (Typ, Full_View (Subt));
+ end Build_Underlying_Full_View;
+
+ -------------------------------
+ -- Check_Abstract_Overriding --
+ -------------------------------
+
+ procedure Check_Abstract_Overriding (T : Entity_Id) is
+ Op_List : Elist_Id;
+ Elmt : Elmt_Id;
+ Subp : Entity_Id;
+ Type_Def : Node_Id;
+
+ begin
+ Op_List := Primitive_Operations (T);
+
+ -- Loop to check primitive operations
+
+ Elmt := First_Elmt (Op_List);
+ while Present (Elmt) loop
+ Subp := Node (Elmt);
+
+ -- Special exception, do not complain about failure to
+ -- override _Input and _Output, since we always provide
+ -- automatic overridings for these subprograms.
+
+ if Is_Abstract (Subp)
+ and then Chars (Subp) /= Name_uInput
+ and then Chars (Subp) /= Name_uOutput
+ and then not Is_Abstract (T)
+ then
+ if Present (Alias (Subp)) then
+ -- Only perform the check for a derived subprogram when
+ -- the type has an explicit record extension. This avoids
+ -- incorrectly flagging abstract subprograms for the case
+ -- of a type without an extension derived from a formal type
+ -- with a tagged actual (can occur within a private part).
+
+ Type_Def := Type_Definition (Parent (T));
+ if Nkind (Type_Def) = N_Derived_Type_Definition
+ and then Present (Record_Extension_Part (Type_Def))
+ then
+ Error_Msg_NE
+ ("type must be declared abstract or & overridden",
+ T, Subp);
+ end if;
+ else
+ Error_Msg_NE
+ ("abstract subprogram not allowed for type&",
+ Subp, T);
+ Error_Msg_NE
+ ("nonabstract type has abstract subprogram&",
+ T, Subp);
+ end if;
+ end if;
+
+ Next_Elmt (Elmt);
+ end loop;
+ end Check_Abstract_Overriding;
+
+ ------------------------------------------------
+ -- Check_Access_Discriminant_Requires_Limited --
+ ------------------------------------------------
+
+ procedure Check_Access_Discriminant_Requires_Limited
+ (D : Node_Id;
+ Loc : Node_Id)
+ is
+ begin
+ -- A discriminant_specification for an access discriminant
+ -- shall appear only in the declaration for a task or protected
+ -- type, or for a type with the reserved word 'limited' in
+ -- its definition or in one of its ancestors. (RM 3.7(10))
+
+ if Nkind (Discriminant_Type (D)) = N_Access_Definition
+ and then not Is_Concurrent_Type (Current_Scope)
+ and then not Is_Concurrent_Record_Type (Current_Scope)
+ and then not Is_Limited_Record (Current_Scope)
+ and then Ekind (Current_Scope) /= E_Limited_Private_Type
+ then
+ Error_Msg_N
+ ("access discriminants allowed only for limited types", Loc);
+ end if;
+ end Check_Access_Discriminant_Requires_Limited;
+
+ -----------------------------------
+ -- Check_Aliased_Component_Types --
+ -----------------------------------
+
+ procedure Check_Aliased_Component_Types (T : Entity_Id) is
+ C : Entity_Id;
+
+ begin
+ -- ??? Also need to check components of record extensions,
+ -- but not components of protected types (which are always
+ -- limited).
+
+ if not Is_Limited_Type (T) then
+ if Ekind (T) = E_Record_Type then
+ C := First_Component (T);
+ while Present (C) loop
+ if Is_Aliased (C)
+ and then Has_Discriminants (Etype (C))
+ and then not Is_Constrained (Etype (C))
+ and then not In_Instance
+ then
+ Error_Msg_N
+ ("aliased component must be constrained ('R'M 3.6(11))",
+ C);
+ end if;
+
+ Next_Component (C);
+ end loop;
+
+ elsif Ekind (T) = E_Array_Type then
+ if Has_Aliased_Components (T)
+ and then Has_Discriminants (Component_Type (T))
+ and then not Is_Constrained (Component_Type (T))
+ and then not In_Instance
+ then
+ Error_Msg_N
+ ("aliased component type must be constrained ('R'M 3.6(11))",
+ T);
+ end if;
+ end if;
+ end if;
+ end Check_Aliased_Component_Types;
+
+ ----------------------
+ -- Check_Completion --
+ ----------------------
+
+ procedure Check_Completion (Body_Id : Node_Id := Empty) is
+ E : Entity_Id;
+
+ procedure Post_Error;
+ -- Post error message for lack of completion for entity E
+
+ procedure Post_Error is
+ begin
+ if not Comes_From_Source (E) then
+
+ if (Ekind (E) = E_Task_Type
+ or else Ekind (E) = E_Protected_Type)
+ then
+ -- It may be an anonymous protected type created for a
+ -- single variable. Post error on variable, if present.
+
+ declare
+ Var : Entity_Id;
+
+ begin
+ Var := First_Entity (Current_Scope);
+
+ while Present (Var) loop
+ exit when Etype (Var) = E
+ and then Comes_From_Source (Var);
+
+ Next_Entity (Var);
+ end loop;
+
+ if Present (Var) then
+ E := Var;
+ end if;
+ end;
+ end if;
+ end if;
+
+ -- If a generated entity has no completion, then either previous
+ -- semantic errors have disabled the expansion phase, or else
+ -- we had missing subunits, or else we are compiling without expan-
+ -- sion, or else something is very wrong.
+
+ if not Comes_From_Source (E) then
+ pragma Assert
+ (Errors_Detected > 0
+ or else Subunits_Missing
+ or else not Expander_Active);
+ return;
+
+ -- Here for source entity
+
+ else
+ -- Here if no body to post the error message, so we post the error
+ -- on the declaration that has no completion. This is not really
+ -- the right place to post it, think about this later ???
+
+ if No (Body_Id) then
+ if Is_Type (E) then
+ Error_Msg_NE
+ ("missing full declaration for }", Parent (E), E);
+ else
+ Error_Msg_NE
+ ("missing body for &", Parent (E), E);
+ end if;
+
+ -- Package body has no completion for a declaration that appears
+ -- in the corresponding spec. Post error on the body, with a
+ -- reference to the non-completed declaration.
+
+ else
+ Error_Msg_Sloc := Sloc (E);
+
+ if Is_Type (E) then
+ Error_Msg_NE
+ ("missing full declaration for }!", Body_Id, E);
+
+ elsif Is_Overloadable (E)
+ and then Current_Entity_In_Scope (E) /= E
+ then
+ -- It may be that the completion is mistyped and appears
+ -- as a distinct overloading of the entity.
+
+ declare
+ Candidate : Entity_Id := Current_Entity_In_Scope (E);
+ Decl : Node_Id := Unit_Declaration_Node (Candidate);
+
+ begin
+ if Is_Overloadable (Candidate)
+ and then Ekind (Candidate) = Ekind (E)
+ and then Nkind (Decl) = N_Subprogram_Body
+ and then Acts_As_Spec (Decl)
+ then
+ Check_Type_Conformant (Candidate, E);
+
+ else
+ Error_Msg_NE ("missing body for & declared#!",
+ Body_Id, E);
+ end if;
+ end;
+ else
+ Error_Msg_NE ("missing body for & declared#!",
+ Body_Id, E);
+ end if;
+ end if;
+ end if;
+ end Post_Error;
+
+ -- Start processing for Check_Completion
+
+ begin
+ E := First_Entity (Current_Scope);
+ while Present (E) loop
+ if Is_Intrinsic_Subprogram (E) then
+ null;
+
+ -- The following situation requires special handling: a child
+ -- unit that appears in the context clause of the body of its
+ -- parent:
+
+ -- procedure Parent.Child (...);
+ --
+ -- with Parent.Child;
+ -- package body Parent is
+
+ -- Here Parent.Child appears as a local entity, but should not
+ -- be flagged as requiring completion, because it is a
+ -- compilation unit.
+
+ elsif Ekind (E) = E_Function
+ or else Ekind (E) = E_Procedure
+ or else Ekind (E) = E_Generic_Function
+ or else Ekind (E) = E_Generic_Procedure
+ then
+ if not Has_Completion (E)
+ and then not Is_Abstract (E)
+ and then Nkind (Parent (Unit_Declaration_Node (E))) /=
+ N_Compilation_Unit
+ and then Chars (E) /= Name_uSize
+ then
+ Post_Error;
+ end if;
+
+ elsif Is_Entry (E) then
+ if not Has_Completion (E) and then
+ (Ekind (Scope (E)) = E_Protected_Object
+ or else Ekind (Scope (E)) = E_Protected_Type)
+ then
+ Post_Error;
+ end if;
+
+ elsif Is_Package (E) then
+ if Unit_Requires_Body (E) then
+ if not Has_Completion (E)
+ and then Nkind (Parent (Unit_Declaration_Node (E))) /=
+ N_Compilation_Unit
+ then
+ Post_Error;
+ end if;
+
+ elsif not Is_Child_Unit (E) then
+ May_Need_Implicit_Body (E);
+ end if;
+
+ elsif Ekind (E) = E_Incomplete_Type
+ and then No (Underlying_Type (E))
+ then
+ Post_Error;
+
+ elsif (Ekind (E) = E_Task_Type or else
+ Ekind (E) = E_Protected_Type)
+ and then not Has_Completion (E)
+ then
+ Post_Error;
+
+ elsif Ekind (E) = E_Constant
+ and then Ekind (Etype (E)) = E_Task_Type
+ and then not Has_Completion (Etype (E))
+ then
+ Post_Error;
+
+ elsif Ekind (E) = E_Protected_Object
+ and then not Has_Completion (Etype (E))
+ then
+ Post_Error;
+
+ elsif Ekind (E) = E_Record_Type then
+ if Is_Tagged_Type (E) then
+ Check_Abstract_Overriding (E);
+ end if;
+
+ Check_Aliased_Component_Types (E);
+
+ elsif Ekind (E) = E_Array_Type then
+ Check_Aliased_Component_Types (E);
+
+ end if;
+
+ Next_Entity (E);
+ end loop;
+ end Check_Completion;
+
+ ----------------------------
+ -- Check_Delta_Expression --
+ ----------------------------
+
+ procedure Check_Delta_Expression (E : Node_Id) is
+ begin
+ if not (Is_Real_Type (Etype (E))) then
+ Wrong_Type (E, Any_Real);
+
+ elsif not Is_OK_Static_Expression (E) then
+ Error_Msg_N ("non-static expression used for delta value", E);
+
+ elsif not UR_Is_Positive (Expr_Value_R (E)) then
+ Error_Msg_N ("delta expression must be positive", E);
+
+ else
+ return;
+ end if;
+
+ -- If any of above errors occurred, then replace the incorrect
+ -- expression by the real 0.1, which should prevent further errors.
+
+ Rewrite (E,
+ Make_Real_Literal (Sloc (E), Ureal_Tenth));
+ Analyze_And_Resolve (E, Standard_Float);
+
+ end Check_Delta_Expression;
+
+ -----------------------------
+ -- Check_Digits_Expression --
+ -----------------------------
+
+ procedure Check_Digits_Expression (E : Node_Id) is
+ begin
+ if not (Is_Integer_Type (Etype (E))) then
+ Wrong_Type (E, Any_Integer);
+
+ elsif not Is_OK_Static_Expression (E) then
+ Error_Msg_N ("non-static expression used for digits value", E);
+
+ elsif Expr_Value (E) <= 0 then
+ Error_Msg_N ("digits value must be greater than zero", E);
+
+ else
+ return;
+ end if;
+
+ -- If any of above errors occurred, then replace the incorrect
+ -- expression by the integer 1, which should prevent further errors.
+
+ Rewrite (E, Make_Integer_Literal (Sloc (E), 1));
+ Analyze_And_Resolve (E, Standard_Integer);
+
+ end Check_Digits_Expression;
+
+ ----------------------
+ -- Check_Incomplete --
+ ----------------------
+
+ procedure Check_Incomplete (T : Entity_Id) is
+ begin
+ if Ekind (Root_Type (Entity (T))) = E_Incomplete_Type then
+ Error_Msg_N ("invalid use of type before its full declaration", T);
+ end if;
+ end Check_Incomplete;
+
+ --------------------------
+ -- Check_Initialization --
+ --------------------------
+
+ procedure Check_Initialization (T : Entity_Id; Exp : Node_Id) is
+ begin
+ if (Is_Limited_Type (T)
+ or else Is_Limited_Composite (T))
+ and then not In_Instance
+ then
+ Error_Msg_N
+ ("cannot initialize entities of limited type", Exp);
+ end if;
+ end Check_Initialization;
+
+ ------------------------------------
+ -- Check_Or_Process_Discriminants --
+ ------------------------------------
+
+ -- If an incomplete or private type declaration was already given for
+ -- the type, the discriminants may have already been processed if they
+ -- were present on the incomplete declaration. In this case a full
+ -- conformance check is performed otherwise just process them.
+
+ procedure Check_Or_Process_Discriminants (N : Node_Id; T : Entity_Id) is
+ begin
+ if Has_Discriminants (T) then
+
+ -- Make the discriminants visible to component declarations.
+
+ declare
+ D : Entity_Id := First_Discriminant (T);
+ Prev : Entity_Id;
+
+ begin
+ while Present (D) loop
+ Prev := Current_Entity (D);
+ Set_Current_Entity (D);
+ Set_Is_Immediately_Visible (D);
+ Set_Homonym (D, Prev);
+
+ -- This restriction gets applied to the full type here; it
+ -- has already been applied earlier to the partial view
+
+ Check_Access_Discriminant_Requires_Limited (Parent (D), N);
+
+ Next_Discriminant (D);
+ end loop;
+ end;
+
+ elsif Present (Discriminant_Specifications (N)) then
+ Process_Discriminants (N);
+ end if;
+ end Check_Or_Process_Discriminants;
+
+ ----------------------
+ -- Check_Real_Bound --
+ ----------------------
+
+ procedure Check_Real_Bound (Bound : Node_Id) is
+ begin
+ if not Is_Real_Type (Etype (Bound)) then
+ Error_Msg_N
+ ("bound in real type definition must be of real type", Bound);
+
+ elsif not Is_OK_Static_Expression (Bound) then
+ Error_Msg_N
+ ("non-static expression used for real type bound", Bound);
+
+ else
+ return;
+ end if;
+
+ Rewrite
+ (Bound, Make_Real_Literal (Sloc (Bound), Ureal_0));
+ Analyze (Bound);
+ Resolve (Bound, Standard_Float);
+ end Check_Real_Bound;
+
+ ------------------------------
+ -- Complete_Private_Subtype --
+ ------------------------------
+
+ procedure Complete_Private_Subtype
+ (Priv : Entity_Id;
+ Full : Entity_Id;
+ Full_Base : Entity_Id;
+ Related_Nod : Node_Id)
+ is
+ Save_Next_Entity : Entity_Id;
+ Save_Homonym : Entity_Id;
+
+ begin
+ -- Set semantic attributes for (implicit) private subtype completion.
+ -- If the full type has no discriminants, then it is a copy of the full
+ -- view of the base. Otherwise, it is a subtype of the base with a
+ -- possible discriminant constraint. Save and restore the original
+ -- Next_Entity field of full to ensure that the calls to Copy_Node
+ -- do not corrupt the entity chain.
+
+ -- Note that the type of the full view is the same entity as the
+ -- type of the partial view. In this fashion, the subtype has
+ -- access to the correct view of the parent.
+
+ Save_Next_Entity := Next_Entity (Full);
+ Save_Homonym := Homonym (Priv);
+
+ case Ekind (Full_Base) is
+
+ when E_Record_Type |
+ E_Record_Subtype |
+ Class_Wide_Kind |
+ Private_Kind |
+ Task_Kind |
+ Protected_Kind =>
+ Copy_Node (Priv, Full);
+
+ Set_Has_Discriminants (Full, Has_Discriminants (Full_Base));
+ Set_First_Entity (Full, First_Entity (Full_Base));
+ Set_Last_Entity (Full, Last_Entity (Full_Base));
+
+ when others =>
+ Copy_Node (Full_Base, Full);
+ Set_Chars (Full, Chars (Priv));
+ Conditional_Delay (Full, Priv);
+ Set_Sloc (Full, Sloc (Priv));
+
+ end case;
+
+ Set_Next_Entity (Full, Save_Next_Entity);
+ Set_Homonym (Full, Save_Homonym);
+ Set_Associated_Node_For_Itype (Full, Related_Nod);
+
+ -- Set common attributes for all subtypes.
+
+ Set_Ekind (Full, Subtype_Kind (Ekind (Full_Base)));
+
+ -- The Etype of the full view is inconsistent. Gigi needs to see the
+ -- structural full view, which is what the current scheme gives:
+ -- the Etype of the full view is the etype of the full base. However,
+ -- if the full base is a derived type, the full view then looks like
+ -- a subtype of the parent, not a subtype of the full base. If instead
+ -- we write:
+
+ -- Set_Etype (Full, Full_Base);
+
+ -- then we get inconsistencies in the front-end (confusion between
+ -- views). Several outstanding bugs are related to this.
+
+ Set_Is_First_Subtype (Full, False);
+ Set_Scope (Full, Scope (Priv));
+ Set_Size_Info (Full, Full_Base);
+ Set_RM_Size (Full, RM_Size (Full_Base));
+ Set_Is_Itype (Full);
+
+ -- A subtype of a private-type-without-discriminants, whose full-view
+ -- has discriminants with default expressions, is not constrained!
+
+ if not Has_Discriminants (Priv) then
+ Set_Is_Constrained (Full, Is_Constrained (Full_Base));
+ end if;
+
+ Set_First_Rep_Item (Full, First_Rep_Item (Full_Base));
+ Set_Depends_On_Private (Full, Has_Private_Component (Full));
+
+ -- Freeze the private subtype entity if its parent is delayed,
+ -- and not already frozen. We skip this processing if the type
+ -- is an anonymous subtype of a record component, or is the
+ -- corresponding record of a protected type, since ???
+
+ if not Is_Type (Scope (Full)) then
+ Set_Has_Delayed_Freeze (Full,
+ Has_Delayed_Freeze (Full_Base)
+ and then (not Is_Frozen (Full_Base)));
+ end if;
+
+ Set_Freeze_Node (Full, Empty);
+ Set_Is_Frozen (Full, False);
+ Set_Full_View (Priv, Full);
+
+ if Has_Discriminants (Full) then
+ Set_Girder_Constraint_From_Discriminant_Constraint (Full);
+ Set_Girder_Constraint (Priv, Girder_Constraint (Full));
+ if Has_Unknown_Discriminants (Full) then
+ Set_Discriminant_Constraint (Full, No_Elist);
+ end if;
+ end if;
+
+ if Ekind (Full_Base) = E_Record_Type
+ and then Has_Discriminants (Full_Base)
+ and then Has_Discriminants (Priv) -- might not, if errors
+ and then not Is_Empty_Elmt_List (Discriminant_Constraint (Priv))
+ then
+ Create_Constrained_Components
+ (Full, Related_Nod, Full_Base, Discriminant_Constraint (Priv));
+
+ -- If the full base is itself derived from private, build a congruent
+ -- subtype of its underlying type, for use by the back end.
+
+ elsif Ekind (Full_Base) in Private_Kind
+ and then Is_Derived_Type (Full_Base)
+ and then Has_Discriminants (Full_Base)
+ and then
+ Nkind (Subtype_Indication (Parent (Priv))) = N_Subtype_Indication
+ then
+ Build_Underlying_Full_View (Parent (Priv), Full, Etype (Full_Base));
+
+ elsif Is_Record_Type (Full_Base) then
+
+ -- Show Full is simply a renaming of Full_Base.
+
+ Set_Cloned_Subtype (Full, Full_Base);
+ end if;
+
+ -- It is usafe to share to bounds of a scalar type, because the
+ -- Itype is elaborated on demand, and if a bound is non-static
+ -- then different orders of elaboration in different units will
+ -- lead to different external symbols.
+
+ if Is_Scalar_Type (Full_Base) then
+ Set_Scalar_Range (Full,
+ Make_Range (Sloc (Related_Nod),
+ Low_Bound => Duplicate_Subexpr (Type_Low_Bound (Full_Base)),
+ High_Bound => Duplicate_Subexpr (Type_High_Bound (Full_Base))));
+ end if;
+
+ -- ??? It seems that a lot of fields are missing that should be
+ -- copied from Full_Base to Full. Here are some that are introduced
+ -- in a non-disruptive way but a cleanup is necessary.
+
+ if Is_Tagged_Type (Full_Base) then
+ Set_Is_Tagged_Type (Full);
+ Set_Primitive_Operations (Full, Primitive_Operations (Full_Base));
+
+ elsif Is_Concurrent_Type (Full_Base) then
+
+ if Has_Discriminants (Full)
+ and then Present (Corresponding_Record_Type (Full_Base))
+ then
+ Set_Corresponding_Record_Type (Full,
+ Constrain_Corresponding_Record
+ (Full, Corresponding_Record_Type (Full_Base),
+ Related_Nod, Full_Base));
+
+ else
+ Set_Corresponding_Record_Type (Full,
+ Corresponding_Record_Type (Full_Base));
+ end if;
+ end if;
+
+ end Complete_Private_Subtype;
+
+ ----------------------------
+ -- Constant_Redeclaration --
+ ----------------------------
+
+ procedure Constant_Redeclaration
+ (Id : Entity_Id;
+ N : Node_Id;
+ T : out Entity_Id)
+ is
+ Prev : constant Entity_Id := Current_Entity_In_Scope (Id);
+ Obj_Def : constant Node_Id := Object_Definition (N);
+ New_T : Entity_Id;
+
+ begin
+ if Nkind (Parent (Prev)) = N_Object_Declaration then
+ if Nkind (Object_Definition
+ (Parent (Prev))) = N_Subtype_Indication
+ then
+ -- Find type of new declaration. The constraints of the two
+ -- views must match statically, but there is no point in
+ -- creating an itype for the full view.
+
+ if Nkind (Obj_Def) = N_Subtype_Indication then
+ Find_Type (Subtype_Mark (Obj_Def));
+ New_T := Entity (Subtype_Mark (Obj_Def));
+
+ else
+ Find_Type (Obj_Def);
+ New_T := Entity (Obj_Def);
+ end if;
+
+ T := Etype (Prev);
+
+ else
+ -- The full view may impose a constraint, even if the partial
+ -- view does not, so construct the subtype.
+
+ New_T := Find_Type_Of_Object (Obj_Def, N);
+ T := New_T;
+ end if;
+
+ else
+ -- Current declaration is illegal, diagnosed below in Enter_Name.
+
+ T := Empty;
+ New_T := Any_Type;
+ end if;
+
+ -- If previous full declaration exists, or if a homograph is present,
+ -- let Enter_Name handle it, either with an error, or with the removal
+ -- of an overridden implicit subprogram.
+
+ if Ekind (Prev) /= E_Constant
+ or else Present (Expression (Parent (Prev)))
+ then
+ Enter_Name (Id);
+
+ -- Verify that types of both declarations match.
+
+ elsif Base_Type (Etype (Prev)) /= Base_Type (New_T) then
+ Error_Msg_Sloc := Sloc (Prev);
+ Error_Msg_N ("type does not match declaration#", N);
+ Set_Full_View (Prev, Id);
+ Set_Etype (Id, Any_Type);
+
+ -- If so, process the full constant declaration
+
+ else
+ Set_Full_View (Prev, Id);
+ Set_Is_Public (Id, Is_Public (Prev));
+ Set_Is_Internal (Id);
+ Append_Entity (Id, Current_Scope);
+
+ -- Check ALIASED present if present before (RM 7.4(7))
+
+ if Is_Aliased (Prev)
+ and then not Aliased_Present (N)
+ then
+ Error_Msg_Sloc := Sloc (Prev);
+ Error_Msg_N ("ALIASED required (see declaration#)", N);
+ end if;
+
+ -- Check that placement is in private part
+
+ if Ekind (Current_Scope) = E_Package
+ and then not In_Private_Part (Current_Scope)
+ then
+ Error_Msg_Sloc := Sloc (Prev);
+ Error_Msg_N ("full constant for declaration#"
+ & " must be in private part", N);
+ end if;
+ end if;
+ end Constant_Redeclaration;
+
+ ----------------------
+ -- Constrain_Access --
+ ----------------------
+
+ procedure Constrain_Access
+ (Def_Id : in out Entity_Id;
+ S : Node_Id;
+ Related_Nod : Node_Id)
+ is
+ T : constant Entity_Id := Entity (Subtype_Mark (S));
+ Desig_Type : constant Entity_Id := Designated_Type (T);
+ Desig_Subtype : Entity_Id := Create_Itype (E_Void, Related_Nod);
+ Constraint_OK : Boolean := True;
+
+ begin
+ if Is_Array_Type (Desig_Type) then
+ Constrain_Array (Desig_Subtype, S, Related_Nod, Def_Id, 'P');
+
+ elsif (Is_Record_Type (Desig_Type)
+ or else Is_Incomplete_Or_Private_Type (Desig_Type))
+ and then not Is_Constrained (Desig_Type)
+ then
+ -- ??? The following code is a temporary kludge to ignore
+ -- discriminant constraint on access type if
+ -- it is constraining the current record. Avoid creating the
+ -- implicit subtype of the record we are currently compiling
+ -- since right now, we cannot handle these.
+ -- For now, just return the access type itself.
+
+ if Desig_Type = Current_Scope
+ and then No (Def_Id)
+ then
+ Set_Ekind (Desig_Subtype, E_Record_Subtype);
+ Def_Id := Entity (Subtype_Mark (S));
+
+ -- This call added to ensure that the constraint is
+ -- analyzed (needed for a B test). Note that we
+ -- still return early from this procedure to avoid
+ -- recursive processing. ???
+
+ Constrain_Discriminated_Type
+ (Desig_Subtype, S, Related_Nod, For_Access => True);
+
+ return;
+ end if;
+
+ Constrain_Discriminated_Type (Desig_Subtype, S, Related_Nod,
+ For_Access => True);
+
+ elsif (Is_Task_Type (Desig_Type)
+ or else Is_Protected_Type (Desig_Type))
+ and then not Is_Constrained (Desig_Type)
+ then
+ Constrain_Concurrent
+ (Desig_Subtype, S, Related_Nod, Desig_Type, ' ');
+
+ else
+ Error_Msg_N ("invalid constraint on access type", S);
+ Desig_Subtype := Desig_Type; -- Ignore invalid constraint.
+ Constraint_OK := False;
+ end if;
+
+ if No (Def_Id) then
+ Def_Id := Create_Itype (E_Access_Subtype, Related_Nod);
+ else
+ Set_Ekind (Def_Id, E_Access_Subtype);
+ end if;
+
+ if Constraint_OK then
+ Set_Etype (Def_Id, Base_Type (T));
+
+ if Is_Private_Type (Desig_Type) then
+ Prepare_Private_Subtype_Completion (Desig_Subtype, Related_Nod);
+ end if;
+ else
+ Set_Etype (Def_Id, Any_Type);
+ end if;
+
+ Set_Size_Info (Def_Id, T);
+ Set_Is_Constrained (Def_Id, Constraint_OK);
+ Set_Directly_Designated_Type (Def_Id, Desig_Subtype);
+ Set_Depends_On_Private (Def_Id, Has_Private_Component (Def_Id));
+ Set_Is_Access_Constant (Def_Id, Is_Access_Constant (T));
+
+ -- Itypes created for constrained record components do not receive
+ -- a freeze node, they are elaborated when first seen.
+
+ if not Is_Record_Type (Current_Scope) then
+ Conditional_Delay (Def_Id, T);
+ end if;
+ end Constrain_Access;
+
+ ---------------------
+ -- Constrain_Array --
+ ---------------------
+
+ procedure Constrain_Array
+ (Def_Id : in out Entity_Id;
+ SI : Node_Id;
+ Related_Nod : Node_Id;
+ Related_Id : Entity_Id;
+ Suffix : Character)
+ is
+ C : constant Node_Id := Constraint (SI);
+ Number_Of_Constraints : Nat := 0;
+ Index : Node_Id;
+ S, T : Entity_Id;
+ Constraint_OK : Boolean := True;
+
+ begin
+ T := Entity (Subtype_Mark (SI));
+
+ if Ekind (T) in Access_Kind then
+ T := Designated_Type (T);
+ end if;
+
+ -- If an index constraint follows a subtype mark in a subtype indication
+ -- then the type or subtype denoted by the subtype mark must not already
+ -- impose an index constraint. The subtype mark must denote either an
+ -- unconstrained array type or an access type whose designated type
+ -- is such an array type... (RM 3.6.1)
+
+ if Is_Constrained (T) then
+ Error_Msg_N
+ ("array type is already constrained", Subtype_Mark (SI));
+ Constraint_OK := False;
+
+ else
+ S := First (Constraints (C));
+
+ while Present (S) loop
+ Number_Of_Constraints := Number_Of_Constraints + 1;
+ Next (S);
+ end loop;
+
+ -- In either case, the index constraint must provide a discrete
+ -- range for each index of the array type and the type of each
+ -- discrete range must be the same as that of the corresponding
+ -- index. (RM 3.6.1)
+
+ if Number_Of_Constraints /= Number_Dimensions (T) then
+ Error_Msg_NE ("incorrect number of index constraints for }", C, T);
+ Constraint_OK := False;
+
+ else
+ S := First (Constraints (C));
+ Index := First_Index (T);
+ Analyze (Index);
+
+ -- Apply constraints to each index type
+
+ for J in 1 .. Number_Of_Constraints loop
+ Constrain_Index (Index, S, Related_Nod, Related_Id, Suffix, J);
+ Next (Index);
+ Next (S);
+ end loop;
+
+ end if;
+ end if;
+
+ if No (Def_Id) then
+ Def_Id :=
+ Create_Itype (E_Array_Subtype, Related_Nod, Related_Id, Suffix);
+ else
+ Set_Ekind (Def_Id, E_Array_Subtype);
+ end if;
+
+ Set_Size_Info (Def_Id, (T));
+ Set_First_Rep_Item (Def_Id, First_Rep_Item (T));
+ Set_Etype (Def_Id, Base_Type (T));
+
+ if Constraint_OK then
+ Set_First_Index (Def_Id, First (Constraints (C)));
+ end if;
+
+ Set_Component_Type (Def_Id, Component_Type (T));
+ Set_Is_Constrained (Def_Id, True);
+ Set_Is_Aliased (Def_Id, Is_Aliased (T));
+ Set_Depends_On_Private (Def_Id, Has_Private_Component (Def_Id));
+
+ Set_Is_Private_Composite (Def_Id, Is_Private_Composite (T));
+ Set_Is_Limited_Composite (Def_Id, Is_Limited_Composite (T));
+
+ -- If the subtype is not that of a record component, build a freeze
+ -- node if parent still needs one.
+
+ -- If the subtype is not that of a record component, make sure
+ -- that the Depends_On_Private status is set (explanation ???)
+ -- and also that a conditional delay is set.
+
+ if not Is_Type (Scope (Def_Id)) then
+ Set_Depends_On_Private (Def_Id, Depends_On_Private (T));
+ Conditional_Delay (Def_Id, T);
+ end if;
+
+ end Constrain_Array;
+
+ ------------------------------
+ -- Constrain_Component_Type --
+ ------------------------------
+
+ function Constrain_Component_Type
+ (Compon_Type : Entity_Id;
+ Constrained_Typ : Entity_Id;
+ Related_Node : Node_Id;
+ Typ : Entity_Id;
+ Constraints : Elist_Id)
+ return Entity_Id
+ is
+ Loc : constant Source_Ptr := Sloc (Constrained_Typ);
+
+ function Build_Constrained_Array_Type
+ (Old_Type : Entity_Id)
+ return Entity_Id;
+ -- If Old_Type is an array type, one of whose indices is
+ -- constrained by a discriminant, build an Itype whose constraint
+ -- replaces the discriminant with its value in the constraint.
+
+ function Build_Constrained_Discriminated_Type
+ (Old_Type : Entity_Id)
+ return Entity_Id;
+ -- Ditto for record components.
+
+ function Build_Constrained_Access_Type
+ (Old_Type : Entity_Id)
+ return Entity_Id;
+ -- Ditto for access types. Makes use of previous two functions, to
+ -- constrain designated type.
+
+ function Build_Subtype (T : Entity_Id; C : List_Id) return Entity_Id;
+ -- T is an array or discriminated type, C is a list of constraints
+ -- that apply to T. This routine builds the constrained subtype.
+
+ function Is_Discriminant (Expr : Node_Id) return Boolean;
+ -- Returns True if Expr is a discriminant.
+
+ function Get_Value (Discrim : Entity_Id) return Node_Id;
+ -- Find the value of discriminant Discrim in Constraint.
+
+ -----------------------------------
+ -- Build_Constrained_Access_Type --
+ -----------------------------------
+
+ function Build_Constrained_Access_Type
+ (Old_Type : Entity_Id)
+ return Entity_Id
+ is
+ Desig_Type : constant Entity_Id := Designated_Type (Old_Type);
+ Itype : Entity_Id;
+ Desig_Subtype : Entity_Id;
+ Scop : Entity_Id;
+
+ begin
+ -- if the original access type was not embedded in the enclosing
+ -- type definition, there is no need to produce a new access
+ -- subtype. In fact every access type with an explicit constraint
+ -- generates an itype whose scope is the enclosing record.
+
+ if not Is_Type (Scope (Old_Type)) then
+ return Old_Type;
+
+ elsif Is_Array_Type (Desig_Type) then
+ Desig_Subtype := Build_Constrained_Array_Type (Desig_Type);
+
+ elsif Has_Discriminants (Desig_Type) then
+
+ -- This may be an access type to an enclosing record type for
+ -- which we are constructing the constrained components. Return
+ -- the enclosing record subtype. This is not always correct,
+ -- but avoids infinite recursion. ???
+
+ Desig_Subtype := Any_Type;
+
+ for J in reverse 0 .. Scope_Stack.Last loop
+ Scop := Scope_Stack.Table (J).Entity;
+
+ if Is_Type (Scop)
+ and then Base_Type (Scop) = Base_Type (Desig_Type)
+ then
+ Desig_Subtype := Scop;
+ end if;
+
+ exit when not Is_Type (Scop);
+ end loop;
+
+ if Desig_Subtype = Any_Type then
+ Desig_Subtype :=
+ Build_Constrained_Discriminated_Type (Desig_Type);
+ end if;
+
+ else
+ return Old_Type;
+ end if;
+
+ if Desig_Subtype /= Desig_Type then
+ -- The Related_Node better be here or else we won't be able
+ -- to attach new itypes to a node in the tree.
+
+ pragma Assert (Present (Related_Node));
+
+ Itype := Create_Itype (E_Access_Subtype, Related_Node);
+
+ Set_Etype (Itype, Base_Type (Old_Type));
+ Set_Size_Info (Itype, (Old_Type));
+ Set_Directly_Designated_Type (Itype, Desig_Subtype);
+ Set_Depends_On_Private (Itype, Has_Private_Component
+ (Old_Type));
+ Set_Is_Access_Constant (Itype, Is_Access_Constant
+ (Old_Type));
+
+ -- The new itype needs freezing when it depends on a not frozen
+ -- type and the enclosing subtype needs freezing.
+
+ if Has_Delayed_Freeze (Constrained_Typ)
+ and then not Is_Frozen (Constrained_Typ)
+ then
+ Conditional_Delay (Itype, Base_Type (Old_Type));
+ end if;
+
+ return Itype;
+
+ else
+ return Old_Type;
+ end if;
+ end Build_Constrained_Access_Type;
+
+ ----------------------------------
+ -- Build_Constrained_Array_Type --
+ ----------------------------------
+
+ function Build_Constrained_Array_Type
+ (Old_Type : Entity_Id)
+ return Entity_Id
+ is
+ Lo_Expr : Node_Id;
+ Hi_Expr : Node_Id;
+ Old_Index : Node_Id;
+ Range_Node : Node_Id;
+ Constr_List : List_Id;
+
+ Need_To_Create_Itype : Boolean := False;
+
+ begin
+ Old_Index := First_Index (Old_Type);
+ while Present (Old_Index) loop
+ Get_Index_Bounds (Old_Index, Lo_Expr, Hi_Expr);
+
+ if Is_Discriminant (Lo_Expr)
+ or else Is_Discriminant (Hi_Expr)
+ then
+ Need_To_Create_Itype := True;
+ end if;
+
+ Next_Index (Old_Index);
+ end loop;
+
+ if Need_To_Create_Itype then
+ Constr_List := New_List;
+
+ Old_Index := First_Index (Old_Type);
+ while Present (Old_Index) loop
+ Get_Index_Bounds (Old_Index, Lo_Expr, Hi_Expr);
+
+ if Is_Discriminant (Lo_Expr) then
+ Lo_Expr := Get_Value (Lo_Expr);
+ end if;
+
+ if Is_Discriminant (Hi_Expr) then
+ Hi_Expr := Get_Value (Hi_Expr);
+ end if;
+
+ Range_Node :=
+ Make_Range
+ (Loc, New_Copy_Tree (Lo_Expr), New_Copy_Tree (Hi_Expr));
+
+ Append (Range_Node, To => Constr_List);
+
+ Next_Index (Old_Index);
+ end loop;
+
+ return Build_Subtype (Old_Type, Constr_List);
+
+ else
+ return Old_Type;
+ end if;
+ end Build_Constrained_Array_Type;
+
+ ------------------------------------------
+ -- Build_Constrained_Discriminated_Type --
+ ------------------------------------------
+
+ function Build_Constrained_Discriminated_Type
+ (Old_Type : Entity_Id)
+ return Entity_Id
+ is
+ Expr : Node_Id;
+ Constr_List : List_Id;
+ Old_Constraint : Elmt_Id;
+
+ Need_To_Create_Itype : Boolean := False;
+
+ begin
+ Old_Constraint := First_Elmt (Discriminant_Constraint (Old_Type));
+ while Present (Old_Constraint) loop
+ Expr := Node (Old_Constraint);
+
+ if Is_Discriminant (Expr) then
+ Need_To_Create_Itype := True;
+ end if;
+
+ Next_Elmt (Old_Constraint);
+ end loop;
+
+ if Need_To_Create_Itype then
+ Constr_List := New_List;
+
+ Old_Constraint := First_Elmt (Discriminant_Constraint (Old_Type));
+ while Present (Old_Constraint) loop
+ Expr := Node (Old_Constraint);
+
+ if Is_Discriminant (Expr) then
+ Expr := Get_Value (Expr);
+ end if;
+
+ Append (New_Copy_Tree (Expr), To => Constr_List);
+
+ Next_Elmt (Old_Constraint);
+ end loop;
+
+ return Build_Subtype (Old_Type, Constr_List);
+
+ else
+ return Old_Type;
+ end if;
+ end Build_Constrained_Discriminated_Type;
+
+ -------------------
+ -- Build_Subtype --
+ -------------------
+
+ function Build_Subtype (T : Entity_Id; C : List_Id) return Entity_Id is
+ Indic : Node_Id;
+ Subtyp_Decl : Node_Id;
+ Def_Id : Entity_Id;
+ Btyp : Entity_Id := Base_Type (T);
+
+ begin
+ -- The Related_Node better be here or else we won't be able
+ -- to attach new itypes to a node in the tree.
+
+ pragma Assert (Present (Related_Node));
+
+ -- If the view of the component's type is incomplete or private
+ -- with unknown discriminants, then the constraint must be applied
+ -- to the full type.
+
+ if Has_Unknown_Discriminants (Btyp)
+ and then Present (Underlying_Type (Btyp))
+ then
+ Btyp := Underlying_Type (Btyp);
+ end if;
+
+ Indic :=
+ Make_Subtype_Indication (Loc,
+ Subtype_Mark => New_Occurrence_Of (Btyp, Loc),
+ Constraint => Make_Index_Or_Discriminant_Constraint (Loc, C));
+
+ Def_Id := Create_Itype (Ekind (T), Related_Node);
+
+ Subtyp_Decl :=
+ Make_Subtype_Declaration (Loc,
+ Defining_Identifier => Def_Id,
+ Subtype_Indication => Indic);
+ Set_Parent (Subtyp_Decl, Parent (Related_Node));
+
+ -- Itypes must be analyzed with checks off (see itypes.ads).
+
+ Analyze (Subtyp_Decl, Suppress => All_Checks);
+
+ return Def_Id;
+ end Build_Subtype;
+
+ ---------------
+ -- Get_Value --
+ ---------------
+
+ function Get_Value (Discrim : Entity_Id) return Node_Id is
+ D : Entity_Id := First_Discriminant (Typ);
+ E : Elmt_Id := First_Elmt (Constraints);
+
+ begin
+ while Present (D) loop
+
+ -- If we are constraining the subtype of a derived tagged type,
+ -- recover the discriminant of the parent, which appears in
+ -- the constraint of an inherited component.
+
+ if D = Entity (Discrim)
+ or else Corresponding_Discriminant (D) = Entity (Discrim)
+ then
+ return Node (E);
+ end if;
+
+ Next_Discriminant (D);
+ Next_Elmt (E);
+ end loop;
+
+ -- Something is wrong if we did not find the value
+
+ raise Program_Error;
+ end Get_Value;
+
+ ---------------------
+ -- Is_Discriminant --
+ ---------------------
+
+ function Is_Discriminant (Expr : Node_Id) return Boolean is
+ Discrim_Scope : Entity_Id;
+
+ begin
+ if Denotes_Discriminant (Expr) then
+ Discrim_Scope := Scope (Entity (Expr));
+
+ -- Either we have a reference to one of Typ's discriminants,
+
+ pragma Assert (Discrim_Scope = Typ
+
+ -- or to the discriminants of the parent type, in the case
+ -- of a derivation of a tagged type with variants.
+
+ or else Discrim_Scope = Etype (Typ)
+ or else Full_View (Discrim_Scope) = Etype (Typ)
+
+ -- or same as above for the case where the discriminants
+ -- were declared in Typ's private view.
+
+ or else (Is_Private_Type (Discrim_Scope)
+ and then Chars (Discrim_Scope) = Chars (Typ))
+
+ -- or else we are deriving from the full view and the
+ -- discriminant is declared in the private entity.
+
+ or else (Is_Private_Type (Typ)
+ and then Chars (Discrim_Scope) = Chars (Typ))
+
+ -- or we have a class-wide type, in which case make sure the
+ -- discriminant found belongs to the root type.
+
+ or else (Is_Class_Wide_Type (Typ)
+ and then Etype (Typ) = Discrim_Scope));
+
+ return True;
+ end if;
+
+ -- In all other cases we have something wrong.
+
+ return False;
+ end Is_Discriminant;
+
+ -- Start of processing for Constrain_Component_Type
+
+ begin
+ if Is_Array_Type (Compon_Type) then
+ return Build_Constrained_Array_Type (Compon_Type);
+
+ elsif Has_Discriminants (Compon_Type) then
+ return Build_Constrained_Discriminated_Type (Compon_Type);
+
+ elsif Is_Access_Type (Compon_Type) then
+ return Build_Constrained_Access_Type (Compon_Type);
+ end if;
+
+ return Compon_Type;
+ end Constrain_Component_Type;
+
+ --------------------------
+ -- Constrain_Concurrent --
+ --------------------------
+
+ -- For concurrent types, the associated record value type carries the same
+ -- discriminants, so when we constrain a concurrent type, we must constrain
+ -- the value type as well.
+
+ procedure Constrain_Concurrent
+ (Def_Id : in out Entity_Id;
+ SI : Node_Id;
+ Related_Nod : Node_Id;
+ Related_Id : Entity_Id;
+ Suffix : Character)
+ is
+ T_Ent : Entity_Id := Entity (Subtype_Mark (SI));
+ T_Val : Entity_Id;
+
+ begin
+ if Ekind (T_Ent) in Access_Kind then
+ T_Ent := Designated_Type (T_Ent);
+ end if;
+
+ T_Val := Corresponding_Record_Type (T_Ent);
+
+ if Present (T_Val) then
+
+ if No (Def_Id) then
+ Def_Id := Create_Itype (E_Void, Related_Nod, Related_Id, Suffix);
+ end if;
+
+ Constrain_Discriminated_Type (Def_Id, SI, Related_Nod);
+
+ Set_Depends_On_Private (Def_Id, Has_Private_Component (Def_Id));
+ Set_Corresponding_Record_Type (Def_Id,
+ Constrain_Corresponding_Record
+ (Def_Id, T_Val, Related_Nod, Related_Id));
+
+ else
+ -- If there is no associated record, expansion is disabled and this
+ -- is a generic context. Create a subtype in any case, so that
+ -- semantic analysis can proceed.
+
+ if No (Def_Id) then
+ Def_Id := Create_Itype (E_Void, Related_Nod, Related_Id, Suffix);
+ end if;
+
+ Constrain_Discriminated_Type (Def_Id, SI, Related_Nod);
+ end if;
+ end Constrain_Concurrent;
+
+ ------------------------------------
+ -- Constrain_Corresponding_Record --
+ ------------------------------------
+
+ function Constrain_Corresponding_Record
+ (Prot_Subt : Entity_Id;
+ Corr_Rec : Entity_Id;
+ Related_Nod : Node_Id;
+ Related_Id : Entity_Id)
+ return Entity_Id
+ is
+ T_Sub : constant Entity_Id
+ := Create_Itype (E_Record_Subtype, Related_Nod, Related_Id, 'V');
+
+ begin
+ Set_Etype (T_Sub, Corr_Rec);
+ Init_Size_Align (T_Sub);
+ Set_Has_Discriminants (T_Sub, Has_Discriminants (Prot_Subt));
+ Set_Is_Constrained (T_Sub, True);
+ Set_First_Entity (T_Sub, First_Entity (Corr_Rec));
+ Set_Last_Entity (T_Sub, Last_Entity (Corr_Rec));
+
+ Conditional_Delay (T_Sub, Corr_Rec);
+
+ if Has_Discriminants (Prot_Subt) then -- False only if errors.
+ Set_Discriminant_Constraint (T_Sub,
+ Discriminant_Constraint (Prot_Subt));
+ Set_Girder_Constraint_From_Discriminant_Constraint (T_Sub);
+ Create_Constrained_Components (T_Sub, Related_Nod, Corr_Rec,
+ Discriminant_Constraint (T_Sub));
+ end if;
+
+ Set_Depends_On_Private (T_Sub, Has_Private_Component (T_Sub));
+
+ return T_Sub;
+ end Constrain_Corresponding_Record;
+
+ -----------------------
+ -- Constrain_Decimal --
+ -----------------------
+
+ procedure Constrain_Decimal
+ (Def_Id : Node_Id;
+ S : Node_Id;
+ Related_Nod : Node_Id)
+ is
+ T : constant Entity_Id := Entity (Subtype_Mark (S));
+ C : constant Node_Id := Constraint (S);
+ Loc : constant Source_Ptr := Sloc (C);
+ Range_Expr : Node_Id;
+ Digits_Expr : Node_Id;
+ Digits_Val : Uint;
+ Bound_Val : Ureal;
+
+ begin
+ Set_Ekind (Def_Id, E_Decimal_Fixed_Point_Subtype);
+
+ if Nkind (C) = N_Range_Constraint then
+ Range_Expr := Range_Expression (C);
+ Digits_Val := Digits_Value (T);
+
+ else
+ pragma Assert (Nkind (C) = N_Digits_Constraint);
+ Digits_Expr := Digits_Expression (C);
+ Analyze_And_Resolve (Digits_Expr, Any_Integer);
+
+ Check_Digits_Expression (Digits_Expr);
+ Digits_Val := Expr_Value (Digits_Expr);
+
+ if Digits_Val > Digits_Value (T) then
+ Error_Msg_N
+ ("digits expression is incompatible with subtype", C);
+ Digits_Val := Digits_Value (T);
+ end if;
+
+ if Present (Range_Constraint (C)) then
+ Range_Expr := Range_Expression (Range_Constraint (C));
+ else
+ Range_Expr := Empty;
+ end if;
+ end if;
+
+ Set_Etype (Def_Id, Base_Type (T));
+ Set_Size_Info (Def_Id, (T));
+ Set_First_Rep_Item (Def_Id, First_Rep_Item (T));
+ Set_Delta_Value (Def_Id, Delta_Value (T));
+ Set_Scale_Value (Def_Id, Scale_Value (T));
+ Set_Small_Value (Def_Id, Small_Value (T));
+ Set_Machine_Radix_10 (Def_Id, Machine_Radix_10 (T));
+ Set_Digits_Value (Def_Id, Digits_Val);
+
+ -- Manufacture range from given digits value if no range present
+
+ if No (Range_Expr) then
+ Bound_Val := (Ureal_10 ** Digits_Val - Ureal_1) * Small_Value (T);
+ Range_Expr :=
+ Make_Range (Loc,
+ Low_Bound =>
+ Convert_To (T, Make_Real_Literal (Loc, (-Bound_Val))),
+ High_Bound =>
+ Convert_To (T, Make_Real_Literal (Loc, Bound_Val)));
+
+ end if;
+
+ Set_Scalar_Range_For_Subtype (Def_Id, Range_Expr, T, Related_Nod);
+ Set_Discrete_RM_Size (Def_Id);
+
+ -- Unconditionally delay the freeze, since we cannot set size
+ -- information in all cases correctly until the freeze point.
+
+ Set_Has_Delayed_Freeze (Def_Id);
+ end Constrain_Decimal;
+
+ ----------------------------------
+ -- Constrain_Discriminated_Type --
+ ----------------------------------
+
+ procedure Constrain_Discriminated_Type
+ (Def_Id : Entity_Id;
+ S : Node_Id;
+ Related_Nod : Node_Id;
+ For_Access : Boolean := False)
+ is
+ T : Entity_Id;
+ C : Node_Id;
+ Elist : Elist_Id := New_Elmt_List;
+
+ procedure Fixup_Bad_Constraint;
+ -- This is called after finding a bad constraint, and after having
+ -- posted an appropriate error message. The mission is to leave the
+ -- entity T in as reasonable state as possible!
+
+ procedure Fixup_Bad_Constraint is
+ begin
+ -- Set a reasonable Ekind for the entity. For an incomplete type,
+ -- we can't do much, but for other types, we can set the proper
+ -- corresponding subtype kind.
+
+ if Ekind (T) = E_Incomplete_Type then
+ Set_Ekind (Def_Id, Ekind (T));
+ else
+ Set_Ekind (Def_Id, Subtype_Kind (Ekind (T)));
+ end if;
+
+ Set_Etype (Def_Id, Any_Type);
+ Set_Error_Posted (Def_Id);
+ end Fixup_Bad_Constraint;
+
+ -- Start of processing for Constrain_Discriminated_Type
+
+ begin
+ C := Constraint (S);
+
+ -- A discriminant constraint is only allowed in a subtype indication,
+ -- after a subtype mark. This subtype mark must denote either a type
+ -- with discriminants, or an access type whose designated type is a
+ -- type with discriminants. A discriminant constraint specifies the
+ -- values of these discriminants (RM 3.7.2(5)).
+
+ T := Base_Type (Entity (Subtype_Mark (S)));
+
+ if Ekind (T) in Access_Kind then
+ T := Designated_Type (T);
+ end if;
+
+ if not Has_Discriminants (T) then
+ Error_Msg_N ("invalid constraint: type has no discriminant", C);
+ Fixup_Bad_Constraint;
+ return;
+
+ elsif Is_Constrained (Entity (Subtype_Mark (S))) then
+ Error_Msg_N ("type is already constrained", Subtype_Mark (S));
+ Fixup_Bad_Constraint;
+ return;
+ end if;
+
+ -- T may be an unconstrained subtype (e.g. a generic actual).
+ -- Constraint applies to the base type.
+
+ T := Base_Type (T);
+
+ Elist := Build_Discriminant_Constraints (T, S);
+
+ -- If the list returned was empty we had an error in building the
+ -- discriminant constraint. We have also already signalled an error
+ -- in the incomplete type case
+
+ if Is_Empty_Elmt_List (Elist) then
+ Fixup_Bad_Constraint;
+ return;
+ end if;
+
+ Build_Discriminated_Subtype (T, Def_Id, Elist, Related_Nod, For_Access);
+ end Constrain_Discriminated_Type;
+
+ ---------------------------
+ -- Constrain_Enumeration --
+ ---------------------------
+
+ procedure Constrain_Enumeration
+ (Def_Id : Node_Id;
+ S : Node_Id;
+ Related_Nod : Node_Id)
+ is
+ T : constant Entity_Id := Entity (Subtype_Mark (S));
+ C : constant Node_Id := Constraint (S);
+
+ begin
+ Set_Ekind (Def_Id, E_Enumeration_Subtype);
+
+ Set_First_Literal (Def_Id, First_Literal (Base_Type (T)));
+
+ Set_Etype (Def_Id, Base_Type (T));
+ Set_Size_Info (Def_Id, (T));
+ Set_First_Rep_Item (Def_Id, First_Rep_Item (T));
+ Set_Is_Character_Type (Def_Id, Is_Character_Type (T));
+
+ Set_Scalar_Range_For_Subtype
+ (Def_Id, Range_Expression (C), T, Related_Nod);
+
+ Set_Discrete_RM_Size (Def_Id);
+
+ end Constrain_Enumeration;
+
+ ----------------------
+ -- Constrain_Float --
+ ----------------------
+
+ procedure Constrain_Float
+ (Def_Id : Node_Id;
+ S : Node_Id;
+ Related_Nod : Node_Id)
+ is
+ T : constant Entity_Id := Entity (Subtype_Mark (S));
+ C : Node_Id;
+ D : Node_Id;
+ Rais : Node_Id;
+
+ begin
+ Set_Ekind (Def_Id, E_Floating_Point_Subtype);
+
+ Set_Etype (Def_Id, Base_Type (T));
+ Set_Size_Info (Def_Id, (T));
+ Set_First_Rep_Item (Def_Id, First_Rep_Item (T));
+
+ -- Process the constraint
+
+ C := Constraint (S);
+
+ -- Digits constraint present
+
+ if Nkind (C) = N_Digits_Constraint then
+ D := Digits_Expression (C);
+ Analyze_And_Resolve (D, Any_Integer);
+ Check_Digits_Expression (D);
+ Set_Digits_Value (Def_Id, Expr_Value (D));
+
+ -- Check that digits value is in range. Obviously we can do this
+ -- at compile time, but it is strictly a runtime check, and of
+ -- course there is an ACVC test that checks this!
+
+ if Digits_Value (Def_Id) > Digits_Value (T) then
+ Error_Msg_Uint_1 := Digits_Value (T);
+ Error_Msg_N ("?digits value is too large, maximum is ^", D);
+ Rais := Make_Raise_Constraint_Error (Sloc (D));
+ Insert_Action (Declaration_Node (Def_Id), Rais);
+ end if;
+
+ C := Range_Constraint (C);
+
+ -- No digits constraint present
+
+ else
+ Set_Digits_Value (Def_Id, Digits_Value (T));
+ end if;
+
+ -- Range constraint present
+
+ if Nkind (C) = N_Range_Constraint then
+ Set_Scalar_Range_For_Subtype
+ (Def_Id, Range_Expression (C), T, Related_Nod);
+
+ -- No range constraint present
+
+ else
+ pragma Assert (No (C));
+ Set_Scalar_Range (Def_Id, Scalar_Range (T));
+ end if;
+
+ Set_Is_Constrained (Def_Id);
+ end Constrain_Float;
+
+ ---------------------
+ -- Constrain_Index --
+ ---------------------
+
+ procedure Constrain_Index
+ (Index : Node_Id;
+ S : Node_Id;
+ Related_Nod : Node_Id;
+ Related_Id : Entity_Id;
+ Suffix : Character;
+ Suffix_Index : Nat)
+ is
+ Def_Id : Entity_Id;
+ R : Node_Id;
+ Checks_Off : Boolean := False;
+ T : constant Entity_Id := Etype (Index);
+
+ begin
+ if Nkind (S) = N_Range
+ or else Nkind (S) = N_Attribute_Reference
+ then
+ -- A Range attribute will transformed into N_Range by Resolve.
+
+ Analyze (S);
+ Set_Etype (S, T);
+ R := S;
+
+ -- ??? Why on earth do we turn checks of in this very specific case ?
+
+ -- From the revision history: (Constrain_Index): Call
+ -- Process_Range_Expr_In_Decl with range checking off for range
+ -- bounds that are attributes. This avoids some horrible
+ -- constraint error checks.
+
+ if Nkind (R) = N_Range
+ and then Nkind (Low_Bound (R)) = N_Attribute_Reference
+ and then Nkind (High_Bound (R)) = N_Attribute_Reference
+ then
+ Checks_Off := True;
+ end if;
+
+ Process_Range_Expr_In_Decl
+ (R, T, Related_Nod, Empty_List, Checks_Off);
+
+ if not Error_Posted (S)
+ and then
+ (Nkind (S) /= N_Range
+ or else Base_Type (T) /= Base_Type (Etype (Low_Bound (S)))
+ or else Base_Type (T) /= Base_Type (Etype (High_Bound (S))))
+ then
+ if Base_Type (T) /= Any_Type
+ and then Etype (Low_Bound (S)) /= Any_Type
+ and then Etype (High_Bound (S)) /= Any_Type
+ then
+ Error_Msg_N ("range expected", S);
+ end if;
+ end if;
+
+ elsif Nkind (S) = N_Subtype_Indication then
+ -- the parser has verified that this is a discrete indication.
+
+ Resolve_Discrete_Subtype_Indication (S, T);
+ R := Range_Expression (Constraint (S));
+
+ elsif Nkind (S) = N_Discriminant_Association then
+
+ -- syntactically valid in subtype indication.
+
+ Error_Msg_N ("invalid index constraint", S);
+ Rewrite (S, New_Occurrence_Of (T, Sloc (S)));
+ return;
+
+ -- Subtype_Mark case, no anonymous subtypes to construct
+
+ else
+ Analyze (S);
+
+ if Is_Entity_Name (S) then
+
+ if not Is_Type (Entity (S)) then
+ Error_Msg_N ("expect subtype mark for index constraint", S);
+
+ elsif Base_Type (Entity (S)) /= Base_Type (T) then
+ Wrong_Type (S, Base_Type (T));
+ end if;
+
+ return;
+
+ else
+ Error_Msg_N ("invalid index constraint", S);
+ Rewrite (S, New_Occurrence_Of (T, Sloc (S)));
+ return;
+ end if;
+ end if;
+
+ Def_Id :=
+ Create_Itype (E_Void, Related_Nod, Related_Id, Suffix, Suffix_Index);
+
+ Set_Etype (Def_Id, Base_Type (T));
+
+ if Is_Modular_Integer_Type (T) then
+ Set_Ekind (Def_Id, E_Modular_Integer_Subtype);
+
+ elsif Is_Integer_Type (T) then
+ Set_Ekind (Def_Id, E_Signed_Integer_Subtype);
+
+ else
+ Set_Ekind (Def_Id, E_Enumeration_Subtype);
+ Set_Is_Character_Type (Def_Id, Is_Character_Type (T));
+ end if;
+
+ Set_Size_Info (Def_Id, (T));
+ Set_RM_Size (Def_Id, RM_Size (T));
+ Set_First_Rep_Item (Def_Id, First_Rep_Item (T));
+
+ -- ??? ??? is R always initialized, not at all obvious why?
+
+ Set_Scalar_Range (Def_Id, R);
+
+ Set_Etype (S, Def_Id);
+ Set_Discrete_RM_Size (Def_Id);
+ end Constrain_Index;
+
+ -----------------------
+ -- Constrain_Integer --
+ -----------------------
+
+ procedure Constrain_Integer
+ (Def_Id : Node_Id;
+ S : Node_Id;
+ Related_Nod : Node_Id)
+ is
+ T : constant Entity_Id := Entity (Subtype_Mark (S));
+ C : constant Node_Id := Constraint (S);
+
+ begin
+ Set_Scalar_Range_For_Subtype
+ (Def_Id, Range_Expression (C), T, Related_Nod);
+
+ if Is_Modular_Integer_Type (T) then
+ Set_Ekind (Def_Id, E_Modular_Integer_Subtype);
+ else
+ Set_Ekind (Def_Id, E_Signed_Integer_Subtype);
+ end if;
+
+ Set_Etype (Def_Id, Base_Type (T));
+ Set_Size_Info (Def_Id, (T));
+ Set_First_Rep_Item (Def_Id, First_Rep_Item (T));
+ Set_Discrete_RM_Size (Def_Id);
+
+ end Constrain_Integer;
+
+ ------------------------------
+ -- Constrain_Ordinary_Fixed --
+ ------------------------------
+
+ procedure Constrain_Ordinary_Fixed
+ (Def_Id : Node_Id;
+ S : Node_Id;
+ Related_Nod : Node_Id)
+ is
+ T : constant Entity_Id := Entity (Subtype_Mark (S));
+ C : Node_Id;
+ D : Node_Id;
+ Rais : Node_Id;
+
+ begin
+ Set_Ekind (Def_Id, E_Ordinary_Fixed_Point_Subtype);
+ Set_Etype (Def_Id, Base_Type (T));
+ Set_Size_Info (Def_Id, (T));
+ Set_First_Rep_Item (Def_Id, First_Rep_Item (T));
+ Set_Small_Value (Def_Id, Small_Value (T));
+
+ -- Process the constraint
+
+ C := Constraint (S);
+
+ -- Delta constraint present
+
+ if Nkind (C) = N_Delta_Constraint then
+ D := Delta_Expression (C);
+ Analyze_And_Resolve (D, Any_Real);
+ Check_Delta_Expression (D);
+ Set_Delta_Value (Def_Id, Expr_Value_R (D));
+
+ -- Check that delta value is in range. Obviously we can do this
+ -- at compile time, but it is strictly a runtime check, and of
+ -- course there is an ACVC test that checks this!
+
+ if Delta_Value (Def_Id) < Delta_Value (T) then
+ Error_Msg_N ("?delta value is too small", D);
+ Rais := Make_Raise_Constraint_Error (Sloc (D));
+ Insert_Action (Declaration_Node (Def_Id), Rais);
+ end if;
+
+ C := Range_Constraint (C);
+
+ -- No delta constraint present
+
+ else
+ Set_Delta_Value (Def_Id, Delta_Value (T));
+ end if;
+
+ -- Range constraint present
+
+ if Nkind (C) = N_Range_Constraint then
+ Set_Scalar_Range_For_Subtype
+ (Def_Id, Range_Expression (C), T, Related_Nod);
+
+ -- No range constraint present
+
+ else
+ pragma Assert (No (C));
+ Set_Scalar_Range (Def_Id, Scalar_Range (T));
+
+ end if;
+
+ Set_Discrete_RM_Size (Def_Id);
+
+ -- Unconditionally delay the freeze, since we cannot set size
+ -- information in all cases correctly until the freeze point.
+
+ Set_Has_Delayed_Freeze (Def_Id);
+ end Constrain_Ordinary_Fixed;
+
+ ---------------------------
+ -- Convert_Scalar_Bounds --
+ ---------------------------
+
+ procedure Convert_Scalar_Bounds
+ (N : Node_Id;
+ Parent_Type : Entity_Id;
+ Derived_Type : Entity_Id;
+ Loc : Source_Ptr)
+ is
+ Implicit_Base : constant Entity_Id := Base_Type (Derived_Type);
+
+ Lo : Node_Id;
+ Hi : Node_Id;
+ Rng : Node_Id;
+
+ begin
+ Lo := Build_Scalar_Bound
+ (Type_Low_Bound (Derived_Type),
+ Parent_Type, Implicit_Base, Loc);
+
+ Hi := Build_Scalar_Bound
+ (Type_High_Bound (Derived_Type),
+ Parent_Type, Implicit_Base, Loc);
+
+ Rng :=
+ Make_Range (Loc,
+ Low_Bound => Lo,
+ High_Bound => Hi);
+
+ Set_Includes_Infinities (Rng, Has_Infinities (Derived_Type));
+
+ Set_Parent (Rng, N);
+ Set_Scalar_Range (Derived_Type, Rng);
+
+ -- Analyze the bounds
+
+ Analyze_And_Resolve (Lo, Implicit_Base);
+ Analyze_And_Resolve (Hi, Implicit_Base);
+
+ -- Analyze the range itself, except that we do not analyze it if
+ -- the bounds are real literals, and we have a fixed-point type.
+ -- The reason for this is that we delay setting the bounds in this
+ -- case till we know the final Small and Size values (see circuit
+ -- in Freeze.Freeze_Fixed_Point_Type for further details).
+
+ if Is_Fixed_Point_Type (Parent_Type)
+ and then Nkind (Lo) = N_Real_Literal
+ and then Nkind (Hi) = N_Real_Literal
+ then
+ return;
+
+ -- Here we do the analysis of the range.
+
+ -- Note: we do this manually, since if we do a normal Analyze and
+ -- Resolve call, there are problems with the conversions used for
+ -- the derived type range.
+
+ else
+ Set_Etype (Rng, Implicit_Base);
+ Set_Analyzed (Rng, True);
+ end if;
+ end Convert_Scalar_Bounds;
+
+ -------------------
+ -- Copy_And_Swap --
+ -------------------
+
+ procedure Copy_And_Swap (Privat, Full : Entity_Id) is
+ begin
+ -- Initialize new full declaration entity by copying the pertinent
+ -- fields of the corresponding private declaration entity.
+
+ Copy_Private_To_Full (Privat, Full);
+
+ -- Swap the two entities. Now Privat is the full type entity and
+ -- Full is the private one. They will be swapped back at the end
+ -- of the private part. This swapping ensures that the entity that
+ -- is visible in the private part is the full declaration.
+
+ Exchange_Entities (Privat, Full);
+ Append_Entity (Full, Scope (Full));
+ end Copy_And_Swap;
+
+ -------------------------------------
+ -- Copy_Array_Base_Type_Attributes --
+ -------------------------------------
+
+ procedure Copy_Array_Base_Type_Attributes (T1, T2 : Entity_Id) is
+ begin
+ Set_Component_Alignment (T1, Component_Alignment (T2));
+ Set_Component_Type (T1, Component_Type (T2));
+ Set_Component_Size (T1, Component_Size (T2));
+ Set_Has_Controlled_Component (T1, Has_Controlled_Component (T2));
+ Set_Finalize_Storage_Only (T1, Finalize_Storage_Only (T2));
+ Set_Has_Non_Standard_Rep (T1, Has_Non_Standard_Rep (T2));
+ Set_Has_Task (T1, Has_Task (T2));
+ Set_Is_Packed (T1, Is_Packed (T2));
+ Set_Has_Aliased_Components (T1, Has_Aliased_Components (T2));
+ Set_Has_Atomic_Components (T1, Has_Atomic_Components (T2));
+ Set_Has_Volatile_Components (T1, Has_Volatile_Components (T2));
+ end Copy_Array_Base_Type_Attributes;
+
+ -----------------------------------
+ -- Copy_Array_Subtype_Attributes --
+ -----------------------------------
+
+ procedure Copy_Array_Subtype_Attributes (T1, T2 : Entity_Id) is
+ begin
+ Set_Size_Info (T1, T2);
+
+ Set_First_Index (T1, First_Index (T2));
+ Set_Is_Aliased (T1, Is_Aliased (T2));
+ Set_Is_Atomic (T1, Is_Atomic (T2));
+ Set_Is_Volatile (T1, Is_Volatile (T2));
+ Set_Is_Constrained (T1, Is_Constrained (T2));
+ Set_Depends_On_Private (T1, Has_Private_Component (T2));
+ Set_First_Rep_Item (T1, First_Rep_Item (T2));
+ Set_Convention (T1, Convention (T2));
+ Set_Is_Limited_Composite (T1, Is_Limited_Composite (T2));
+ Set_Is_Private_Composite (T1, Is_Private_Composite (T2));
+ end Copy_Array_Subtype_Attributes;
+
+ --------------------------
+ -- Copy_Private_To_Full --
+ --------------------------
+
+ procedure Copy_Private_To_Full (Priv, Full : Entity_Id) is
+ begin
+ -- We temporarily set Ekind to a value appropriate for a type to
+ -- avoid assert failures in Einfo from checking for setting type
+ -- attributes on something that is not a type. Ekind (Priv) is an
+ -- appropriate choice, since it allowed the attributes to be set
+ -- in the first place. This Ekind value will be modified later.
+
+ Set_Ekind (Full, Ekind (Priv));
+
+ -- Also set Etype temporarily to Any_Type, again, in the absence
+ -- of errors, it will be properly reset, and if there are errors,
+ -- then we want a value of Any_Type to remain.
+
+ Set_Etype (Full, Any_Type);
+
+ -- Now start copying attributes
+
+ Set_Has_Discriminants (Full, Has_Discriminants (Priv));
+
+ if Has_Discriminants (Full) then
+ Set_Discriminant_Constraint (Full, Discriminant_Constraint (Priv));
+ Set_Girder_Constraint (Full, Girder_Constraint (Priv));
+ end if;
+
+ Set_Homonym (Full, Homonym (Priv));
+ Set_Is_Immediately_Visible (Full, Is_Immediately_Visible (Priv));
+ Set_Is_Public (Full, Is_Public (Priv));
+ Set_Is_Pure (Full, Is_Pure (Priv));
+ Set_Is_Tagged_Type (Full, Is_Tagged_Type (Priv));
+
+ Conditional_Delay (Full, Priv);
+
+ if Is_Tagged_Type (Full) then
+ Set_Primitive_Operations (Full, Primitive_Operations (Priv));
+
+ if Priv = Base_Type (Priv) then
+ Set_Class_Wide_Type (Full, Class_Wide_Type (Priv));
+ end if;
+ end if;
+
+ Set_Is_Volatile (Full, Is_Volatile (Priv));
+ Set_Scope (Full, Scope (Priv));
+ Set_Next_Entity (Full, Next_Entity (Priv));
+ Set_First_Entity (Full, First_Entity (Priv));
+ Set_Last_Entity (Full, Last_Entity (Priv));
+
+ -- If access types have been recorded for later handling, keep them
+ -- in the full view so that they get handled when the full view freeze
+ -- node is expanded.
+
+ if Present (Freeze_Node (Priv))
+ and then Present (Access_Types_To_Process (Freeze_Node (Priv)))
+ then
+ Ensure_Freeze_Node (Full);
+ Set_Access_Types_To_Process (Freeze_Node (Full),
+ Access_Types_To_Process (Freeze_Node (Priv)));
+ end if;
+ end Copy_Private_To_Full;
+
+ -----------------------------------
+ -- Create_Constrained_Components --
+ -----------------------------------
+
+ procedure Create_Constrained_Components
+ (Subt : Entity_Id;
+ Decl_Node : Node_Id;
+ Typ : Entity_Id;
+ Constraints : Elist_Id)
+ is
+ Loc : constant Source_Ptr := Sloc (Subt);
+ Assoc_List : List_Id := New_List;
+ Comp_List : Elist_Id := New_Elmt_List;
+ Discr_Val : Elmt_Id;
+ Errors : Boolean;
+ New_C : Entity_Id;
+ Old_C : Entity_Id;
+ Is_Static : Boolean := True;
+ Parent_Type : constant Entity_Id := Etype (Typ);
+
+ procedure Collect_Fixed_Components (Typ : Entity_Id);
+ -- Collect components of parent type that do not appear in a variant
+ -- part.
+
+ procedure Create_All_Components;
+ -- Iterate over Comp_List to create the components of the subtype.
+
+ function Create_Component (Old_Compon : Entity_Id) return Entity_Id;
+ -- Creates a new component from Old_Compon, coppying all the fields from
+ -- it, including its Etype, inserts the new component in the Subt entity
+ -- chain and returns the new component.
+
+ function Is_Variant_Record (T : Entity_Id) return Boolean;
+ -- If true, and discriminants are static, collect only components from
+ -- variants selected by discriminant values.
+
+ ------------------------------
+ -- Collect_Fixed_Components --
+ ------------------------------
+
+ procedure Collect_Fixed_Components (Typ : Entity_Id) is
+ begin
+ -- Build association list for discriminants, and find components of
+ -- the variant part selected by the values of the discriminants.
+
+ Old_C := First_Discriminant (Typ);
+ Discr_Val := First_Elmt (Constraints);
+
+ while Present (Old_C) loop
+ Append_To (Assoc_List,
+ Make_Component_Association (Loc,
+ Choices => New_List (New_Occurrence_Of (Old_C, Loc)),
+ Expression => New_Copy (Node (Discr_Val))));
+
+ Next_Elmt (Discr_Val);
+ Next_Discriminant (Old_C);
+ end loop;
+
+ -- The tag, and the possible parent and controller components
+ -- are unconditionally in the subtype.
+
+ if Is_Tagged_Type (Typ)
+ or else Has_Controlled_Component (Typ)
+ then
+ Old_C := First_Component (Typ);
+
+ while Present (Old_C) loop
+ if Chars ((Old_C)) = Name_uTag
+ or else Chars ((Old_C)) = Name_uParent
+ or else Chars ((Old_C)) = Name_uController
+ then
+ Append_Elmt (Old_C, Comp_List);
+ end if;
+
+ Next_Component (Old_C);
+ end loop;
+ end if;
+ end Collect_Fixed_Components;
+
+ ---------------------------
+ -- Create_All_Components --
+ ---------------------------
+
+ procedure Create_All_Components is
+ Comp : Elmt_Id;
+
+ begin
+ Comp := First_Elmt (Comp_List);
+
+ while Present (Comp) loop
+ Old_C := Node (Comp);
+ New_C := Create_Component (Old_C);
+
+ Set_Etype
+ (New_C,
+ Constrain_Component_Type
+ (Etype (Old_C), Subt, Decl_Node, Typ, Constraints));
+ Set_Is_Public (New_C, Is_Public (Subt));
+
+ Next_Elmt (Comp);
+ end loop;
+ end Create_All_Components;
+
+ ----------------------
+ -- Create_Component --
+ ----------------------
+
+ function Create_Component (Old_Compon : Entity_Id) return Entity_Id is
+ New_Compon : Entity_Id := New_Copy (Old_Compon);
+
+ begin
+ -- Set the parent so we have a proper link for freezing etc. This
+ -- is not a real parent pointer, since of course our parent does
+ -- not own up to us and reference us, we are an illegitimate
+ -- child of the original parent!
+
+ Set_Parent (New_Compon, Parent (Old_Compon));
+
+ -- We do not want this node marked as Comes_From_Source, since
+ -- otherwise it would get first class status and a separate
+ -- cross-reference line would be generated. Illegitimate
+ -- children do not rate such recognition.
+
+ Set_Comes_From_Source (New_Compon, False);
+
+ -- But it is a real entity, and a birth certificate must be
+ -- properly registered by entering it into the entity list.
+
+ Enter_Name (New_Compon);
+ return New_Compon;
+ end Create_Component;
+
+ -----------------------
+ -- Is_Variant_Record --
+ -----------------------
+
+ function Is_Variant_Record (T : Entity_Id) return Boolean is
+ begin
+ return Nkind (Parent (T)) = N_Full_Type_Declaration
+ and then Nkind (Type_Definition (Parent (T))) = N_Record_Definition
+ and then Present (Component_List (Type_Definition (Parent (T))))
+ and then Present (
+ Variant_Part (Component_List (Type_Definition (Parent (T)))));
+ end Is_Variant_Record;
+
+ -- Start of processing for Create_Constrained_Components
+
+ begin
+ pragma Assert (Subt /= Base_Type (Subt));
+ pragma Assert (Typ = Base_Type (Typ));
+
+ Set_First_Entity (Subt, Empty);
+ Set_Last_Entity (Subt, Empty);
+
+ -- Check whether constraint is fully static, in which case we can
+ -- optimize the list of components.
+
+ Discr_Val := First_Elmt (Constraints);
+
+ while Present (Discr_Val) loop
+
+ if not Is_OK_Static_Expression (Node (Discr_Val)) then
+ Is_Static := False;
+ exit;
+ end if;
+
+ Next_Elmt (Discr_Val);
+ end loop;
+
+ New_Scope (Subt);
+
+ -- Inherit the discriminants of the parent type.
+
+ Old_C := First_Discriminant (Typ);
+
+ while Present (Old_C) loop
+ New_C := Create_Component (Old_C);
+ Set_Is_Public (New_C, Is_Public (Subt));
+ Next_Discriminant (Old_C);
+ end loop;
+
+ if Is_Static
+ and then Is_Variant_Record (Typ)
+ then
+ Collect_Fixed_Components (Typ);
+
+ Gather_Components (
+ Typ,
+ Component_List (Type_Definition (Parent (Typ))),
+ Governed_By => Assoc_List,
+ Into => Comp_List,
+ Report_Errors => Errors);
+ pragma Assert (not Errors);
+
+ Create_All_Components;
+
+ -- If the subtype declaration is created for a tagged type derivation
+ -- with constraints, we retrieve the record definition of the parent
+ -- type to select the components of the proper variant.
+
+ elsif Is_Static
+ and then Is_Tagged_Type (Typ)
+ and then Nkind (Parent (Typ)) = N_Full_Type_Declaration
+ and then
+ Nkind (Type_Definition (Parent (Typ))) = N_Derived_Type_Definition
+ and then Is_Variant_Record (Parent_Type)
+ then
+ Collect_Fixed_Components (Typ);
+
+ Gather_Components (
+ Typ,
+ Component_List (Type_Definition (Parent (Parent_Type))),
+ Governed_By => Assoc_List,
+ Into => Comp_List,
+ Report_Errors => Errors);
+ pragma Assert (not Errors);
+
+ -- If the tagged derivation has a type extension, collect all the
+ -- new components therein.
+
+ if Present (
+ Record_Extension_Part (Type_Definition (Parent (Typ))))
+ then
+ Old_C := First_Component (Typ);
+
+ while Present (Old_C) loop
+ if Original_Record_Component (Old_C) = Old_C
+ and then Chars (Old_C) /= Name_uTag
+ and then Chars (Old_C) /= Name_uParent
+ and then Chars (Old_C) /= Name_uController
+ then
+ Append_Elmt (Old_C, Comp_List);
+ end if;
+
+ Next_Component (Old_C);
+ end loop;
+ end if;
+
+ Create_All_Components;
+
+ else
+ -- If the discriminants are not static, or if this is a multi-level
+ -- type extension, we have to include all the components of the
+ -- parent type.
+
+ Old_C := First_Component (Typ);
+
+ while Present (Old_C) loop
+ New_C := Create_Component (Old_C);
+
+ Set_Etype
+ (New_C,
+ Constrain_Component_Type
+ (Etype (Old_C), Subt, Decl_Node, Typ, Constraints));
+ Set_Is_Public (New_C, Is_Public (Subt));
+
+ Next_Component (Old_C);
+ end loop;
+ end if;
+
+ End_Scope;
+ end Create_Constrained_Components;
+
+ ------------------------------------------
+ -- Decimal_Fixed_Point_Type_Declaration --
+ ------------------------------------------
+
+ procedure Decimal_Fixed_Point_Type_Declaration
+ (T : Entity_Id;
+ Def : Node_Id)
+ is
+ Loc : constant Source_Ptr := Sloc (Def);
+ Digs_Expr : constant Node_Id := Digits_Expression (Def);
+ Delta_Expr : constant Node_Id := Delta_Expression (Def);
+ Implicit_Base : Entity_Id;
+ Digs_Val : Uint;
+ Delta_Val : Ureal;
+ Scale_Val : Uint;
+ Bound_Val : Ureal;
+
+ -- Start of processing for Decimal_Fixed_Point_Type_Declaration
+
+ begin
+ Check_Restriction (No_Fixed_Point, Def);
+
+ -- Create implicit base type
+
+ Implicit_Base :=
+ Create_Itype (E_Decimal_Fixed_Point_Type, Parent (Def), T, 'B');
+ Set_Etype (Implicit_Base, Implicit_Base);
+
+ -- Analyze and process delta expression
+
+ Analyze_And_Resolve (Delta_Expr, Universal_Real);
+
+ Check_Delta_Expression (Delta_Expr);
+ Delta_Val := Expr_Value_R (Delta_Expr);
+
+ -- Check delta is power of 10, and determine scale value from it
+
+ declare
+ Val : Ureal := Delta_Val;
+
+ begin
+ Scale_Val := Uint_0;
+
+ if Val < Ureal_1 then
+ while Val < Ureal_1 loop
+ Val := Val * Ureal_10;
+ Scale_Val := Scale_Val + 1;
+ end loop;
+
+ if Scale_Val > 18 then
+ Error_Msg_N ("scale exceeds maximum value of 18", Def);
+ Scale_Val := UI_From_Int (+18);
+ end if;
+
+ else
+ while Val > Ureal_1 loop
+ Val := Val / Ureal_10;
+ Scale_Val := Scale_Val - 1;
+ end loop;
+
+ if Scale_Val < -18 then
+ Error_Msg_N ("scale is less than minimum value of -18", Def);
+ Scale_Val := UI_From_Int (-18);
+ end if;
+ end if;
+
+ if Val /= Ureal_1 then
+ Error_Msg_N ("delta expression must be a power of 10", Def);
+ Delta_Val := Ureal_10 ** (-Scale_Val);
+ end if;
+ end;
+
+ -- Set delta, scale and small (small = delta for decimal type)
+
+ Set_Delta_Value (Implicit_Base, Delta_Val);
+ Set_Scale_Value (Implicit_Base, Scale_Val);
+ Set_Small_Value (Implicit_Base, Delta_Val);
+
+ -- Analyze and process digits expression
+
+ Analyze_And_Resolve (Digs_Expr, Any_Integer);
+ Check_Digits_Expression (Digs_Expr);
+ Digs_Val := Expr_Value (Digs_Expr);
+
+ if Digs_Val > 18 then
+ Digs_Val := UI_From_Int (+18);
+ Error_Msg_N ("digits value out of range, maximum is 18", Digs_Expr);
+ end if;
+
+ Set_Digits_Value (Implicit_Base, Digs_Val);
+ Bound_Val := UR_From_Uint (10 ** Digs_Val - 1) * Delta_Val;
+
+ -- Set range of base type from digits value for now. This will be
+ -- expanded to represent the true underlying base range by Freeze.
+
+ Set_Fixed_Range (Implicit_Base, Loc, -Bound_Val, Bound_Val);
+
+ -- Set size to zero for now, size will be set at freeze time. We have
+ -- to do this for ordinary fixed-point, because the size depends on
+ -- the specified small, and we might as well do the same for decimal
+ -- fixed-point.
+
+ Init_Size_Align (Implicit_Base);
+
+ -- Complete entity for first subtype
+
+ Set_Ekind (T, E_Decimal_Fixed_Point_Subtype);
+ Set_Etype (T, Implicit_Base);
+ Set_Size_Info (T, Implicit_Base);
+ Set_First_Rep_Item (T, First_Rep_Item (Implicit_Base));
+ Set_Digits_Value (T, Digs_Val);
+ Set_Delta_Value (T, Delta_Val);
+ Set_Small_Value (T, Delta_Val);
+ Set_Scale_Value (T, Scale_Val);
+ Set_Is_Constrained (T);
+
+ -- If there are bounds given in the declaration use them as the
+ -- bounds of the first named subtype.
+
+ if Present (Real_Range_Specification (Def)) then
+ declare
+ RRS : constant Node_Id := Real_Range_Specification (Def);
+ Low : constant Node_Id := Low_Bound (RRS);
+ High : constant Node_Id := High_Bound (RRS);
+ Low_Val : Ureal;
+ High_Val : Ureal;
+
+ begin
+ Analyze_And_Resolve (Low, Any_Real);
+ Analyze_And_Resolve (High, Any_Real);
+ Check_Real_Bound (Low);
+ Check_Real_Bound (High);
+ Low_Val := Expr_Value_R (Low);
+ High_Val := Expr_Value_R (High);
+
+ if Low_Val < (-Bound_Val) then
+ Error_Msg_N
+ ("range low bound too small for digits value", Low);
+ Low_Val := -Bound_Val;
+ end if;
+
+ if High_Val > Bound_Val then
+ Error_Msg_N
+ ("range high bound too large for digits value", High);
+ High_Val := Bound_Val;
+ end if;
+
+ Set_Fixed_Range (T, Loc, Low_Val, High_Val);
+ end;
+
+ -- If no explicit range, use range that corresponds to given
+ -- digits value. This will end up as the final range for the
+ -- first subtype.
+
+ else
+ Set_Fixed_Range (T, Loc, -Bound_Val, Bound_Val);
+ end if;
+
+ end Decimal_Fixed_Point_Type_Declaration;
+
+ -----------------------
+ -- Derive_Subprogram --
+ -----------------------
+
+ procedure Derive_Subprogram
+ (New_Subp : in out Entity_Id;
+ Parent_Subp : Entity_Id;
+ Derived_Type : Entity_Id;
+ Parent_Type : Entity_Id;
+ Actual_Subp : Entity_Id := Empty)
+ is
+ Formal : Entity_Id;
+ New_Formal : Entity_Id;
+ Same_Subt : constant Boolean :=
+ Is_Scalar_Type (Parent_Type)
+ and then Subtypes_Statically_Compatible (Parent_Type, Derived_Type);
+
+ function Is_Private_Overriding return Boolean;
+ -- If Subp is a private overriding of a visible operation, the in-
+ -- herited operation derives from the overridden op (even though
+ -- its body is the overriding one) and the inherited operation is
+ -- visible now. See sem_disp to see the details of the handling of
+ -- the overridden subprogram, which is removed from the list of
+ -- primitive operations of the type.
+
+ procedure Replace_Type (Id, New_Id : Entity_Id);
+ -- When the type is an anonymous access type, create a new access type
+ -- designating the derived type.
+
+ ---------------------------
+ -- Is_Private_Overriding --
+ ---------------------------
+
+ function Is_Private_Overriding return Boolean is
+ Prev : Entity_Id;
+
+ begin
+ Prev := Homonym (Parent_Subp);
+
+ -- The visible operation that is overriden is a homonym of
+ -- the parent subprogram. We scan the homonym chain to find
+ -- the one whose alias is the subprogram we are deriving.
+
+ while Present (Prev) loop
+ if Is_Dispatching_Operation (Parent_Subp)
+ and then Present (Prev)
+ and then Ekind (Prev) = Ekind (Parent_Subp)
+ and then Alias (Prev) = Parent_Subp
+ and then Scope (Parent_Subp) = Scope (Prev)
+ and then not Is_Hidden (Prev)
+ then
+ return True;
+ end if;
+
+ Prev := Homonym (Prev);
+ end loop;
+
+ return False;
+ end Is_Private_Overriding;
+
+ ------------------
+ -- Replace_Type --
+ ------------------
+
+ procedure Replace_Type (Id, New_Id : Entity_Id) is
+ Acc_Type : Entity_Id;
+ IR : Node_Id;
+
+ begin
+ -- When the type is an anonymous access type, create a new access
+ -- type designating the derived type. This itype must be elaborated
+ -- at the point of the derivation, not on subsequent calls that may
+ -- be out of the proper scope for Gigi, so we insert a reference to
+ -- it after the derivation.
+
+ if Ekind (Etype (Id)) = E_Anonymous_Access_Type then
+ declare
+ Desig_Typ : Entity_Id := Designated_Type (Etype (Id));
+
+ begin
+ if Ekind (Desig_Typ) = E_Record_Type_With_Private
+ and then Present (Full_View (Desig_Typ))
+ and then not Is_Private_Type (Parent_Type)
+ then
+ Desig_Typ := Full_View (Desig_Typ);
+ end if;
+
+ if Base_Type (Desig_Typ) = Base_Type (Parent_Type) then
+ Acc_Type := New_Copy (Etype (Id));
+ Set_Etype (Acc_Type, Acc_Type);
+ Set_Scope (Acc_Type, New_Subp);
+
+ -- Compute size of anonymous access type.
+
+ if Is_Array_Type (Desig_Typ)
+ and then not Is_Constrained (Desig_Typ)
+ then
+ Init_Size (Acc_Type, 2 * System_Address_Size);
+ else
+ Init_Size (Acc_Type, System_Address_Size);
+ end if;
+
+ Init_Alignment (Acc_Type);
+
+ Set_Directly_Designated_Type (Acc_Type, Derived_Type);
+
+ Set_Etype (New_Id, Acc_Type);
+ Set_Scope (New_Id, New_Subp);
+
+ -- Create a reference to it.
+
+ IR := Make_Itype_Reference (Sloc (Parent (Derived_Type)));
+ Set_Itype (IR, Acc_Type);
+ Insert_After (Parent (Derived_Type), IR);
+
+ else
+ Set_Etype (New_Id, Etype (Id));
+ end if;
+ end;
+ elsif Base_Type (Etype (Id)) = Base_Type (Parent_Type)
+ or else
+ (Ekind (Etype (Id)) = E_Record_Type_With_Private
+ and then Present (Full_View (Etype (Id)))
+ and then Base_Type (Full_View (Etype (Id))) =
+ Base_Type (Parent_Type))
+ then
+
+ -- Constraint checks on formals are generated during expansion,
+ -- based on the signature of the original subprogram. The bounds
+ -- of the derived type are not relevant, and thus we can use
+ -- the base type for the formals. However, the return type may be
+ -- used in a context that requires that the proper static bounds
+ -- be used (a case statement, for example) and for those cases
+ -- we must use the derived type (first subtype), not its base.
+
+ if Etype (Id) = Parent_Type
+ and then Same_Subt
+ then
+ Set_Etype (New_Id, Derived_Type);
+ else
+ Set_Etype (New_Id, Base_Type (Derived_Type));
+ end if;
+
+ else
+ Set_Etype (New_Id, Etype (Id));
+ end if;
+ end Replace_Type;
+
+ -- Start of processing for Derive_Subprogram
+
+ begin
+ New_Subp :=
+ New_Entity (Nkind (Parent_Subp), Sloc (Derived_Type));
+ Set_Ekind (New_Subp, Ekind (Parent_Subp));
+
+ -- Check whether the inherited subprogram is a private operation that
+ -- should be inherited but not yet made visible. Such subprograms can
+ -- become visible at a later point (e.g., the private part of a public
+ -- child unit) via Declare_Inherited_Private_Subprograms. If the
+ -- following predicate is true, then this is not such a private
+ -- operation and the subprogram simply inherits the name of the parent
+ -- subprogram. Note the special check for the names of controlled
+ -- operations, which are currently exempted from being inherited with
+ -- a hidden name because they must be findable for generation of
+ -- implicit run-time calls.
+
+ if not Is_Hidden (Parent_Subp)
+ or else Is_Internal (Parent_Subp)
+ or else Is_Private_Overriding
+ or else Is_Internal_Name (Chars (Parent_Subp))
+ or else Chars (Parent_Subp) = Name_Initialize
+ or else Chars (Parent_Subp) = Name_Adjust
+ or else Chars (Parent_Subp) = Name_Finalize
+ then
+ Set_Chars (New_Subp, Chars (Parent_Subp));
+
+ -- If parent is hidden, this can be a regular derivation if the
+ -- parent is immediately visible in a non-instantiating context,
+ -- or if we are in the private part of an instance. This test
+ -- should still be refined ???
+
+ -- The test for In_Instance_Not_Visible avoids inheriting the
+ -- derived operation as a non-visible operation in cases where
+ -- the parent subprogram might not be visible now, but was
+ -- visible within the original generic, so it would be wrong
+ -- to make the inherited subprogram non-visible now. (Not
+ -- clear if this test is fully correct; are there any cases
+ -- where we should declare the inherited operation as not
+ -- visible to avoid it being overridden, e.g., when the
+ -- parent type is a generic actual with private primitives ???)
+
+ -- (they should be treated the same as other private inherited
+ -- subprograms, but it's not clear how to do this cleanly). ???
+
+ elsif (In_Open_Scopes (Scope (Base_Type (Parent_Type)))
+ and then Is_Immediately_Visible (Parent_Subp)
+ and then not In_Instance)
+ or else In_Instance_Not_Visible
+ then
+ Set_Chars (New_Subp, Chars (Parent_Subp));
+
+ -- The type is inheriting a private operation, so enter
+ -- it with a special name so it can't be overridden.
+
+ else
+ Set_Chars (New_Subp, New_External_Name (Chars (Parent_Subp), 'P'));
+ end if;
+
+ Set_Parent (New_Subp, Parent (Derived_Type));
+ Replace_Type (Parent_Subp, New_Subp);
+ Conditional_Delay (New_Subp, Parent_Subp);
+
+ Formal := First_Formal (Parent_Subp);
+ while Present (Formal) loop
+ New_Formal := New_Copy (Formal);
+
+ -- Normally we do not go copying parents, but in the case of
+ -- formals, we need to link up to the declaration (which is
+ -- the parameter specification), and it is fine to link up to
+ -- the original formal's parameter specification in this case.
+
+ Set_Parent (New_Formal, Parent (Formal));
+
+ Append_Entity (New_Formal, New_Subp);
+
+ Replace_Type (Formal, New_Formal);
+ Next_Formal (Formal);
+ end loop;
+
+ -- If this derivation corresponds to a tagged generic actual, then
+ -- primitive operations rename those of the actual. Otherwise the
+ -- primitive operations rename those of the parent type.
+
+ if No (Actual_Subp) then
+ Set_Alias (New_Subp, Parent_Subp);
+ Set_Is_Intrinsic_Subprogram (New_Subp,
+ Is_Intrinsic_Subprogram (Parent_Subp));
+
+ else
+ Set_Alias (New_Subp, Actual_Subp);
+ end if;
+
+ -- Derived subprograms of a tagged type must inherit the convention
+ -- of the parent subprogram (a requirement of AI-117). Derived
+ -- subprograms of untagged types simply get convention Ada by default.
+
+ if Is_Tagged_Type (Derived_Type) then
+ Set_Convention (New_Subp, Convention (Parent_Subp));
+ end if;
+
+ Set_Is_Imported (New_Subp, Is_Imported (Parent_Subp));
+ Set_Is_Exported (New_Subp, Is_Exported (Parent_Subp));
+
+ if Ekind (Parent_Subp) = E_Procedure then
+ Set_Is_Valued_Procedure
+ (New_Subp, Is_Valued_Procedure (Parent_Subp));
+ end if;
+
+ New_Overloaded_Entity (New_Subp, Derived_Type);
+
+ -- Check for case of a derived subprogram for the instantiation
+ -- of a formal derived tagged type, so mark the subprogram as
+ -- dispatching and inherit the dispatching attributes of the
+ -- parent subprogram. The derived subprogram is effectively a
+ -- renaming of the actual subprogram, so it needs to have the
+ -- same attributes as the actual.
+
+ if Present (Actual_Subp)
+ and then Is_Dispatching_Operation (Parent_Subp)
+ then
+ Set_Is_Dispatching_Operation (New_Subp);
+ if Present (DTC_Entity (Parent_Subp)) then
+ Set_DTC_Entity (New_Subp, DTC_Entity (Parent_Subp));
+ Set_DT_Position (New_Subp, DT_Position (Parent_Subp));
+ end if;
+ end if;
+
+ -- Indicate that a derived subprogram does not require a body
+ -- and that it does not require processing of default expressions.
+
+ Set_Has_Completion (New_Subp);
+ Set_Default_Expressions_Processed (New_Subp);
+
+ -- A derived function with a controlling result is abstract.
+ -- If the Derived_Type is a nonabstract formal generic derived
+ -- type, then inherited operations are not abstract: check is
+ -- done at instantiation time. If the derivation is for a generic
+ -- actual, the function is not abstract unless the actual is.
+
+ if Is_Generic_Type (Derived_Type)
+ and then not Is_Abstract (Derived_Type)
+ then
+ null;
+
+ elsif Is_Abstract (Alias (New_Subp))
+ or else (Is_Tagged_Type (Derived_Type)
+ and then Etype (New_Subp) = Derived_Type
+ and then No (Actual_Subp))
+ then
+ Set_Is_Abstract (New_Subp);
+ end if;
+
+ if Ekind (New_Subp) = E_Function then
+ Set_Mechanism (New_Subp, Mechanism (Parent_Subp));
+ end if;
+ end Derive_Subprogram;
+
+ ------------------------
+ -- Derive_Subprograms --
+ ------------------------
+
+ procedure Derive_Subprograms
+ (Parent_Type : Entity_Id;
+ Derived_Type : Entity_Id;
+ Generic_Actual : Entity_Id := Empty)
+ is
+ Op_List : Elist_Id := Collect_Primitive_Operations (Parent_Type);
+ Act_List : Elist_Id;
+ Act_Elmt : Elmt_Id;
+ Elmt : Elmt_Id;
+ Subp : Entity_Id;
+ New_Subp : Entity_Id := Empty;
+ Parent_Base : Entity_Id;
+
+ begin
+ if Ekind (Parent_Type) = E_Record_Type_With_Private
+ and then Has_Discriminants (Parent_Type)
+ and then Present (Full_View (Parent_Type))
+ then
+ Parent_Base := Full_View (Parent_Type);
+ else
+ Parent_Base := Parent_Type;
+ end if;
+
+ Elmt := First_Elmt (Op_List);
+
+ if Present (Generic_Actual) then
+ Act_List := Collect_Primitive_Operations (Generic_Actual);
+ Act_Elmt := First_Elmt (Act_List);
+ else
+ Act_Elmt := No_Elmt;
+ end if;
+
+ -- Literals are derived earlier in the process of building the
+ -- derived type, and are skipped here.
+
+ while Present (Elmt) loop
+ Subp := Node (Elmt);
+
+ if Ekind (Subp) /= E_Enumeration_Literal then
+ if No (Generic_Actual) then
+ Derive_Subprogram
+ (New_Subp, Subp, Derived_Type, Parent_Base);
+
+ else
+ Derive_Subprogram (New_Subp, Subp,
+ Derived_Type, Parent_Base, Node (Act_Elmt));
+ Next_Elmt (Act_Elmt);
+ end if;
+ end if;
+
+ Next_Elmt (Elmt);
+ end loop;
+ end Derive_Subprograms;
+
+ --------------------------------
+ -- Derived_Standard_Character --
+ --------------------------------
+
+ procedure Derived_Standard_Character
+ (N : Node_Id;
+ Parent_Type : Entity_Id;
+ Derived_Type : Entity_Id)
+ is
+ Loc : constant Source_Ptr := Sloc (N);
+ Def : constant Node_Id := Type_Definition (N);
+ Indic : constant Node_Id := Subtype_Indication (Def);
+ Parent_Base : constant Entity_Id := Base_Type (Parent_Type);
+ Implicit_Base : constant Entity_Id :=
+ Create_Itype
+ (E_Enumeration_Type, N, Derived_Type, 'B');
+
+ Lo : Node_Id;
+ Hi : Node_Id;
+ T : Entity_Id;
+
+ begin
+ T := Process_Subtype (Indic, N);
+
+ Set_Etype (Implicit_Base, Parent_Base);
+ Set_Size_Info (Implicit_Base, Root_Type (Parent_Type));
+ Set_RM_Size (Implicit_Base, RM_Size (Root_Type (Parent_Type)));
+
+ Set_Is_Character_Type (Implicit_Base, True);
+ Set_Has_Delayed_Freeze (Implicit_Base);
+
+ Lo := New_Copy_Tree (Type_Low_Bound (Parent_Type));
+ Hi := New_Copy_Tree (Type_High_Bound (Parent_Type));
+
+ Set_Scalar_Range (Implicit_Base,
+ Make_Range (Loc,
+ Low_Bound => Lo,
+ High_Bound => Hi));
+
+ Conditional_Delay (Derived_Type, Parent_Type);
+
+ Set_Ekind (Derived_Type, E_Enumeration_Subtype);
+ Set_Etype (Derived_Type, Implicit_Base);
+ Set_Size_Info (Derived_Type, Parent_Type);
+
+ if Unknown_RM_Size (Derived_Type) then
+ Set_RM_Size (Derived_Type, RM_Size (Parent_Type));
+ end if;
+
+ Set_Is_Character_Type (Derived_Type, True);
+
+ if Nkind (Indic) /= N_Subtype_Indication then
+ Set_Scalar_Range (Derived_Type, Scalar_Range (Implicit_Base));
+ end if;
+
+ Convert_Scalar_Bounds (N, Parent_Type, Derived_Type, Loc);
+
+ -- Because the implicit base is used in the conversion of the bounds,
+ -- we have to freeze it now. This is similar to what is done for
+ -- numeric types, and it equally suspicious, but otherwise a non-
+ -- static bound will have a reference to an unfrozen type, which is
+ -- rejected by Gigi (???).
+
+ Freeze_Before (N, Implicit_Base);
+
+ end Derived_Standard_Character;
+
+ ------------------------------
+ -- Derived_Type_Declaration --
+ ------------------------------
+
+ procedure Derived_Type_Declaration
+ (T : Entity_Id;
+ N : Node_Id;
+ Is_Completion : Boolean)
+ is
+ Def : constant Node_Id := Type_Definition (N);
+ Indic : constant Node_Id := Subtype_Indication (Def);
+ Extension : constant Node_Id := Record_Extension_Part (Def);
+ Parent_Type : Entity_Id;
+ Parent_Scope : Entity_Id;
+ Taggd : Boolean;
+
+ begin
+ Parent_Type := Find_Type_Of_Subtype_Indic (Indic);
+
+ if Parent_Type = Any_Type
+ or else Etype (Parent_Type) = Any_Type
+ or else (Is_Class_Wide_Type (Parent_Type)
+ and then Etype (Parent_Type) = T)
+ then
+ -- If Parent_Type is undefined or illegal, make new type into
+ -- a subtype of Any_Type, and set a few attributes to prevent
+ -- cascaded errors. If this is a self-definition, emit error now.
+
+ if T = Parent_Type
+ or else T = Etype (Parent_Type)
+ then
+ Error_Msg_N ("type cannot be used in its own definition", Indic);
+ end if;
+
+ Set_Ekind (T, Ekind (Parent_Type));
+ Set_Etype (T, Any_Type);
+ Set_Scalar_Range (T, Scalar_Range (Any_Type));
+
+ if Is_Tagged_Type (T) then
+ Set_Primitive_Operations (T, New_Elmt_List);
+ end if;
+ return;
+
+ elsif Is_Unchecked_Union (Parent_Type) then
+ Error_Msg_N ("cannot derive from Unchecked_Union type", N);
+ end if;
+
+ -- Only composite types other than array types are allowed to have
+ -- discriminants.
+
+ if Present (Discriminant_Specifications (N))
+ and then (Is_Elementary_Type (Parent_Type)
+ or else Is_Array_Type (Parent_Type))
+ and then not Error_Posted (N)
+ then
+ Error_Msg_N
+ ("elementary or array type cannot have discriminants",
+ Defining_Identifier (First (Discriminant_Specifications (N))));
+ Set_Has_Discriminants (T, False);
+ end if;
+
+ -- In Ada 83, a derived type defined in a package specification cannot
+ -- be used for further derivation until the end of its visible part.
+ -- Note that derivation in the private part of the package is allowed.
+
+ if Ada_83
+ and then Is_Derived_Type (Parent_Type)
+ and then In_Visible_Part (Scope (Parent_Type))
+ then
+ if Ada_83 and then Comes_From_Source (Indic) then
+ Error_Msg_N
+ ("(Ada 83): premature use of type for derivation", Indic);
+ end if;
+ end if;
+
+ -- Check for early use of incomplete or private type
+
+ if Ekind (Parent_Type) = E_Void
+ or else Ekind (Parent_Type) = E_Incomplete_Type
+ then
+ Error_Msg_N ("premature derivation of incomplete type", Indic);
+ return;
+
+ elsif (Is_Incomplete_Or_Private_Type (Parent_Type)
+ and then not Is_Generic_Type (Parent_Type)
+ and then not Is_Generic_Type (Root_Type (Parent_Type))
+ and then not Is_Generic_Actual_Type (Parent_Type))
+ or else Has_Private_Component (Parent_Type)
+ then
+ -- The ancestor type of a formal type can be incomplete, in which
+ -- case only the operations of the partial view are available in
+ -- the generic. Subsequent checks may be required when the full
+ -- view is analyzed, to verify that derivation from a tagged type
+ -- has an extension.
+
+ if Nkind (Original_Node (N)) = N_Formal_Type_Declaration then
+ null;
+
+ elsif No (Underlying_Type (Parent_Type))
+ or else Has_Private_Component (Parent_Type)
+ then
+ Error_Msg_N
+ ("premature derivation of derived or private type", Indic);
+
+ -- Flag the type itself as being in error, this prevents some
+ -- nasty problems with people looking at the malformed type.
+
+ Set_Error_Posted (T);
+
+ -- Check that within the immediate scope of an untagged partial
+ -- view it's illegal to derive from the partial view if the
+ -- full view is tagged. (7.3(7))
+
+ -- We verify that the Parent_Type is a partial view by checking
+ -- that it is not a Full_Type_Declaration (i.e. a private type or
+ -- private extension declaration), to distinguish a partial view
+ -- from a derivation from a private type which also appears as
+ -- E_Private_Type.
+
+ elsif Present (Full_View (Parent_Type))
+ and then Nkind (Parent (Parent_Type)) /= N_Full_Type_Declaration
+ and then not Is_Tagged_Type (Parent_Type)
+ and then Is_Tagged_Type (Full_View (Parent_Type))
+ then
+ Parent_Scope := Scope (T);
+ while Present (Parent_Scope)
+ and then Parent_Scope /= Standard_Standard
+ loop
+ if Parent_Scope = Scope (Parent_Type) then
+ Error_Msg_N
+ ("premature derivation from type with tagged full view",
+ Indic);
+ end if;
+
+ Parent_Scope := Scope (Parent_Scope);
+ end loop;
+ end if;
+ end if;
+
+ -- Check that form of derivation is appropriate
+
+ Taggd := Is_Tagged_Type (Parent_Type);
+
+ -- Perhaps the parent type should be changed to the class-wide type's
+ -- specific type in this case to prevent cascading errors ???
+
+ if Present (Extension) and then Is_Class_Wide_Type (Parent_Type) then
+ Error_Msg_N ("parent type must not be a class-wide type", Indic);
+ return;
+ end if;
+
+ if Present (Extension) and then not Taggd then
+ Error_Msg_N
+ ("type derived from untagged type cannot have extension", Indic);
+
+ elsif No (Extension) and then Taggd then
+ -- If this is within a private part (or body) of a generic
+ -- instantiation then the derivation is allowed (the parent
+ -- type can only appear tagged in this case if it's a generic
+ -- actual type, since it would otherwise have been rejected
+ -- in the analysis of the generic template).
+
+ if not Is_Generic_Actual_Type (Parent_Type)
+ or else In_Visible_Part (Scope (Parent_Type))
+ then
+ Error_Msg_N
+ ("type derived from tagged type must have extension", Indic);
+ end if;
+ end if;
+
+ Build_Derived_Type (N, Parent_Type, T, Is_Completion);
+ end Derived_Type_Declaration;
+
+ ----------------------------------
+ -- Enumeration_Type_Declaration --
+ ----------------------------------
+
+ procedure Enumeration_Type_Declaration (T : Entity_Id; Def : Node_Id) is
+ Ev : Uint;
+ L : Node_Id;
+ R_Node : Node_Id;
+ B_Node : Node_Id;
+
+ begin
+ -- Create identifier node representing lower bound
+
+ B_Node := New_Node (N_Identifier, Sloc (Def));
+ L := First (Literals (Def));
+ Set_Chars (B_Node, Chars (L));
+ Set_Entity (B_Node, L);
+ Set_Etype (B_Node, T);
+ Set_Is_Static_Expression (B_Node, True);
+
+ R_Node := New_Node (N_Range, Sloc (Def));
+ Set_Low_Bound (R_Node, B_Node);
+
+ Set_Ekind (T, E_Enumeration_Type);
+ Set_First_Literal (T, L);
+ Set_Etype (T, T);
+ Set_Is_Constrained (T);
+
+ Ev := Uint_0;
+
+ -- Loop through literals of enumeration type setting pos and rep values
+ -- except that if the Ekind is already set, then it means that the
+ -- literal was already constructed (case of a derived type declaration
+ -- and we should not disturb the Pos and Rep values.
+
+ while Present (L) loop
+ if Ekind (L) /= E_Enumeration_Literal then
+ Set_Ekind (L, E_Enumeration_Literal);
+ Set_Enumeration_Pos (L, Ev);
+ Set_Enumeration_Rep (L, Ev);
+ Set_Is_Known_Valid (L, True);
+ end if;
+
+ Set_Etype (L, T);
+ New_Overloaded_Entity (L);
+ Generate_Definition (L);
+ Set_Convention (L, Convention_Intrinsic);
+
+ if Nkind (L) = N_Defining_Character_Literal then
+ Set_Is_Character_Type (T, True);
+ end if;
+
+ Ev := Ev + 1;
+ Next (L);
+ end loop;
+
+ -- Now create a node representing upper bound
+
+ B_Node := New_Node (N_Identifier, Sloc (Def));
+ Set_Chars (B_Node, Chars (Last (Literals (Def))));
+ Set_Entity (B_Node, Last (Literals (Def)));
+ Set_Etype (B_Node, T);
+ Set_Is_Static_Expression (B_Node, True);
+
+ Set_High_Bound (R_Node, B_Node);
+ Set_Scalar_Range (T, R_Node);
+ Set_RM_Size (T, UI_From_Int (Minimum_Size (T)));
+ Set_Enum_Esize (T);
+
+ -- Set Discard_Names if configuration pragma setg, or if there is
+ -- a parameterless pragma in the current declarative region
+
+ if Global_Discard_Names
+ or else Discard_Names (Scope (T))
+ then
+ Set_Discard_Names (T);
+ end if;
+ end Enumeration_Type_Declaration;
+
+ --------------------------
+ -- Expand_Others_Choice --
+ --------------------------
+
+ procedure Expand_Others_Choice
+ (Case_Table : Choice_Table_Type;
+ Others_Choice : Node_Id;
+ Choice_Type : Entity_Id)
+ is
+ Choice : Node_Id;
+ Choice_List : List_Id := New_List;
+ Exp_Lo : Node_Id;
+ Exp_Hi : Node_Id;
+ Hi : Uint;
+ Lo : Uint;
+ Loc : Source_Ptr := Sloc (Others_Choice);
+ Previous_Hi : Uint;
+
+ function Build_Choice (Value1, Value2 : Uint) return Node_Id;
+ -- Builds a node representing the missing choices given by the
+ -- Value1 and Value2. A N_Range node is built if there is more than
+ -- one literal value missing. Otherwise a single N_Integer_Literal,
+ -- N_Identifier or N_Character_Literal is built depending on what
+ -- Choice_Type is.
+
+ function Lit_Of (Value : Uint) return Node_Id;
+ -- Returns the Node_Id for the enumeration literal corresponding to the
+ -- position given by Value within the enumeration type Choice_Type.
+
+ ------------------
+ -- Build_Choice --
+ ------------------
+
+ function Build_Choice (Value1, Value2 : Uint) return Node_Id is
+ Lit_Node : Node_Id;
+ Lo, Hi : Node_Id;
+
+ begin
+ -- If there is only one choice value missing between Value1 and
+ -- Value2, build an integer or enumeration literal to represent it.
+
+ if (Value2 - Value1) = 0 then
+ if Is_Integer_Type (Choice_Type) then
+ Lit_Node := Make_Integer_Literal (Loc, Value1);
+ Set_Etype (Lit_Node, Choice_Type);
+ else
+ Lit_Node := Lit_Of (Value1);
+ end if;
+
+ -- Otherwise is more that one choice value that is missing between
+ -- Value1 and Value2, therefore build a N_Range node of either
+ -- integer or enumeration literals.
+
+ else
+ if Is_Integer_Type (Choice_Type) then
+ Lo := Make_Integer_Literal (Loc, Value1);
+ Set_Etype (Lo, Choice_Type);
+ Hi := Make_Integer_Literal (Loc, Value2);
+ Set_Etype (Hi, Choice_Type);
+ Lit_Node :=
+ Make_Range (Loc,
+ Low_Bound => Lo,
+ High_Bound => Hi);
+
+ else
+ Lit_Node :=
+ Make_Range (Loc,
+ Low_Bound => Lit_Of (Value1),
+ High_Bound => Lit_Of (Value2));
+ end if;
+ end if;
+
+ return Lit_Node;
+ end Build_Choice;
+
+ ------------
+ -- Lit_Of --
+ ------------
+
+ function Lit_Of (Value : Uint) return Node_Id is
+ Lit : Entity_Id;
+
+ begin
+ -- In the case where the literal is of type Character, there needs
+ -- to be some special handling since there is no explicit chain
+ -- of literals to search. Instead, a N_Character_Literal node
+ -- is created with the appropriate Char_Code and Chars fields.
+
+ if Root_Type (Choice_Type) = Standard_Character then
+ Set_Character_Literal_Name (Char_Code (UI_To_Int (Value)));
+ Lit := New_Node (N_Character_Literal, Loc);
+ Set_Chars (Lit, Name_Find);
+ Set_Char_Literal_Value (Lit, Char_Code (UI_To_Int (Value)));
+ Set_Etype (Lit, Choice_Type);
+ Set_Is_Static_Expression (Lit, True);
+ return Lit;
+
+ -- Otherwise, iterate through the literals list of Choice_Type
+ -- "Value" number of times until the desired literal is reached
+ -- and then return an occurrence of it.
+
+ else
+ Lit := First_Literal (Choice_Type);
+ for J in 1 .. UI_To_Int (Value) loop
+ Next_Literal (Lit);
+ end loop;
+
+ return New_Occurrence_Of (Lit, Loc);
+ end if;
+ end Lit_Of;
+
+ -- Start of processing for Expand_Others_Choice
+
+ begin
+ if Case_Table'Length = 0 then
+
+ -- Pathological case: only an others case is present.
+ -- The others case covers the full range of the type.
+
+ if Is_Static_Subtype (Choice_Type) then
+ Choice := New_Occurrence_Of (Choice_Type, Loc);
+ else
+ Choice := New_Occurrence_Of (Base_Type (Choice_Type), Loc);
+ end if;
+
+ Set_Others_Discrete_Choices (Others_Choice, New_List (Choice));
+ return;
+ end if;
+
+ -- Establish the bound values for the variant depending upon whether
+ -- the type of the discriminant name is static or not.
+
+ if Is_OK_Static_Subtype (Choice_Type) then
+ Exp_Lo := Type_Low_Bound (Choice_Type);
+ Exp_Hi := Type_High_Bound (Choice_Type);
+ else
+ Exp_Lo := Type_Low_Bound (Base_Type (Choice_Type));
+ Exp_Hi := Type_High_Bound (Base_Type (Choice_Type));
+ end if;
+
+ Lo := Expr_Value (Case_Table (Case_Table'First).Lo);
+ Hi := Expr_Value (Case_Table (Case_Table'First).Hi);
+ Previous_Hi := Expr_Value (Case_Table (Case_Table'First).Hi);
+
+ -- Build the node for any missing choices that are smaller than any
+ -- explicit choices given in the variant.
+
+ if Expr_Value (Exp_Lo) < Lo then
+ Append (Build_Choice (Expr_Value (Exp_Lo), Lo - 1), Choice_List);
+ end if;
+
+ -- Build the nodes representing any missing choices that lie between
+ -- the explicit ones given in the variant.
+
+ for J in Case_Table'First + 1 .. Case_Table'Last loop
+ Lo := Expr_Value (Case_Table (J).Lo);
+ Hi := Expr_Value (Case_Table (J).Hi);
+
+ if Lo /= (Previous_Hi + 1) then
+ Append_To (Choice_List, Build_Choice (Previous_Hi + 1, Lo - 1));
+ end if;
+
+ Previous_Hi := Hi;
+ end loop;
+
+ -- Build the node for any missing choices that are greater than any
+ -- explicit choices given in the variant.
+
+ if Expr_Value (Exp_Hi) > Hi then
+ Append (Build_Choice (Hi + 1, Expr_Value (Exp_Hi)), Choice_List);
+ end if;
+
+ Set_Others_Discrete_Choices (Others_Choice, Choice_List);
+ end Expand_Others_Choice;
+
+ ---------------------------------
+ -- Expand_To_Girder_Constraint --
+ ---------------------------------
+
+ function Expand_To_Girder_Constraint
+ (Typ : Entity_Id;
+ Constraint : Elist_Id)
+ return Elist_Id
+ is
+ Explicitly_Discriminated_Type : Entity_Id;
+ Expansion : Elist_Id;
+ Discriminant : Entity_Id;
+
+ function Type_With_Explicit_Discrims (Id : Entity_Id) return Entity_Id;
+ -- Find the nearest type that actually specifies discriminants.
+
+ ---------------------------------
+ -- Type_With_Explicit_Discrims --
+ ---------------------------------
+
+ function Type_With_Explicit_Discrims (Id : Entity_Id) return Entity_Id is
+ Typ : constant E := Base_Type (Id);
+
+ begin
+ if Ekind (Typ) in Incomplete_Or_Private_Kind then
+ if Present (Full_View (Typ)) then
+ return Type_With_Explicit_Discrims (Full_View (Typ));
+ end if;
+
+ else
+ if Has_Discriminants (Typ) then
+ return Typ;
+ end if;
+ end if;
+
+ if Etype (Typ) = Typ then
+ return Empty;
+ elsif Has_Discriminants (Typ) then
+ return Typ;
+ else
+ return Type_With_Explicit_Discrims (Etype (Typ));
+ end if;
+
+ end Type_With_Explicit_Discrims;
+
+ -- Start of processing for Expand_To_Girder_Constraint
+
+ begin
+ if No (Constraint)
+ or else Is_Empty_Elmt_List (Constraint)
+ then
+ return No_Elist;
+ end if;
+
+ Explicitly_Discriminated_Type := Type_With_Explicit_Discrims (Typ);
+
+ if No (Explicitly_Discriminated_Type) then
+ return No_Elist;
+ end if;
+
+ Expansion := New_Elmt_List;
+
+ Discriminant :=
+ First_Girder_Discriminant (Explicitly_Discriminated_Type);
+
+ while Present (Discriminant) loop
+
+ Append_Elmt (
+ Get_Discriminant_Value (
+ Discriminant, Explicitly_Discriminated_Type, Constraint),
+ Expansion);
+
+ Next_Girder_Discriminant (Discriminant);
+ end loop;
+
+ return Expansion;
+ end Expand_To_Girder_Constraint;
+
+ --------------------
+ -- Find_Type_Name --
+ --------------------
+
+ function Find_Type_Name (N : Node_Id) return Entity_Id is
+ Id : constant Entity_Id := Defining_Identifier (N);
+ Prev : Entity_Id;
+ New_Id : Entity_Id;
+ Prev_Par : Node_Id;
+
+ begin
+ -- Find incomplete declaration, if some was given.
+
+ Prev := Current_Entity_In_Scope (Id);
+
+ if Present (Prev) then
+
+ -- Previous declaration exists. Error if not incomplete/private case
+ -- except if previous declaration is implicit, etc. Enter_Name will
+ -- emit error if appropriate.
+
+ Prev_Par := Parent (Prev);
+
+ if not Is_Incomplete_Or_Private_Type (Prev) then
+ Enter_Name (Id);
+ New_Id := Id;
+
+ elsif Nkind (N) /= N_Full_Type_Declaration
+ and then Nkind (N) /= N_Task_Type_Declaration
+ and then Nkind (N) /= N_Protected_Type_Declaration
+ then
+ -- Completion must be a full type declarations (RM 7.3(4))
+
+ Error_Msg_Sloc := Sloc (Prev);
+ Error_Msg_NE ("invalid completion of }", Id, Prev);
+
+ -- Set scope of Id to avoid cascaded errors. Entity is never
+ -- examined again, except when saving globals in generics.
+
+ Set_Scope (Id, Current_Scope);
+ New_Id := Id;
+
+ -- Case of full declaration of incomplete type
+
+ elsif Ekind (Prev) = E_Incomplete_Type then
+
+ -- Indicate that the incomplete declaration has a matching
+ -- full declaration. The defining occurrence of the incomplete
+ -- declaration remains the visible one, and the procedure
+ -- Get_Full_View dereferences it whenever the type is used.
+
+ if Present (Full_View (Prev)) then
+ Error_Msg_NE ("invalid redeclaration of }", Id, Prev);
+ end if;
+
+ Set_Full_View (Prev, Id);
+ Append_Entity (Id, Current_Scope);
+ Set_Is_Public (Id, Is_Public (Prev));
+ Set_Is_Internal (Id);
+ New_Id := Prev;
+
+ -- Case of full declaration of private type
+
+ else
+ if Nkind (Parent (Prev)) /= N_Private_Extension_Declaration then
+ if Etype (Prev) /= Prev then
+
+ -- Prev is a private subtype or a derived type, and needs
+ -- no completion.
+
+ Error_Msg_NE ("invalid redeclaration of }", Id, Prev);
+ New_Id := Id;
+
+ elsif Ekind (Prev) = E_Private_Type
+ and then
+ (Nkind (N) = N_Task_Type_Declaration
+ or else Nkind (N) = N_Protected_Type_Declaration)
+ then
+ Error_Msg_N
+ ("completion of nonlimited type cannot be limited", N);
+ end if;
+
+ elsif Nkind (N) /= N_Full_Type_Declaration
+ or else Nkind (Type_Definition (N)) /= N_Derived_Type_Definition
+ then
+ Error_Msg_N ("full view of private extension must be"
+ & " an extension", N);
+
+ elsif not (Abstract_Present (Parent (Prev)))
+ and then Abstract_Present (Type_Definition (N))
+ then
+ Error_Msg_N ("full view of non-abstract extension cannot"
+ & " be abstract", N);
+ end if;
+
+ if not In_Private_Part (Current_Scope) then
+ Error_Msg_N
+ ("declaration of full view must appear in private part", N);
+ end if;
+
+ Copy_And_Swap (Prev, Id);
+ Set_Full_View (Id, Prev);
+ Set_Has_Private_Declaration (Prev);
+ Set_Has_Private_Declaration (Id);
+ New_Id := Prev;
+ end if;
+
+ -- Verify that full declaration conforms to incomplete one
+
+ if Is_Incomplete_Or_Private_Type (Prev)
+ and then Present (Discriminant_Specifications (Prev_Par))
+ then
+ if Present (Discriminant_Specifications (N)) then
+ if Ekind (Prev) = E_Incomplete_Type then
+ Check_Discriminant_Conformance (N, Prev, Prev);
+ else
+ Check_Discriminant_Conformance (N, Prev, Id);
+ end if;
+
+ else
+ Error_Msg_N
+ ("missing discriminants in full type declaration", N);
+
+ -- To avoid cascaded errors on subsequent use, share the
+ -- discriminants of the partial view.
+
+ Set_Discriminant_Specifications (N,
+ Discriminant_Specifications (Prev_Par));
+ end if;
+ end if;
+
+ -- A prior untagged private type can have an associated
+ -- class-wide type due to use of the class attribute,
+ -- and in this case also the full type is required to
+ -- be tagged.
+
+ if Is_Type (Prev)
+ and then (Is_Tagged_Type (Prev)
+ or else Present (Class_Wide_Type (Prev)))
+ then
+ -- The full declaration is either a tagged record or an
+ -- extension otherwise this is an error
+
+ if Nkind (Type_Definition (N)) = N_Record_Definition then
+ if not Tagged_Present (Type_Definition (N)) then
+ Error_Msg_NE
+ ("full declaration of } must be tagged", Prev, Id);
+ Set_Is_Tagged_Type (Id);
+ Set_Primitive_Operations (Id, New_Elmt_List);
+ end if;
+
+ elsif Nkind (Type_Definition (N)) = N_Derived_Type_Definition then
+ if No (Record_Extension_Part (Type_Definition (N))) then
+ Error_Msg_NE (
+ "full declaration of } must be a record extension",
+ Prev, Id);
+ Set_Is_Tagged_Type (Id);
+ Set_Primitive_Operations (Id, New_Elmt_List);
+ end if;
+
+ else
+ Error_Msg_NE
+ ("full declaration of } must be a tagged type", Prev, Id);
+
+ end if;
+ end if;
+
+ return New_Id;
+
+ else
+ -- New type declaration
+
+ Enter_Name (Id);
+ return Id;
+ end if;
+ end Find_Type_Name;
+
+ -------------------------
+ -- Find_Type_Of_Object --
+ -------------------------
+
+ function Find_Type_Of_Object
+ (Obj_Def : Node_Id;
+ Related_Nod : Node_Id)
+ return Entity_Id
+ is
+ Def_Kind : constant Node_Kind := Nkind (Obj_Def);
+ P : constant Node_Id := Parent (Obj_Def);
+ T : Entity_Id;
+ Nam : Name_Id;
+
+ begin
+ -- Case of an anonymous array subtype
+
+ if Def_Kind = N_Constrained_Array_Definition
+ or else Def_Kind = N_Unconstrained_Array_Definition
+ then
+ T := Empty;
+ Array_Type_Declaration (T, Obj_Def);
+
+ -- Create an explicit subtype whenever possible.
+
+ elsif Nkind (P) /= N_Component_Declaration
+ and then Def_Kind = N_Subtype_Indication
+ then
+ -- Base name of subtype on object name, which will be unique in
+ -- the current scope.
+
+ -- If this is a duplicate declaration, return base type, to avoid
+ -- generating duplicate anonymous types.
+
+ if Error_Posted (P) then
+ Analyze (Subtype_Mark (Obj_Def));
+ return Entity (Subtype_Mark (Obj_Def));
+ end if;
+
+ Nam :=
+ New_External_Name
+ (Chars (Defining_Identifier (Related_Nod)), 'S', 0, 'T');
+
+ T := Make_Defining_Identifier (Sloc (P), Nam);
+
+ Insert_Action (Obj_Def,
+ Make_Subtype_Declaration (Sloc (P),
+ Defining_Identifier => T,
+ Subtype_Indication => Relocate_Node (Obj_Def)));
+
+ -- This subtype may need freezing and it will not be done
+ -- automatically if the object declaration is not in a
+ -- declarative part. Since this is an object declaration, the
+ -- type cannot always be frozen here. Deferred constants do not
+ -- freeze their type (which often enough will be private).
+
+ if Nkind (P) = N_Object_Declaration
+ and then Constant_Present (P)
+ and then No (Expression (P))
+ then
+ null;
+
+ else
+ Insert_Actions (Obj_Def, Freeze_Entity (T, Sloc (P)));
+ end if;
+
+ else
+ T := Process_Subtype (Obj_Def, Related_Nod);
+ end if;
+
+ return T;
+ end Find_Type_Of_Object;
+
+ --------------------------------
+ -- Find_Type_Of_Subtype_Indic --
+ --------------------------------
+
+ function Find_Type_Of_Subtype_Indic (S : Node_Id) return Entity_Id is
+ Typ : Entity_Id;
+
+ begin
+ -- Case of subtype mark with a constraint
+
+ if Nkind (S) = N_Subtype_Indication then
+ Find_Type (Subtype_Mark (S));
+ Typ := Entity (Subtype_Mark (S));
+
+ if not
+ Is_Valid_Constraint_Kind (Ekind (Typ), Nkind (Constraint (S)))
+ then
+ Error_Msg_N
+ ("incorrect constraint for this kind of type", Constraint (S));
+ Rewrite (S, New_Copy_Tree (Subtype_Mark (S)));
+ end if;
+
+ -- Otherwise we have a subtype mark without a constraint
+
+ else
+ Find_Type (S);
+ Typ := Entity (S);
+ end if;
+
+ if Typ = Standard_Wide_Character
+ or else Typ = Standard_Wide_String
+ then
+ Check_Restriction (No_Wide_Characters, S);
+ end if;
+
+ return Typ;
+ end Find_Type_Of_Subtype_Indic;
+
+ -------------------------------------
+ -- Floating_Point_Type_Declaration --
+ -------------------------------------
+
+ procedure Floating_Point_Type_Declaration (T : Entity_Id; Def : Node_Id) is
+ Digs : constant Node_Id := Digits_Expression (Def);
+ Digs_Val : Uint;
+ Base_Typ : Entity_Id;
+ Implicit_Base : Entity_Id;
+ Bound : Node_Id;
+
+ function Can_Derive_From (E : Entity_Id) return Boolean;
+ -- Find if given digits value allows derivation from specified type
+
+ function Can_Derive_From (E : Entity_Id) return Boolean is
+ Spec : constant Entity_Id := Real_Range_Specification (Def);
+
+ begin
+ if Digs_Val > Digits_Value (E) then
+ return False;
+ end if;
+
+ if Present (Spec) then
+ if Expr_Value_R (Type_Low_Bound (E)) >
+ Expr_Value_R (Low_Bound (Spec))
+ then
+ return False;
+ end if;
+
+ if Expr_Value_R (Type_High_Bound (E)) <
+ Expr_Value_R (High_Bound (Spec))
+ then
+ return False;
+ end if;
+ end if;
+
+ return True;
+ end Can_Derive_From;
+
+ -- Start of processing for Floating_Point_Type_Declaration
+
+ begin
+ Check_Restriction (No_Floating_Point, Def);
+
+ -- Create an implicit base type
+
+ Implicit_Base :=
+ Create_Itype (E_Floating_Point_Type, Parent (Def), T, 'B');
+
+ -- Analyze and verify digits value
+
+ Analyze_And_Resolve (Digs, Any_Integer);
+ Check_Digits_Expression (Digs);
+ Digs_Val := Expr_Value (Digs);
+
+ -- Process possible range spec and find correct type to derive from
+
+ Process_Real_Range_Specification (Def);
+
+ if Can_Derive_From (Standard_Short_Float) then
+ Base_Typ := Standard_Short_Float;
+ elsif Can_Derive_From (Standard_Float) then
+ Base_Typ := Standard_Float;
+ elsif Can_Derive_From (Standard_Long_Float) then
+ Base_Typ := Standard_Long_Float;
+ elsif Can_Derive_From (Standard_Long_Long_Float) then
+ Base_Typ := Standard_Long_Long_Float;
+
+ -- If we can't derive from any existing type, use long long float
+ -- and give appropriate message explaining the problem.
+
+ else
+ Base_Typ := Standard_Long_Long_Float;
+
+ if Digs_Val >= Digits_Value (Standard_Long_Long_Float) then
+ Error_Msg_Uint_1 := Digits_Value (Standard_Long_Long_Float);
+ Error_Msg_N ("digits value out of range, maximum is ^", Digs);
+
+ else
+ Error_Msg_N
+ ("range too large for any predefined type",
+ Real_Range_Specification (Def));
+ end if;
+ end if;
+
+ -- If there are bounds given in the declaration use them as the bounds
+ -- of the type, otherwise use the bounds of the predefined base type
+ -- that was chosen based on the Digits value.
+
+ if Present (Real_Range_Specification (Def)) then
+ Set_Scalar_Range (T, Real_Range_Specification (Def));
+ Set_Is_Constrained (T);
+
+ -- The bounds of this range must be converted to machine numbers
+ -- in accordance with RM 4.9(38).
+
+ Bound := Type_Low_Bound (T);
+
+ if Nkind (Bound) = N_Real_Literal then
+ Set_Realval (Bound, Machine (Base_Typ, Realval (Bound), Round));
+ Set_Is_Machine_Number (Bound);
+ end if;
+
+ Bound := Type_High_Bound (T);
+
+ if Nkind (Bound) = N_Real_Literal then
+ Set_Realval (Bound, Machine (Base_Typ, Realval (Bound), Round));
+ Set_Is_Machine_Number (Bound);
+ end if;
+
+ else
+ Set_Scalar_Range (T, Scalar_Range (Base_Typ));
+ end if;
+
+ -- Complete definition of implicit base and declared first subtype
+
+ Set_Etype (Implicit_Base, Base_Typ);
+
+ Set_Scalar_Range (Implicit_Base, Scalar_Range (Base_Typ));
+ Set_Size_Info (Implicit_Base, (Base_Typ));
+ Set_RM_Size (Implicit_Base, RM_Size (Base_Typ));
+ Set_First_Rep_Item (Implicit_Base, First_Rep_Item (Base_Typ));
+ Set_Digits_Value (Implicit_Base, Digits_Value (Base_Typ));
+ Set_Vax_Float (Implicit_Base, Vax_Float (Base_Typ));
+
+ Set_Ekind (T, E_Floating_Point_Subtype);
+ Set_Etype (T, Implicit_Base);
+
+ Set_Size_Info (T, (Implicit_Base));
+ Set_RM_Size (T, RM_Size (Implicit_Base));
+ Set_First_Rep_Item (T, First_Rep_Item (Implicit_Base));
+ Set_Digits_Value (T, Digs_Val);
+
+ end Floating_Point_Type_Declaration;
+
+ ----------------------------
+ -- Get_Discriminant_Value --
+ ----------------------------
+
+ -- This is the situation...
+
+ -- There is a non-derived type
+
+ -- type T0 (Dx, Dy, Dz...)
+
+ -- There are zero or more levels of derivation, with each
+ -- derivation either purely inheriting the discriminants, or
+ -- defining its own.
+
+ -- type Ti is new Ti-1
+ -- or
+ -- type Ti (Dw) is new Ti-1(Dw, 1, X+Y)
+ -- or
+ -- subtype Ti is ...
+
+ -- The subtype issue is avoided by the use of
+ -- Original_Record_Component, and the fact that derived subtypes
+ -- also derive the constraits.
+
+ -- This chain leads back from
+
+ -- Typ_For_Constraint
+
+ -- Typ_For_Constraint has discriminants, and the value for each
+ -- discriminant is given by its corresponding Elmt of Constraints.
+
+ -- Discriminant is some discriminant in this hierarchy.
+
+ -- We need to return its value.
+
+ -- We do this by recursively searching each level, and looking for
+ -- Discriminant. Once we get to the bottom, we start backing up
+ -- returning the value for it which may in turn be a discriminant
+ -- further up, so on the backup we continue the substitution.
+
+ function Get_Discriminant_Value
+ (Discriminant : Entity_Id;
+ Typ_For_Constraint : Entity_Id;
+ Constraint : Elist_Id)
+ return Node_Id
+ is
+ function Recurse
+ (Ti : Entity_Id;
+ Discrim_Values : Elist_Id;
+ Girder_Discrim_Values : Boolean)
+ return Node_Or_Entity_Id;
+ -- This is the routine that performs the recursive search of levels
+ -- as described above.
+
+ function Recurse
+ (Ti : Entity_Id;
+ Discrim_Values : Elist_Id;
+ Girder_Discrim_Values : Boolean)
+ return Node_Or_Entity_Id
+ is
+ Assoc : Elmt_Id;
+ Disc : Entity_Id;
+ Result : Node_Or_Entity_Id;
+ Result_Entity : Node_Id;
+
+ begin
+ -- If inappropriate type, return Error, this happens only in
+ -- cascaded error situations, and we want to avoid a blow up.
+
+ if not Is_Composite_Type (Ti) or else Is_Array_Type (Ti) then
+ return Error;
+ end if;
+
+ -- Look deeper if possible. Use Girder_Constraints only for
+ -- untagged types. For tagged types use the given constraint.
+ -- This asymmetry needs explanation???
+
+ if not Girder_Discrim_Values
+ and then Present (Girder_Constraint (Ti))
+ and then not Is_Tagged_Type (Ti)
+ then
+ Result := Recurse (Ti, Girder_Constraint (Ti), True);
+ else
+ declare
+ Td : Entity_Id := Etype (Ti);
+ begin
+
+ if Td = Ti then
+ Result := Discriminant;
+
+ else
+ if Present (Girder_Constraint (Ti)) then
+ Result :=
+ Recurse (Td, Girder_Constraint (Ti), True);
+ else
+ Result :=
+ Recurse (Td, Discrim_Values, Girder_Discrim_Values);
+ end if;
+ end if;
+ end;
+ end if;
+
+ -- Extra underlying places to search, if not found above. For
+ -- concurrent types, the relevant discriminant appears in the
+ -- corresponding record. For a type derived from a private type
+ -- without discriminant, the full view inherits the discriminants
+ -- of the full view of the parent.
+
+ if Result = Discriminant then
+ if Is_Concurrent_Type (Ti)
+ and then Present (Corresponding_Record_Type (Ti))
+ then
+ Result :=
+ Recurse (
+ Corresponding_Record_Type (Ti),
+ Discrim_Values,
+ Girder_Discrim_Values);
+
+ elsif Is_Private_Type (Ti)
+ and then not Has_Discriminants (Ti)
+ and then Present (Full_View (Ti))
+ and then Etype (Full_View (Ti)) /= Ti
+ then
+ Result :=
+ Recurse (
+ Full_View (Ti),
+ Discrim_Values,
+ Girder_Discrim_Values);
+ end if;
+ end if;
+
+ -- If Result is not a (reference to a) discriminant,
+ -- return it, otherwise set Result_Entity to the discriminant.
+
+ if Nkind (Result) = N_Defining_Identifier then
+
+ pragma Assert (Result = Discriminant);
+
+ Result_Entity := Result;
+
+ else
+ if not Denotes_Discriminant (Result) then
+ return Result;
+ end if;
+
+ Result_Entity := Entity (Result);
+ end if;
+
+ -- See if this level of derivation actually has discriminants
+ -- because tagged derivations can add them, hence the lower
+ -- levels need not have any.
+
+ if not Has_Discriminants (Ti) then
+ return Result;
+ end if;
+
+ -- Scan Ti's discriminants for Result_Entity,
+ -- and return its corresponding value, if any.
+
+ Result_Entity := Original_Record_Component (Result_Entity);
+
+ Assoc := First_Elmt (Discrim_Values);
+
+ if Girder_Discrim_Values then
+ Disc := First_Girder_Discriminant (Ti);
+ else
+ Disc := First_Discriminant (Ti);
+ end if;
+
+ while Present (Disc) loop
+
+ pragma Assert (Present (Assoc));
+
+ if Original_Record_Component (Disc) = Result_Entity then
+ return Node (Assoc);
+ end if;
+
+ Next_Elmt (Assoc);
+
+ if Girder_Discrim_Values then
+ Next_Girder_Discriminant (Disc);
+ else
+ Next_Discriminant (Disc);
+ end if;
+ end loop;
+
+ -- Could not find it
+ --
+ return Result;
+ end Recurse;
+
+ Result : Node_Or_Entity_Id;
+
+ -- Start of processing for Get_Discriminant_Value
+
+ begin
+ -- ??? this routine is a gigantic mess and will be deleted.
+ -- for the time being just test for the trivial case before calling
+ -- recurse.
+
+ if Base_Type (Scope (Discriminant)) = Base_Type (Typ_For_Constraint) then
+ declare
+ D : Entity_Id := First_Discriminant (Typ_For_Constraint);
+ E : Elmt_Id := First_Elmt (Constraint);
+ begin
+ while Present (D) loop
+ if Chars (D) = Chars (Discriminant) then
+ return Node (E);
+ end if;
+
+ Next_Discriminant (D);
+ Next_Elmt (E);
+ end loop;
+ end;
+ end if;
+
+ Result := Recurse (Typ_For_Constraint, Constraint, False);
+
+ -- ??? hack to disappear when this routine is gone
+
+ if Nkind (Result) = N_Defining_Identifier then
+ declare
+ D : Entity_Id := First_Discriminant (Typ_For_Constraint);
+ E : Elmt_Id := First_Elmt (Constraint);
+ begin
+ while Present (D) loop
+ if Corresponding_Discriminant (D) = Discriminant then
+ return Node (E);
+ end if;
+
+ Next_Discriminant (D);
+ Next_Elmt (E);
+ end loop;
+ end;
+ end if;
+
+ pragma Assert (Nkind (Result) /= N_Defining_Identifier);
+ return Result;
+ end Get_Discriminant_Value;
+
+ --------------------------
+ -- Has_Range_Constraint --
+ --------------------------
+
+ function Has_Range_Constraint (N : Node_Id) return Boolean is
+ C : constant Node_Id := Constraint (N);
+
+ begin
+ if Nkind (C) = N_Range_Constraint then
+ return True;
+
+ elsif Nkind (C) = N_Digits_Constraint then
+ return
+ Is_Decimal_Fixed_Point_Type (Entity (Subtype_Mark (N)))
+ or else
+ Present (Range_Constraint (C));
+
+ elsif Nkind (C) = N_Delta_Constraint then
+ return Present (Range_Constraint (C));
+
+ else
+ return False;
+ end if;
+ end Has_Range_Constraint;
+
+ ------------------------
+ -- Inherit_Components --
+ ------------------------
+
+ function Inherit_Components
+ (N : Node_Id;
+ Parent_Base : Entity_Id;
+ Derived_Base : Entity_Id;
+ Is_Tagged : Boolean;
+ Inherit_Discr : Boolean;
+ Discs : Elist_Id)
+ return Elist_Id
+ is
+ Assoc_List : Elist_Id := New_Elmt_List;
+
+ procedure Inherit_Component
+ (Old_C : Entity_Id;
+ Plain_Discrim : Boolean := False;
+ Girder_Discrim : Boolean := False);
+ -- Inherits component Old_C from Parent_Base to the Derived_Base.
+ -- If Plain_Discrim is True, Old_C is a discriminant.
+ -- If Girder_Discrim is True, Old_C is a girder discriminant.
+ -- If they are both false then Old_C is a regular component.
+
+ -----------------------
+ -- Inherit_Component --
+ -----------------------
+
+ procedure Inherit_Component
+ (Old_C : Entity_Id;
+ Plain_Discrim : Boolean := False;
+ Girder_Discrim : Boolean := False)
+ is
+ New_C : Entity_Id := New_Copy (Old_C);
+
+ Discrim : Entity_Id;
+ Corr_Discrim : Entity_Id;
+
+ begin
+ pragma Assert (not Is_Tagged or else not Girder_Discrim);
+
+ Set_Parent (New_C, Parent (Old_C));
+
+ -- Regular discriminants and components must be inserted
+ -- in the scope of the Derived_Base. Do it here.
+
+ if not Girder_Discrim then
+ Enter_Name (New_C);
+ end if;
+
+ -- For tagged types the Original_Record_Component must point to
+ -- whatever this field was pointing to in the parent type. This has
+ -- already been achieved by the call to New_Copy above.
+
+ if not Is_Tagged then
+ Set_Original_Record_Component (New_C, New_C);
+ end if;
+
+ -- If we have inherited a component then see if its Etype contains
+ -- references to Parent_Base discriminants. In this case, replace
+ -- these references with the constraints given in Discs. We do not
+ -- do this for the partial view of private types because this is
+ -- not needed (only the components of the full view will be used
+ -- for code generation) and cause problem. We also avoid this
+ -- transformation in some error situations.
+
+ if Ekind (New_C) = E_Component then
+ if (Is_Private_Type (Derived_Base)
+ and then not Is_Generic_Type (Derived_Base))
+ or else (Is_Empty_Elmt_List (Discs)
+ and then not Expander_Active)
+ then
+ Set_Etype (New_C, Etype (Old_C));
+ else
+ Set_Etype (New_C, Constrain_Component_Type (Etype (Old_C),
+ Derived_Base, N, Parent_Base, Discs));
+ end if;
+ end if;
+
+ -- In derived tagged types it is illegal to reference a non
+ -- discriminant component in the parent type. To catch this, mark
+ -- these components with an Ekind of E_Void. This will be reset in
+ -- Record_Type_Definition after processing the record extension of
+ -- the derived type.
+
+ if Is_Tagged and then Ekind (New_C) = E_Component then
+ Set_Ekind (New_C, E_Void);
+ end if;
+
+ if Plain_Discrim then
+ Set_Corresponding_Discriminant (New_C, Old_C);
+ Build_Discriminal (New_C);
+
+ -- If we are explicitely inheriting a girder discriminant it will be
+ -- completely hidden.
+
+ elsif Girder_Discrim then
+ Set_Corresponding_Discriminant (New_C, Empty);
+ Set_Discriminal (New_C, Empty);
+ Set_Is_Completely_Hidden (New_C);
+
+ -- Set the Original_Record_Component of each discriminant in the
+ -- derived base to point to the corresponding girder that we just
+ -- created.
+
+ Discrim := First_Discriminant (Derived_Base);
+ while Present (Discrim) loop
+ Corr_Discrim := Corresponding_Discriminant (Discrim);
+
+ -- Corr_Discrimm could be missing in an error situation.
+
+ if Present (Corr_Discrim)
+ and then Original_Record_Component (Corr_Discrim) = Old_C
+ then
+ Set_Original_Record_Component (Discrim, New_C);
+ end if;
+
+ Next_Discriminant (Discrim);
+ end loop;
+
+ Append_Entity (New_C, Derived_Base);
+ end if;
+
+ if not Is_Tagged then
+ Append_Elmt (Old_C, Assoc_List);
+ Append_Elmt (New_C, Assoc_List);
+ end if;
+ end Inherit_Component;
+
+ -- Variables local to Inherit_Components.
+
+ Loc : constant Source_Ptr := Sloc (N);
+
+ Parent_Discrim : Entity_Id;
+ Girder_Discrim : Entity_Id;
+ D : Entity_Id;
+
+ Component : Entity_Id;
+
+ -- Start of processing for Inherit_Components
+
+ begin
+ if not Is_Tagged then
+ Append_Elmt (Parent_Base, Assoc_List);
+ Append_Elmt (Derived_Base, Assoc_List);
+ end if;
+
+ -- Inherit parent discriminants if needed.
+
+ if Inherit_Discr then
+ Parent_Discrim := First_Discriminant (Parent_Base);
+ while Present (Parent_Discrim) loop
+ Inherit_Component (Parent_Discrim, Plain_Discrim => True);
+ Next_Discriminant (Parent_Discrim);
+ end loop;
+ end if;
+
+ -- Create explicit girder discrims for untagged types when necessary.
+
+ if not Has_Unknown_Discriminants (Derived_Base)
+ and then Has_Discriminants (Parent_Base)
+ and then not Is_Tagged
+ and then
+ (not Inherit_Discr
+ or else First_Discriminant (Parent_Base) /=
+ First_Girder_Discriminant (Parent_Base))
+ then
+ Girder_Discrim := First_Girder_Discriminant (Parent_Base);
+ while Present (Girder_Discrim) loop
+ Inherit_Component (Girder_Discrim, Girder_Discrim => True);
+ Next_Girder_Discriminant (Girder_Discrim);
+ end loop;
+ end if;
+
+ -- See if we can apply the second transformation for derived types, as
+ -- explained in point 6. in the comments above Build_Derived_Record_Type
+ -- This is achieved by appending Derived_Base discriminants into
+ -- Discs, which has the side effect of returning a non empty Discs
+ -- list to the caller of Inherit_Components, which is what we want.
+
+ if Inherit_Discr
+ and then Is_Empty_Elmt_List (Discs)
+ and then (not Is_Private_Type (Derived_Base)
+ or Is_Generic_Type (Derived_Base))
+ then
+ D := First_Discriminant (Derived_Base);
+ while Present (D) loop
+ Append_Elmt (New_Reference_To (D, Loc), Discs);
+ Next_Discriminant (D);
+ end loop;
+ end if;
+
+ -- Finally, inherit non-discriminant components unless they are not
+ -- visible because defined or inherited from the full view of the
+ -- parent. Don't inherit the _parent field of the parent type.
+
+ Component := First_Entity (Parent_Base);
+ while Present (Component) loop
+ if Ekind (Component) /= E_Component
+ or else Chars (Component) = Name_uParent
+ then
+ null;
+
+ -- If the derived type is within the parent type's declarative
+ -- region, then the components can still be inherited even though
+ -- they aren't visible at this point. This can occur for cases
+ -- such as within public child units where the components must
+ -- become visible upon entering the child unit's private part.
+
+ elsif not Is_Visible_Component (Component)
+ and then not In_Open_Scopes (Scope (Parent_Base))
+ then
+ null;
+
+ elsif Ekind (Derived_Base) = E_Private_Type
+ or else Ekind (Derived_Base) = E_Limited_Private_Type
+ then
+ null;
+
+ else
+ Inherit_Component (Component);
+ end if;
+
+ Next_Entity (Component);
+ end loop;
+
+ -- For tagged derived types, inherited discriminants cannot be used in
+ -- component declarations of the record extension part. To achieve this
+ -- we mark the inherited discriminants as not visible.
+
+ if Is_Tagged and then Inherit_Discr then
+ D := First_Discriminant (Derived_Base);
+ while Present (D) loop
+ Set_Is_Immediately_Visible (D, False);
+ Next_Discriminant (D);
+ end loop;
+ end if;
+
+ return Assoc_List;
+ end Inherit_Components;
+
+ ------------------------------
+ -- Is_Valid_Constraint_Kind --
+ ------------------------------
+
+ function Is_Valid_Constraint_Kind
+ (T_Kind : Type_Kind;
+ Constraint_Kind : Node_Kind)
+ return Boolean
+ is
+ begin
+ case T_Kind is
+
+ when Enumeration_Kind |
+ Integer_Kind =>
+ return Constraint_Kind = N_Range_Constraint;
+
+ when Decimal_Fixed_Point_Kind =>
+ return
+ Constraint_Kind = N_Digits_Constraint
+ or else
+ Constraint_Kind = N_Range_Constraint;
+
+ when Ordinary_Fixed_Point_Kind =>
+ return
+ Constraint_Kind = N_Delta_Constraint
+ or else
+ Constraint_Kind = N_Range_Constraint;
+
+ when Float_Kind =>
+ return
+ Constraint_Kind = N_Digits_Constraint
+ or else
+ Constraint_Kind = N_Range_Constraint;
+
+ when Access_Kind |
+ Array_Kind |
+ E_Record_Type |
+ E_Record_Subtype |
+ Class_Wide_Kind |
+ E_Incomplete_Type |
+ Private_Kind |
+ Concurrent_Kind =>
+ return Constraint_Kind = N_Index_Or_Discriminant_Constraint;
+
+ when others =>
+ return True; -- Error will be detected later.
+ end case;
+
+ end Is_Valid_Constraint_Kind;
+
+ --------------------------
+ -- Is_Visible_Component --
+ --------------------------
+
+ function Is_Visible_Component (C : Entity_Id) return Boolean is
+ Original_Comp : constant Entity_Id := Original_Record_Component (C);
+ Original_Scope : Entity_Id;
+
+ begin
+ if No (Original_Comp) then
+
+ -- Premature usage, or previous error
+
+ return False;
+
+ else
+ Original_Scope := Scope (Original_Comp);
+ end if;
+
+ -- This test only concern tagged types
+
+ if not Is_Tagged_Type (Original_Scope) then
+ return True;
+
+ -- If it is _Parent or _Tag, there is no visiblity issue
+
+ elsif not Comes_From_Source (Original_Comp) then
+ return True;
+
+ -- If we are in the body of an instantiation, the component is
+ -- visible even when the parent type (possibly defined in an
+ -- enclosing unit or in a parent unit) might not.
+
+ elsif In_Instance_Body then
+ return True;
+
+ -- Discriminants are always visible.
+
+ elsif Ekind (Original_Comp) = E_Discriminant
+ and then not Has_Unknown_Discriminants (Original_Scope)
+ then
+ return True;
+
+ -- If the component has been declared in an ancestor which is
+ -- currently a private type, then it is not visible. The same
+ -- applies if the component's containing type is not in an
+ -- open scope and the original component's enclosing type
+ -- is a visible full type of a private type (which can occur
+ -- in cases where an attempt is being made to reference a
+ -- component in a sibling package that is inherited from
+ -- a visible component of a type in an ancestor package;
+ -- the component in the sibling package should not be
+ -- visible even though the component it inherited from
+ -- is visible). This does not apply however in the case
+ -- where the scope of the type is a private child unit.
+ -- The latter suppression of visibility is needed for cases
+ -- that are tested in B730006.
+
+ elsif (Ekind (Original_Comp) /= E_Discriminant
+ or else Has_Unknown_Discriminants (Original_Scope))
+ and then
+ (Is_Private_Type (Original_Scope)
+ or else
+ (not Is_Private_Descendant (Scope (Base_Type (Scope (C))))
+ and then not In_Open_Scopes (Scope (Base_Type (Scope (C))))
+ and then Has_Private_Declaration (Original_Scope)))
+ then
+ return False;
+
+ -- There is another weird way in which a component may be invisible
+ -- when the private and the full view are not derived from the same
+ -- ancestor. Here is an example :
+
+ -- type A1 is tagged record F1 : integer; end record;
+ -- type A2 is new A1 with record F2 : integer; end record;
+ -- type T is new A1 with private;
+ -- private
+ -- type T is new A2 with private;
+
+ -- In this case, the full view of T inherits F1 and F2 but the
+ -- private view inherits only F1
+
+ else
+ declare
+ Ancestor : Entity_Id := Scope (C);
+
+ begin
+ loop
+ if Ancestor = Original_Scope then
+ return True;
+ elsif Ancestor = Etype (Ancestor) then
+ return False;
+ end if;
+
+ Ancestor := Etype (Ancestor);
+ end loop;
+
+ return True;
+ end;
+ end if;
+ end Is_Visible_Component;
+
+ --------------------------
+ -- Make_Class_Wide_Type --
+ --------------------------
+
+ procedure Make_Class_Wide_Type (T : Entity_Id) is
+ CW_Type : Entity_Id;
+ CW_Name : Name_Id;
+ Next_E : Entity_Id;
+
+ begin
+ -- The class wide type can have been defined by the partial view in
+ -- which case everything is already done
+
+ if Present (Class_Wide_Type (T)) then
+ return;
+ end if;
+
+ CW_Type :=
+ New_External_Entity (E_Void, Scope (T), Sloc (T), T, 'C', 0, 'T');
+
+ -- Inherit root type characteristics
+
+ CW_Name := Chars (CW_Type);
+ Next_E := Next_Entity (CW_Type);
+ Copy_Node (T, CW_Type);
+ Set_Comes_From_Source (CW_Type, False);
+ Set_Chars (CW_Type, CW_Name);
+ Set_Parent (CW_Type, Parent (T));
+ Set_Next_Entity (CW_Type, Next_E);
+ Set_Has_Delayed_Freeze (CW_Type);
+
+ -- Customize the class-wide type: It has no prim. op., it cannot be
+ -- abstract and its Etype points back to the root type
+
+ Set_Ekind (CW_Type, E_Class_Wide_Type);
+ Set_Is_Tagged_Type (CW_Type, True);
+ Set_Primitive_Operations (CW_Type, New_Elmt_List);
+ Set_Is_Abstract (CW_Type, False);
+ Set_Etype (CW_Type, T);
+ Set_Is_Constrained (CW_Type, False);
+ Set_Is_First_Subtype (CW_Type, Is_First_Subtype (T));
+ Init_Size_Align (CW_Type);
+
+ -- If this is the class_wide type of a constrained subtype, it does
+ -- not have discriminants.
+
+ Set_Has_Discriminants (CW_Type,
+ Has_Discriminants (T) and then not Is_Constrained (T));
+
+ Set_Has_Unknown_Discriminants (CW_Type, True);
+ Set_Class_Wide_Type (T, CW_Type);
+ Set_Equivalent_Type (CW_Type, Empty);
+
+ -- The class-wide type of a class-wide type is itself (RM 3.9(14))
+
+ Set_Class_Wide_Type (CW_Type, CW_Type);
+
+ end Make_Class_Wide_Type;
+
+ ----------------
+ -- Make_Index --
+ ----------------
+
+ procedure Make_Index
+ (I : Node_Id;
+ Related_Nod : Node_Id;
+ Related_Id : Entity_Id := Empty;
+ Suffix_Index : Nat := 1)
+ is
+ R : Node_Id;
+ T : Entity_Id;
+ Def_Id : Entity_Id := Empty;
+ Found : Boolean := False;
+
+ begin
+ -- For a discrete range used in a constrained array definition and
+ -- defined by a range, an implicit conversion to the predefined type
+ -- INTEGER is assumed if each bound is either a numeric literal, a named
+ -- number, or an attribute, and the type of both bounds (prior to the
+ -- implicit conversion) is the type universal_integer. Otherwise, both
+ -- bounds must be of the same discrete type, other than universal
+ -- integer; this type must be determinable independently of the
+ -- context, but using the fact that the type must be discrete and that
+ -- both bounds must have the same type.
+
+ -- Character literals also have a universal type in the absence of
+ -- of additional context, and are resolved to Standard_Character.
+
+ if Nkind (I) = N_Range then
+
+ -- The index is given by a range constraint. The bounds are known
+ -- to be of a consistent type.
+
+ if not Is_Overloaded (I) then
+ T := Etype (I);
+
+ -- If the bounds are universal, choose the specific predefined
+ -- type.
+
+ if T = Universal_Integer then
+ T := Standard_Integer;
+
+ elsif T = Any_Character then
+
+ if not Ada_83 then
+ Error_Msg_N
+ ("ambiguous character literals (could be Wide_Character)",
+ I);
+ end if;
+
+ T := Standard_Character;
+ end if;
+
+ else
+ T := Any_Type;
+
+ declare
+ Ind : Interp_Index;
+ It : Interp;
+
+ begin
+ Get_First_Interp (I, Ind, It);
+
+ while Present (It.Typ) loop
+ if Is_Discrete_Type (It.Typ) then
+
+ if Found
+ and then not Covers (It.Typ, T)
+ and then not Covers (T, It.Typ)
+ then
+ Error_Msg_N ("ambiguous bounds in discrete range", I);
+ exit;
+ else
+ T := It.Typ;
+ Found := True;
+ end if;
+ end if;
+
+ Get_Next_Interp (Ind, It);
+ end loop;
+
+ if T = Any_Type then
+ Error_Msg_N ("discrete type required for range", I);
+ Set_Etype (I, Any_Type);
+ return;
+
+ elsif T = Universal_Integer then
+ T := Standard_Integer;
+ end if;
+ end;
+ end if;
+
+ if not Is_Discrete_Type (T) then
+ Error_Msg_N ("discrete type required for range", I);
+ Set_Etype (I, Any_Type);
+ return;
+ end if;
+
+ R := I;
+ Process_Range_Expr_In_Decl (R, T, Related_Nod);
+
+ elsif Nkind (I) = N_Subtype_Indication then
+
+ -- The index is given by a subtype with a range constraint.
+
+ T := Base_Type (Entity (Subtype_Mark (I)));
+
+ if not Is_Discrete_Type (T) then
+ Error_Msg_N ("discrete type required for range", I);
+ Set_Etype (I, Any_Type);
+ return;
+ end if;
+
+ R := Range_Expression (Constraint (I));
+
+ Resolve (R, T);
+ Process_Range_Expr_In_Decl (R,
+ Entity (Subtype_Mark (I)), Related_Nod);
+
+ elsif Nkind (I) = N_Attribute_Reference then
+
+ -- The parser guarantees that the attribute is a RANGE attribute
+
+ -- Is order critical here (setting T before Resolve). If so,
+ -- document why, if not use Analyze_And_Resolve and get T after???
+
+ Analyze (I);
+ T := Etype (I);
+ Resolve (I, T);
+ R := I;
+
+ -- If none of the above, must be a subtype. We convert this to a
+ -- range attribute reference because in the case of declared first
+ -- named subtypes, the types in the range reference can be different
+ -- from the type of the entity. A range attribute normalizes the
+ -- reference and obtains the correct types for the bounds.
+
+ -- This transformation is in the nature of an expansion, is only
+ -- done if expansion is active. In particular, it is not done on
+ -- formal generic types, because we need to retain the name of the
+ -- original index for instantiation purposes.
+
+ else
+ if not Is_Entity_Name (I) or else not Is_Type (Entity (I)) then
+ Error_Msg_N ("invalid subtype mark in discrete range ", I);
+ Set_Etype (I, Any_Integer);
+ return;
+ else
+ -- The type mark may be that of an incomplete type. It is only
+ -- now that we can get the full view, previous analysis does
+ -- not look specifically for a type mark.
+
+ Set_Entity (I, Get_Full_View (Entity (I)));
+ Set_Etype (I, Entity (I));
+ Def_Id := Entity (I);
+
+ if not Is_Discrete_Type (Def_Id) then
+ Error_Msg_N ("discrete type required for index", I);
+ Set_Etype (I, Any_Type);
+ return;
+ end if;
+ end if;
+
+ if Expander_Active then
+ Rewrite (I,
+ Make_Attribute_Reference (Sloc (I),
+ Attribute_Name => Name_Range,
+ Prefix => Relocate_Node (I)));
+
+ -- The original was a subtype mark that does not freeze. This
+ -- means that the rewritten version must not freeze either.
+
+ Set_Must_Not_Freeze (I);
+ Set_Must_Not_Freeze (Prefix (I));
+
+ -- Is order critical??? if so, document why, if not
+ -- use Analyze_And_Resolve
+
+ Analyze (I);
+ T := Etype (I);
+ Resolve (I, T);
+ R := I;
+
+ else
+ -- Type is legal, nothing else to construct.
+ return;
+ end if;
+ end if;
+
+ if not Is_Discrete_Type (T) then
+ Error_Msg_N ("discrete type required for range", I);
+ Set_Etype (I, Any_Type);
+ return;
+
+ elsif T = Any_Type then
+ Set_Etype (I, Any_Type);
+ return;
+ end if;
+
+ -- We will now create the appropriate Itype to describe the
+ -- range, but first a check. If we originally had a subtype,
+ -- then we just label the range with this subtype. Not only
+ -- is there no need to construct a new subtype, but it is wrong
+ -- to do so for two reasons:
+
+ -- 1. A legality concern, if we have a subtype, it must not
+ -- freeze, and the Itype would cause freezing incorrectly
+
+ -- 2. An efficiency concern, if we created an Itype, it would
+ -- not be recognized as the same type for the purposes of
+ -- eliminating checks in some circumstances.
+
+ -- We signal this case by setting the subtype entity in Def_Id.
+
+ -- It would be nice to also do this optimization for the cases
+ -- of X'Range and also the explicit range X'First .. X'Last,
+ -- but that is not done yet (it is just an efficiency concern) ???
+
+ if No (Def_Id) then
+
+ Def_Id :=
+ Create_Itype (E_Void, Related_Nod, Related_Id, 'D', Suffix_Index);
+ Set_Etype (Def_Id, Base_Type (T));
+
+ if Is_Signed_Integer_Type (T) then
+ Set_Ekind (Def_Id, E_Signed_Integer_Subtype);
+
+ elsif Is_Modular_Integer_Type (T) then
+ Set_Ekind (Def_Id, E_Modular_Integer_Subtype);
+
+ else
+ Set_Ekind (Def_Id, E_Enumeration_Subtype);
+ Set_Is_Character_Type (Def_Id, Is_Character_Type (T));
+ end if;
+
+ Set_Size_Info (Def_Id, (T));
+ Set_RM_Size (Def_Id, RM_Size (T));
+ Set_First_Rep_Item (Def_Id, First_Rep_Item (T));
+
+ Set_Scalar_Range (Def_Id, R);
+ Conditional_Delay (Def_Id, T);
+
+ -- In the subtype indication case, if the immediate parent of the
+ -- new subtype is non-static, then the subtype we create is non-
+ -- static, even if its bounds are static.
+
+ if Nkind (I) = N_Subtype_Indication
+ and then not Is_Static_Subtype (Entity (Subtype_Mark (I)))
+ then
+ Set_Is_Non_Static_Subtype (Def_Id);
+ end if;
+ end if;
+
+ -- Final step is to label the index with this constructed type
+
+ Set_Etype (I, Def_Id);
+ end Make_Index;
+
+ ------------------------------
+ -- Modular_Type_Declaration --
+ ------------------------------
+
+ procedure Modular_Type_Declaration (T : Entity_Id; Def : Node_Id) is
+ Mod_Expr : constant Node_Id := Expression (Def);
+ M_Val : Uint;
+
+ procedure Set_Modular_Size (Bits : Int);
+ -- Sets RM_Size to Bits, and Esize to normal word size above this
+
+ procedure Set_Modular_Size (Bits : Int) is
+ begin
+ Set_RM_Size (T, UI_From_Int (Bits));
+
+ if Bits <= 8 then
+ Init_Esize (T, 8);
+
+ elsif Bits <= 16 then
+ Init_Esize (T, 16);
+
+ elsif Bits <= 32 then
+ Init_Esize (T, 32);
+
+ else
+ Init_Esize (T, System_Max_Binary_Modulus_Power);
+ end if;
+ end Set_Modular_Size;
+
+ -- Start of processing for Modular_Type_Declaration
+
+ begin
+ Analyze_And_Resolve (Mod_Expr, Any_Integer);
+ Set_Etype (T, T);
+ Set_Ekind (T, E_Modular_Integer_Type);
+ Init_Alignment (T);
+ Set_Is_Constrained (T);
+
+ if not Is_OK_Static_Expression (Mod_Expr) then
+ Error_Msg_N
+ ("non-static expression used for modular type bound", Mod_Expr);
+ M_Val := 2 ** System_Max_Binary_Modulus_Power;
+ else
+ M_Val := Expr_Value (Mod_Expr);
+ end if;
+
+ if M_Val < 1 then
+ Error_Msg_N ("modulus value must be positive", Mod_Expr);
+ M_Val := 2 ** System_Max_Binary_Modulus_Power;
+ end if;
+
+ Set_Modulus (T, M_Val);
+
+ -- Create bounds for the modular type based on the modulus given in
+ -- the type declaration and then analyze and resolve those bounds.
+
+ Set_Scalar_Range (T,
+ Make_Range (Sloc (Mod_Expr),
+ Low_Bound =>
+ Make_Integer_Literal (Sloc (Mod_Expr), 0),
+ High_Bound =>
+ Make_Integer_Literal (Sloc (Mod_Expr), M_Val - 1)));
+
+ -- Properly analyze the literals for the range. We do this manually
+ -- because we can't go calling Resolve, since we are resolving these
+ -- bounds with the type, and this type is certainly not complete yet!
+
+ Set_Etype (Low_Bound (Scalar_Range (T)), T);
+ Set_Etype (High_Bound (Scalar_Range (T)), T);
+ Set_Is_Static_Expression (Low_Bound (Scalar_Range (T)));
+ Set_Is_Static_Expression (High_Bound (Scalar_Range (T)));
+
+ -- Loop through powers of two to find number of bits required
+
+ for Bits in Int range 0 .. System_Max_Binary_Modulus_Power loop
+
+ -- Binary case
+
+ if M_Val = 2 ** Bits then
+ Set_Modular_Size (Bits);
+ return;
+
+ -- Non-binary case
+
+ elsif M_Val < 2 ** Bits then
+ Set_Non_Binary_Modulus (T);
+
+ if Bits > System_Max_Nonbinary_Modulus_Power then
+ Error_Msg_Uint_1 :=
+ UI_From_Int (System_Max_Nonbinary_Modulus_Power);
+ Error_Msg_N
+ ("nonbinary modulus exceeds limit (2 '*'*^ - 1)", Mod_Expr);
+ Set_Modular_Size (System_Max_Binary_Modulus_Power);
+ return;
+
+ else
+ -- In the non-binary case, set size as per RM 13.3(55).
+
+ Set_Modular_Size (Bits);
+ return;
+ end if;
+ end if;
+
+ end loop;
+
+ -- If we fall through, then the size exceed System.Max_Binary_Modulus
+ -- so we just signal an error and set the maximum size.
+
+ Error_Msg_Uint_1 := UI_From_Int (System_Max_Binary_Modulus_Power);
+ Error_Msg_N ("modulus exceeds limit (2 '*'*^)", Mod_Expr);
+
+ Set_Modular_Size (System_Max_Binary_Modulus_Power);
+ Init_Alignment (T);
+
+ end Modular_Type_Declaration;
+
+ -------------------------
+ -- New_Binary_Operator --
+ -------------------------
+
+ procedure New_Binary_Operator (Op_Name : Name_Id; Typ : Entity_Id) is
+ Loc : constant Source_Ptr := Sloc (Typ);
+ Op : Entity_Id;
+
+ function Make_Op_Formal (Typ, Op : Entity_Id) return Entity_Id;
+ -- Create abbreviated declaration for the formal of a predefined
+ -- Operator 'Op' of type 'Typ'
+
+ --------------------
+ -- Make_Op_Formal --
+ --------------------
+
+ function Make_Op_Formal (Typ, Op : Entity_Id) return Entity_Id is
+ Formal : Entity_Id;
+
+ begin
+ Formal := New_Internal_Entity (E_In_Parameter, Op, Loc, 'P');
+ Set_Etype (Formal, Typ);
+ Set_Mechanism (Formal, Default_Mechanism);
+ return Formal;
+ end Make_Op_Formal;
+
+ -- Start of processing for New_Binary_Operator
+
+ begin
+ Op := Make_Defining_Operator_Symbol (Loc, Op_Name);
+
+ Set_Ekind (Op, E_Operator);
+ Set_Scope (Op, Current_Scope);
+ Set_Etype (Op, Typ);
+ Set_Homonym (Op, Get_Name_Entity_Id (Op_Name));
+ Set_Is_Immediately_Visible (Op);
+ Set_Is_Intrinsic_Subprogram (Op);
+ Set_Has_Completion (Op);
+ Append_Entity (Op, Current_Scope);
+
+ Set_Name_Entity_Id (Op_Name, Op);
+
+ Append_Entity (Make_Op_Formal (Typ, Op), Op);
+ Append_Entity (Make_Op_Formal (Typ, Op), Op);
+
+ end New_Binary_Operator;
+
+ -------------------------------------------
+ -- Ordinary_Fixed_Point_Type_Declaration --
+ -------------------------------------------
+
+ procedure Ordinary_Fixed_Point_Type_Declaration
+ (T : Entity_Id;
+ Def : Node_Id)
+ is
+ Loc : constant Source_Ptr := Sloc (Def);
+ Delta_Expr : constant Node_Id := Delta_Expression (Def);
+ RRS : constant Node_Id := Real_Range_Specification (Def);
+ Implicit_Base : Entity_Id;
+ Delta_Val : Ureal;
+ Small_Val : Ureal;
+ Low_Val : Ureal;
+ High_Val : Ureal;
+
+ begin
+ Check_Restriction (No_Fixed_Point, Def);
+
+ -- Create implicit base type
+
+ Implicit_Base :=
+ Create_Itype (E_Ordinary_Fixed_Point_Type, Parent (Def), T, 'B');
+ Set_Etype (Implicit_Base, Implicit_Base);
+
+ -- Analyze and process delta expression
+
+ Analyze_And_Resolve (Delta_Expr, Any_Real);
+
+ Check_Delta_Expression (Delta_Expr);
+ Delta_Val := Expr_Value_R (Delta_Expr);
+
+ Set_Delta_Value (Implicit_Base, Delta_Val);
+
+ -- Compute default small from given delta, which is the largest
+ -- power of two that does not exceed the given delta value.
+
+ declare
+ Tmp : Ureal := Ureal_1;
+ Scale : Int := 0;
+
+ begin
+ if Delta_Val < Ureal_1 then
+ while Delta_Val < Tmp loop
+ Tmp := Tmp / Ureal_2;
+ Scale := Scale + 1;
+ end loop;
+
+ else
+ loop
+ Tmp := Tmp * Ureal_2;
+ exit when Tmp > Delta_Val;
+ Scale := Scale - 1;
+ end loop;
+ end if;
+
+ Small_Val := UR_From_Components (Uint_1, UI_From_Int (Scale), 2);
+ end;
+
+ Set_Small_Value (Implicit_Base, Small_Val);
+
+ -- If no range was given, set a dummy range
+
+ if RRS <= Empty_Or_Error then
+ Low_Val := -Small_Val;
+ High_Val := Small_Val;
+
+ -- Otherwise analyze and process given range
+
+ else
+ declare
+ Low : constant Node_Id := Low_Bound (RRS);
+ High : constant Node_Id := High_Bound (RRS);
+
+ begin
+ Analyze_And_Resolve (Low, Any_Real);
+ Analyze_And_Resolve (High, Any_Real);
+ Check_Real_Bound (Low);
+ Check_Real_Bound (High);
+
+ -- Obtain and set the range
+
+ Low_Val := Expr_Value_R (Low);
+ High_Val := Expr_Value_R (High);
+
+ if Low_Val > High_Val then
+ Error_Msg_NE ("?fixed point type& has null range", Def, T);
+ end if;
+ end;
+ end if;
+
+ -- The range for both the implicit base and the declared first
+ -- subtype cannot be set yet, so we use the special routine
+ -- Set_Fixed_Range to set a temporary range in place. Note that
+ -- the bounds of the base type will be widened to be symmetrical
+ -- and to fill the available bits when the type is frozen.
+
+ -- We could do this with all discrete types, and probably should, but
+ -- we absolutely have to do it for fixed-point, since the end-points
+ -- of the range and the size are determined by the small value, which
+ -- could be reset before the freeze point.
+
+ Set_Fixed_Range (Implicit_Base, Loc, Low_Val, High_Val);
+ Set_Fixed_Range (T, Loc, Low_Val, High_Val);
+
+ Init_Size_Align (Implicit_Base);
+
+ -- Complete definition of first subtype
+
+ Set_Ekind (T, E_Ordinary_Fixed_Point_Subtype);
+ Set_Etype (T, Implicit_Base);
+ Init_Size_Align (T);
+ Set_First_Rep_Item (T, First_Rep_Item (Implicit_Base));
+ Set_Small_Value (T, Small_Val);
+ Set_Delta_Value (T, Delta_Val);
+ Set_Is_Constrained (T);
+
+ end Ordinary_Fixed_Point_Type_Declaration;
+
+ ----------------------------------------
+ -- Prepare_Private_Subtype_Completion --
+ ----------------------------------------
+
+ procedure Prepare_Private_Subtype_Completion
+ (Id : Entity_Id;
+ Related_Nod : Node_Id)
+ is
+ Id_B : constant Entity_Id := Base_Type (Id);
+ Full_B : constant Entity_Id := Full_View (Id_B);
+ Full : Entity_Id;
+
+ begin
+ if Present (Full_B) then
+
+ -- The Base_Type is already completed, we can complete the
+ -- subtype now. We have to create a new entity with the same name,
+ -- Thus we can't use Create_Itype.
+ -- This is messy, should be fixed ???
+
+ Full := Make_Defining_Identifier (Sloc (Id), Chars (Id));
+ Set_Is_Itype (Full);
+ Set_Associated_Node_For_Itype (Full, Related_Nod);
+ Complete_Private_Subtype (Id, Full, Full_B, Related_Nod);
+ end if;
+
+ -- The parent subtype may be private, but the base might not, in some
+ -- nested instances. In that case, the subtype does not need to be
+ -- exchanged. It would still be nice to make private subtypes and their
+ -- bases consistent at all times ???
+
+ if Is_Private_Type (Id_B) then
+ Append_Elmt (Id, Private_Dependents (Id_B));
+ end if;
+
+ end Prepare_Private_Subtype_Completion;
+
+ ---------------------------
+ -- Process_Discriminants --
+ ---------------------------
+
+ procedure Process_Discriminants (N : Node_Id) is
+ Id : Node_Id;
+ Discr : Node_Id;
+ Discr_Number : Uint;
+ Discr_Type : Entity_Id;
+ Default_Present : Boolean := False;
+ Default_Not_Present : Boolean := False;
+ Elist : Elist_Id := New_Elmt_List;
+
+ begin
+ -- A composite type other than an array type can have discriminants.
+ -- Discriminants of non-limited types must have a discrete type.
+ -- On entry, the current scope is the composite type.
+
+ -- The discriminants are initially entered into the scope of the type
+ -- via Enter_Name with the default Ekind of E_Void to prevent premature
+ -- use, as explained at the end of this procedure.
+
+ Discr := First (Discriminant_Specifications (N));
+ while Present (Discr) loop
+ Enter_Name (Defining_Identifier (Discr));
+
+ if Nkind (Discriminant_Type (Discr)) = N_Access_Definition then
+ Discr_Type := Access_Definition (N, Discriminant_Type (Discr));
+
+ else
+ Find_Type (Discriminant_Type (Discr));
+ Discr_Type := Etype (Discriminant_Type (Discr));
+
+ if Error_Posted (Discriminant_Type (Discr)) then
+ Discr_Type := Any_Type;
+ end if;
+ end if;
+
+ if Is_Access_Type (Discr_Type) then
+ Check_Access_Discriminant_Requires_Limited
+ (Discr, Discriminant_Type (Discr));
+
+ if Ada_83 and then Comes_From_Source (Discr) then
+ Error_Msg_N
+ ("(Ada 83) access discriminant not allowed", Discr);
+ end if;
+
+ elsif not Is_Discrete_Type (Discr_Type) then
+ Error_Msg_N ("discriminants must have a discrete or access type",
+ Discriminant_Type (Discr));
+ end if;
+
+ Set_Etype (Defining_Identifier (Discr), Discr_Type);
+
+ -- If a discriminant specification includes the assignment compound
+ -- delimiter followed by an expression, the expression is the default
+ -- expression of the discriminant; the default expression must be of
+ -- the type of the discriminant. (RM 3.7.1) Since this expression is
+ -- a default expression, we do the special preanalysis, since this
+ -- expression does not freeze (see "Handling of Default Expressions"
+ -- in spec of package Sem).
+
+ if Present (Expression (Discr)) then
+ Analyze_Default_Expression (Expression (Discr), Discr_Type);
+
+ if Nkind (N) = N_Formal_Type_Declaration then
+ Error_Msg_N
+ ("discriminant defaults not allowed for formal type",
+ Expression (Discr));
+
+ elsif Is_Tagged_Type (Current_Scope) then
+ Error_Msg_N
+ ("discriminants of tagged type cannot have defaults",
+ Expression (Discr));
+
+ else
+ Default_Present := True;
+ Append_Elmt (Expression (Discr), Elist);
+
+ -- Tag the defining identifiers for the discriminants with
+ -- their corresponding default expressions from the tree.
+
+ Set_Discriminant_Default_Value
+ (Defining_Identifier (Discr), Expression (Discr));
+ end if;
+
+ else
+ Default_Not_Present := True;
+ end if;
+
+ Next (Discr);
+ end loop;
+
+ -- An element list consisting of the default expressions of the
+ -- discriminants is constructed in the above loop and used to set
+ -- the Discriminant_Constraint attribute for the type. If an object
+ -- is declared of this (record or task) type without any explicit
+ -- discriminant constraint given, this element list will form the
+ -- actual parameters for the corresponding initialization procedure
+ -- for the type.
+
+ Set_Discriminant_Constraint (Current_Scope, Elist);
+ Set_Girder_Constraint (Current_Scope, No_Elist);
+
+ -- Default expressions must be provided either for all or for none
+ -- of the discriminants of a discriminant part. (RM 3.7.1)
+
+ if Default_Present and then Default_Not_Present then
+ Error_Msg_N
+ ("incomplete specification of defaults for discriminants", N);
+ end if;
+
+ -- The use of the name of a discriminant is not allowed in default
+ -- expressions of a discriminant part if the specification of the
+ -- discriminant is itself given in the discriminant part. (RM 3.7.1)
+
+ -- To detect this, the discriminant names are entered initially with an
+ -- Ekind of E_Void (which is the default Ekind given by Enter_Name). Any
+ -- attempt to use a void entity (for example in an expression that is
+ -- type-checked) produces the error message: premature usage. Now after
+ -- completing the semantic analysis of the discriminant part, we can set
+ -- the Ekind of all the discriminants appropriately.
+
+ Discr := First (Discriminant_Specifications (N));
+ Discr_Number := Uint_1;
+
+ while Present (Discr) loop
+ Id := Defining_Identifier (Discr);
+ Set_Ekind (Id, E_Discriminant);
+ Init_Component_Location (Id);
+ Init_Esize (Id);
+ Set_Discriminant_Number (Id, Discr_Number);
+
+ -- Make sure this is always set, even in illegal programs
+
+ Set_Corresponding_Discriminant (Id, Empty);
+
+ -- Initialize the Original_Record_Component to the entity itself.
+ -- Inherit_Components will propagate the right value to
+ -- discriminants in derived record types.
+
+ Set_Original_Record_Component (Id, Id);
+
+ -- Create the discriminal for the discriminant.
+
+ Build_Discriminal (Id);
+
+ Next (Discr);
+ Discr_Number := Discr_Number + 1;
+ end loop;
+
+ Set_Has_Discriminants (Current_Scope);
+ end Process_Discriminants;
+
+ -----------------------
+ -- Process_Full_View --
+ -----------------------
+
+ procedure Process_Full_View (N : Node_Id; Full_T, Priv_T : Entity_Id) is
+ Priv_Parent : Entity_Id;
+ Full_Parent : Entity_Id;
+ Full_Indic : Node_Id;
+
+ begin
+ -- First some sanity checks that must be done after semantic
+ -- decoration of the full view and thus cannot be placed with other
+ -- similar checks in Find_Type_Name
+
+ if not Is_Limited_Type (Priv_T)
+ and then (Is_Limited_Type (Full_T)
+ or else Is_Limited_Composite (Full_T))
+ then
+ Error_Msg_N
+ ("completion of nonlimited type cannot be limited", Full_T);
+
+ elsif Is_Abstract (Full_T) and then not Is_Abstract (Priv_T) then
+ Error_Msg_N
+ ("completion of nonabstract type cannot be abstract", Full_T);
+
+ elsif Is_Tagged_Type (Priv_T)
+ and then Is_Limited_Type (Priv_T)
+ and then not Is_Limited_Type (Full_T)
+ then
+ -- GNAT allow its own definition of Limited_Controlled to disobey
+ -- this rule in order in ease the implementation. The next test is
+ -- safe because Root_Controlled is defined in a private system child
+
+ if Etype (Full_T) = Full_View (RTE (RE_Root_Controlled)) then
+ Set_Is_Limited_Composite (Full_T);
+ else
+ Error_Msg_N
+ ("completion of limited tagged type must be limited", Full_T);
+ end if;
+
+ elsif Is_Generic_Type (Priv_T) then
+ Error_Msg_N ("generic type cannot have a completion", Full_T);
+ end if;
+
+ if Is_Tagged_Type (Priv_T)
+ and then Nkind (Parent (Priv_T)) = N_Private_Extension_Declaration
+ and then Is_Derived_Type (Full_T)
+ then
+ Priv_Parent := Etype (Priv_T);
+
+ -- The full view of a private extension may have been transformed
+ -- into an unconstrained derived type declaration and a subtype
+ -- declaration (see build_derived_record_type for details).
+
+ if Nkind (N) = N_Subtype_Declaration then
+ Full_Indic := Subtype_Indication (N);
+ Full_Parent := Etype (Base_Type (Full_T));
+ else
+ Full_Indic := Subtype_Indication (Type_Definition (N));
+ Full_Parent := Etype (Full_T);
+ end if;
+
+ -- Check that the parent type of the full type is a descendant of
+ -- the ancestor subtype given in the private extension. If either
+ -- entity has an Etype equal to Any_Type then we had some previous
+ -- error situation [7.3(8)].
+
+ if Priv_Parent = Any_Type or else Full_Parent = Any_Type then
+ return;
+
+ elsif not Is_Ancestor (Base_Type (Priv_Parent), Full_Parent) then
+ Error_Msg_N
+ ("parent of full type must descend from parent"
+ & " of private extension", Full_Indic);
+
+ -- Check the rules of 7.3(10): if the private extension inherits
+ -- known discriminants, then the full type must also inherit those
+ -- discriminants from the same (ancestor) type, and the parent
+ -- subtype of the full type must be constrained if and only if
+ -- the ancestor subtype of the private extension is constrained.
+
+ elsif not Present (Discriminant_Specifications (Parent (Priv_T)))
+ and then not Has_Unknown_Discriminants (Priv_T)
+ and then Has_Discriminants (Base_Type (Priv_Parent))
+ then
+ declare
+ Priv_Indic : constant Node_Id :=
+ Subtype_Indication (Parent (Priv_T));
+
+ Priv_Constr : constant Boolean :=
+ Is_Constrained (Priv_Parent)
+ or else
+ Nkind (Priv_Indic) = N_Subtype_Indication
+ or else Is_Constrained (Entity (Priv_Indic));
+
+ Full_Constr : constant Boolean :=
+ Is_Constrained (Full_Parent)
+ or else
+ Nkind (Full_Indic) = N_Subtype_Indication
+ or else Is_Constrained (Entity (Full_Indic));
+
+ Priv_Discr : Entity_Id;
+ Full_Discr : Entity_Id;
+
+ begin
+ Priv_Discr := First_Discriminant (Priv_Parent);
+ Full_Discr := First_Discriminant (Full_Parent);
+
+ while Present (Priv_Discr) and then Present (Full_Discr) loop
+ if Original_Record_Component (Priv_Discr) =
+ Original_Record_Component (Full_Discr)
+ or else
+ Corresponding_Discriminant (Priv_Discr) =
+ Corresponding_Discriminant (Full_Discr)
+ then
+ null;
+ else
+ exit;
+ end if;
+
+ Next_Discriminant (Priv_Discr);
+ Next_Discriminant (Full_Discr);
+ end loop;
+
+ if Present (Priv_Discr) or else Present (Full_Discr) then
+ Error_Msg_N
+ ("full view must inherit discriminants of the parent type"
+ & " used in the private extension", Full_Indic);
+
+ elsif Priv_Constr and then not Full_Constr then
+ Error_Msg_N
+ ("parent subtype of full type must be constrained",
+ Full_Indic);
+
+ elsif Full_Constr and then not Priv_Constr then
+ Error_Msg_N
+ ("parent subtype of full type must be unconstrained",
+ Full_Indic);
+ end if;
+ end;
+
+ -- Check the rules of 7.3(12): if a partial view has neither known
+ -- or unknown discriminants, then the full type declaration shall
+ -- define a definite subtype.
+
+ elsif not Has_Unknown_Discriminants (Priv_T)
+ and then not Has_Discriminants (Priv_T)
+ and then not Is_Constrained (Full_T)
+ then
+ Error_Msg_N
+ ("full view must define a constrained type if partial view"
+ & " has no discriminants", Full_T);
+ end if;
+
+ -- ??????? Do we implement the following properly ?????
+ -- If the ancestor subtype of a private extension has constrained
+ -- discriminants, then the parent subtype of the full view shall
+ -- impose a statically matching constraint on those discriminants
+ -- [7.3(13)].
+
+ else
+ -- For untagged types, verify that a type without discriminants
+ -- is not completed with an unconstrained type.
+
+ if not Is_Indefinite_Subtype (Priv_T)
+ and then Is_Indefinite_Subtype (Full_T)
+ then
+ Error_Msg_N ("full view of type must be definite subtype", Full_T);
+ end if;
+ end if;
+
+ -- Create a full declaration for all its subtypes recorded in
+ -- Private_Dependents and swap them similarly to the base type.
+ -- These are subtypes that have been define before the full
+ -- declaration of the private type. We also swap the entry in
+ -- Private_Dependents list so we can properly restore the
+ -- private view on exit from the scope.
+
+ declare
+ Priv_Elmt : Elmt_Id;
+ Priv : Entity_Id;
+ Full : Entity_Id;
+
+ begin
+ Priv_Elmt := First_Elmt (Private_Dependents (Priv_T));
+ while Present (Priv_Elmt) loop
+ Priv := Node (Priv_Elmt);
+
+ if Ekind (Priv) = E_Private_Subtype
+ or else Ekind (Priv) = E_Limited_Private_Subtype
+ or else Ekind (Priv) = E_Record_Subtype_With_Private
+ then
+ Full := Make_Defining_Identifier (Sloc (Priv), Chars (Priv));
+ Set_Is_Itype (Full);
+ Set_Parent (Full, Parent (Priv));
+ Set_Associated_Node_For_Itype (Full, N);
+
+ -- Now we need to complete the private subtype, but since the
+ -- base type has already been swapped, we must also swap the
+ -- subtypes (and thus, reverse the arguments in the call to
+ -- Complete_Private_Subtype).
+
+ Copy_And_Swap (Priv, Full);
+ Complete_Private_Subtype (Full, Priv, Full_T, N);
+ Replace_Elmt (Priv_Elmt, Full);
+ end if;
+
+ Next_Elmt (Priv_Elmt);
+ end loop;
+ end;
+
+ -- If the private view was tagged, copy the new Primitive
+ -- operations from the private view to the full view.
+
+ if Is_Tagged_Type (Full_T) then
+ declare
+ Priv_List : Elist_Id;
+ Full_List : constant Elist_Id := Primitive_Operations (Full_T);
+ P1, P2 : Elmt_Id;
+ Prim : Entity_Id;
+ D_Type : Entity_Id;
+
+ begin
+ if Is_Tagged_Type (Priv_T) then
+ Priv_List := Primitive_Operations (Priv_T);
+
+ P1 := First_Elmt (Priv_List);
+ while Present (P1) loop
+ Prim := Node (P1);
+
+ -- Transfer explicit primitives, not those inherited from
+ -- parent of partial view, which will be re-inherited on
+ -- the full view.
+
+ if Comes_From_Source (Prim) then
+ P2 := First_Elmt (Full_List);
+ while Present (P2) and then Node (P2) /= Prim loop
+ Next_Elmt (P2);
+ end loop;
+
+ -- If not found, that is a new one
+
+ if No (P2) then
+ Append_Elmt (Prim, Full_List);
+ end if;
+ end if;
+
+ Next_Elmt (P1);
+ end loop;
+
+ else
+ -- In this case the partial view is untagged, so here we
+ -- locate all of the earlier primitives that need to be
+ -- treated as dispatching (those that appear between the
+ -- two views). Note that these additional operations must
+ -- all be new operations (any earlier operations that
+ -- override inherited operations of the full view will
+ -- already have been inserted in the primitives list and
+ -- marked as dispatching by Check_Operation_From_Private_View.
+ -- Note that implicit "/=" operators are excluded from being
+ -- added to the primitives list since they shouldn't be
+ -- treated as dispatching (tagged "/=" is handled specially).
+
+ Prim := Next_Entity (Full_T);
+ while Present (Prim) and then Prim /= Priv_T loop
+ if (Ekind (Prim) = E_Procedure
+ or else Ekind (Prim) = E_Function)
+ then
+
+ D_Type := Find_Dispatching_Type (Prim);
+
+ if D_Type = Full_T
+ and then (Chars (Prim) /= Name_Op_Ne
+ or else Comes_From_Source (Prim))
+ then
+ Check_Controlling_Formals (Full_T, Prim);
+
+ if not Is_Dispatching_Operation (Prim) then
+ Append_Elmt (Prim, Full_List);
+ Set_Is_Dispatching_Operation (Prim, True);
+ Set_DT_Position (Prim, No_Uint);
+ end if;
+
+ elsif Is_Dispatching_Operation (Prim)
+ and then D_Type /= Full_T
+ then
+
+ -- Verify that it is not otherwise controlled by
+ -- a formal or a return value ot type T.
+
+ Check_Controlling_Formals (D_Type, Prim);
+ end if;
+ end if;
+
+ Next_Entity (Prim);
+ end loop;
+ end if;
+
+ -- For the tagged case, the two views can share the same
+ -- Primitive Operation list and the same class wide type.
+ -- Update attributes of the class-wide type which depend on
+ -- the full declaration.
+
+ if Is_Tagged_Type (Priv_T) then
+ Set_Primitive_Operations (Priv_T, Full_List);
+ Set_Class_Wide_Type
+ (Base_Type (Full_T), Class_Wide_Type (Priv_T));
+
+ -- Any other attributes should be propagated to C_W ???
+
+ Set_Has_Task (Class_Wide_Type (Priv_T), Has_Task (Full_T));
+
+ end if;
+ end;
+ end if;
+ end Process_Full_View;
+
+ -----------------------------------
+ -- Process_Incomplete_Dependents --
+ -----------------------------------
+
+ procedure Process_Incomplete_Dependents
+ (N : Node_Id;
+ Full_T : Entity_Id;
+ Inc_T : Entity_Id)
+ is
+ Inc_Elmt : Elmt_Id;
+ Priv_Dep : Entity_Id;
+ New_Subt : Entity_Id;
+
+ Disc_Constraint : Elist_Id;
+
+ begin
+ if No (Private_Dependents (Inc_T)) then
+ return;
+
+ else
+ Inc_Elmt := First_Elmt (Private_Dependents (Inc_T));
+
+ -- Itypes that may be generated by the completion of an incomplete
+ -- subtype are not used by the back-end and not attached to the tree.
+ -- They are created only for constraint-checking purposes.
+ end if;
+
+ while Present (Inc_Elmt) loop
+ Priv_Dep := Node (Inc_Elmt);
+
+ if Ekind (Priv_Dep) = E_Subprogram_Type then
+
+ -- An Access_To_Subprogram type may have a return type or a
+ -- parameter type that is incomplete. Replace with the full view.
+
+ if Etype (Priv_Dep) = Inc_T then
+ Set_Etype (Priv_Dep, Full_T);
+ end if;
+
+ declare
+ Formal : Entity_Id;
+
+ begin
+ Formal := First_Formal (Priv_Dep);
+
+ while Present (Formal) loop
+
+ if Etype (Formal) = Inc_T then
+ Set_Etype (Formal, Full_T);
+ end if;
+
+ Next_Formal (Formal);
+ end loop;
+ end;
+
+ elsif Is_Overloadable (Priv_Dep) then
+
+ if Is_Tagged_Type (Full_T) then
+
+ -- Subprogram has an access parameter whose designated type
+ -- was incomplete. Reexamine declaration now, because it may
+ -- be a primitive operation of the full type.
+
+ Check_Operation_From_Incomplete_Type (Priv_Dep, Inc_T);
+ Set_Is_Dispatching_Operation (Priv_Dep);
+ Check_Controlling_Formals (Full_T, Priv_Dep);
+ end if;
+
+ elsif Ekind (Priv_Dep) = E_Subprogram_Body then
+
+ -- Can happen during processing of a body before the completion
+ -- of a TA type. Ignore, because spec is also on dependent list.
+
+ return;
+
+ -- Dependent is a subtype
+
+ else
+ -- We build a new subtype indication using the full view of the
+ -- incomplete parent. The discriminant constraints have been
+ -- elaborated already at the point of the subtype declaration.
+
+ New_Subt := Create_Itype (E_Void, N);
+
+ if Has_Discriminants (Full_T) then
+ Disc_Constraint := Discriminant_Constraint (Priv_Dep);
+ else
+ Disc_Constraint := No_Elist;
+ end if;
+
+ Build_Discriminated_Subtype (Full_T, New_Subt, Disc_Constraint, N);
+ Set_Full_View (Priv_Dep, New_Subt);
+ end if;
+
+ Next_Elmt (Inc_Elmt);
+ end loop;
+
+ end Process_Incomplete_Dependents;
+
+ --------------------------------
+ -- Process_Range_Expr_In_Decl --
+ --------------------------------
+
+ procedure Process_Range_Expr_In_Decl
+ (R : Node_Id;
+ T : Entity_Id;
+ Related_Nod : Node_Id;
+ Check_List : List_Id := Empty_List;
+ R_Check_Off : Boolean := False)
+ is
+ Lo, Hi : Node_Id;
+ R_Checks : Check_Result;
+ Type_Decl : Node_Id;
+ Def_Id : Entity_Id;
+
+ begin
+ Analyze_And_Resolve (R, Base_Type (T));
+
+ if Nkind (R) = N_Range then
+ Lo := Low_Bound (R);
+ Hi := High_Bound (R);
+
+ -- If there were errors in the declaration, try and patch up some
+ -- common mistakes in the bounds. The cases handled are literals
+ -- which are Integer where the expected type is Real and vice versa.
+ -- These corrections allow the compilation process to proceed further
+ -- along since some basic assumptions of the format of the bounds
+ -- are guaranteed.
+
+ if Etype (R) = Any_Type then
+
+ if Nkind (Lo) = N_Integer_Literal and then Is_Real_Type (T) then
+ Rewrite (Lo,
+ Make_Real_Literal (Sloc (Lo), UR_From_Uint (Intval (Lo))));
+
+ elsif Nkind (Hi) = N_Integer_Literal and then Is_Real_Type (T) then
+ Rewrite (Hi,
+ Make_Real_Literal (Sloc (Hi), UR_From_Uint (Intval (Hi))));
+
+ elsif Nkind (Lo) = N_Real_Literal and then Is_Integer_Type (T) then
+ Rewrite (Lo,
+ Make_Integer_Literal (Sloc (Lo), UR_To_Uint (Realval (Lo))));
+
+ elsif Nkind (Hi) = N_Real_Literal and then Is_Integer_Type (T) then
+ Rewrite (Hi,
+ Make_Integer_Literal (Sloc (Hi), UR_To_Uint (Realval (Hi))));
+ end if;
+
+ Set_Etype (Lo, T);
+ Set_Etype (Hi, T);
+ end if;
+
+ -- If the bounds of the range have been mistakenly given as
+ -- string literals (perhaps in place of character literals),
+ -- then an error has already been reported, but we rewrite
+ -- the string literal as a bound of the range's type to
+ -- avoid blowups in later processing that looks at static
+ -- values.
+
+ if Nkind (Lo) = N_String_Literal then
+ Rewrite (Lo,
+ Make_Attribute_Reference (Sloc (Lo),
+ Attribute_Name => Name_First,
+ Prefix => New_Reference_To (T, Sloc (Lo))));
+ Analyze_And_Resolve (Lo);
+ end if;
+
+ if Nkind (Hi) = N_String_Literal then
+ Rewrite (Hi,
+ Make_Attribute_Reference (Sloc (Hi),
+ Attribute_Name => Name_First,
+ Prefix => New_Reference_To (T, Sloc (Hi))));
+ Analyze_And_Resolve (Hi);
+ end if;
+
+ -- If bounds aren't scalar at this point then exit, avoiding
+ -- problems with further processing of the range in this procedure.
+
+ if not Is_Scalar_Type (Etype (Lo)) then
+ return;
+ end if;
+
+ -- Resolve (actually Sem_Eval) has checked that the bounds are in
+ -- then range of the base type. Here we check whether the bounds
+ -- are in the range of the subtype itself. Note that if the bounds
+ -- represent the null range the Constraint_Error exception should
+ -- not be raised.
+
+ -- ??? The following code should be cleaned up as follows
+ -- 1. The Is_Null_Range (Lo, Hi) test should disapper since it
+ -- is done in the call to Range_Check (R, T); below
+ -- 2. The use of R_Check_Off should be investigated and possibly
+ -- removed, this would clean up things a bit.
+
+ if Is_Null_Range (Lo, Hi) then
+ null;
+
+ else
+ -- We use a flag here instead of suppressing checks on the
+ -- type because the type we check against isn't necessarily the
+ -- place where we put the check.
+
+ if not R_Check_Off then
+ R_Checks := Range_Check (R, T);
+ Type_Decl := Parent (R);
+
+ -- Look up tree to find an appropriate insertion point.
+ -- This seems really junk code, and very brittle, couldn't
+ -- we just use an insert actions call of some kind ???
+
+ while Present (Type_Decl) and then not
+ (Nkind (Type_Decl) = N_Full_Type_Declaration
+ or else
+ Nkind (Type_Decl) = N_Subtype_Declaration
+ or else
+ Nkind (Type_Decl) = N_Loop_Statement
+ or else
+ Nkind (Type_Decl) = N_Task_Type_Declaration
+ or else
+ Nkind (Type_Decl) = N_Single_Task_Declaration
+ or else
+ Nkind (Type_Decl) = N_Protected_Type_Declaration
+ or else
+ Nkind (Type_Decl) = N_Single_Protected_Declaration)
+ loop
+ Type_Decl := Parent (Type_Decl);
+ end loop;
+
+ -- Why would Type_Decl not be present??? Without this test,
+ -- short regression tests fail.
+
+ if Present (Type_Decl) then
+ if Nkind (Type_Decl) = N_Loop_Statement then
+ declare
+ Indic : Node_Id := Parent (R);
+ begin
+ while Present (Indic) and then not
+ (Nkind (Indic) = N_Subtype_Indication)
+ loop
+ Indic := Parent (Indic);
+ end loop;
+
+ if Present (Indic) then
+ Def_Id := Etype (Subtype_Mark (Indic));
+
+ Insert_Range_Checks
+ (R_Checks,
+ Type_Decl,
+ Def_Id,
+ Sloc (Type_Decl),
+ R,
+ Do_Before => True);
+ end if;
+ end;
+ else
+ Def_Id := Defining_Identifier (Type_Decl);
+
+ if (Ekind (Def_Id) = E_Record_Type
+ and then Depends_On_Discriminant (R))
+ or else
+ (Ekind (Def_Id) = E_Protected_Type
+ and then Has_Discriminants (Def_Id))
+ then
+ Append_Range_Checks
+ (R_Checks, Check_List, Def_Id, Sloc (Type_Decl), R);
+
+ else
+ Insert_Range_Checks
+ (R_Checks, Type_Decl, Def_Id, Sloc (Type_Decl), R);
+
+ end if;
+ end if;
+ end if;
+ end if;
+ end if;
+ end if;
+
+ Get_Index_Bounds (R, Lo, Hi);
+
+ if Expander_Active then
+ Force_Evaluation (Lo);
+ Force_Evaluation (Hi);
+ end if;
+
+ end Process_Range_Expr_In_Decl;
+
+ --------------------------------------
+ -- Process_Real_Range_Specification --
+ --------------------------------------
+
+ procedure Process_Real_Range_Specification (Def : Node_Id) is
+ Spec : constant Node_Id := Real_Range_Specification (Def);
+ Lo : Node_Id;
+ Hi : Node_Id;
+ Err : Boolean := False;
+
+ procedure Analyze_Bound (N : Node_Id);
+ -- Analyze and check one bound
+
+ procedure Analyze_Bound (N : Node_Id) is
+ begin
+ Analyze_And_Resolve (N, Any_Real);
+
+ if not Is_OK_Static_Expression (N) then
+ Error_Msg_N
+ ("bound in real type definition is not static", N);
+ Err := True;
+ end if;
+ end Analyze_Bound;
+
+ begin
+ if Present (Spec) then
+ Lo := Low_Bound (Spec);
+ Hi := High_Bound (Spec);
+ Analyze_Bound (Lo);
+ Analyze_Bound (Hi);
+
+ -- If error, clear away junk range specification
+
+ if Err then
+ Set_Real_Range_Specification (Def, Empty);
+ end if;
+ end if;
+ end Process_Real_Range_Specification;
+
+ ---------------------
+ -- Process_Subtype --
+ ---------------------
+
+ function Process_Subtype
+ (S : Node_Id;
+ Related_Nod : Node_Id;
+ Related_Id : Entity_Id := Empty;
+ Suffix : Character := ' ')
+ return Entity_Id
+ is
+ P : Node_Id;
+ Def_Id : Entity_Id;
+ Full_View_Id : Entity_Id;
+ Subtype_Mark_Id : Entity_Id;
+ N_Dynamic_Ityp : Node_Id := Empty;
+
+ begin
+ -- Case of constraint present, so that we have an N_Subtype_Indication
+ -- node (this node is created only if constraints are present).
+
+ if Nkind (S) = N_Subtype_Indication then
+ Find_Type (Subtype_Mark (S));
+
+ if Nkind (Parent (S)) /= N_Access_To_Object_Definition
+ and then not
+ (Nkind (Parent (S)) = N_Subtype_Declaration
+ and then
+ Is_Itype (Defining_Identifier (Parent (S))))
+ then
+ Check_Incomplete (Subtype_Mark (S));
+ end if;
+
+ P := Parent (S);
+ Subtype_Mark_Id := Entity (Subtype_Mark (S));
+
+ if Is_Unchecked_Union (Subtype_Mark_Id)
+ and then Comes_From_Source (Related_Nod)
+ then
+ Error_Msg_N
+ ("cannot create subtype of Unchecked_Union", Related_Nod);
+ end if;
+
+ -- Explicit subtype declaration case
+
+ if Nkind (P) = N_Subtype_Declaration then
+ Def_Id := Defining_Identifier (P);
+
+ -- Explicit derived type definition case
+
+ elsif Nkind (P) = N_Derived_Type_Definition then
+ Def_Id := Defining_Identifier (Parent (P));
+
+ -- Implicit case, the Def_Id must be created as an implicit type.
+ -- The one exception arises in the case of concurrent types,
+ -- array and access types, where other subsidiary implicit types
+ -- may be created and must appear before the main implicit type.
+ -- In these cases we leave Def_Id set to Empty as a signal that
+ -- Create_Itype has not yet been called to create Def_Id.
+
+ else
+ if Is_Array_Type (Subtype_Mark_Id)
+ or else Is_Concurrent_Type (Subtype_Mark_Id)
+ or else Is_Access_Type (Subtype_Mark_Id)
+ then
+ Def_Id := Empty;
+
+ -- For the other cases, we create a new unattached Itype,
+ -- and set the indication to ensure it gets attached later.
+
+ else
+ Def_Id :=
+ Create_Itype (E_Void, Related_Nod, Related_Id, Suffix);
+ end if;
+
+ N_Dynamic_Ityp := Related_Nod;
+ end if;
+
+ -- If the kind of constraint is invalid for this kind of type,
+ -- then give an error, and then pretend no constraint was given.
+
+ if not Is_Valid_Constraint_Kind
+ (Ekind (Subtype_Mark_Id), Nkind (Constraint (S)))
+ then
+ Error_Msg_N
+ ("incorrect constraint for this kind of type", Constraint (S));
+
+ Rewrite (S, New_Copy_Tree (Subtype_Mark (S)));
+
+ -- Make recursive call, having got rid of the bogus constraint
+
+ return Process_Subtype (S, Related_Nod, Related_Id, Suffix);
+ end if;
+
+ -- Remaining processing depends on type
+
+ case Ekind (Subtype_Mark_Id) is
+
+ when Access_Kind =>
+ Constrain_Access (Def_Id, S, Related_Nod);
+
+ when Array_Kind =>
+ Constrain_Array (Def_Id, S, Related_Nod, Related_Id, Suffix);
+
+ when Decimal_Fixed_Point_Kind =>
+ Constrain_Decimal (Def_Id, S, N_Dynamic_Ityp);
+
+ when Enumeration_Kind =>
+ Constrain_Enumeration (Def_Id, S, N_Dynamic_Ityp);
+
+ when Ordinary_Fixed_Point_Kind =>
+ Constrain_Ordinary_Fixed (Def_Id, S, N_Dynamic_Ityp);
+
+ when Float_Kind =>
+ Constrain_Float (Def_Id, S, N_Dynamic_Ityp);
+
+ when Integer_Kind =>
+ Constrain_Integer (Def_Id, S, N_Dynamic_Ityp);
+
+ when E_Record_Type |
+ E_Record_Subtype |
+ Class_Wide_Kind |
+ E_Incomplete_Type =>
+ Constrain_Discriminated_Type (Def_Id, S, Related_Nod);
+
+ when Private_Kind =>
+ Constrain_Discriminated_Type (Def_Id, S, Related_Nod);
+ Set_Private_Dependents (Def_Id, New_Elmt_List);
+
+ -- In case of an invalid constraint prevent further processing
+ -- since the type constructed is missing expected fields.
+
+ if Etype (Def_Id) = Any_Type then
+ return Def_Id;
+ end if;
+
+ -- If the full view is that of a task with discriminants,
+ -- we must constrain both the concurrent type and its
+ -- corresponding record type. Otherwise we will just propagate
+ -- the constraint to the full view, if available.
+
+ if Present (Full_View (Subtype_Mark_Id))
+ and then Has_Discriminants (Subtype_Mark_Id)
+ and then Is_Concurrent_Type (Full_View (Subtype_Mark_Id))
+ then
+ Full_View_Id :=
+ Create_Itype (E_Void, Related_Nod, Related_Id, Suffix);
+
+ Set_Entity (Subtype_Mark (S), Full_View (Subtype_Mark_Id));
+ Constrain_Concurrent (Full_View_Id, S,
+ Related_Nod, Related_Id, Suffix);
+ Set_Entity (Subtype_Mark (S), Subtype_Mark_Id);
+ Set_Full_View (Def_Id, Full_View_Id);
+
+ else
+ Prepare_Private_Subtype_Completion (Def_Id, Related_Nod);
+ end if;
+
+ when Concurrent_Kind =>
+ Constrain_Concurrent (Def_Id, S,
+ Related_Nod, Related_Id, Suffix);
+
+ when others =>
+ Error_Msg_N ("invalid subtype mark in subtype indication", S);
+ end case;
+
+ -- Size and Convention are always inherited from the base type
+
+ Set_Size_Info (Def_Id, (Subtype_Mark_Id));
+ Set_Convention (Def_Id, Convention (Subtype_Mark_Id));
+
+ return Def_Id;
+
+ -- Case of no constraints present
+
+ else
+ Find_Type (S);
+ Check_Incomplete (S);
+ return Entity (S);
+ end if;
+ end Process_Subtype;
+
+ -----------------------------
+ -- Record_Type_Declaration --
+ -----------------------------
+
+ procedure Record_Type_Declaration (T : Entity_Id; N : Node_Id) is
+ Def : constant Node_Id := Type_Definition (N);
+ Range_Checks_Suppressed_Flag : Boolean := False;
+
+ Is_Tagged : Boolean;
+ Tag_Comp : Entity_Id;
+
+ begin
+ -- The flag Is_Tagged_Type might have already been set by Find_Type_Name
+ -- if it detected an error for declaration T. This arises in the case of
+ -- private tagged types where the full view omits the word tagged.
+
+ Is_Tagged := Tagged_Present (Def)
+ or else (Errors_Detected > 0 and then Is_Tagged_Type (T));
+
+ -- Records constitute a scope for the component declarations within.
+ -- The scope is created prior to the processing of these declarations.
+ -- Discriminants are processed first, so that they are visible when
+ -- processing the other components. The Ekind of the record type itself
+ -- is set to E_Record_Type (subtypes appear as E_Record_Subtype).
+
+ -- Enter record scope
+
+ New_Scope (T);
+
+ -- These flags must be initialized before calling Process_Discriminants
+ -- because this routine makes use of them.
+
+ Set_Is_Tagged_Type (T, Is_Tagged);
+ Set_Is_Limited_Record (T, Limited_Present (Def));
+
+ -- Type is abstract if full declaration carries keyword, or if
+ -- previous partial view did.
+
+ Set_Is_Abstract (T, Is_Abstract (T) or else Abstract_Present (Def));
+
+ Set_Ekind (T, E_Record_Type);
+ Set_Etype (T, T);
+ Init_Size_Align (T);
+
+ Set_Girder_Constraint (T, No_Elist);
+
+ -- If an incomplete or private type declaration was already given for
+ -- the type, then this scope already exists, and the discriminants have
+ -- been declared within. We must verify that the full declaration
+ -- matches the incomplete one.
+
+ Check_Or_Process_Discriminants (N, T);
+
+ Set_Is_Constrained (T, not Has_Discriminants (T));
+ Set_Has_Delayed_Freeze (T, True);
+
+ -- For tagged types add a manually analyzed component corresponding
+ -- to the component _tag, the corresponding piece of tree will be
+ -- expanded as part of the freezing actions if it is not a CPP_Class.
+
+ if Is_Tagged then
+ -- Do not add the tag unless we are in expansion mode.
+
+ if Expander_Active then
+ Tag_Comp := Make_Defining_Identifier (Sloc (Def), Name_uTag);
+ Enter_Name (Tag_Comp);
+
+ Set_Is_Tag (Tag_Comp);
+ Set_Ekind (Tag_Comp, E_Component);
+ Set_Etype (Tag_Comp, RTE (RE_Tag));
+ Set_DT_Entry_Count (Tag_Comp, No_Uint);
+ Set_Original_Record_Component (Tag_Comp, Tag_Comp);
+ Init_Component_Location (Tag_Comp);
+ end if;
+
+ Make_Class_Wide_Type (T);
+ Set_Primitive_Operations (T, New_Elmt_List);
+ end if;
+
+ -- We must suppress range checks when processing the components
+ -- of a record in the presence of discriminants, since we don't
+ -- want spurious checks to be generated during their analysis, but
+ -- must reset the Suppress_Range_Checks flags after having procesed
+ -- the record definition.
+
+ if Has_Discriminants (T) and then not Suppress_Range_Checks (T) then
+ Set_Suppress_Range_Checks (T, True);
+ Range_Checks_Suppressed_Flag := True;
+ end if;
+
+ Record_Type_Definition (Def, T);
+
+ if Range_Checks_Suppressed_Flag then
+ Set_Suppress_Range_Checks (T, False);
+ Range_Checks_Suppressed_Flag := False;
+ end if;
+
+ -- Exit from record scope
+
+ End_Scope;
+ end Record_Type_Declaration;
+
+ ----------------------------
+ -- Record_Type_Definition --
+ ----------------------------
+
+ procedure Record_Type_Definition (Def : Node_Id; T : Entity_Id) is
+ Component : Entity_Id;
+ Ctrl_Components : Boolean := False;
+ Final_Storage_Only : Boolean := not Is_Controlled (T);
+
+ begin
+ -- If the component list of a record type is defined by the reserved
+ -- word null and there is no discriminant part, then the record type has
+ -- no components and all records of the type are null records (RM 3.7)
+ -- This procedure is also called to process the extension part of a
+ -- record extension, in which case the current scope may have inherited
+ -- components.
+
+ if No (Def)
+ or else No (Component_List (Def))
+ or else Null_Present (Component_List (Def))
+ then
+ null;
+
+ else
+ Analyze_Declarations (Component_Items (Component_List (Def)));
+
+ if Present (Variant_Part (Component_List (Def))) then
+ Analyze (Variant_Part (Component_List (Def)));
+ end if;
+ end if;
+
+ -- After completing the semantic analysis of the record definition,
+ -- record components, both new and inherited, are accessible. Set
+ -- their kind accordingly.
+
+ Component := First_Entity (Current_Scope);
+ while Present (Component) loop
+
+ if Ekind (Component) = E_Void then
+ Set_Ekind (Component, E_Component);
+ Init_Component_Location (Component);
+ end if;
+
+ if Has_Task (Etype (Component)) then
+ Set_Has_Task (T);
+ end if;
+
+ if Ekind (Component) /= E_Component then
+ null;
+
+ elsif Has_Controlled_Component (Etype (Component))
+ or else (Chars (Component) /= Name_uParent
+ and then Is_Controlled (Etype (Component)))
+ then
+ Set_Has_Controlled_Component (T, True);
+ Final_Storage_Only := Final_Storage_Only
+ and then Finalize_Storage_Only (Etype (Component));
+ Ctrl_Components := True;
+ end if;
+
+ Next_Entity (Component);
+ end loop;
+
+ -- A type is Finalize_Storage_Only only if all its controlled
+ -- components are so.
+
+ if Ctrl_Components then
+ Set_Finalize_Storage_Only (T, Final_Storage_Only);
+ end if;
+
+ if Present (Def) then
+ Process_End_Label (Def, 'e');
+ end if;
+ end Record_Type_Definition;
+
+ ---------------------
+ -- Set_Fixed_Range --
+ ---------------------
+
+ -- The range for fixed-point types is complicated by the fact that we
+ -- do not know the exact end points at the time of the declaration. This
+ -- is true for three reasons:
+
+ -- A size clause may affect the fudging of the end-points
+ -- A small clause may affect the values of the end-points
+ -- We try to include the end-points if it does not affect the size
+
+ -- This means that the actual end-points must be established at the
+ -- point when the type is frozen. Meanwhile, we first narrow the range
+ -- as permitted (so that it will fit if necessary in a small specified
+ -- size), and then build a range subtree with these narrowed bounds.
+
+ -- Set_Fixed_Range constructs the range from real literal values, and
+ -- sets the range as the Scalar_Range of the given fixed-point type
+ -- entity.
+
+ -- The parent of this range is set to point to the entity so that it
+ -- is properly hooked into the tree (unlike normal Scalar_Range entries
+ -- for other scalar types, which are just pointers to the range in the
+ -- original tree, this would otherwise be an orphan).
+
+ -- The tree is left unanalyzed. When the type is frozen, the processing
+ -- in Freeze.Freeze_Fixed_Point_Type notices that the range is not
+ -- analyzed, and uses this as an indication that it should complete
+ -- work on the range (it will know the final small and size values).
+
+ procedure Set_Fixed_Range
+ (E : Entity_Id;
+ Loc : Source_Ptr;
+ Lo : Ureal;
+ Hi : Ureal)
+ is
+ S : constant Node_Id :=
+ Make_Range (Loc,
+ Low_Bound => Make_Real_Literal (Loc, Lo),
+ High_Bound => Make_Real_Literal (Loc, Hi));
+
+ begin
+ Set_Scalar_Range (E, S);
+ Set_Parent (S, E);
+ end Set_Fixed_Range;
+
+ --------------------------------------------------------
+ -- Set_Girder_Constraint_From_Discriminant_Constraint --
+ --------------------------------------------------------
+
+ procedure Set_Girder_Constraint_From_Discriminant_Constraint
+ (E : Entity_Id)
+ is
+ begin
+ -- Make sure set if encountered during
+ -- Expand_To_Girder_Constraint
+
+ Set_Girder_Constraint (E, No_Elist);
+
+ -- Give it the right value
+
+ if Is_Constrained (E) and then Has_Discriminants (E) then
+ Set_Girder_Constraint (E,
+ Expand_To_Girder_Constraint (E, Discriminant_Constraint (E)));
+ end if;
+
+ end Set_Girder_Constraint_From_Discriminant_Constraint;
+
+ ----------------------------------
+ -- Set_Scalar_Range_For_Subtype --
+ ----------------------------------
+
+ procedure Set_Scalar_Range_For_Subtype
+ (Def_Id : Entity_Id;
+ R : Node_Id;
+ Subt : Entity_Id;
+ Related_Nod : Node_Id)
+ is
+ Kind : constant Entity_Kind := Ekind (Def_Id);
+ begin
+ Set_Scalar_Range (Def_Id, R);
+
+ -- We need to link the range into the tree before resolving it so
+ -- that types that are referenced, including importantly the subtype
+ -- itself, are properly frozen (Freeze_Expression requires that the
+ -- expression be properly linked into the tree). Of course if it is
+ -- already linked in, then we do not disturb the current link.
+
+ if No (Parent (R)) then
+ Set_Parent (R, Def_Id);
+ end if;
+
+ -- Reset the kind of the subtype during analysis of the range, to
+ -- catch possible premature use in the bounds themselves.
+
+ Set_Ekind (Def_Id, E_Void);
+ Process_Range_Expr_In_Decl (R, Subt, Related_Nod);
+ Set_Ekind (Def_Id, Kind);
+
+ end Set_Scalar_Range_For_Subtype;
+
+ -------------------------------------
+ -- Signed_Integer_Type_Declaration --
+ -------------------------------------
+
+ procedure Signed_Integer_Type_Declaration (T : Entity_Id; Def : Node_Id) is
+ Implicit_Base : Entity_Id;
+ Base_Typ : Entity_Id;
+ Lo_Val : Uint;
+ Hi_Val : Uint;
+ Errs : Boolean := False;
+ Lo : Node_Id;
+ Hi : Node_Id;
+
+ function Can_Derive_From (E : Entity_Id) return Boolean;
+ -- Determine whether given bounds allow derivation from specified type
+
+ procedure Check_Bound (Expr : Node_Id);
+ -- Check bound to make sure it is integral and static. If not, post
+ -- appropriate error message and set Errs flag
+
+ function Can_Derive_From (E : Entity_Id) return Boolean is
+ Lo : constant Uint := Expr_Value (Type_Low_Bound (E));
+ Hi : constant Uint := Expr_Value (Type_High_Bound (E));
+
+ begin
+ -- Note we check both bounds against both end values, to deal with
+ -- strange types like ones with a range of 0 .. -12341234.
+
+ return Lo <= Lo_Val and then Lo_Val <= Hi
+ and then
+ Lo <= Hi_Val and then Hi_Val <= Hi;
+ end Can_Derive_From;
+
+ procedure Check_Bound (Expr : Node_Id) is
+ begin
+ -- If a range constraint is used as an integer type definition, each
+ -- bound of the range must be defined by a static expression of some
+ -- integer type, but the two bounds need not have the same integer
+ -- type (Negative bounds are allowed.) (RM 3.5.4)
+
+ if not Is_Integer_Type (Etype (Expr)) then
+ Error_Msg_N
+ ("integer type definition bounds must be of integer type", Expr);
+ Errs := True;
+
+ elsif not Is_OK_Static_Expression (Expr) then
+ Error_Msg_N
+ ("non-static expression used for integer type bound", Expr);
+ Errs := True;
+
+ -- The bounds are folded into literals, and we set their type to be
+ -- universal, to avoid typing difficulties: we cannot set the type
+ -- of the literal to the new type, because this would be a forward
+ -- reference for the back end, and if the original type is user-
+ -- defined this can lead to spurious semantic errors (e.g. 2928-003).
+
+ else
+ if Is_Entity_Name (Expr) then
+ Fold_Uint (Expr, Expr_Value (Expr));
+ end if;
+
+ Set_Etype (Expr, Universal_Integer);
+ end if;
+ end Check_Bound;
+
+ -- Start of processing for Signed_Integer_Type_Declaration
+
+ begin
+ -- Create an anonymous base type
+
+ Implicit_Base :=
+ Create_Itype (E_Signed_Integer_Type, Parent (Def), T, 'B');
+
+ -- Analyze and check the bounds, they can be of any integer type
+
+ Lo := Low_Bound (Def);
+ Hi := High_Bound (Def);
+ Analyze_And_Resolve (Lo, Any_Integer);
+ Analyze_And_Resolve (Hi, Any_Integer);
+
+ Check_Bound (Lo);
+ Check_Bound (Hi);
+
+ if Errs then
+ Hi := Type_High_Bound (Standard_Long_Long_Integer);
+ Lo := Type_Low_Bound (Standard_Long_Long_Integer);
+ end if;
+
+ -- Find type to derive from
+
+ Lo_Val := Expr_Value (Lo);
+ Hi_Val := Expr_Value (Hi);
+
+ if Can_Derive_From (Standard_Short_Short_Integer) then
+ Base_Typ := Base_Type (Standard_Short_Short_Integer);
+
+ elsif Can_Derive_From (Standard_Short_Integer) then
+ Base_Typ := Base_Type (Standard_Short_Integer);
+
+ elsif Can_Derive_From (Standard_Integer) then
+ Base_Typ := Base_Type (Standard_Integer);
+
+ elsif Can_Derive_From (Standard_Long_Integer) then
+ Base_Typ := Base_Type (Standard_Long_Integer);
+
+ elsif Can_Derive_From (Standard_Long_Long_Integer) then
+ Base_Typ := Base_Type (Standard_Long_Long_Integer);
+
+ else
+ Base_Typ := Base_Type (Standard_Long_Long_Integer);
+ Error_Msg_N ("integer type definition bounds out of range", Def);
+ Hi := Type_High_Bound (Standard_Long_Long_Integer);
+ Lo := Type_Low_Bound (Standard_Long_Long_Integer);
+ end if;
+
+ -- Complete both implicit base and declared first subtype entities
+
+ Set_Etype (Implicit_Base, Base_Typ);
+ Set_Scalar_Range (Implicit_Base, Scalar_Range (Base_Typ));
+ Set_Size_Info (Implicit_Base, (Base_Typ));
+ Set_RM_Size (Implicit_Base, RM_Size (Base_Typ));
+ Set_First_Rep_Item (Implicit_Base, First_Rep_Item (Base_Typ));
+
+ Set_Ekind (T, E_Signed_Integer_Subtype);
+ Set_Etype (T, Implicit_Base);
+
+ Set_Size_Info (T, (Implicit_Base));
+ Set_First_Rep_Item (T, First_Rep_Item (Implicit_Base));
+ Set_Scalar_Range (T, Def);
+ Set_RM_Size (T, UI_From_Int (Minimum_Size (T)));
+ Set_Is_Constrained (T);
+
+ end Signed_Integer_Type_Declaration;
+
+end Sem_Ch3;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S E M _ C H 3 --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.57 $
+-- --
+-- 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). --
+-- --
+------------------------------------------------------------------------------
+
+with Nlists; use Nlists;
+with Types; use Types;
+
+package Sem_Ch3 is
+ procedure Analyze_Component_Declaration (N : Node_Id);
+ procedure Analyze_Incomplete_Type_Decl (N : Node_Id);
+ procedure Analyze_Itype_Reference (N : Node_Id);
+ procedure Analyze_Number_Declaration (N : Node_Id);
+ procedure Analyze_Object_Declaration (N : Node_Id);
+ procedure Analyze_Others_Choice (N : Node_Id);
+ procedure Analyze_Private_Extension_Declaration (N : Node_Id);
+ procedure Analyze_Subtype_Declaration (N : Node_Id);
+ procedure Analyze_Subtype_Indication (N : Node_Id);
+ procedure Analyze_Type_Declaration (N : Node_Id);
+ procedure Analyze_Variant_Part (N : Node_Id);
+
+ function Access_Definition
+ (Related_Nod : Node_Id;
+ N : Node_Id)
+ return Entity_Id;
+ -- An access definition defines a general access type for a formal
+ -- parameter. The procedure is called when processing formals, when
+ -- the current scope is the subprogram. The Implicit type is attached
+ -- to the Related_Nod put into the enclosing scope, so that the only
+ -- entities defined in the spec are the formals themselves.
+
+ procedure Access_Subprogram_Declaration
+ (T_Name : Entity_Id;
+ T_Def : Node_Id);
+ -- The subprogram specification yields the signature of an implicit
+ -- type, whose Ekind is Access_Subprogram_Type. This implicit type is
+ -- the designated type of the declared access type. In subprogram calls,
+ -- the signature of the implicit type works like the profile of a regular
+ -- subprogram.
+
+ procedure Analyze_Declarations (L : List_Id);
+ -- Called to analyze a list of declarations (in what context ???). Also
+ -- performs necessary freezing actions (more description needed ???)
+
+ procedure Analyze_Default_Expression (N : Node_Id; T : Entity_Id);
+ -- Default expressions do not freeze their components, and must be
+ -- analyzed and resolved accordingly, by calling the
+ -- Pre_Analyze_And_Resolve routine and setting the global
+ -- In_Default_Expression flag.
+
+ procedure Array_Type_Declaration (T : in out Entity_Id; Def : Node_Id);
+ -- Process an array type declaration. If the array is constrained, we
+ -- create an implicit parent array type, with the same index types and
+ -- component type.
+
+ procedure Access_Type_Declaration (T : Entity_Id; Def : Node_Id);
+ -- Process an access type declaration
+
+ procedure Check_Abstract_Overriding (T : Entity_Id);
+ -- Check that all abstract subprograms inherited from T's parent type
+ -- have been overridden as required, and that nonabstract subprograms
+ -- have not been incorrectly overridden with an abstract subprogram.
+
+ procedure Check_Aliased_Component_Types (T : Entity_Id);
+ -- Given an array type or record type T, check that if the type is
+ -- nonlimited, then the nominal subtype of any components of T
+ -- that have discriminants must be constrained.
+
+ procedure Check_Completion (Body_Id : Node_Id := Empty);
+ -- At the end of a declarative part, verify that all entities that
+ -- require completion have received one. If Body_Id is absent, the
+ -- error indicating a missing completion is placed on the declaration
+ -- that needs completion. If Body_Id is present, it is the defining
+ -- identifier of a package body, and errors are posted on that node,
+ -- rather than on the declarations that require completion in the package
+ -- declaration.
+
+ procedure Derive_Subprogram
+ (New_Subp : in out Entity_Id;
+ Parent_Subp : Entity_Id;
+ Derived_Type : Entity_Id;
+ Parent_Type : Entity_Id;
+ Actual_Subp : Entity_Id := Empty);
+ -- Derive the subprogram Parent_Subp from Parent_Type, and replace the
+ -- subsidiary subtypes with the derived type to build the specification
+ -- of the inherited subprogram (returned in New_Subp). For tagged types,
+ -- the derived subprogram is aliased to that of the actual (in the
+ -- case where Actual_Subp is nonempty) rather than to the corresponding
+ -- subprogram of the parent type.
+
+ procedure Derive_Subprograms
+ (Parent_Type : Entity_Id;
+ Derived_Type : Entity_Id;
+ Generic_Actual : Entity_Id := Empty);
+ -- To complete type derivation, collect or retrieve the primitive
+ -- operations of the parent type, and replace the subsidiary subtypes
+ -- with the derived type, to build the specs of the inherited ops.
+ -- For generic actuals, the mapping of the primitive operations to those
+ -- of the parent type is also done by rederiving the operations within
+ -- the instance. For tagged types, the derived subprograms are aliased to
+ -- those of the actual, not those of the ancestor.
+
+ function Expand_To_Girder_Constraint
+ (Typ : Entity_Id;
+ Constraint : Elist_Id)
+ return Elist_Id;
+ -- Given a Constraint (ie a list of expressions) on the discriminants of
+ -- Typ, expand it into a constraint on the girder discriminants and
+ -- return the new list of expressions constraining the girder
+ -- discriminants.
+
+ function Find_Type_Name (N : Node_Id) return Entity_Id;
+ -- Enter the identifier in a type definition, or find the entity already
+ -- declared, in the case of the full declaration of an incomplete or
+ -- private type.
+
+ function Get_Discriminant_Value
+ (Discriminant : Entity_Id;
+ Typ_For_Constraint : Entity_Id;
+ Constraint : Elist_Id)
+ return Node_Id;
+ -- ??? MORE DOCUMENTATION
+ -- Given a discriminant somewhere in the Typ_For_Constraint tree
+ -- and a Constraint, return the value of that discriminant.
+
+ function Is_Visible_Component (C : Entity_Id) return Boolean;
+ -- Determines if a record component C is visible in the present context.
+ -- Note that even though component C could appear in the entity chain
+ -- of a record type, C may not be visible in the current context. For
+ -- instance, C may be a component inherited in the full view of a private
+ -- extension which is not visible in the current context.
+
+ procedure Make_Index
+ (I : Node_Id;
+ Related_Nod : Node_Id;
+ Related_Id : Entity_Id := Empty;
+ Suffix_Index : Nat := 1);
+ -- Process an index that is given in an array declaration, an entry
+ -- family declaration or a loop iteration. The index is given by an
+ -- index declaration (a 'box'), or by a discrete range. The later can
+ -- be the name of a discrete type, or a subtype indication.
+ -- Related_Nod is the node where the potential generated implicit types
+ -- will be inserted. The 2 last parameters are used for creating the name.
+
+ procedure Make_Class_Wide_Type (T : Entity_Id);
+ -- A Class_Wide_Type is created for each tagged type definition. The
+ -- attributes of a class wide type are inherited from those of the type
+ -- T. If T is introduced by a private declaration, the corresponding
+ -- class wide type is created at the same time, and therefore there is
+ -- a private and a full declaration for the class wide type type as well.
+
+ procedure Process_Full_View (N : Node_Id; Full_T, Priv_T : Entity_Id);
+ -- Process some semantic actions when the full view of a private type is
+ -- encountered and analyzed. The first action is to create the full views
+ -- of the dependant private subtypes. The second action is to recopy the
+ -- primitive operations of the private view (in the tagged case).
+ -- N is the N_Full_Type_Declaration node.
+
+ -- Full_T is the full view of the type whose full declaration is in N.
+ --
+ -- Priv_T is the private view of the type whose full declaration is in N.
+
+ procedure Process_Range_Expr_In_Decl
+ (R : Node_Id;
+ T : Entity_Id;
+ Related_Nod : Node_Id;
+ Check_List : List_Id := Empty_List;
+ R_Check_Off : Boolean := False);
+ -- Process a range expression that appears in a declaration context. The
+ -- range is analyzed and resolved with the base type of the given type,
+ -- and an appropriate check for expressions in non-static contexts made
+ -- on the bounds. R is analyzed and resolved using T, so the caller should
+ -- if necessary link R into the tree before the call, and in particular in
+ -- the case of a subtype declaration, it is appropriate to set the parent
+ -- pointer of R so that the types get properly frozen. The Check_List
+ -- parameter is used when the subprogram is called from
+ -- Build_Record_Init_Proc and is used to return a set of constraint
+ -- checking statements generated by the Checks package. R_Check_Off is
+ -- set to True when the call to Range_Check is to be skipped.
+
+ function Process_Subtype
+ (S : Node_Id;
+ Related_Nod : Node_Id;
+ Related_Id : Entity_Id := Empty;
+ Suffix : Character := ' ')
+ return Entity_Id;
+ -- Process a subtype indication S and return corresponding entity.
+ -- Related_Nod is the node where the potential generated implicit types
+ -- will be inserted. The Related_Id and Suffix parameters are used to
+ -- build the associated Implicit type name.
+
+ procedure Process_Discriminants (N : Node_Id);
+ -- Process the discriminants contained in an N_Full_Type_Declaration or
+ -- N_Incomplete_Type_Decl node N.
+
+ procedure Set_Girder_Constraint_From_Discriminant_Constraint
+ (E : Entity_Id);
+ -- E is some record type. This routine computes E's Girder_Constraint
+ -- from its Discriminant_Constraint.
+
+end Sem_Ch3;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S E M _ C H 4 --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.511 $
+-- --
+-- 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). --
+-- --
+------------------------------------------------------------------------------
+
+with Atree; use Atree;
+with Debug; use Debug;
+with Einfo; use Einfo;
+with Errout; use Errout;
+with Exp_Util; use Exp_Util;
+with Hostparm; use Hostparm;
+with Itypes; use Itypes;
+with Lib.Xref; use Lib.Xref;
+with Namet; use Namet;
+with Nlists; use Nlists;
+with Nmake; use Nmake;
+with Opt; use Opt;
+with Output; use Output;
+with Restrict; use Restrict;
+with Sem; use Sem;
+with Sem_Cat; use Sem_Cat;
+with Sem_Ch3; use Sem_Ch3;
+with Sem_Ch8; use Sem_Ch8;
+with Sem_Dist; use Sem_Dist;
+with Sem_Eval; use Sem_Eval;
+with Sem_Res; use Sem_Res;
+with Sem_Util; use Sem_Util;
+with Sem_Type; use Sem_Type;
+with Stand; use Stand;
+with Sinfo; use Sinfo;
+with Snames; use Snames;
+with Tbuild; use Tbuild;
+
+with GNAT.Spelling_Checker; use GNAT.Spelling_Checker;
+
+package body Sem_Ch4 is
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ procedure Analyze_Expression (N : Node_Id);
+ -- For expressions that are not names, this is just a call to analyze.
+ -- If the expression is a name, it may be a call to a parameterless
+ -- function, and if so must be converted into an explicit call node
+ -- and analyzed as such. This deproceduring must be done during the first
+ -- pass of overload resolution, because otherwise a procedure call with
+ -- overloaded actuals may fail to resolve. See 4327-001 for an example.
+
+ procedure Analyze_Operator_Call (N : Node_Id; Op_Id : Entity_Id);
+ -- Analyze a call of the form "+"(x, y), etc. The prefix of the call
+ -- is an operator name or an expanded name whose selector is an operator
+ -- name, and one possible interpretation is as a predefined operator.
+
+ procedure Analyze_Overloaded_Selected_Component (N : Node_Id);
+ -- If the prefix of a selected_component is overloaded, the proper
+ -- interpretation that yields a record type with the proper selector
+ -- name must be selected.
+
+ procedure Analyze_User_Defined_Binary_Op (N : Node_Id; Op_Id : Entity_Id);
+ -- Procedure to analyze a user defined binary operator, which is resolved
+ -- like a function, but instead of a list of actuals it is presented
+ -- with the left and right operands of an operator node.
+
+ procedure Analyze_User_Defined_Unary_Op (N : Node_Id; Op_Id : Entity_Id);
+ -- Procedure to analyze a user defined unary operator, which is resolved
+ -- like a function, but instead of a list of actuals, it is presented with
+ -- the operand of the operator node.
+
+ procedure Ambiguous_Operands (N : Node_Id);
+ -- for equality, membership, and comparison operators with overloaded
+ -- arguments, list possible interpretations.
+
+ procedure Insert_Explicit_Dereference (N : Node_Id);
+ -- In a context that requires a composite or subprogram type and
+ -- where a prefix is an access type, insert an explicit dereference.
+
+ procedure Analyze_One_Call
+ (N : Node_Id;
+ Nam : Entity_Id;
+ Report : Boolean;
+ Success : out Boolean);
+ -- Check one interpretation of an overloaded subprogram name for
+ -- compatibility with the types of the actuals in a call. If there is a
+ -- single interpretation which does not match, post error if Report is
+ -- set to True.
+ --
+ -- Nam is the entity that provides the formals against which the actuals
+ -- are checked. Nam is either the name of a subprogram, or the internal
+ -- subprogram type constructed for an access_to_subprogram. If the actuals
+ -- are compatible with Nam, then Nam is added to the list of candidate
+ -- interpretations for N, and Success is set to True.
+
+ procedure Check_Misspelled_Selector
+ (Prefix : Entity_Id;
+ Sel : Node_Id);
+ -- Give possible misspelling diagnostic if Sel is likely to be
+ -- a misspelling of one of the selectors of the Prefix.
+ -- This is called by Analyze_Selected_Component after producing
+ -- an invalid selector error message.
+
+ function Defined_In_Scope (T : Entity_Id; S : Entity_Id) return Boolean;
+ -- Verify that type T is declared in scope S. Used to find intepretations
+ -- for operators given by expanded names. This is abstracted as a separate
+ -- function to handle extensions to System, where S is System, but T is
+ -- declared in the extension.
+
+ procedure Find_Arithmetic_Types
+ (L, R : Node_Id;
+ Op_Id : Entity_Id;
+ N : Node_Id);
+ -- L and R are the operands of an arithmetic operator. Find
+ -- consistent pairs of interpretations for L and R that have a
+ -- numeric type consistent with the semantics of the operator.
+
+ procedure Find_Comparison_Types
+ (L, R : Node_Id;
+ Op_Id : Entity_Id;
+ N : Node_Id);
+ -- L and R are operands of a comparison operator. Find consistent
+ -- pairs of interpretations for L and R.
+
+ procedure Find_Concatenation_Types
+ (L, R : Node_Id;
+ Op_Id : Entity_Id;
+ N : Node_Id);
+ -- For the four varieties of concatenation.
+
+ procedure Find_Equality_Types
+ (L, R : Node_Id;
+ Op_Id : Entity_Id;
+ N : Node_Id);
+ -- Ditto for equality operators.
+
+ procedure Find_Boolean_Types
+ (L, R : Node_Id;
+ Op_Id : Entity_Id;
+ N : Node_Id);
+ -- Ditto for binary logical operations.
+
+ procedure Find_Negation_Types
+ (R : Node_Id;
+ Op_Id : Entity_Id;
+ N : Node_Id);
+ -- Find consistent interpretation for operand of negation operator.
+
+ procedure Find_Non_Universal_Interpretations
+ (N : Node_Id;
+ R : Node_Id;
+ Op_Id : Entity_Id;
+ T1 : Entity_Id);
+ -- For equality and comparison operators, the result is always boolean,
+ -- and the legality of the operation is determined from the visibility
+ -- of the operand types. If one of the operands has a universal interpre-
+ -- tation, the legality check uses some compatible non-universal
+ -- interpretation of the other operand. N can be an operator node, or
+ -- a function call whose name is an operator designator.
+
+ procedure Find_Unary_Types
+ (R : Node_Id;
+ Op_Id : Entity_Id;
+ N : Node_Id);
+ -- Unary arithmetic types: plus, minus, abs.
+
+ procedure Check_Arithmetic_Pair
+ (T1, T2 : Entity_Id;
+ Op_Id : Entity_Id;
+ N : Node_Id);
+ -- Subsidiary procedure to Find_Arithmetic_Types. T1 and T2 are valid
+ -- types for left and right operand. Determine whether they constitute
+ -- a valid pair for the given operator, and record the corresponding
+ -- interpretation of the operator node. The node N may be an operator
+ -- node (the usual case) or a function call whose prefix is an operator
+ -- designator. In both cases Op_Id is the operator name itself.
+
+ procedure Diagnose_Call (N : Node_Id; Nam : Node_Id);
+ -- Give detailed information on overloaded call where none of the
+ -- interpretations match. N is the call node, Nam the designator for
+ -- the overloaded entity being called.
+
+ function Junk_Operand (N : Node_Id) return Boolean;
+ -- Test for an operand that is an inappropriate entity (e.g. a package
+ -- name or a label). If so, issue an error message and return True. If
+ -- the operand is not an inappropriate entity kind, return False.
+
+ procedure Operator_Check (N : Node_Id);
+ -- Verify that an operator has received some valid interpretation.
+ -- If none was found, determine whether a use clause would make the
+ -- operation legal. The variable Candidate_Type (defined in Sem_Type) is
+ -- set for every type compatible with the operator, even if the operator
+ -- for the type is not directly visible. The routine uses this type to emit
+ -- a more informative message.
+
+ function Try_Indexed_Call
+ (N : Node_Id;
+ Nam : Entity_Id;
+ Typ : Entity_Id)
+ return Boolean;
+ -- If a function has defaults for all its actuals, a call to it may
+ -- in fact be an indexing on the result of the call. Try_Indexed_Call
+ -- attempts the interpretation as an indexing, prior to analysis as
+ -- a call. If both are possible, the node is overloaded with both
+ -- interpretations (same symbol but two different types).
+
+ function Try_Indirect_Call
+ (N : Node_Id;
+ Nam : Entity_Id;
+ Typ : Entity_Id)
+ return Boolean;
+ -- Similarly, a function F that needs no actuals can return an access
+ -- to a subprogram, and the call F (X) interpreted as F.all (X). In
+ -- this case the call may be overloaded with both interpretations.
+
+ ------------------------
+ -- Ambiguous_Operands --
+ ------------------------
+
+ procedure Ambiguous_Operands (N : Node_Id) is
+ procedure List_Interps (Opnd : Node_Id);
+
+ procedure List_Interps (Opnd : Node_Id) is
+ Index : Interp_Index;
+ It : Interp;
+ Nam : Node_Id;
+ Err : Node_Id := N;
+
+ begin
+ if Is_Overloaded (Opnd) then
+ if Nkind (Opnd) in N_Op then
+ Nam := Opnd;
+
+ elsif Nkind (Opnd) = N_Function_Call then
+ Nam := Name (Opnd);
+
+ else
+ return;
+ end if;
+
+ else
+ return;
+ end if;
+
+ if Opnd = Left_Opnd (N) then
+ Error_Msg_N
+ ("\left operand has the following interpretations", N);
+ else
+ Error_Msg_N
+ ("\right operand has the following interpretations", N);
+ Err := Opnd;
+ end if;
+
+ Get_First_Interp (Nam, Index, It);
+
+ while Present (It.Nam) loop
+
+ if Scope (It.Nam) = Standard_Standard
+ and then Scope (It.Typ) /= Standard_Standard
+ then
+ Error_Msg_Sloc := Sloc (Parent (It.Typ));
+ Error_Msg_NE (" & (inherited) declared#!", Err, It.Nam);
+
+ else
+ Error_Msg_Sloc := Sloc (It.Nam);
+ Error_Msg_NE (" & declared#!", Err, It.Nam);
+ end if;
+
+ Get_Next_Interp (Index, It);
+ end loop;
+ end List_Interps;
+
+ begin
+ if Nkind (N) = N_In
+ or else Nkind (N) = N_Not_In
+ then
+ Error_Msg_N ("ambiguous operands for membership", N);
+
+ elsif Nkind (N) = N_Op_Eq
+ or else Nkind (N) = N_Op_Ne
+ then
+ Error_Msg_N ("ambiguous operands for equality", N);
+
+ else
+ Error_Msg_N ("ambiguous operands for comparison", N);
+ end if;
+
+ if All_Errors_Mode then
+ List_Interps (Left_Opnd (N));
+ List_Interps (Right_Opnd (N));
+ else
+
+ if OpenVMS then
+ Error_Msg_N (
+ "\use '/'R'E'P'O'R'T'_'E'R'R'O'R'S'='F'U'L'L for details",
+ N);
+ else
+ Error_Msg_N ("\use -gnatf for details", N);
+ end if;
+ end if;
+ end Ambiguous_Operands;
+
+ -----------------------
+ -- Analyze_Aggregate --
+ -----------------------
+
+ -- Most of the analysis of Aggregates requires that the type be known,
+ -- and is therefore put off until resolution.
+
+ procedure Analyze_Aggregate (N : Node_Id) is
+ begin
+ if No (Etype (N)) then
+ Set_Etype (N, Any_Composite);
+ end if;
+ end Analyze_Aggregate;
+
+ -----------------------
+ -- Analyze_Allocator --
+ -----------------------
+
+ procedure Analyze_Allocator (N : Node_Id) is
+ Loc : constant Source_Ptr := Sloc (N);
+ Sav_Errs : constant Nat := Errors_Detected;
+ E : Node_Id := Expression (N);
+ Acc_Type : Entity_Id;
+ Type_Id : Entity_Id;
+
+ begin
+ Check_Restriction (No_Allocators, N);
+
+ if Nkind (E) = N_Qualified_Expression then
+ Acc_Type := Create_Itype (E_Allocator_Type, N);
+ Set_Etype (Acc_Type, Acc_Type);
+ Init_Size_Align (Acc_Type);
+ Find_Type (Subtype_Mark (E));
+ Type_Id := Entity (Subtype_Mark (E));
+ Check_Fully_Declared (Type_Id, N);
+ Set_Directly_Designated_Type (Acc_Type, Type_Id);
+
+ if Is_Protected_Type (Type_Id) then
+ Check_Restriction (No_Protected_Type_Allocators, N);
+ end if;
+
+ if Is_Limited_Type (Type_Id)
+ and then Comes_From_Source (N)
+ and then not In_Instance_Body
+ then
+ Error_Msg_N ("initialization not allowed for limited types", N);
+ end if;
+
+ Analyze_And_Resolve (Expression (E), Type_Id);
+
+ -- A qualified expression requires an exact match of the type,
+ -- class-wide matching is not allowed.
+
+ if Is_Class_Wide_Type (Type_Id)
+ and then Base_Type (Etype (Expression (E))) /= Base_Type (Type_Id)
+ then
+ Wrong_Type (Expression (E), Type_Id);
+ end if;
+
+ Check_Non_Static_Context (Expression (E));
+
+ -- We don't analyze the qualified expression itself because it's
+ -- part of the allocator
+
+ Set_Etype (E, Type_Id);
+
+ else
+ declare
+ Def_Id : Entity_Id;
+
+ begin
+ -- If the allocator includes a N_Subtype_Indication then a
+ -- constraint is present, otherwise the node is a subtype mark.
+ -- Introduce an explicit subtype declaration into the tree
+ -- defining some anonymous subtype and rewrite the allocator to
+ -- use this subtype rather than the subtype indication.
+
+ -- It is important to introduce the explicit subtype declaration
+ -- so that the bounds of the subtype indication are attached to
+ -- the tree in case the allocator is inside a generic unit.
+
+ if Nkind (E) = N_Subtype_Indication then
+
+ -- A constraint is only allowed for a composite type in Ada
+ -- 95. In Ada 83, a constraint is also allowed for an
+ -- access-to-composite type, but the constraint is ignored.
+
+ Find_Type (Subtype_Mark (E));
+
+ if Is_Elementary_Type (Entity (Subtype_Mark (E))) then
+ if not (Ada_83
+ and then Is_Access_Type (Entity (Subtype_Mark (E))))
+ then
+ Error_Msg_N ("constraint not allowed here", E);
+
+ if Nkind (Constraint (E))
+ = N_Index_Or_Discriminant_Constraint
+ then
+ Error_Msg_N
+ ("\if qualified expression was meant, " &
+ "use apostrophe", Constraint (E));
+ end if;
+ end if;
+
+ -- Get rid of the bogus constraint:
+
+ Rewrite (E, New_Copy_Tree (Subtype_Mark (E)));
+ Analyze_Allocator (N);
+ return;
+ end if;
+
+ if Expander_Active then
+ Def_Id :=
+ Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
+
+ Insert_Action (E,
+ Make_Subtype_Declaration (Loc,
+ Defining_Identifier => Def_Id,
+ Subtype_Indication => Relocate_Node (E)));
+
+ if Sav_Errs /= Errors_Detected
+ and then Nkind (Constraint (E))
+ = N_Index_Or_Discriminant_Constraint
+ then
+ Error_Msg_N
+ ("if qualified expression was meant, " &
+ "use apostrophe!", Constraint (E));
+ end if;
+
+ E := New_Occurrence_Of (Def_Id, Loc);
+ Rewrite (Expression (N), E);
+ end if;
+ end if;
+
+ Type_Id := Process_Subtype (E, N);
+ Acc_Type := Create_Itype (E_Allocator_Type, N);
+ Set_Etype (Acc_Type, Acc_Type);
+ Init_Size_Align (Acc_Type);
+ Set_Directly_Designated_Type (Acc_Type, Type_Id);
+ Check_Fully_Declared (Type_Id, N);
+
+ -- Check for missing initialization. Skip this check if we already
+ -- had errors on analyzing the allocator, since in that case these
+ -- are probably cascaded errors
+
+ if Is_Indefinite_Subtype (Type_Id)
+ and then Errors_Detected = Sav_Errs
+ then
+ if Is_Class_Wide_Type (Type_Id) then
+ Error_Msg_N
+ ("initialization required in class-wide allocation", N);
+ else
+ Error_Msg_N
+ ("initialization required in unconstrained allocation", N);
+ end if;
+ end if;
+ end;
+ end if;
+
+ if Is_Abstract (Type_Id) then
+ Error_Msg_N ("cannot allocate abstract object", E);
+ end if;
+
+ if Has_Task (Designated_Type (Acc_Type)) then
+ Check_Restriction (No_Task_Allocators, N);
+ end if;
+
+ Set_Etype (N, Acc_Type);
+
+ if not Is_Library_Level_Entity (Acc_Type) then
+ Check_Restriction (No_Local_Allocators, N);
+ end if;
+
+ if Errors_Detected > Sav_Errs then
+ Set_Error_Posted (N);
+ Set_Etype (N, Any_Type);
+ end if;
+
+ end Analyze_Allocator;
+
+ ---------------------------
+ -- Analyze_Arithmetic_Op --
+ ---------------------------
+
+ procedure Analyze_Arithmetic_Op (N : Node_Id) is
+ L : constant Node_Id := Left_Opnd (N);
+ R : constant Node_Id := Right_Opnd (N);
+ Op_Id : Entity_Id;
+
+ begin
+ Candidate_Type := Empty;
+ Analyze_Expression (L);
+ Analyze_Expression (R);
+
+ -- If the entity is already set, the node is the instantiation of
+ -- a generic node with a non-local reference, or was manufactured
+ -- by a call to Make_Op_xxx. In either case the entity is known to
+ -- be valid, and we do not need to collect interpretations, instead
+ -- we just get the single possible interpretation.
+
+ Op_Id := Entity (N);
+
+ if Present (Op_Id) then
+ if Ekind (Op_Id) = E_Operator then
+
+ if (Nkind (N) = N_Op_Divide or else
+ Nkind (N) = N_Op_Mod or else
+ Nkind (N) = N_Op_Multiply or else
+ Nkind (N) = N_Op_Rem)
+ and then Treat_Fixed_As_Integer (N)
+ then
+ null;
+ else
+ Set_Etype (N, Any_Type);
+ Find_Arithmetic_Types (L, R, Op_Id, N);
+ end if;
+
+ else
+ Set_Etype (N, Any_Type);
+ Add_One_Interp (N, Op_Id, Etype (Op_Id));
+ end if;
+
+ -- Entity is not already set, so we do need to collect interpretations
+
+ else
+ Op_Id := Get_Name_Entity_Id (Chars (N));
+ Set_Etype (N, Any_Type);
+
+ while Present (Op_Id) loop
+ if Ekind (Op_Id) = E_Operator
+ and then Present (Next_Entity (First_Entity (Op_Id)))
+ then
+ Find_Arithmetic_Types (L, R, Op_Id, N);
+
+ -- The following may seem superfluous, because an operator cannot
+ -- be generic, but this ignores the cleverness of the author of
+ -- ACVC bc1013a.
+
+ elsif Is_Overloadable (Op_Id) then
+ Analyze_User_Defined_Binary_Op (N, Op_Id);
+ end if;
+
+ Op_Id := Homonym (Op_Id);
+ end loop;
+ end if;
+
+ Operator_Check (N);
+ end Analyze_Arithmetic_Op;
+
+ ------------------
+ -- Analyze_Call --
+ ------------------
+
+ -- Function, procedure, and entry calls are checked here. The Name
+ -- in the call may be overloaded. The actuals have been analyzed
+ -- and may themselves be overloaded. On exit from this procedure, the node
+ -- N may have zero, one or more interpretations. In the first case an error
+ -- message is produced. In the last case, the node is flagged as overloaded
+ -- and the interpretations are collected in All_Interp.
+
+ -- If the name is an Access_To_Subprogram, it cannot be overloaded, but
+ -- the type-checking is similar to that of other calls.
+
+ procedure Analyze_Call (N : Node_Id) is
+ Actuals : constant List_Id := Parameter_Associations (N);
+ Nam : Node_Id := Name (N);
+ X : Interp_Index;
+ It : Interp;
+ Nam_Ent : Entity_Id;
+ Success : Boolean := False;
+
+ function Name_Denotes_Function return Boolean;
+ -- If the type of the name is an access to subprogram, this may be
+ -- the type of a name, or the return type of the function being called.
+ -- If the name is not an entity then it can denote a protected function.
+ -- Until we distinguish Etype from Return_Type, we must use this
+ -- routine to resolve the meaning of the name in the call.
+
+ ---------------------------
+ -- Name_Denotes_Function --
+ ---------------------------
+
+ function Name_Denotes_Function return Boolean is
+ begin
+ if Is_Entity_Name (Nam) then
+ return Ekind (Entity (Nam)) = E_Function;
+
+ elsif Nkind (Nam) = N_Selected_Component then
+ return Ekind (Entity (Selector_Name (Nam))) = E_Function;
+
+ else
+ return False;
+ end if;
+ end Name_Denotes_Function;
+
+ -- Start of processing for Analyze_Call
+
+ begin
+ -- Initialize the type of the result of the call to the error type,
+ -- which will be reset if the type is successfully resolved.
+
+ Set_Etype (N, Any_Type);
+
+ if not Is_Overloaded (Nam) then
+
+ -- Only one interpretation to check
+
+ if Ekind (Etype (Nam)) = E_Subprogram_Type then
+ Nam_Ent := Etype (Nam);
+
+ elsif Is_Access_Type (Etype (Nam))
+ and then Ekind (Designated_Type (Etype (Nam))) = E_Subprogram_Type
+ and then not Name_Denotes_Function
+ then
+ Nam_Ent := Designated_Type (Etype (Nam));
+ Insert_Explicit_Dereference (Nam);
+
+ -- Selected component case. Simple entry or protected operation,
+ -- where the entry name is given by the selector name.
+
+ elsif Nkind (Nam) = N_Selected_Component then
+ Nam_Ent := Entity (Selector_Name (Nam));
+
+ if Ekind (Nam_Ent) /= E_Entry
+ and then Ekind (Nam_Ent) /= E_Entry_Family
+ and then Ekind (Nam_Ent) /= E_Function
+ and then Ekind (Nam_Ent) /= E_Procedure
+ then
+ Error_Msg_N ("name in call is not a callable entity", Nam);
+ Set_Etype (N, Any_Type);
+ return;
+ end if;
+
+ -- If the name is an Indexed component, it can be a call to a member
+ -- of an entry family. The prefix must be a selected component whose
+ -- selector is the entry. Analyze_Procedure_Call normalizes several
+ -- kinds of call into this form.
+
+ elsif Nkind (Nam) = N_Indexed_Component then
+
+ if Nkind (Prefix (Nam)) = N_Selected_Component then
+ Nam_Ent := Entity (Selector_Name (Prefix (Nam)));
+
+ else
+ Error_Msg_N ("name in call is not a callable entity", Nam);
+ Set_Etype (N, Any_Type);
+ return;
+
+ end if;
+
+ elsif not Is_Entity_Name (Nam) then
+ Error_Msg_N ("name in call is not a callable entity", Nam);
+ Set_Etype (N, Any_Type);
+ return;
+
+ else
+ Nam_Ent := Entity (Nam);
+
+ -- If no interpretations, give error message
+
+ if not Is_Overloadable (Nam_Ent) then
+ declare
+ L : constant Boolean := Is_List_Member (N);
+ K : constant Node_Kind := Nkind (Parent (N));
+
+ begin
+ -- If the node is in a list whose parent is not an
+ -- expression then it must be an attempted procedure call.
+
+ if L and then K not in N_Subexpr then
+ if Ekind (Entity (Nam)) = E_Generic_Procedure then
+ Error_Msg_NE
+ ("must instantiate generic procedure& before call",
+ Nam, Entity (Nam));
+ else
+ Error_Msg_N
+ ("procedure or entry name expected", Nam);
+ end if;
+
+ -- Check for tasking cases where only an entry call will do
+
+ elsif not L
+ and then (K = N_Entry_Call_Alternative
+ or else K = N_Triggering_Alternative)
+ then
+ Error_Msg_N ("entry name expected", Nam);
+
+ -- Otherwise give general error message
+
+ else
+ Error_Msg_N ("invalid prefix in call", Nam);
+ end if;
+
+ return;
+ end;
+ end if;
+ end if;
+
+ Analyze_One_Call (N, Nam_Ent, True, Success);
+
+ else
+ -- An overloaded selected component must denote overloaded
+ -- operations of a concurrent type. The interpretations are
+ -- attached to the simple name of those operations.
+
+ if Nkind (Nam) = N_Selected_Component then
+ Nam := Selector_Name (Nam);
+ end if;
+
+ Get_First_Interp (Nam, X, It);
+
+ while Present (It.Nam) loop
+ Nam_Ent := It.Nam;
+
+ -- Name may be call that returns an access to subprogram, or more
+ -- generally an overloaded expression one of whose interpretations
+ -- yields an access to subprogram. If the name is an entity, we
+ -- do not dereference, because the node is a call that returns
+ -- the access type: note difference between f(x), where the call
+ -- may return an access subprogram type, and f(x)(y), where the
+ -- type returned by the call to f is implicitly dereferenced to
+ -- analyze the outer call.
+
+ if Is_Access_Type (Nam_Ent) then
+ Nam_Ent := Designated_Type (Nam_Ent);
+
+ elsif Is_Access_Type (Etype (Nam_Ent))
+ and then not Is_Entity_Name (Nam)
+ and then Ekind (Designated_Type (Etype (Nam_Ent)))
+ = E_Subprogram_Type
+ then
+ Nam_Ent := Designated_Type (Etype (Nam_Ent));
+ end if;
+
+ Analyze_One_Call (N, Nam_Ent, False, Success);
+
+ -- If the interpretation succeeds, mark the proper type of the
+ -- prefix (any valid candidate will do). If not, remove the
+ -- candidate interpretation. This only needs to be done for
+ -- overloaded protected operations, for other entities disambi-
+ -- guation is done directly in Resolve.
+
+ if Success then
+ Set_Etype (Nam, It.Typ);
+
+ elsif Nkind (Name (N)) = N_Selected_Component then
+ Remove_Interp (X);
+ end if;
+
+ Get_Next_Interp (X, It);
+ end loop;
+
+ -- If the name is the result of a function call, it can only
+ -- be a call to a function returning an access to subprogram.
+ -- Insert explicit dereference.
+
+ if Nkind (Nam) = N_Function_Call then
+ Insert_Explicit_Dereference (Nam);
+ end if;
+
+ if Etype (N) = Any_Type then
+
+ -- None of the interpretations is compatible with the actuals
+
+ Diagnose_Call (N, Nam);
+
+ -- Special checks for uninstantiated put routines
+
+ if Nkind (N) = N_Procedure_Call_Statement
+ and then Is_Entity_Name (Nam)
+ and then Chars (Nam) = Name_Put
+ and then List_Length (Actuals) = 1
+ then
+ declare
+ Arg : constant Node_Id := First (Actuals);
+ Typ : Entity_Id;
+
+ begin
+ if Nkind (Arg) = N_Parameter_Association then
+ Typ := Etype (Explicit_Actual_Parameter (Arg));
+ else
+ Typ := Etype (Arg);
+ end if;
+
+ if Is_Signed_Integer_Type (Typ) then
+ Error_Msg_N
+ ("possible missing instantiation of " &
+ "'Text_'I'O.'Integer_'I'O!", Nam);
+
+ elsif Is_Modular_Integer_Type (Typ) then
+ Error_Msg_N
+ ("possible missing instantiation of " &
+ "'Text_'I'O.'Modular_'I'O!", Nam);
+
+ elsif Is_Floating_Point_Type (Typ) then
+ Error_Msg_N
+ ("possible missing instantiation of " &
+ "'Text_'I'O.'Float_'I'O!", Nam);
+
+ elsif Is_Ordinary_Fixed_Point_Type (Typ) then
+ Error_Msg_N
+ ("possible missing instantiation of " &
+ "'Text_'I'O.'Fixed_'I'O!", Nam);
+
+ elsif Is_Decimal_Fixed_Point_Type (Typ) then
+ Error_Msg_N
+ ("possible missing instantiation of " &
+ "'Text_'I'O.'Decimal_'I'O!", Nam);
+
+ elsif Is_Enumeration_Type (Typ) then
+ Error_Msg_N
+ ("possible missing instantiation of " &
+ "'Text_'I'O.'Enumeration_'I'O!", Nam);
+ end if;
+ end;
+ end if;
+
+ elsif not Is_Overloaded (N)
+ and then Is_Entity_Name (Nam)
+ then
+ -- Resolution yields a single interpretation. Verify that
+ -- is has the proper capitalization.
+
+ Set_Entity_With_Style_Check (Nam, Entity (Nam));
+ Generate_Reference (Entity (Nam), Nam);
+
+ Set_Etype (Nam, Etype (Entity (Nam)));
+ end if;
+
+ End_Interp_List;
+ end if;
+ end Analyze_Call;
+
+ ---------------------------
+ -- Analyze_Comparison_Op --
+ ---------------------------
+
+ procedure Analyze_Comparison_Op (N : Node_Id) is
+ L : constant Node_Id := Left_Opnd (N);
+ R : constant Node_Id := Right_Opnd (N);
+ Op_Id : Entity_Id := Entity (N);
+
+ begin
+ Set_Etype (N, Any_Type);
+ Candidate_Type := Empty;
+
+ Analyze_Expression (L);
+ Analyze_Expression (R);
+
+ if Present (Op_Id) then
+
+ if Ekind (Op_Id) = E_Operator then
+ Find_Comparison_Types (L, R, Op_Id, N);
+ else
+ Add_One_Interp (N, Op_Id, Etype (Op_Id));
+ end if;
+
+ if Is_Overloaded (L) then
+ Set_Etype (L, Intersect_Types (L, R));
+ end if;
+
+ else
+ Op_Id := Get_Name_Entity_Id (Chars (N));
+
+ while Present (Op_Id) loop
+
+ if Ekind (Op_Id) = E_Operator then
+ Find_Comparison_Types (L, R, Op_Id, N);
+ else
+ Analyze_User_Defined_Binary_Op (N, Op_Id);
+ end if;
+
+ Op_Id := Homonym (Op_Id);
+ end loop;
+ end if;
+
+ Operator_Check (N);
+ end Analyze_Comparison_Op;
+
+ ---------------------------
+ -- Analyze_Concatenation --
+ ---------------------------
+
+ -- If the only one-dimensional array type in scope is String,
+ -- this is the resulting type of the operation. Otherwise there
+ -- will be a concatenation operation defined for each user-defined
+ -- one-dimensional array.
+
+ procedure Analyze_Concatenation (N : Node_Id) is
+ L : constant Node_Id := Left_Opnd (N);
+ R : constant Node_Id := Right_Opnd (N);
+ Op_Id : Entity_Id := Entity (N);
+ LT : Entity_Id;
+ RT : Entity_Id;
+
+ begin
+ Set_Etype (N, Any_Type);
+ Candidate_Type := Empty;
+
+ Analyze_Expression (L);
+ Analyze_Expression (R);
+
+ -- If the entity is present, the node appears in an instance,
+ -- and denotes a predefined concatenation operation. The resulting
+ -- type is obtained from the arguments when possible.
+
+ if Present (Op_Id) then
+ if Ekind (Op_Id) = E_Operator then
+
+ LT := Base_Type (Etype (L));
+ RT := Base_Type (Etype (R));
+
+ if Is_Array_Type (LT)
+ and then (RT = LT or else RT = Base_Type (Component_Type (LT)))
+ then
+ Add_One_Interp (N, Op_Id, LT);
+
+ elsif Is_Array_Type (RT)
+ and then LT = Base_Type (Component_Type (RT))
+ then
+ Add_One_Interp (N, Op_Id, RT);
+
+ else
+ Add_One_Interp (N, Op_Id, Etype (Op_Id));
+ end if;
+
+ else
+ Add_One_Interp (N, Op_Id, Etype (Op_Id));
+ end if;
+
+ else
+ Op_Id := Get_Name_Entity_Id (Name_Op_Concat);
+
+ while Present (Op_Id) loop
+ if Ekind (Op_Id) = E_Operator then
+ Find_Concatenation_Types (L, R, Op_Id, N);
+ else
+ Analyze_User_Defined_Binary_Op (N, Op_Id);
+ end if;
+
+ Op_Id := Homonym (Op_Id);
+ end loop;
+ end if;
+
+ Operator_Check (N);
+ end Analyze_Concatenation;
+
+ ------------------------------------
+ -- Analyze_Conditional_Expression --
+ ------------------------------------
+
+ procedure Analyze_Conditional_Expression (N : Node_Id) is
+ Condition : constant Node_Id := First (Expressions (N));
+ Then_Expr : constant Node_Id := Next (Condition);
+ Else_Expr : constant Node_Id := Next (Then_Expr);
+
+ begin
+ Analyze_Expression (Condition);
+ Analyze_Expression (Then_Expr);
+ Analyze_Expression (Else_Expr);
+ Set_Etype (N, Etype (Then_Expr));
+ end Analyze_Conditional_Expression;
+
+ -------------------------
+ -- Analyze_Equality_Op --
+ -------------------------
+
+ procedure Analyze_Equality_Op (N : Node_Id) is
+ Loc : constant Source_Ptr := Sloc (N);
+ L : constant Node_Id := Left_Opnd (N);
+ R : constant Node_Id := Right_Opnd (N);
+ Op_Id : Entity_Id;
+
+ begin
+ Set_Etype (N, Any_Type);
+ Candidate_Type := Empty;
+
+ Analyze_Expression (L);
+ Analyze_Expression (R);
+
+ -- If the entity is set, the node is a generic instance with a non-local
+ -- reference to the predefined operator or to a user-defined function.
+ -- It can also be an inequality that is expanded into the negation of a
+ -- call to a user-defined equality operator.
+
+ -- For the predefined case, the result is Boolean, regardless of the
+ -- type of the operands. The operands may even be limited, if they are
+ -- generic actuals. If they are overloaded, label the left argument with
+ -- the common type that must be present, or with the type of the formal
+ -- of the user-defined function.
+
+ if Present (Entity (N)) then
+
+ Op_Id := Entity (N);
+
+ if Ekind (Op_Id) = E_Operator then
+ Add_One_Interp (N, Op_Id, Standard_Boolean);
+ else
+ Add_One_Interp (N, Op_Id, Etype (Op_Id));
+ end if;
+
+ if Is_Overloaded (L) then
+
+ if Ekind (Op_Id) = E_Operator then
+ Set_Etype (L, Intersect_Types (L, R));
+ else
+ Set_Etype (L, Etype (First_Formal (Op_Id)));
+ end if;
+ end if;
+
+ else
+ Op_Id := Get_Name_Entity_Id (Chars (N));
+
+ while Present (Op_Id) loop
+
+ if Ekind (Op_Id) = E_Operator then
+ Find_Equality_Types (L, R, Op_Id, N);
+ else
+ Analyze_User_Defined_Binary_Op (N, Op_Id);
+ end if;
+
+ Op_Id := Homonym (Op_Id);
+ end loop;
+ end if;
+
+ -- If there was no match, and the operator is inequality, this may
+ -- be a case where inequality has not been made explicit, as for
+ -- tagged types. Analyze the node as the negation of an equality
+ -- operation. This cannot be done earlier, because before analysis
+ -- we cannot rule out the presence of an explicit inequality.
+
+ if Etype (N) = Any_Type
+ and then Nkind (N) = N_Op_Ne
+ then
+ Op_Id := Get_Name_Entity_Id (Name_Op_Eq);
+
+ while Present (Op_Id) loop
+
+ if Ekind (Op_Id) = E_Operator then
+ Find_Equality_Types (L, R, Op_Id, N);
+ else
+ Analyze_User_Defined_Binary_Op (N, Op_Id);
+ end if;
+
+ Op_Id := Homonym (Op_Id);
+ end loop;
+
+ if Etype (N) /= Any_Type then
+ Op_Id := Entity (N);
+
+ Rewrite (N,
+ Make_Op_Not (Loc,
+ Right_Opnd =>
+ Make_Op_Eq (Loc,
+ Left_Opnd => Relocate_Node (Left_Opnd (N)),
+ Right_Opnd => Relocate_Node (Right_Opnd (N)))));
+
+ Set_Entity (Right_Opnd (N), Op_Id);
+ Analyze (N);
+ end if;
+ end if;
+
+ Operator_Check (N);
+ end Analyze_Equality_Op;
+
+ ----------------------------------
+ -- Analyze_Explicit_Dereference --
+ ----------------------------------
+
+ procedure Analyze_Explicit_Dereference (N : Node_Id) is
+ Loc : constant Source_Ptr := Sloc (N);
+ P : constant Node_Id := Prefix (N);
+ T : Entity_Id;
+ I : Interp_Index;
+ It : Interp;
+ New_N : Node_Id;
+
+ function Is_Function_Type return Boolean;
+ -- Check whether node may be interpreted as an implicit function call.
+
+ function Is_Function_Type return Boolean is
+ I : Interp_Index;
+ It : Interp;
+
+ begin
+ if not Is_Overloaded (N) then
+ return Ekind (Base_Type (Etype (N))) = E_Subprogram_Type
+ and then Etype (Base_Type (Etype (N))) /= Standard_Void_Type;
+
+ else
+ Get_First_Interp (N, I, It);
+
+ while Present (It.Nam) loop
+ if Ekind (Base_Type (It.Typ)) /= E_Subprogram_Type
+ or else Etype (Base_Type (It.Typ)) = Standard_Void_Type
+ then
+ return False;
+ end if;
+
+ Get_Next_Interp (I, It);
+ end loop;
+
+ return True;
+ end if;
+ end Is_Function_Type;
+
+ begin
+ Analyze (P);
+ Set_Etype (N, Any_Type);
+
+ -- Test for remote access to subprogram type, and if so return
+ -- after rewriting the original tree.
+
+ if Remote_AST_E_Dereference (P) then
+ return;
+ end if;
+
+ -- Normal processing for other than remote access to subprogram type
+
+ if not Is_Overloaded (P) then
+ if Is_Access_Type (Etype (P)) then
+
+ -- Set the Etype. We need to go thru Is_For_Access_Subtypes
+ -- to avoid other problems caused by the Private_Subtype
+ -- and it is safe to go to the Base_Type because this is the
+ -- same as converting the access value to its Base_Type.
+
+ declare
+ DT : Entity_Id := Designated_Type (Etype (P));
+
+ begin
+ if Ekind (DT) = E_Private_Subtype
+ and then Is_For_Access_Subtype (DT)
+ then
+ DT := Base_Type (DT);
+ end if;
+
+ Set_Etype (N, DT);
+ end;
+
+ elsif Etype (P) /= Any_Type then
+ Error_Msg_N ("prefix of dereference must be an access type", N);
+ return;
+ end if;
+
+ else
+ Get_First_Interp (P, I, It);
+
+ while Present (It.Nam) loop
+ T := It.Typ;
+
+ if Is_Access_Type (T) then
+ Add_One_Interp (N, Designated_Type (T), Designated_Type (T));
+ end if;
+
+ Get_Next_Interp (I, It);
+ end loop;
+
+ End_Interp_List;
+
+ -- Error if no interpretation of the prefix has an access type.
+
+ if Etype (N) = Any_Type then
+ Error_Msg_N
+ ("access type required in prefix of explicit dereference", P);
+ Set_Etype (N, Any_Type);
+ return;
+ end if;
+ end if;
+
+ if Is_Function_Type
+ and then Nkind (Parent (N)) /= N_Indexed_Component
+
+ and then (Nkind (Parent (N)) /= N_Function_Call
+ or else N /= Name (Parent (N)))
+
+ and then (Nkind (Parent (N)) /= N_Procedure_Call_Statement
+ or else N /= Name (Parent (N)))
+
+ and then Nkind (Parent (N)) /= N_Subprogram_Renaming_Declaration
+ and then (Nkind (Parent (N)) /= N_Attribute_Reference
+ or else
+ (Attribute_Name (Parent (N)) /= Name_Address
+ and then
+ Attribute_Name (Parent (N)) /= Name_Access))
+ then
+ -- Name is a function call with no actuals, in a context that
+ -- requires deproceduring (including as an actual in an enclosing
+ -- function or procedure call). We can conceive of pathological cases
+ -- where the prefix might include functions that return access to
+ -- subprograms and others that return a regular type. Disambiguation
+ -- of those will have to take place in Resolve. See e.g. 7117-014.
+
+ New_N :=
+ Make_Function_Call (Loc,
+ Name => Make_Explicit_Dereference (Loc, P),
+ Parameter_Associations => New_List);
+
+ -- If the prefix is overloaded, remove operations that have formals,
+ -- we know that this is a parameterless call.
+
+ if Is_Overloaded (P) then
+ Get_First_Interp (P, I, It);
+
+ while Present (It.Nam) loop
+ T := It.Typ;
+
+ if No (First_Formal (Base_Type (Designated_Type (T)))) then
+ Set_Etype (P, T);
+ else
+ Remove_Interp (I);
+ end if;
+
+ Get_Next_Interp (I, It);
+ end loop;
+ end if;
+
+ Rewrite (N, New_N);
+ Analyze (N);
+ end if;
+
+ -- A value of remote access-to-class-wide must not be dereferenced
+ -- (RM E.2.2(16)).
+
+ Validate_Remote_Access_To_Class_Wide_Type (N);
+
+ end Analyze_Explicit_Dereference;
+
+ ------------------------
+ -- Analyze_Expression --
+ ------------------------
+
+ procedure Analyze_Expression (N : Node_Id) is
+ begin
+ Analyze (N);
+ Check_Parameterless_Call (N);
+ end Analyze_Expression;
+
+ ------------------------------------
+ -- Analyze_Indexed_Component_Form --
+ ------------------------------------
+
+ procedure Analyze_Indexed_Component_Form (N : Node_Id) is
+ P : constant Node_Id := Prefix (N);
+ Exprs : List_Id := Expressions (N);
+ Exp : Node_Id;
+ P_T : Entity_Id;
+ E : Node_Id;
+ U_N : Entity_Id;
+
+ procedure Process_Function_Call;
+ -- Prefix in indexed component form is an overloadable entity,
+ -- so the node is a function call. Reformat it as such.
+
+ procedure Process_Indexed_Component;
+ -- Prefix in indexed component form is actually an indexed component.
+ -- This routine processes it, knowing that the prefix is already
+ -- resolved.
+
+ procedure Process_Indexed_Component_Or_Slice;
+ -- An indexed component with a single index may designate a slice if
+ -- the index is a subtype mark. This routine disambiguates these two
+ -- cases by resolving the prefix to see if it is a subtype mark.
+
+ procedure Process_Overloaded_Indexed_Component;
+ -- If the prefix of an indexed component is overloaded, the proper
+ -- interpretation is selected by the index types and the context.
+
+ ---------------------------
+ -- Process_Function_Call --
+ ---------------------------
+
+ procedure Process_Function_Call is
+ Actual : Node_Id;
+
+ begin
+ Change_Node (N, N_Function_Call);
+ Set_Name (N, P);
+ Set_Parameter_Associations (N, Exprs);
+ Actual := First (Parameter_Associations (N));
+
+ while Present (Actual) loop
+ Analyze (Actual);
+ Check_Parameterless_Call (Actual);
+ Next_Actual (Actual);
+ end loop;
+
+ Analyze_Call (N);
+ end Process_Function_Call;
+
+ -------------------------------
+ -- Process_Indexed_Component --
+ -------------------------------
+
+ procedure Process_Indexed_Component is
+ Exp : Node_Id;
+ Array_Type : Entity_Id;
+ Index : Node_Id;
+ Entry_Family : Entity_Id;
+
+ begin
+ Exp := First (Exprs);
+
+ if Is_Overloaded (P) then
+ Process_Overloaded_Indexed_Component;
+
+ else
+ Array_Type := Etype (P);
+
+ -- Prefix must be appropriate for an array type.
+ -- Dereference the prefix if it is an access type.
+
+ if Is_Access_Type (Array_Type) then
+ Array_Type := Designated_Type (Array_Type);
+ end if;
+
+ if Is_Array_Type (Array_Type) then
+ null;
+
+ elsif (Is_Entity_Name (P)
+ and then
+ Ekind (Entity (P)) = E_Entry_Family)
+ or else
+ (Nkind (P) = N_Selected_Component
+ and then
+ Is_Entity_Name (Selector_Name (P))
+ and then
+ Ekind (Entity (Selector_Name (P))) = E_Entry_Family)
+ then
+ if Is_Entity_Name (P) then
+ Entry_Family := Entity (P);
+ else
+ Entry_Family := Entity (Selector_Name (P));
+ end if;
+
+ Analyze (Exp);
+ Set_Etype (N, Any_Type);
+
+ if not Has_Compatible_Type
+ (Exp, Entry_Index_Type (Entry_Family))
+ then
+ Error_Msg_N ("invalid index type in entry name", N);
+
+ elsif Present (Next (Exp)) then
+ Error_Msg_N ("too many subscripts in entry reference", N);
+
+ else
+ Set_Etype (N, Etype (P));
+ end if;
+
+ return;
+
+ elsif Is_Record_Type (Array_Type)
+ and then Remote_AST_I_Dereference (P)
+ then
+ return;
+
+ elsif Array_Type = Any_Type then
+ Set_Etype (N, Any_Type);
+ return;
+
+ -- Here we definitely have a bad indexing
+
+ else
+ if Nkind (Parent (N)) = N_Requeue_Statement
+ and then
+ ((Is_Entity_Name (P)
+ and then Ekind (Entity (P)) = E_Entry)
+ or else
+ (Nkind (P) = N_Selected_Component
+ and then Is_Entity_Name (Selector_Name (P))
+ and then Ekind (Entity (Selector_Name (P))) = E_Entry))
+ then
+ Error_Msg_N
+ ("REQUEUE does not permit parameters", First (Exprs));
+
+ elsif Is_Entity_Name (P)
+ and then Etype (P) = Standard_Void_Type
+ then
+ Error_Msg_NE ("incorrect use of&", P, Entity (P));
+
+ else
+ Error_Msg_N ("array type required in indexed component", P);
+ end if;
+
+ Set_Etype (N, Any_Type);
+ return;
+ end if;
+
+ Index := First_Index (Array_Type);
+
+ while Present (Index) and then Present (Exp) loop
+ if not Has_Compatible_Type (Exp, Etype (Index)) then
+ Wrong_Type (Exp, Etype (Index));
+ Set_Etype (N, Any_Type);
+ return;
+ end if;
+
+ Next_Index (Index);
+ Next (Exp);
+ end loop;
+
+ Set_Etype (N, Component_Type (Array_Type));
+
+ if Present (Index) then
+ Error_Msg_N
+ ("too few subscripts in array reference", First (Exprs));
+
+ elsif Present (Exp) then
+ Error_Msg_N ("too many subscripts in array reference", Exp);
+ end if;
+ end if;
+
+ end Process_Indexed_Component;
+
+ ----------------------------------------
+ -- Process_Indexed_Component_Or_Slice --
+ ----------------------------------------
+
+ procedure Process_Indexed_Component_Or_Slice is
+ begin
+ Exp := First (Exprs);
+
+ while Present (Exp) loop
+ Analyze_Expression (Exp);
+ Next (Exp);
+ end loop;
+
+ Exp := First (Exprs);
+
+ -- If one index is present, and it is a subtype name, then the
+ -- node denotes a slice (note that the case of an explicit range
+ -- for a slice was already built as an N_Slice node in the first
+ -- place, so that case is not handled here).
+
+ -- We use a replace rather than a rewrite here because this is one
+ -- of the cases in which the tree built by the parser is plain wrong.
+
+ if No (Next (Exp))
+ and then Is_Entity_Name (Exp)
+ and then Is_Type (Entity (Exp))
+ then
+ Replace (N,
+ Make_Slice (Sloc (N),
+ Prefix => P,
+ Discrete_Range => New_Copy (Exp)));
+ Analyze (N);
+
+ -- Otherwise (more than one index present, or single index is not
+ -- a subtype name), then we have the indexed component case.
+
+ else
+ Process_Indexed_Component;
+ end if;
+ end Process_Indexed_Component_Or_Slice;
+
+ ------------------------------------------
+ -- Process_Overloaded_Indexed_Component --
+ ------------------------------------------
+
+ procedure Process_Overloaded_Indexed_Component is
+ Exp : Node_Id;
+ I : Interp_Index;
+ It : Interp;
+ Typ : Entity_Id;
+ Index : Node_Id;
+ Found : Boolean;
+
+ begin
+ Set_Etype (N, Any_Type);
+ Get_First_Interp (P, I, It);
+
+ while Present (It.Nam) loop
+ Typ := It.Typ;
+
+ if Is_Access_Type (Typ) then
+ Typ := Designated_Type (Typ);
+ end if;
+
+ if Is_Array_Type (Typ) then
+
+ -- Got a candidate: verify that index types are compatible
+
+ Index := First_Index (Typ);
+ Found := True;
+
+ Exp := First (Exprs);
+
+ while Present (Index) and then Present (Exp) loop
+ if Has_Compatible_Type (Exp, Etype (Index)) then
+ null;
+ else
+ Found := False;
+ Remove_Interp (I);
+ exit;
+ end if;
+
+ Next_Index (Index);
+ Next (Exp);
+ end loop;
+
+ if Found and then No (Index) and then No (Exp) then
+ Add_One_Interp (N,
+ Etype (Component_Type (Typ)),
+ Etype (Component_Type (Typ)));
+ end if;
+ end if;
+
+ Get_Next_Interp (I, It);
+ end loop;
+
+ if Etype (N) = Any_Type then
+ Error_Msg_N ("no legal interpetation for indexed component", N);
+ Set_Is_Overloaded (N, False);
+ end if;
+
+ End_Interp_List;
+ end Process_Overloaded_Indexed_Component;
+
+ ------------------------------------
+ -- Analyze_Indexed_Component_Form --
+ ------------------------------------
+
+ begin
+ -- Get name of array, function or type
+
+ Analyze (P);
+ P_T := Base_Type (Etype (P));
+
+ if Is_Entity_Name (P)
+ or else Nkind (P) = N_Operator_Symbol
+ then
+ U_N := Entity (P);
+
+ if Ekind (U_N) in Type_Kind then
+
+ -- Reformat node as a type conversion.
+
+ E := Remove_Head (Exprs);
+
+ if Present (First (Exprs)) then
+ Error_Msg_N
+ ("argument of type conversion must be single expression", N);
+ end if;
+
+ Change_Node (N, N_Type_Conversion);
+ Set_Subtype_Mark (N, P);
+ Set_Etype (N, U_N);
+ Set_Expression (N, E);
+
+ -- After changing the node, call for the specific Analysis
+ -- routine directly, to avoid a double call to the expander.
+
+ Analyze_Type_Conversion (N);
+ return;
+ end if;
+
+ if Is_Overloadable (U_N) then
+ Process_Function_Call;
+
+ elsif Ekind (Etype (P)) = E_Subprogram_Type
+ or else (Is_Access_Type (Etype (P))
+ and then
+ Ekind (Designated_Type (Etype (P))) = E_Subprogram_Type)
+ then
+ -- Call to access_to-subprogram with possible implicit dereference
+
+ Process_Function_Call;
+
+ elsif Ekind (U_N) = E_Generic_Function
+ or else Ekind (U_N) = E_Generic_Procedure
+ then
+ -- A common beginner's (or C++ templates fan) error.
+
+ Error_Msg_N ("generic subprogram cannot be called", N);
+ Set_Etype (N, Any_Type);
+ return;
+
+ else
+ Process_Indexed_Component_Or_Slice;
+ end if;
+
+ -- If not an entity name, prefix is an expression that may denote
+ -- an array or an access-to-subprogram.
+
+ else
+
+ if (Ekind (P_T) = E_Subprogram_Type)
+ or else (Is_Access_Type (P_T)
+ and then
+ Ekind (Designated_Type (P_T)) = E_Subprogram_Type)
+ then
+ Process_Function_Call;
+
+ elsif Nkind (P) = N_Selected_Component
+ and then Ekind (Entity (Selector_Name (P))) = E_Function
+ then
+ Process_Function_Call;
+
+ else
+ -- Indexed component, slice, or a call to a member of a family
+ -- entry, which will be converted to an entry call later.
+ Process_Indexed_Component_Or_Slice;
+ end if;
+ end if;
+ end Analyze_Indexed_Component_Form;
+
+ ------------------------
+ -- Analyze_Logical_Op --
+ ------------------------
+
+ procedure Analyze_Logical_Op (N : Node_Id) is
+ L : constant Node_Id := Left_Opnd (N);
+ R : constant Node_Id := Right_Opnd (N);
+ Op_Id : Entity_Id := Entity (N);
+
+ begin
+ Set_Etype (N, Any_Type);
+ Candidate_Type := Empty;
+
+ Analyze_Expression (L);
+ Analyze_Expression (R);
+
+ if Present (Op_Id) then
+
+ if Ekind (Op_Id) = E_Operator then
+ Find_Boolean_Types (L, R, Op_Id, N);
+ else
+ Add_One_Interp (N, Op_Id, Etype (Op_Id));
+ end if;
+
+ else
+ Op_Id := Get_Name_Entity_Id (Chars (N));
+
+ while Present (Op_Id) loop
+ if Ekind (Op_Id) = E_Operator then
+ Find_Boolean_Types (L, R, Op_Id, N);
+ else
+ Analyze_User_Defined_Binary_Op (N, Op_Id);
+ end if;
+
+ Op_Id := Homonym (Op_Id);
+ end loop;
+ end if;
+
+ Operator_Check (N);
+ end Analyze_Logical_Op;
+
+ ---------------------------
+ -- Analyze_Membership_Op --
+ ---------------------------
+
+ procedure Analyze_Membership_Op (N : Node_Id) is
+ L : constant Node_Id := Left_Opnd (N);
+ R : constant Node_Id := Right_Opnd (N);
+
+ Index : Interp_Index;
+ It : Interp;
+ Found : Boolean := False;
+ I_F : Interp_Index;
+ T_F : Entity_Id;
+
+ procedure Try_One_Interp (T1 : Entity_Id);
+ -- Routine to try one proposed interpretation. Note that the context
+ -- of the operation plays no role in resolving the arguments, so that
+ -- if there is more than one interpretation of the operands that is
+ -- compatible with a membership test, the operation is ambiguous.
+
+ procedure Try_One_Interp (T1 : Entity_Id) is
+ begin
+ if Has_Compatible_Type (R, T1) then
+ if Found
+ and then Base_Type (T1) /= Base_Type (T_F)
+ then
+ It := Disambiguate (L, I_F, Index, Any_Type);
+
+ if It = No_Interp then
+ Ambiguous_Operands (N);
+ Set_Etype (L, Any_Type);
+ return;
+
+ else
+ T_F := It.Typ;
+ end if;
+
+ else
+ Found := True;
+ T_F := T1;
+ I_F := Index;
+ end if;
+
+ Set_Etype (L, T_F);
+ end if;
+
+ end Try_One_Interp;
+
+ -- Start of processing for Analyze_Membership_Op
+
+ begin
+ Analyze_Expression (L);
+
+ if Nkind (R) = N_Range
+ or else (Nkind (R) = N_Attribute_Reference
+ and then Attribute_Name (R) = Name_Range)
+ then
+ Analyze (R);
+
+ if not Is_Overloaded (L) then
+ Try_One_Interp (Etype (L));
+
+ else
+ Get_First_Interp (L, Index, It);
+
+ while Present (It.Typ) loop
+ Try_One_Interp (It.Typ);
+ Get_Next_Interp (Index, It);
+ end loop;
+ end if;
+
+ -- If not a range, it can only be a subtype mark, or else there
+ -- is a more basic error, to be diagnosed in Find_Type.
+
+ else
+ Find_Type (R);
+
+ if Is_Entity_Name (R) then
+ Check_Fully_Declared (Entity (R), R);
+ end if;
+ end if;
+
+ -- Compatibility between expression and subtype mark or range is
+ -- checked during resolution. The result of the operation is Boolean
+ -- in any case.
+
+ Set_Etype (N, Standard_Boolean);
+ end Analyze_Membership_Op;
+
+ ----------------------
+ -- Analyze_Negation --
+ ----------------------
+
+ procedure Analyze_Negation (N : Node_Id) is
+ R : constant Node_Id := Right_Opnd (N);
+ Op_Id : Entity_Id := Entity (N);
+
+ begin
+ Set_Etype (N, Any_Type);
+ Candidate_Type := Empty;
+
+ Analyze_Expression (R);
+
+ if Present (Op_Id) then
+ if Ekind (Op_Id) = E_Operator then
+ Find_Negation_Types (R, Op_Id, N);
+ else
+ Add_One_Interp (N, Op_Id, Etype (Op_Id));
+ end if;
+
+ else
+ Op_Id := Get_Name_Entity_Id (Chars (N));
+
+ while Present (Op_Id) loop
+ if Ekind (Op_Id) = E_Operator then
+ Find_Negation_Types (R, Op_Id, N);
+ else
+ Analyze_User_Defined_Unary_Op (N, Op_Id);
+ end if;
+
+ Op_Id := Homonym (Op_Id);
+ end loop;
+ end if;
+
+ Operator_Check (N);
+ end Analyze_Negation;
+
+ -------------------
+ -- Analyze_Null --
+ -------------------
+
+ procedure Analyze_Null (N : Node_Id) is
+ begin
+ Set_Etype (N, Any_Access);
+ end Analyze_Null;
+
+ ----------------------
+ -- Analyze_One_Call --
+ ----------------------
+
+ procedure Analyze_One_Call
+ (N : Node_Id;
+ Nam : Entity_Id;
+ Report : Boolean;
+ Success : out Boolean)
+ is
+ Actuals : constant List_Id := Parameter_Associations (N);
+ Prev_T : constant Entity_Id := Etype (N);
+ Formal : Entity_Id;
+ Actual : Node_Id;
+ Is_Indexed : Boolean := False;
+ Subp_Type : constant Entity_Id := Etype (Nam);
+ Norm_OK : Boolean;
+
+ procedure Set_Name;
+ -- If candidate interpretation matches, indicate name and type of
+ -- result on call node.
+
+ --------------
+ -- Set_Name --
+ --------------
+
+ procedure Set_Name is
+ begin
+ Add_One_Interp (N, Nam, Etype (Nam));
+ Success := True;
+
+ -- If the prefix of the call is a name, indicate the entity
+ -- being called. If it is not a name, it is an expression that
+ -- denotes an access to subprogram or else an entry or family. In
+ -- the latter case, the name is a selected component, and the entity
+ -- being called is noted on the selector.
+
+ if not Is_Type (Nam) then
+ if Is_Entity_Name (Name (N))
+ or else Nkind (Name (N)) = N_Operator_Symbol
+ then
+ Set_Entity (Name (N), Nam);
+
+ elsif Nkind (Name (N)) = N_Selected_Component then
+ Set_Entity (Selector_Name (Name (N)), Nam);
+ end if;
+ end if;
+
+ if Debug_Flag_E and not Report then
+ Write_Str (" Overloaded call ");
+ Write_Int (Int (N));
+ Write_Str (" compatible with ");
+ Write_Int (Int (Nam));
+ Write_Eol;
+ end if;
+ end Set_Name;
+
+ -- Start of processing for Analyze_One_Call
+
+ begin
+ Success := False;
+
+ -- If the subprogram has no formals, or if all the formals have
+ -- defaults, and the return type is an array type, the node may
+ -- denote an indexing of the result of a parameterless call.
+
+ if Needs_No_Actuals (Nam)
+ and then Present (Actuals)
+ then
+ if Is_Array_Type (Subp_Type) then
+ Is_Indexed := Try_Indexed_Call (N, Nam, Subp_Type);
+
+ elsif Is_Access_Type (Subp_Type)
+ and then Is_Array_Type (Designated_Type (Subp_Type))
+ then
+ Is_Indexed :=
+ Try_Indexed_Call (N, Nam, Designated_Type (Subp_Type));
+
+ elsif Is_Access_Type (Subp_Type)
+ and then Ekind (Designated_Type (Subp_Type)) = E_Subprogram_Type
+ then
+ Is_Indexed := Try_Indirect_Call (N, Nam, Subp_Type);
+ end if;
+
+ end if;
+
+ Normalize_Actuals (N, Nam, (Report and not Is_Indexed), Norm_OK);
+
+ if not Norm_OK then
+
+ -- Mismatch in number or names of parameters
+
+ if Debug_Flag_E then
+ Write_Str (" normalization fails in call ");
+ Write_Int (Int (N));
+ Write_Str (" with subprogram ");
+ Write_Int (Int (Nam));
+ Write_Eol;
+ end if;
+
+ -- If the context expects a function call, discard any interpretation
+ -- that is a procedure. If the node is not overloaded, leave as is for
+ -- better error reporting when type mismatch is found.
+
+ elsif Nkind (N) = N_Function_Call
+ and then Is_Overloaded (Name (N))
+ and then Ekind (Nam) = E_Procedure
+ then
+ return;
+
+ -- Ditto for function calls in a procedure context.
+
+ elsif Nkind (N) = N_Procedure_Call_Statement
+ and then Is_Overloaded (Name (N))
+ and then Etype (Nam) /= Standard_Void_Type
+ then
+ return;
+
+ elsif not Present (Actuals) then
+
+ -- If Normalize succeeds, then there are default parameters for
+ -- all formals.
+
+ Set_Name;
+
+ elsif Ekind (Nam) = E_Operator then
+
+ if Nkind (N) = N_Procedure_Call_Statement then
+ return;
+ end if;
+
+ -- This can occur when the prefix of the call is an operator
+ -- name or an expanded name whose selector is an operator name.
+
+ Analyze_Operator_Call (N, Nam);
+
+ if Etype (N) /= Prev_T then
+
+ -- There may be a user-defined operator that hides the
+ -- current interpretation. We must check for this independently
+ -- of the analysis of the call with the user-defined operation,
+ -- because the parameter names may be wrong and yet the hiding
+ -- takes place. Fixes b34014o.
+
+ if Is_Overloaded (Name (N)) then
+ declare
+ I : Interp_Index;
+ It : Interp;
+
+ begin
+ Get_First_Interp (Name (N), I, It);
+
+ while Present (It.Nam) loop
+
+ if Ekind (It.Nam) /= E_Operator
+ and then Hides_Op (It.Nam, Nam)
+ and then
+ Has_Compatible_Type
+ (First_Actual (N), Etype (First_Formal (It.Nam)))
+ and then (No (Next_Actual (First_Actual (N)))
+ or else Has_Compatible_Type
+ (Next_Actual (First_Actual (N)),
+ Etype (Next_Formal (First_Formal (It.Nam)))))
+ then
+ Set_Etype (N, Prev_T);
+ return;
+ end if;
+
+ Get_Next_Interp (I, It);
+ end loop;
+ end;
+ end if;
+
+ -- If operator matches formals, record its name on the call.
+ -- If the operator is overloaded, Resolve will select the
+ -- correct one from the list of interpretations. The call
+ -- node itself carries the first candidate.
+
+ Set_Entity (Name (N), Nam);
+ Success := True;
+
+ elsif Report and then Etype (N) = Any_Type then
+ Error_Msg_N ("incompatible arguments for operator", N);
+ end if;
+
+ else
+ -- Normalize_Actuals has chained the named associations in the
+ -- correct order of the formals.
+
+ Actual := First_Actual (N);
+ Formal := First_Formal (Nam);
+
+ while Present (Actual) and then Present (Formal) loop
+
+ if (Nkind (Parent (Actual)) /= N_Parameter_Association
+ or else Chars (Selector_Name (Parent (Actual))) = Chars (Formal))
+ then
+ if Has_Compatible_Type (Actual, Etype (Formal)) then
+ Next_Actual (Actual);
+ Next_Formal (Formal);
+
+ else
+ if Debug_Flag_E then
+ Write_Str (" type checking fails in call ");
+ Write_Int (Int (N));
+ Write_Str (" with formal ");
+ Write_Int (Int (Formal));
+ Write_Str (" in subprogram ");
+ Write_Int (Int (Nam));
+ Write_Eol;
+ end if;
+
+ if Report and not Is_Indexed then
+
+ Wrong_Type (Actual, Etype (Formal));
+
+ if Nkind (Actual) = N_Op_Eq
+ and then Nkind (Left_Opnd (Actual)) = N_Identifier
+ then
+ Formal := First_Formal (Nam);
+
+ while Present (Formal) loop
+
+ if Chars (Left_Opnd (Actual)) = Chars (Formal) then
+ Error_Msg_N
+ ("possible misspelling of `=>`!", Actual);
+ exit;
+ end if;
+
+ Next_Formal (Formal);
+ end loop;
+ end if;
+
+ if All_Errors_Mode then
+ Error_Msg_Sloc := Sloc (Nam);
+
+ if Is_Overloadable (Nam)
+ and then Present (Alias (Nam))
+ and then not Comes_From_Source (Nam)
+ then
+ Error_Msg_NE
+ (" ==> in call to &#(inherited)!", Actual, Nam);
+ else
+ Error_Msg_NE (" ==> in call to &#!", Actual, Nam);
+ end if;
+ end if;
+ end if;
+
+ return;
+ end if;
+
+ else
+ -- Normalize_Actuals has verified that a default value exists
+ -- for this formal. Current actual names a subsequent formal.
+
+ Next_Formal (Formal);
+ end if;
+ end loop;
+
+ -- On exit, all actuals match.
+
+ Set_Name;
+ end if;
+ end Analyze_One_Call;
+
+ ----------------------------
+ -- Analyze_Operator_Call --
+ ----------------------------
+
+ procedure Analyze_Operator_Call (N : Node_Id; Op_Id : Entity_Id) is
+ Op_Name : constant Name_Id := Chars (Op_Id);
+ Act1 : constant Node_Id := First_Actual (N);
+ Act2 : constant Node_Id := Next_Actual (Act1);
+
+ begin
+ if Present (Act2) then
+
+ -- Maybe binary operators
+
+ if Present (Next_Actual (Act2)) then
+
+ -- Too many actuals for an operator
+
+ return;
+
+ elsif Op_Name = Name_Op_Add
+ or else Op_Name = Name_Op_Subtract
+ or else Op_Name = Name_Op_Multiply
+ or else Op_Name = Name_Op_Divide
+ or else Op_Name = Name_Op_Mod
+ or else Op_Name = Name_Op_Rem
+ or else Op_Name = Name_Op_Expon
+ then
+ Find_Arithmetic_Types (Act1, Act2, Op_Id, N);
+
+ elsif Op_Name = Name_Op_And
+ or else Op_Name = Name_Op_Or
+ or else Op_Name = Name_Op_Xor
+ then
+ Find_Boolean_Types (Act1, Act2, Op_Id, N);
+
+ elsif Op_Name = Name_Op_Lt
+ or else Op_Name = Name_Op_Le
+ or else Op_Name = Name_Op_Gt
+ or else Op_Name = Name_Op_Ge
+ then
+ Find_Comparison_Types (Act1, Act2, Op_Id, N);
+
+ elsif Op_Name = Name_Op_Eq
+ or else Op_Name = Name_Op_Ne
+ then
+ Find_Equality_Types (Act1, Act2, Op_Id, N);
+
+ elsif Op_Name = Name_Op_Concat then
+ Find_Concatenation_Types (Act1, Act2, Op_Id, N);
+
+ -- Is this else null correct, or should it be an abort???
+
+ else
+ null;
+ end if;
+
+ else
+ -- Unary operators
+
+ if Op_Name = Name_Op_Subtract or else
+ Op_Name = Name_Op_Add or else
+ Op_Name = Name_Op_Abs
+ then
+ Find_Unary_Types (Act1, Op_Id, N);
+
+ elsif
+ Op_Name = Name_Op_Not
+ then
+ Find_Negation_Types (Act1, Op_Id, N);
+
+ -- Is this else null correct, or should it be an abort???
+
+ else
+ null;
+ end if;
+ end if;
+ end Analyze_Operator_Call;
+
+ -------------------------------------------
+ -- Analyze_Overloaded_Selected_Component --
+ -------------------------------------------
+
+ procedure Analyze_Overloaded_Selected_Component (N : Node_Id) is
+ Comp : Entity_Id;
+ Nam : Node_Id := Prefix (N);
+ Sel : Node_Id := Selector_Name (N);
+ I : Interp_Index;
+ It : Interp;
+ T : Entity_Id;
+
+ begin
+ Get_First_Interp (Nam, I, It);
+
+ Set_Etype (Sel, Any_Type);
+
+ while Present (It.Typ) loop
+ if Is_Access_Type (It.Typ) then
+ T := Designated_Type (It.Typ);
+ else
+ T := It.Typ;
+ end if;
+
+ if Is_Record_Type (T) then
+ Comp := First_Entity (T);
+
+ while Present (Comp) loop
+
+ if Chars (Comp) = Chars (Sel)
+ and then Is_Visible_Component (Comp)
+ then
+ Set_Entity_With_Style_Check (Sel, Comp);
+ Generate_Reference (Comp, Sel);
+
+ Set_Etype (Sel, Etype (Comp));
+ Add_One_Interp (N, Etype (Comp), Etype (Comp));
+
+ -- This also specifies a candidate to resolve the name.
+ -- Further overloading will be resolved from context.
+
+ Set_Etype (Nam, It.Typ);
+ end if;
+
+ Next_Entity (Comp);
+ end loop;
+
+ elsif Is_Concurrent_Type (T) then
+ Comp := First_Entity (T);
+
+ while Present (Comp)
+ and then Comp /= First_Private_Entity (T)
+ loop
+ if Chars (Comp) = Chars (Sel) then
+ if Is_Overloadable (Comp) then
+ Add_One_Interp (Sel, Comp, Etype (Comp));
+ else
+ Set_Entity_With_Style_Check (Sel, Comp);
+ Generate_Reference (Comp, Sel);
+ end if;
+
+ Set_Etype (Sel, Etype (Comp));
+ Set_Etype (N, Etype (Comp));
+ Set_Etype (Nam, It.Typ);
+
+ -- For access type case, introduce explicit deference for
+ -- more uniform treatment of entry calls.
+
+ if Is_Access_Type (Etype (Nam)) then
+ Insert_Explicit_Dereference (Nam);
+ end if;
+ end if;
+
+ Next_Entity (Comp);
+ end loop;
+
+ Set_Is_Overloaded (N, Is_Overloaded (Sel));
+
+ end if;
+
+ Get_Next_Interp (I, It);
+ end loop;
+
+ if Etype (N) = Any_Type then
+ Error_Msg_NE ("undefined selector& for overloaded prefix", N, Sel);
+ Set_Entity (Sel, Any_Id);
+ Set_Etype (Sel, Any_Type);
+ end if;
+
+ end Analyze_Overloaded_Selected_Component;
+
+ ----------------------------------
+ -- Analyze_Qualified_Expression --
+ ----------------------------------
+
+ procedure Analyze_Qualified_Expression (N : Node_Id) is
+ Mark : constant Entity_Id := Subtype_Mark (N);
+ T : Entity_Id;
+
+ begin
+ Set_Etype (N, Any_Type);
+ Find_Type (Mark);
+ T := Entity (Mark);
+
+ if T = Any_Type then
+ return;
+ end if;
+ Check_Fully_Declared (T, N);
+
+ Analyze_Expression (Expression (N));
+ Set_Etype (N, T);
+ end Analyze_Qualified_Expression;
+
+ -------------------
+ -- Analyze_Range --
+ -------------------
+
+ procedure Analyze_Range (N : Node_Id) is
+ L : constant Node_Id := Low_Bound (N);
+ H : constant Node_Id := High_Bound (N);
+ I1, I2 : Interp_Index;
+ It1, It2 : Interp;
+
+ procedure Check_Common_Type (T1, T2 : Entity_Id);
+ -- Verify the compatibility of two types, and choose the
+ -- non universal one if the other is universal.
+
+ procedure Check_High_Bound (T : Entity_Id);
+ -- Test one interpretation of the low bound against all those
+ -- of the high bound.
+
+ -----------------------
+ -- Check_Common_Type --
+ -----------------------
+
+ procedure Check_Common_Type (T1, T2 : Entity_Id) is
+ begin
+ if Covers (T1, T2) or else Covers (T2, T1) then
+ if T1 = Universal_Integer
+ or else T1 = Universal_Real
+ or else T1 = Any_Character
+ then
+ Add_One_Interp (N, Base_Type (T2), Base_Type (T2));
+
+ elsif (T1 = T2) then
+ Add_One_Interp (N, T1, T1);
+
+ else
+ Add_One_Interp (N, Base_Type (T1), Base_Type (T1));
+ end if;
+ end if;
+ end Check_Common_Type;
+
+ ----------------------
+ -- Check_High_Bound --
+ ----------------------
+
+ procedure Check_High_Bound (T : Entity_Id) is
+ begin
+ if not Is_Overloaded (H) then
+ Check_Common_Type (T, Etype (H));
+ else
+ Get_First_Interp (H, I2, It2);
+
+ while Present (It2.Typ) loop
+ Check_Common_Type (T, It2.Typ);
+ Get_Next_Interp (I2, It2);
+ end loop;
+ end if;
+ end Check_High_Bound;
+
+ -- Start of processing for Analyze_Range
+
+ begin
+ Set_Etype (N, Any_Type);
+ Analyze_Expression (L);
+ Analyze_Expression (H);
+
+ if Etype (L) = Any_Type or else Etype (H) = Any_Type then
+ return;
+
+ else
+ if not Is_Overloaded (L) then
+ Check_High_Bound (Etype (L));
+ else
+ Get_First_Interp (L, I1, It1);
+
+ while Present (It1.Typ) loop
+ Check_High_Bound (It1.Typ);
+ Get_Next_Interp (I1, It1);
+ end loop;
+ end if;
+
+ -- If result is Any_Type, then we did not find a compatible pair
+
+ if Etype (N) = Any_Type then
+ Error_Msg_N ("incompatible types in range ", N);
+ end if;
+ end if;
+ end Analyze_Range;
+
+ -----------------------
+ -- Analyze_Reference --
+ -----------------------
+
+ procedure Analyze_Reference (N : Node_Id) is
+ P : constant Node_Id := Prefix (N);
+ Acc_Type : Entity_Id;
+
+ begin
+ Analyze (P);
+ Acc_Type := Create_Itype (E_Allocator_Type, N);
+ Set_Etype (Acc_Type, Acc_Type);
+ Init_Size_Align (Acc_Type);
+ Set_Directly_Designated_Type (Acc_Type, Etype (P));
+ Set_Etype (N, Acc_Type);
+ end Analyze_Reference;
+
+ --------------------------------
+ -- Analyze_Selected_Component --
+ --------------------------------
+
+ -- Prefix is a record type or a task or protected type. In the
+ -- later case, the selector must denote a visible entry.
+
+ procedure Analyze_Selected_Component (N : Node_Id) is
+ Name : constant Node_Id := Prefix (N);
+ Sel : constant Node_Id := Selector_Name (N);
+ Comp : Entity_Id;
+ Entity_List : Entity_Id;
+ Prefix_Type : Entity_Id;
+ Act_Decl : Node_Id;
+ In_Scope : Boolean;
+ Parent_N : Node_Id;
+
+ -- Start of processing for Analyze_Selected_Component
+
+ begin
+ Set_Etype (N, Any_Type);
+
+ if Is_Overloaded (Name) then
+ Analyze_Overloaded_Selected_Component (N);
+ return;
+
+ elsif Etype (Name) = Any_Type then
+ Set_Entity (Sel, Any_Id);
+ Set_Etype (Sel, Any_Type);
+ return;
+
+ else
+ -- Function calls that are prefixes of selected components must be
+ -- fully resolved in case we need to build an actual subtype, or
+ -- do some other operation requiring a fully resolved prefix.
+
+ -- Note: Resolving all Nkinds of nodes here doesn't work.
+ -- (Breaks 2129-008) ???.
+
+ if Nkind (Name) = N_Function_Call then
+ Resolve (Name, Etype (Name));
+ end if;
+
+ Prefix_Type := Etype (Name);
+ end if;
+
+ if Is_Access_Type (Prefix_Type) then
+ if Is_Remote_Access_To_Class_Wide_Type (Prefix_Type)
+ and then Comes_From_Source (N)
+ then
+ -- A RACW object can never be used as prefix of a selected
+ -- component since that means it is dereferenced without
+ -- being a controlling operand of a dispatching operation
+ -- (RM E.2.2(15)).
+
+ Error_Msg_N
+ ("invalid dereference of a remote access to class-wide value",
+ N);
+ end if;
+ Prefix_Type := Designated_Type (Prefix_Type);
+ end if;
+
+ if Ekind (Prefix_Type) = E_Private_Subtype then
+ Prefix_Type := Base_Type (Prefix_Type);
+ end if;
+
+ Entity_List := Prefix_Type;
+
+ -- For class-wide types, use the entity list of the root type. This
+ -- indirection is specially important for private extensions because
+ -- only the root type get switched (not the class-wide type).
+
+ if Is_Class_Wide_Type (Prefix_Type) then
+ Entity_List := Root_Type (Prefix_Type);
+ end if;
+
+ Comp := First_Entity (Entity_List);
+
+ -- If the selector has an original discriminant, the node appears in
+ -- an instance. Replace the discriminant with the corresponding one
+ -- in the current discriminated type. For nested generics, this must
+ -- be done transitively, so note the new original discriminant.
+
+ if Nkind (Sel) = N_Identifier
+ and then Present (Original_Discriminant (Sel))
+ then
+ Comp := Find_Corresponding_Discriminant (Sel, Prefix_Type);
+
+ -- Mark entity before rewriting, for completeness and because
+ -- subsequent semantic checks might examine the original node.
+
+ Set_Entity (Sel, Comp);
+ Rewrite (Selector_Name (N),
+ New_Occurrence_Of (Comp, Sloc (N)));
+ Set_Original_Discriminant (Selector_Name (N), Comp);
+ Set_Etype (N, Etype (Comp));
+
+ if Is_Access_Type (Etype (Name)) then
+ Insert_Explicit_Dereference (Name);
+ end if;
+
+ elsif Is_Record_Type (Prefix_Type) then
+
+ -- Find component with given name
+
+ while Present (Comp) loop
+
+ if Chars (Comp) = Chars (Sel)
+ and then Is_Visible_Component (Comp)
+ then
+ Set_Entity_With_Style_Check (Sel, Comp);
+ Generate_Reference (Comp, Sel);
+
+ Set_Etype (Sel, Etype (Comp));
+
+ if Ekind (Comp) = E_Discriminant then
+ if Is_Unchecked_Union (Prefix_Type) then
+ Error_Msg_N
+ ("cannot reference discriminant of Unchecked_Union",
+ Sel);
+ end if;
+
+ if Is_Generic_Type (Prefix_Type)
+ or else
+ Is_Generic_Type (Root_Type (Prefix_Type))
+ then
+ Set_Original_Discriminant (Sel, Comp);
+ end if;
+ end if;
+
+ -- Resolve the prefix early otherwise it is not possible to
+ -- build the actual subtype of the component: it may need
+ -- to duplicate this prefix and duplication is only allowed
+ -- on fully resolved expressions.
+
+ Resolve (Name, Etype (Name));
+
+ -- We never need an actual subtype for the case of a selection
+ -- for a indexed component of a non-packed array, since in
+ -- this case gigi generates all the checks and can find the
+ -- necessary bounds information.
+
+ -- We also do not need an actual subtype for the case of
+ -- a first, last, length, or range attribute applied to a
+ -- non-packed array, since gigi can again get the bounds in
+ -- these cases (gigi cannot handle the packed case, since it
+ -- has the bounds of the packed array type, not the original
+ -- bounds of the type). However, if the prefix is itself a
+ -- selected component, as in a.b.c (i), gigi may regard a.b.c
+ -- as a dynamic-sized temporary, so we do generate an actual
+ -- subtype for this case.
+
+ Parent_N := Parent (N);
+
+ if not Is_Packed (Etype (Comp))
+ and then
+ ((Nkind (Parent_N) = N_Indexed_Component
+ and then Nkind (Name) /= N_Selected_Component)
+ or else
+ (Nkind (Parent_N) = N_Attribute_Reference
+ and then (Attribute_Name (Parent_N) = Name_First
+ or else
+ Attribute_Name (Parent_N) = Name_Last
+ or else
+ Attribute_Name (Parent_N) = Name_Length
+ or else
+ Attribute_Name (Parent_N) = Name_Range)))
+ then
+ Set_Etype (N, Etype (Comp));
+
+ -- In all other cases, we currently build an actual subtype. It
+ -- seems likely that many of these cases can be avoided, but
+ -- right now, the front end makes direct references to the
+ -- bounds (e.g. in egnerating a length check), and if we do
+ -- not make an actual subtype, we end up getting a direct
+ -- reference to a discriminant which will not do.
+
+ else
+ Act_Decl :=
+ Build_Actual_Subtype_Of_Component (Etype (Comp), N);
+ Insert_Action (N, Act_Decl);
+
+ if No (Act_Decl) then
+ Set_Etype (N, Etype (Comp));
+
+ else
+ -- Component type depends on discriminants. Enter the
+ -- main attributes of the subtype.
+
+ declare
+ Subt : Entity_Id := Defining_Identifier (Act_Decl);
+
+ begin
+ Set_Etype (Subt, Base_Type (Etype (Comp)));
+ Set_Ekind (Subt, Ekind (Etype (Comp)));
+ Set_Etype (N, Subt);
+ end;
+ end if;
+ end if;
+
+ return;
+ end if;
+
+ Next_Entity (Comp);
+ end loop;
+
+ elsif Is_Private_Type (Prefix_Type) then
+
+ -- Allow access only to discriminants of the type. If the
+ -- type has no full view, gigi uses the parent type for
+ -- the components, so we do the same here.
+
+ if No (Full_View (Prefix_Type)) then
+ Entity_List := Root_Type (Base_Type (Prefix_Type));
+ Comp := First_Entity (Entity_List);
+ end if;
+
+ while Present (Comp) loop
+
+ if Chars (Comp) = Chars (Sel) then
+ if Ekind (Comp) = E_Discriminant then
+ Set_Entity_With_Style_Check (Sel, Comp);
+ Generate_Reference (Comp, Sel);
+
+ Set_Etype (Sel, Etype (Comp));
+ Set_Etype (N, Etype (Comp));
+
+ if Is_Generic_Type (Prefix_Type)
+ or else
+ Is_Generic_Type (Root_Type (Prefix_Type))
+ then
+ Set_Original_Discriminant (Sel, Comp);
+ end if;
+
+ else
+ Error_Msg_NE
+ ("invisible selector for }",
+ N, First_Subtype (Prefix_Type));
+ Set_Entity (Sel, Any_Id);
+ Set_Etype (N, Any_Type);
+ end if;
+
+ return;
+ end if;
+
+ Next_Entity (Comp);
+ end loop;
+
+ elsif Is_Concurrent_Type (Prefix_Type) then
+
+ -- Prefix is concurrent type. Find visible operation with given name
+ -- For a task, this can only include entries or discriminants if
+ -- the task type is not an enclosing scope. If it is an enclosing
+ -- scope (e.g. in an inner task) then all entities are visible, but
+ -- the prefix must denote the enclosing scope, i.e. can only be
+ -- a direct name or an expanded name.
+
+ Set_Etype (Sel, Any_Type);
+ In_Scope := In_Open_Scopes (Prefix_Type);
+
+ while Present (Comp) loop
+ if Chars (Comp) = Chars (Sel) then
+ if Is_Overloadable (Comp) then
+ Add_One_Interp (Sel, Comp, Etype (Comp));
+
+ elsif Ekind (Comp) = E_Discriminant
+ or else Ekind (Comp) = E_Entry_Family
+ or else (In_Scope
+ and then Is_Entity_Name (Name))
+ then
+ Set_Entity_With_Style_Check (Sel, Comp);
+ Generate_Reference (Comp, Sel);
+
+ else
+ goto Next_Comp;
+ end if;
+
+ Set_Etype (Sel, Etype (Comp));
+ Set_Etype (N, Etype (Comp));
+
+ if Ekind (Comp) = E_Discriminant then
+ Set_Original_Discriminant (Sel, Comp);
+ end if;
+
+ -- For access type case, introduce explicit deference for
+ -- more uniform treatment of entry calls.
+
+ if Is_Access_Type (Etype (Name)) then
+ Insert_Explicit_Dereference (Name);
+ end if;
+ end if;
+
+ <<Next_Comp>>
+ Next_Entity (Comp);
+ exit when not In_Scope
+ and then Comp = First_Private_Entity (Prefix_Type);
+ end loop;
+
+ Set_Is_Overloaded (N, Is_Overloaded (Sel));
+
+ else
+ -- Invalid prefix
+
+ Error_Msg_NE ("invalid prefix in selected component&", N, Sel);
+ end if;
+
+ -- If N still has no type, the component is not defined in the prefix.
+
+ if Etype (N) = Any_Type then
+
+ -- If the prefix is a single concurrent object, use its name in
+ -- the error message, rather than that of its anonymous type.
+
+ if Is_Concurrent_Type (Prefix_Type)
+ and then Is_Internal_Name (Chars (Prefix_Type))
+ and then not Is_Derived_Type (Prefix_Type)
+ and then Is_Entity_Name (Name)
+ then
+
+ Error_Msg_Node_2 := Entity (Name);
+ Error_Msg_NE ("no selector& for&", N, Sel);
+
+ Check_Misspelled_Selector (Entity_List, Sel);
+
+ else
+ if Ekind (Prefix_Type) = E_Record_Subtype then
+
+ -- Check whether this is a component of the base type
+ -- which is absent from a statically constrained subtype.
+ -- This will raise constraint error at run-time, but is
+ -- not a compile-time error. When the selector is illegal
+ -- for base type as well fall through and generate a
+ -- compilation error anyway.
+
+ Comp := First_Component (Base_Type (Prefix_Type));
+
+ while Present (Comp) loop
+
+ if Chars (Comp) = Chars (Sel)
+ and then Is_Visible_Component (Comp)
+ then
+ Set_Entity_With_Style_Check (Sel, Comp);
+ Generate_Reference (Comp, Sel);
+ Set_Etype (Sel, Etype (Comp));
+ Set_Etype (N, Etype (Comp));
+
+ -- Emit appropriate message. Gigi will replace the
+ -- node subsequently with the appropriate Raise.
+
+ Apply_Compile_Time_Constraint_Error
+ (N, "component not present in }?",
+ Ent => Prefix_Type, Rep => False);
+ Set_Raises_Constraint_Error (N);
+ return;
+ end if;
+
+ Next_Component (Comp);
+ end loop;
+
+ end if;
+
+ Error_Msg_Node_2 := First_Subtype (Prefix_Type);
+ Error_Msg_NE ("no selector& for}", N, Sel);
+
+ Check_Misspelled_Selector (Entity_List, Sel);
+
+ end if;
+
+ Set_Entity (Sel, Any_Id);
+ Set_Etype (Sel, Any_Type);
+ end if;
+ end Analyze_Selected_Component;
+
+ ---------------------------
+ -- Analyze_Short_Circuit --
+ ---------------------------
+
+ procedure Analyze_Short_Circuit (N : Node_Id) is
+ L : constant Node_Id := Left_Opnd (N);
+ R : constant Node_Id := Right_Opnd (N);
+ Ind : Interp_Index;
+ It : Interp;
+
+ begin
+ Analyze_Expression (L);
+ Analyze_Expression (R);
+ Set_Etype (N, Any_Type);
+
+ if not Is_Overloaded (L) then
+
+ if Root_Type (Etype (L)) = Standard_Boolean
+ and then Has_Compatible_Type (R, Etype (L))
+ then
+ Add_One_Interp (N, Etype (L), Etype (L));
+ end if;
+
+ else
+ Get_First_Interp (L, Ind, It);
+
+ while Present (It.Typ) loop
+ if Root_Type (It.Typ) = Standard_Boolean
+ and then Has_Compatible_Type (R, It.Typ)
+ then
+ Add_One_Interp (N, It.Typ, It.Typ);
+ end if;
+
+ Get_Next_Interp (Ind, It);
+ end loop;
+ end if;
+
+ -- Here we have failed to find an interpretation. Clearly we
+ -- know that it is not the case that both operands can have
+ -- an interpretation of Boolean, but this is by far the most
+ -- likely intended interpretation. So we simply resolve both
+ -- operands as Booleans, and at least one of these resolutions
+ -- will generate an error message, and we do not need to give
+ -- a further error message on the short circuit operation itself.
+
+ if Etype (N) = Any_Type then
+ Resolve (L, Standard_Boolean);
+ Resolve (R, Standard_Boolean);
+ Set_Etype (N, Standard_Boolean);
+ end if;
+ end Analyze_Short_Circuit;
+
+ -------------------
+ -- Analyze_Slice --
+ -------------------
+
+ procedure Analyze_Slice (N : Node_Id) is
+ P : constant Node_Id := Prefix (N);
+ D : constant Node_Id := Discrete_Range (N);
+ Array_Type : Entity_Id;
+
+ procedure Analyze_Overloaded_Slice;
+ -- If the prefix is overloaded, select those interpretations that
+ -- yield a one-dimensional array type.
+
+ procedure Analyze_Overloaded_Slice is
+ I : Interp_Index;
+ It : Interp;
+ Typ : Entity_Id;
+
+ begin
+ Set_Etype (N, Any_Type);
+ Get_First_Interp (P, I, It);
+
+ while Present (It.Nam) loop
+ Typ := It.Typ;
+
+ if Is_Access_Type (Typ) then
+ Typ := Designated_Type (Typ);
+ end if;
+
+ if Is_Array_Type (Typ)
+ and then Number_Dimensions (Typ) = 1
+ and then Has_Compatible_Type (D, Etype (First_Index (Typ)))
+ then
+ Add_One_Interp (N, Typ, Typ);
+ end if;
+
+ Get_Next_Interp (I, It);
+ end loop;
+
+ if Etype (N) = Any_Type then
+ Error_Msg_N ("expect array type in prefix of slice", N);
+ end if;
+ end Analyze_Overloaded_Slice;
+
+ -- Start of processing for Analyze_Slice
+
+ begin
+ -- Analyze the prefix if not done already
+
+ if No (Etype (P)) then
+ Analyze (P);
+ end if;
+
+ Analyze (D);
+
+ if Is_Overloaded (P) then
+ Analyze_Overloaded_Slice;
+
+ else
+ Array_Type := Etype (P);
+ Set_Etype (N, Any_Type);
+
+ if Is_Access_Type (Array_Type) then
+ Array_Type := Designated_Type (Array_Type);
+ end if;
+
+ if not Is_Array_Type (Array_Type) then
+ Wrong_Type (P, Any_Array);
+
+ elsif Number_Dimensions (Array_Type) > 1 then
+ Error_Msg_N
+ ("type is not one-dimensional array in slice prefix", N);
+
+ elsif not
+ Has_Compatible_Type (D, Etype (First_Index (Array_Type)))
+ then
+ Wrong_Type (D, Etype (First_Index (Array_Type)));
+
+ else
+ Set_Etype (N, Array_Type);
+ end if;
+ end if;
+ end Analyze_Slice;
+
+ -----------------------------
+ -- Analyze_Type_Conversion --
+ -----------------------------
+
+ procedure Analyze_Type_Conversion (N : Node_Id) is
+ Expr : constant Node_Id := Expression (N);
+ T : Entity_Id;
+
+ begin
+ -- If Conversion_OK is set, then the Etype is already set, and the
+ -- only processing required is to analyze the expression. This is
+ -- used to construct certain "illegal" conversions which are not
+ -- allowed by Ada semantics, but can be handled OK by Gigi, see
+ -- Sinfo for further details.
+
+ if Conversion_OK (N) then
+ Analyze (Expr);
+ return;
+ end if;
+
+ -- Otherwise full type analysis is required, as well as some semantic
+ -- checks to make sure the argument of the conversion is appropriate.
+
+ Find_Type (Subtype_Mark (N));
+ T := Entity (Subtype_Mark (N));
+ Set_Etype (N, T);
+ Check_Fully_Declared (T, N);
+ Analyze_Expression (Expr);
+ Validate_Remote_Type_Type_Conversion (N);
+
+ -- Only remaining step is validity checks on the argument. These
+ -- are skipped if the conversion does not come from the source.
+
+ if not Comes_From_Source (N) then
+ return;
+
+ elsif Nkind (Expr) = N_Null then
+ Error_Msg_N ("argument of conversion cannot be null", N);
+ Error_Msg_N ("\use qualified expression instead", N);
+ Set_Etype (N, Any_Type);
+
+ elsif Nkind (Expr) = N_Aggregate then
+ Error_Msg_N ("argument of conversion cannot be aggregate", N);
+ Error_Msg_N ("\use qualified expression instead", N);
+
+ elsif Nkind (Expr) = N_Allocator then
+ Error_Msg_N ("argument of conversion cannot be an allocator", N);
+ Error_Msg_N ("\use qualified expression instead", N);
+
+ elsif Nkind (Expr) = N_String_Literal then
+ Error_Msg_N ("argument of conversion cannot be string literal", N);
+ Error_Msg_N ("\use qualified expression instead", N);
+
+ elsif Nkind (Expr) = N_Character_Literal then
+ if Ada_83 then
+ Resolve (Expr, T);
+ else
+ Error_Msg_N ("argument of conversion cannot be character literal",
+ N);
+ Error_Msg_N ("\use qualified expression instead", N);
+ end if;
+
+ elsif Nkind (Expr) = N_Attribute_Reference
+ and then
+ (Attribute_Name (Expr) = Name_Access or else
+ Attribute_Name (Expr) = Name_Unchecked_Access or else
+ Attribute_Name (Expr) = Name_Unrestricted_Access)
+ then
+ Error_Msg_N ("argument of conversion cannot be access", N);
+ Error_Msg_N ("\use qualified expression instead", N);
+ end if;
+
+ end Analyze_Type_Conversion;
+
+ ----------------------
+ -- Analyze_Unary_Op --
+ ----------------------
+
+ procedure Analyze_Unary_Op (N : Node_Id) is
+ R : constant Node_Id := Right_Opnd (N);
+ Op_Id : Entity_Id := Entity (N);
+
+ begin
+ Set_Etype (N, Any_Type);
+ Candidate_Type := Empty;
+
+ Analyze_Expression (R);
+
+ if Present (Op_Id) then
+ if Ekind (Op_Id) = E_Operator then
+ Find_Unary_Types (R, Op_Id, N);
+ else
+ Add_One_Interp (N, Op_Id, Etype (Op_Id));
+ end if;
+
+ else
+ Op_Id := Get_Name_Entity_Id (Chars (N));
+
+ while Present (Op_Id) loop
+
+ if Ekind (Op_Id) = E_Operator then
+ if No (Next_Entity (First_Entity (Op_Id))) then
+ Find_Unary_Types (R, Op_Id, N);
+ end if;
+
+ elsif Is_Overloadable (Op_Id) then
+ Analyze_User_Defined_Unary_Op (N, Op_Id);
+ end if;
+
+ Op_Id := Homonym (Op_Id);
+ end loop;
+ end if;
+
+ Operator_Check (N);
+ end Analyze_Unary_Op;
+
+ ----------------------------------
+ -- Analyze_Unchecked_Expression --
+ ----------------------------------
+
+ procedure Analyze_Unchecked_Expression (N : Node_Id) is
+ begin
+ Analyze (Expression (N), Suppress => All_Checks);
+ Set_Etype (N, Etype (Expression (N)));
+ Save_Interps (Expression (N), N);
+ end Analyze_Unchecked_Expression;
+
+ ---------------------------------------
+ -- Analyze_Unchecked_Type_Conversion --
+ ---------------------------------------
+
+ procedure Analyze_Unchecked_Type_Conversion (N : Node_Id) is
+ begin
+ Find_Type (Subtype_Mark (N));
+ Analyze_Expression (Expression (N));
+ Set_Etype (N, Entity (Subtype_Mark (N)));
+ end Analyze_Unchecked_Type_Conversion;
+
+ ------------------------------------
+ -- Analyze_User_Defined_Binary_Op --
+ ------------------------------------
+
+ procedure Analyze_User_Defined_Binary_Op
+ (N : Node_Id;
+ Op_Id : Entity_Id)
+ is
+ begin
+ -- Only do analysis if the operator Comes_From_Source, since otherwise
+ -- the operator was generated by the expander, and all such operators
+ -- always refer to the operators in package Standard.
+
+ if Comes_From_Source (N) then
+ declare
+ F1 : constant Entity_Id := First_Formal (Op_Id);
+ F2 : constant Entity_Id := Next_Formal (F1);
+
+ begin
+ -- Verify that Op_Id is a visible binary function. Note that since
+ -- we know Op_Id is overloaded, potentially use visible means use
+ -- visible for sure (RM 9.4(11)).
+
+ if Ekind (Op_Id) = E_Function
+ and then Present (F2)
+ and then (Is_Immediately_Visible (Op_Id)
+ or else Is_Potentially_Use_Visible (Op_Id))
+ and then Has_Compatible_Type (Left_Opnd (N), Etype (F1))
+ and then Has_Compatible_Type (Right_Opnd (N), Etype (F2))
+ then
+ Add_One_Interp (N, Op_Id, Etype (Op_Id));
+
+ if Debug_Flag_E then
+ Write_Str ("user defined operator ");
+ Write_Name (Chars (Op_Id));
+ Write_Str (" on node ");
+ Write_Int (Int (N));
+ Write_Eol;
+ end if;
+ end if;
+ end;
+ end if;
+ end Analyze_User_Defined_Binary_Op;
+
+ -----------------------------------
+ -- Analyze_User_Defined_Unary_Op --
+ -----------------------------------
+
+ procedure Analyze_User_Defined_Unary_Op
+ (N : Node_Id;
+ Op_Id : Entity_Id)
+ is
+ begin
+ -- Only do analysis if the operator Comes_From_Source, since otherwise
+ -- the operator was generated by the expander, and all such operators
+ -- always refer to the operators in package Standard.
+
+ if Comes_From_Source (N) then
+ declare
+ F : constant Entity_Id := First_Formal (Op_Id);
+
+ begin
+ -- Verify that Op_Id is a visible unary function. Note that since
+ -- we know Op_Id is overloaded, potentially use visible means use
+ -- visible for sure (RM 9.4(11)).
+
+ if Ekind (Op_Id) = E_Function
+ and then No (Next_Formal (F))
+ and then (Is_Immediately_Visible (Op_Id)
+ or else Is_Potentially_Use_Visible (Op_Id))
+ and then Has_Compatible_Type (Right_Opnd (N), Etype (F))
+ then
+ Add_One_Interp (N, Op_Id, Etype (Op_Id));
+ end if;
+ end;
+ end if;
+ end Analyze_User_Defined_Unary_Op;
+
+ ---------------------------
+ -- Check_Arithmetic_Pair --
+ ---------------------------
+
+ procedure Check_Arithmetic_Pair
+ (T1, T2 : Entity_Id;
+ Op_Id : Entity_Id;
+ N : Node_Id)
+ is
+ Op_Name : constant Name_Id := Chars (Op_Id);
+
+ function Specific_Type (T1, T2 : Entity_Id) return Entity_Id;
+ -- Get specific type (i.e. non-universal type if there is one)
+
+ function Specific_Type (T1, T2 : Entity_Id) return Entity_Id is
+ begin
+ if T1 = Universal_Integer or else T1 = Universal_Real then
+ return Base_Type (T2);
+ else
+ return Base_Type (T1);
+ end if;
+ end Specific_Type;
+
+ -- Start of processing for Check_Arithmetic_Pair
+
+ begin
+ if Op_Name = Name_Op_Add or else Op_Name = Name_Op_Subtract then
+
+ if Is_Numeric_Type (T1)
+ and then Is_Numeric_Type (T2)
+ and then (Covers (T1, T2) or else Covers (T2, T1))
+ then
+ Add_One_Interp (N, Op_Id, Specific_Type (T1, T2));
+ end if;
+
+ elsif Op_Name = Name_Op_Multiply or else Op_Name = Name_Op_Divide then
+
+ if Is_Fixed_Point_Type (T1)
+ and then (Is_Fixed_Point_Type (T2)
+ or else T2 = Universal_Real)
+ then
+ -- If Treat_Fixed_As_Integer is set then the Etype is already set
+ -- and no further processing is required (this is the case of an
+ -- operator constructed by Exp_Fixd for a fixed point operation)
+ -- Otherwise add one interpretation with universal fixed result
+ -- If the operator is given in functional notation, it comes
+ -- from source and Fixed_As_Integer cannot apply.
+
+ if Nkind (N) not in N_Op
+ or else not Treat_Fixed_As_Integer (N) then
+ Add_One_Interp (N, Op_Id, Universal_Fixed);
+ end if;
+
+ elsif Is_Fixed_Point_Type (T2)
+ and then (Nkind (N) not in N_Op
+ or else not Treat_Fixed_As_Integer (N))
+ and then T1 = Universal_Real
+ then
+ Add_One_Interp (N, Op_Id, Universal_Fixed);
+
+ elsif Is_Numeric_Type (T1)
+ and then Is_Numeric_Type (T2)
+ and then (Covers (T1, T2) or else Covers (T2, T1))
+ then
+ Add_One_Interp (N, Op_Id, Specific_Type (T1, T2));
+
+ elsif Is_Fixed_Point_Type (T1)
+ and then (Base_Type (T2) = Base_Type (Standard_Integer)
+ or else T2 = Universal_Integer)
+ then
+ Add_One_Interp (N, Op_Id, T1);
+
+ elsif T2 = Universal_Real
+ and then Base_Type (T1) = Base_Type (Standard_Integer)
+ and then Op_Name = Name_Op_Multiply
+ then
+ Add_One_Interp (N, Op_Id, Any_Fixed);
+
+ elsif T1 = Universal_Real
+ and then Base_Type (T2) = Base_Type (Standard_Integer)
+ then
+ Add_One_Interp (N, Op_Id, Any_Fixed);
+
+ elsif Is_Fixed_Point_Type (T2)
+ and then (Base_Type (T1) = Base_Type (Standard_Integer)
+ or else T1 = Universal_Integer)
+ and then Op_Name = Name_Op_Multiply
+ then
+ Add_One_Interp (N, Op_Id, T2);
+
+ elsif T1 = Universal_Real and then T2 = Universal_Integer then
+ Add_One_Interp (N, Op_Id, T1);
+
+ elsif T2 = Universal_Real
+ and then T1 = Universal_Integer
+ and then Op_Name = Name_Op_Multiply
+ then
+ Add_One_Interp (N, Op_Id, T2);
+ end if;
+
+ elsif Op_Name = Name_Op_Mod or else Op_Name = Name_Op_Rem then
+
+ -- Note: The fixed-point operands case with Treat_Fixed_As_Integer
+ -- set does not require any special processing, since the Etype is
+ -- already set (case of operation constructed by Exp_Fixed).
+
+ if Is_Integer_Type (T1)
+ and then (Covers (T1, T2) or else Covers (T2, T1))
+ then
+ Add_One_Interp (N, Op_Id, Specific_Type (T1, T2));
+ end if;
+
+ elsif Op_Name = Name_Op_Expon then
+
+ if Is_Numeric_Type (T1)
+ and then not Is_Fixed_Point_Type (T1)
+ and then (Base_Type (T2) = Base_Type (Standard_Integer)
+ or else T2 = Universal_Integer)
+ then
+ Add_One_Interp (N, Op_Id, Base_Type (T1));
+ end if;
+
+ else pragma Assert (Nkind (N) in N_Op_Shift);
+
+ -- If not one of the predefined operators, the node may be one
+ -- of the intrinsic functions. Its kind is always specific, and
+ -- we can use it directly, rather than the name of the operation.
+
+ if Is_Integer_Type (T1)
+ and then (Base_Type (T2) = Base_Type (Standard_Integer)
+ or else T2 = Universal_Integer)
+ then
+ Add_One_Interp (N, Op_Id, Base_Type (T1));
+ end if;
+ end if;
+ end Check_Arithmetic_Pair;
+
+ -------------------------------
+ -- Check_Misspelled_Selector --
+ -------------------------------
+
+ procedure Check_Misspelled_Selector
+ (Prefix : Entity_Id;
+ Sel : Node_Id)
+ is
+ Max_Suggestions : constant := 2;
+ Nr_Of_Suggestions : Natural := 0;
+
+ Suggestion_1 : Entity_Id := Empty;
+ Suggestion_2 : Entity_Id := Empty;
+
+ Comp : Entity_Id;
+
+ begin
+ -- All the components of the prefix of selector Sel are matched
+ -- against Sel and a count is maintained of possible misspellings.
+ -- When at the end of the analysis there are one or two (not more!)
+ -- possible misspellings, these misspellings will be suggested as
+ -- possible correction.
+
+ if not (Is_Private_Type (Prefix) or Is_Record_Type (Prefix)) then
+ -- Concurrent types should be handled as well ???
+ return;
+ end if;
+
+ Get_Name_String (Chars (Sel));
+
+ declare
+ S : constant String (1 .. Name_Len) :=
+ Name_Buffer (1 .. Name_Len);
+
+ begin
+ Comp := First_Entity (Prefix);
+
+ while Nr_Of_Suggestions <= Max_Suggestions
+ and then Present (Comp)
+ loop
+
+ if Is_Visible_Component (Comp) then
+ Get_Name_String (Chars (Comp));
+
+ if Is_Bad_Spelling_Of (Name_Buffer (1 .. Name_Len), S) then
+ Nr_Of_Suggestions := Nr_Of_Suggestions + 1;
+
+ case Nr_Of_Suggestions is
+ when 1 => Suggestion_1 := Comp;
+ when 2 => Suggestion_2 := Comp;
+ when others => exit;
+ end case;
+ end if;
+ end if;
+
+ Comp := Next_Entity (Comp);
+ end loop;
+
+ -- Report at most two suggestions
+
+ if Nr_Of_Suggestions = 1 then
+ Error_Msg_NE ("\possible misspelling of&", Sel, Suggestion_1);
+
+ elsif Nr_Of_Suggestions = 2 then
+ Error_Msg_Node_2 := Suggestion_2;
+ Error_Msg_NE ("\possible misspelling of& or&",
+ Sel, Suggestion_1);
+ end if;
+ end;
+ end Check_Misspelled_Selector;
+
+ ----------------------
+ -- Defined_In_Scope --
+ ----------------------
+
+ function Defined_In_Scope (T : Entity_Id; S : Entity_Id) return Boolean
+ is
+ S1 : constant Entity_Id := Scope (Base_Type (T));
+
+ begin
+ return S1 = S
+ or else (S1 = System_Aux_Id and then S = Scope (S1));
+ end Defined_In_Scope;
+
+ -------------------
+ -- Diagnose_Call --
+ -------------------
+
+ procedure Diagnose_Call (N : Node_Id; Nam : Node_Id) is
+ Actual : Node_Id;
+ X : Interp_Index;
+ It : Interp;
+ Success : Boolean;
+
+ begin
+ if Extensions_Allowed then
+ Actual := First_Actual (N);
+
+ while Present (Actual) loop
+ if not Analyzed (Etype (Actual))
+ and then From_With_Type (Etype (Actual))
+ then
+ Error_Msg_Qual_Level := 1;
+ Error_Msg_NE
+ ("missing with_clause for scope of imported type&",
+ Actual, Etype (Actual));
+ Error_Msg_Qual_Level := 0;
+ end if;
+
+ Next_Actual (Actual);
+ end loop;
+ end if;
+
+ if All_Errors_Mode then
+
+ -- Analyze each candidate call again, with full error reporting
+ -- for each.
+
+ Error_Msg_N ("\no candidate interpretations "
+ & "match the actuals:!", Nam);
+
+ Get_First_Interp (Nam, X, It);
+
+ while Present (It.Nam) loop
+ Analyze_One_Call (N, It.Nam, True, Success);
+ Get_Next_Interp (X, It);
+ end loop;
+
+ else
+ if OpenVMS then
+ Error_Msg_N
+ ("invalid parameter list in call " &
+ "('/'R'E'P'O'R'T'_'E'R'R'O'R'S'='F'U'L'L for details)!",
+ Nam);
+ else
+ Error_Msg_N
+ ("invalid parameter list in call (use -gnatf for details)!",
+ Nam);
+ end if;
+ end if;
+
+ if Nkind (N) = N_Function_Call then
+ Get_First_Interp (Nam, X, It);
+
+ while Present (It.Nam) loop
+ if Ekind (It.Nam) = E_Function
+ or else Ekind (It.Nam) = E_Operator
+ then
+ return;
+ else
+ Get_Next_Interp (X, It);
+ end if;
+ end loop;
+
+ -- If all interpretations are procedures, this deserves a
+ -- more precise message. Ditto if this appears as the prefix
+ -- of a selected component, which may be a lexical error.
+
+ Error_Msg_N (
+ "\context requires function call, found procedure name", Nam);
+
+ if Nkind (Parent (N)) = N_Selected_Component
+ and then N = Prefix (Parent (N))
+ then
+ Error_Msg_N (
+ "\period should probably be semicolon", Parent (N));
+ end if;
+ end if;
+ end Diagnose_Call;
+
+ ---------------------------
+ -- Find_Arithmetic_Types --
+ ---------------------------
+
+ procedure Find_Arithmetic_Types
+ (L, R : Node_Id;
+ Op_Id : Entity_Id;
+ N : Node_Id)
+ is
+ Index1, Index2 : Interp_Index;
+ It1, It2 : Interp;
+
+ procedure Check_Right_Argument (T : Entity_Id);
+ -- Check right operand of operator
+
+ procedure Check_Right_Argument (T : Entity_Id) is
+ begin
+ if not Is_Overloaded (R) then
+ Check_Arithmetic_Pair (T, Etype (R), Op_Id, N);
+ else
+ Get_First_Interp (R, Index2, It2);
+
+ while Present (It2.Typ) loop
+ Check_Arithmetic_Pair (T, It2.Typ, Op_Id, N);
+ Get_Next_Interp (Index2, It2);
+ end loop;
+ end if;
+ end Check_Right_Argument;
+
+ -- Start processing for Find_Arithmetic_Types
+
+ begin
+ if not Is_Overloaded (L) then
+ Check_Right_Argument (Etype (L));
+
+ else
+ Get_First_Interp (L, Index1, It1);
+
+ while Present (It1.Typ) loop
+ Check_Right_Argument (It1.Typ);
+ Get_Next_Interp (Index1, It1);
+ end loop;
+ end if;
+
+ end Find_Arithmetic_Types;
+
+ ------------------------
+ -- Find_Boolean_Types --
+ ------------------------
+
+ procedure Find_Boolean_Types
+ (L, R : Node_Id;
+ Op_Id : Entity_Id;
+ N : Node_Id)
+ is
+ Index : Interp_Index;
+ It : Interp;
+
+ procedure Check_Numeric_Argument (T : Entity_Id);
+ -- Special case for logical operations one of whose operands is an
+ -- integer literal. If both are literal the result is any modular type.
+
+ procedure Check_Numeric_Argument (T : Entity_Id) is
+ begin
+ if T = Universal_Integer then
+ Add_One_Interp (N, Op_Id, Any_Modular);
+
+ elsif Is_Modular_Integer_Type (T) then
+ Add_One_Interp (N, Op_Id, T);
+ end if;
+ end Check_Numeric_Argument;
+
+ -- Start of processing for Find_Boolean_Types
+
+ begin
+ if not Is_Overloaded (L) then
+
+ if Etype (L) = Universal_Integer
+ or else Etype (L) = Any_Modular
+ then
+ if not Is_Overloaded (R) then
+ Check_Numeric_Argument (Etype (R));
+
+ else
+ Get_First_Interp (R, Index, It);
+
+ while Present (It.Typ) loop
+ Check_Numeric_Argument (It.Typ);
+
+ Get_Next_Interp (Index, It);
+ end loop;
+ end if;
+
+ elsif Valid_Boolean_Arg (Etype (L))
+ and then Has_Compatible_Type (R, Etype (L))
+ then
+ Add_One_Interp (N, Op_Id, Etype (L));
+ end if;
+
+ else
+ Get_First_Interp (L, Index, It);
+
+ while Present (It.Typ) loop
+ if Valid_Boolean_Arg (It.Typ)
+ and then Has_Compatible_Type (R, It.Typ)
+ then
+ Add_One_Interp (N, Op_Id, It.Typ);
+ end if;
+
+ Get_Next_Interp (Index, It);
+ end loop;
+ end if;
+ end Find_Boolean_Types;
+
+ ---------------------------
+ -- Find_Comparison_Types --
+ ---------------------------
+
+ procedure Find_Comparison_Types
+ (L, R : Node_Id;
+ Op_Id : Entity_Id;
+ N : Node_Id)
+ is
+ Index : Interp_Index;
+ It : Interp;
+ Found : Boolean := False;
+ I_F : Interp_Index;
+ T_F : Entity_Id;
+ Scop : Entity_Id := Empty;
+
+ procedure Try_One_Interp (T1 : Entity_Id);
+ -- Routine to try one proposed interpretation. Note that the context
+ -- of the operator plays no role in resolving the arguments, so that
+ -- if there is more than one interpretation of the operands that is
+ -- compatible with comparison, the operation is ambiguous.
+
+ procedure Try_One_Interp (T1 : Entity_Id) is
+ begin
+
+ -- If the operator is an expanded name, then the type of the operand
+ -- must be defined in the corresponding scope. If the type is
+ -- universal, the context will impose the correct type.
+
+ if Present (Scop)
+ and then not Defined_In_Scope (T1, Scop)
+ and then T1 /= Universal_Integer
+ and then T1 /= Universal_Real
+ and then T1 /= Any_String
+ and then T1 /= Any_Composite
+ then
+ return;
+ end if;
+
+ if Valid_Comparison_Arg (T1)
+ and then Has_Compatible_Type (R, T1)
+ then
+ if Found
+ and then Base_Type (T1) /= Base_Type (T_F)
+ then
+ It := Disambiguate (L, I_F, Index, Any_Type);
+
+ if It = No_Interp then
+ Ambiguous_Operands (N);
+ Set_Etype (L, Any_Type);
+ return;
+
+ else
+ T_F := It.Typ;
+ end if;
+
+ else
+ Found := True;
+ T_F := T1;
+ I_F := Index;
+ end if;
+
+ Set_Etype (L, T_F);
+ Find_Non_Universal_Interpretations (N, R, Op_Id, T1);
+
+ end if;
+ end Try_One_Interp;
+
+ -- Start processing for Find_Comparison_Types
+
+ begin
+
+ if Nkind (N) = N_Function_Call
+ and then Nkind (Name (N)) = N_Expanded_Name
+ then
+ Scop := Entity (Prefix (Name (N)));
+
+ -- The prefix may be a package renaming, and the subsequent test
+ -- requires the original package.
+
+ if Ekind (Scop) = E_Package
+ and then Present (Renamed_Entity (Scop))
+ then
+ Scop := Renamed_Entity (Scop);
+ Set_Entity (Prefix (Name (N)), Scop);
+ end if;
+ end if;
+
+ if not Is_Overloaded (L) then
+ Try_One_Interp (Etype (L));
+
+ else
+ Get_First_Interp (L, Index, It);
+
+ while Present (It.Typ) loop
+ Try_One_Interp (It.Typ);
+ Get_Next_Interp (Index, It);
+ end loop;
+ end if;
+ end Find_Comparison_Types;
+
+ ----------------------------------------
+ -- Find_Non_Universal_Interpretations --
+ ----------------------------------------
+
+ procedure Find_Non_Universal_Interpretations
+ (N : Node_Id;
+ R : Node_Id;
+ Op_Id : Entity_Id;
+ T1 : Entity_Id)
+ is
+ Index : Interp_Index;
+ It : Interp;
+
+ begin
+ if T1 = Universal_Integer
+ or else T1 = Universal_Real
+ then
+ if not Is_Overloaded (R) then
+ Add_One_Interp
+ (N, Op_Id, Standard_Boolean, Base_Type (Etype (R)));
+ else
+ Get_First_Interp (R, Index, It);
+
+ while Present (It.Typ) loop
+ if Covers (It.Typ, T1) then
+ Add_One_Interp
+ (N, Op_Id, Standard_Boolean, Base_Type (It.Typ));
+ end if;
+
+ Get_Next_Interp (Index, It);
+ end loop;
+ end if;
+ else
+ Add_One_Interp (N, Op_Id, Standard_Boolean, Base_Type (T1));
+ end if;
+ end Find_Non_Universal_Interpretations;
+
+ ------------------------------
+ -- Find_Concatenation_Types --
+ ------------------------------
+
+ procedure Find_Concatenation_Types
+ (L, R : Node_Id;
+ Op_Id : Entity_Id;
+ N : Node_Id)
+ is
+ Op_Type : constant Entity_Id := Etype (Op_Id);
+
+ begin
+ if Is_Array_Type (Op_Type)
+ and then not Is_Limited_Type (Op_Type)
+
+ and then (Has_Compatible_Type (L, Op_Type)
+ or else
+ Has_Compatible_Type (L, Component_Type (Op_Type)))
+
+ and then (Has_Compatible_Type (R, Op_Type)
+ or else
+ Has_Compatible_Type (R, Component_Type (Op_Type)))
+ then
+ Add_One_Interp (N, Op_Id, Op_Type);
+ end if;
+ end Find_Concatenation_Types;
+
+ -------------------------
+ -- Find_Equality_Types --
+ -------------------------
+
+ procedure Find_Equality_Types
+ (L, R : Node_Id;
+ Op_Id : Entity_Id;
+ N : Node_Id)
+ is
+ Index : Interp_Index;
+ It : Interp;
+ Found : Boolean := False;
+ I_F : Interp_Index;
+ T_F : Entity_Id;
+ Scop : Entity_Id := Empty;
+
+ procedure Try_One_Interp (T1 : Entity_Id);
+ -- The context of the operator plays no role in resolving the
+ -- arguments, so that if there is more than one interpretation
+ -- of the operands that is compatible with equality, the construct
+ -- is ambiguous and an error can be emitted now, after trying to
+ -- disambiguate, i.e. applying preference rules.
+
+ procedure Try_One_Interp (T1 : Entity_Id) is
+ begin
+
+ -- If the operator is an expanded name, then the type of the operand
+ -- must be defined in the corresponding scope. If the type is
+ -- universal, the context will impose the correct type. An anonymous
+ -- type for a 'Access reference is also universal in this sense, as
+ -- the actual type is obtained from context.
+
+ if Present (Scop)
+ and then not Defined_In_Scope (T1, Scop)
+ and then T1 /= Universal_Integer
+ and then T1 /= Universal_Real
+ and then T1 /= Any_Access
+ and then T1 /= Any_String
+ and then T1 /= Any_Composite
+ and then (Ekind (T1) /= E_Access_Subprogram_Type
+ or else Comes_From_Source (T1))
+ then
+ return;
+ end if;
+
+ if T1 /= Standard_Void_Type
+ and then not Is_Limited_Type (T1)
+ and then not Is_Limited_Composite (T1)
+ and then Ekind (T1) /= E_Anonymous_Access_Type
+ and then Has_Compatible_Type (R, T1)
+ then
+ if Found
+ and then Base_Type (T1) /= Base_Type (T_F)
+ then
+ It := Disambiguate (L, I_F, Index, Any_Type);
+
+ if It = No_Interp then
+ Ambiguous_Operands (N);
+ Set_Etype (L, Any_Type);
+ return;
+
+ else
+ T_F := It.Typ;
+ end if;
+
+ else
+ Found := True;
+ T_F := T1;
+ I_F := Index;
+ end if;
+
+ if not Analyzed (L) then
+ Set_Etype (L, T_F);
+ end if;
+
+ Find_Non_Universal_Interpretations (N, R, Op_Id, T1);
+
+ if Etype (N) = Any_Type then
+
+ -- Operator was not visible.
+
+ Found := False;
+ end if;
+ end if;
+ end Try_One_Interp;
+
+ -- Start of processing for Find_Equality_Types
+
+ begin
+
+ if Nkind (N) = N_Function_Call
+ and then Nkind (Name (N)) = N_Expanded_Name
+ then
+ Scop := Entity (Prefix (Name (N)));
+
+ -- The prefix may be a package renaming, and the subsequent test
+ -- requires the original package.
+
+ if Ekind (Scop) = E_Package
+ and then Present (Renamed_Entity (Scop))
+ then
+ Scop := Renamed_Entity (Scop);
+ Set_Entity (Prefix (Name (N)), Scop);
+ end if;
+ end if;
+
+ if not Is_Overloaded (L) then
+ Try_One_Interp (Etype (L));
+ else
+
+ Get_First_Interp (L, Index, It);
+
+ while Present (It.Typ) loop
+ Try_One_Interp (It.Typ);
+ Get_Next_Interp (Index, It);
+ end loop;
+ end if;
+ end Find_Equality_Types;
+
+ -------------------------
+ -- Find_Negation_Types --
+ -------------------------
+
+ procedure Find_Negation_Types
+ (R : Node_Id;
+ Op_Id : Entity_Id;
+ N : Node_Id)
+ is
+ Index : Interp_Index;
+ It : Interp;
+
+ begin
+ if not Is_Overloaded (R) then
+
+ if Etype (R) = Universal_Integer then
+ Add_One_Interp (N, Op_Id, Any_Modular);
+
+ elsif Valid_Boolean_Arg (Etype (R)) then
+ Add_One_Interp (N, Op_Id, Etype (R));
+ end if;
+
+ else
+ Get_First_Interp (R, Index, It);
+
+ while Present (It.Typ) loop
+ if Valid_Boolean_Arg (It.Typ) then
+ Add_One_Interp (N, Op_Id, It.Typ);
+ end if;
+
+ Get_Next_Interp (Index, It);
+ end loop;
+ end if;
+ end Find_Negation_Types;
+
+ ----------------------
+ -- Find_Unary_Types --
+ ----------------------
+
+ procedure Find_Unary_Types
+ (R : Node_Id;
+ Op_Id : Entity_Id;
+ N : Node_Id)
+ is
+ Index : Interp_Index;
+ It : Interp;
+
+ begin
+ if not Is_Overloaded (R) then
+ if Is_Numeric_Type (Etype (R)) then
+ Add_One_Interp (N, Op_Id, Base_Type (Etype (R)));
+ end if;
+
+ else
+ Get_First_Interp (R, Index, It);
+
+ while Present (It.Typ) loop
+ if Is_Numeric_Type (It.Typ) then
+ Add_One_Interp (N, Op_Id, Base_Type (It.Typ));
+ end if;
+
+ Get_Next_Interp (Index, It);
+ end loop;
+ end if;
+ end Find_Unary_Types;
+
+ ---------------------------------
+ -- Insert_Explicit_Dereference --
+ ---------------------------------
+
+ procedure Insert_Explicit_Dereference (N : Node_Id) is
+ New_Prefix : Node_Id := Relocate_Node (N);
+ I : Interp_Index;
+ It : Interp;
+ T : Entity_Id;
+
+ begin
+ Save_Interps (N, New_Prefix);
+ Rewrite (N,
+ Make_Explicit_Dereference (Sloc (N), Prefix => New_Prefix));
+
+ Set_Etype (N, Designated_Type (Etype (New_Prefix)));
+
+ if Is_Overloaded (New_Prefix) then
+
+ -- The deference is also overloaded, and its interpretations are the
+ -- designated types of the interpretations of the original node.
+
+ Set_Is_Overloaded (N);
+ Get_First_Interp (New_Prefix, I, It);
+
+ while Present (It.Nam) loop
+ T := It.Typ;
+
+ if Is_Access_Type (T) then
+ Add_One_Interp (N, Designated_Type (T), Designated_Type (T));
+ end if;
+
+ Get_Next_Interp (I, It);
+ end loop;
+
+ End_Interp_List;
+ end if;
+
+ end Insert_Explicit_Dereference;
+
+ ------------------
+ -- Junk_Operand --
+ ------------------
+
+ function Junk_Operand (N : Node_Id) return Boolean is
+ Enode : Node_Id;
+
+ begin
+ if Error_Posted (N) then
+ return False;
+ end if;
+
+ -- Get entity to be tested
+
+ if Is_Entity_Name (N)
+ and then Present (Entity (N))
+ then
+ Enode := N;
+
+ -- An odd case, a procedure name gets converted to a very peculiar
+ -- function call, and here is where we detect this happening.
+
+ elsif Nkind (N) = N_Function_Call
+ and then Is_Entity_Name (Name (N))
+ and then Present (Entity (Name (N)))
+ then
+ Enode := Name (N);
+
+ -- Another odd case, there are at least some cases of selected
+ -- components where the selected component is not marked as having
+ -- an entity, even though the selector does have an entity
+
+ elsif Nkind (N) = N_Selected_Component
+ and then Present (Entity (Selector_Name (N)))
+ then
+ Enode := Selector_Name (N);
+
+ else
+ return False;
+ end if;
+
+ -- Now test the entity we got to see if it a bad case
+
+ case Ekind (Entity (Enode)) is
+
+ when E_Package =>
+ Error_Msg_N
+ ("package name cannot be used as operand", Enode);
+
+ when Generic_Unit_Kind =>
+ Error_Msg_N
+ ("generic unit name cannot be used as operand", Enode);
+
+ when Type_Kind =>
+ Error_Msg_N
+ ("subtype name cannot be used as operand", Enode);
+
+ when Entry_Kind =>
+ Error_Msg_N
+ ("entry name cannot be used as operand", Enode);
+
+ when E_Procedure =>
+ Error_Msg_N
+ ("procedure name cannot be used as operand", Enode);
+
+ when E_Exception =>
+ Error_Msg_N
+ ("exception name cannot be used as operand", Enode);
+
+ when E_Block | E_Label | E_Loop =>
+ Error_Msg_N
+ ("label name cannot be used as operand", Enode);
+
+ when others =>
+ return False;
+
+ end case;
+
+ return True;
+ end Junk_Operand;
+
+ --------------------
+ -- Operator_Check --
+ --------------------
+
+ procedure Operator_Check (N : Node_Id) is
+ begin
+ -- Test for case of no interpretation found for operator
+
+ if Etype (N) = Any_Type then
+ declare
+ L : Node_Id;
+ R : Node_Id;
+
+ begin
+ R := Right_Opnd (N);
+
+ if Nkind (N) in N_Binary_Op then
+ L := Left_Opnd (N);
+ else
+ L := Empty;
+ end if;
+
+ -- If either operand has no type, then don't complain further,
+ -- since this simply means that we have a propragated error.
+
+ if R = Error
+ or else Etype (R) = Any_Type
+ or else (Nkind (N) in N_Binary_Op and then Etype (L) = Any_Type)
+ then
+ return;
+
+ -- We explicitly check for the case of concatenation of
+ -- component with component to avoid reporting spurious
+ -- matching array types that might happen to be lurking
+ -- in distant packages (such as run-time packages). This
+ -- also prevents inconsistencies in the messages for certain
+ -- ACVC B tests, which can vary depending on types declared
+ -- in run-time interfaces. A further improvement, when
+ -- aggregates are present, is to look for a well-typed operand.
+
+ elsif Present (Candidate_Type)
+ and then (Nkind (N) /= N_Op_Concat
+ or else Is_Array_Type (Etype (L))
+ or else Is_Array_Type (Etype (R)))
+ then
+
+ if Nkind (N) = N_Op_Concat then
+ if Etype (L) /= Any_Composite
+ and then Is_Array_Type (Etype (L))
+ then
+ Candidate_Type := Etype (L);
+
+ elsif Etype (R) /= Any_Composite
+ and then Is_Array_Type (Etype (R))
+ then
+ Candidate_Type := Etype (R);
+ end if;
+ end if;
+
+ Error_Msg_NE
+ ("operator for} is not directly visible!",
+ N, First_Subtype (Candidate_Type));
+ Error_Msg_N ("use clause would make operation legal!", N);
+ return;
+
+ -- If either operand is a junk operand (e.g. package name), then
+ -- post appropriate error messages, but do not complain further.
+
+ -- Note that the use of OR in this test instead of OR ELSE
+ -- is quite deliberate, we may as well check both operands
+ -- in the binary operator case.
+
+ elsif Junk_Operand (R)
+ or (Nkind (N) in N_Binary_Op and then Junk_Operand (L))
+ then
+ return;
+
+ -- If we have a logical operator, one of whose operands is
+ -- Boolean, then we know that the other operand cannot resolve
+ -- to Boolean (since we got no interpretations), but in that
+ -- case we pretty much know that the other operand should be
+ -- Boolean, so resolve it that way (generating an error)
+
+ elsif Nkind (N) = N_Op_And
+ or else
+ Nkind (N) = N_Op_Or
+ or else
+ Nkind (N) = N_Op_Xor
+ then
+ if Etype (L) = Standard_Boolean then
+ Resolve (R, Standard_Boolean);
+ return;
+ elsif Etype (R) = Standard_Boolean then
+ Resolve (L, Standard_Boolean);
+ return;
+ end if;
+
+ -- For an arithmetic operator or comparison operator, if one
+ -- of the operands is numeric, then we know the other operand
+ -- is not the same numeric type. If it is a non-numeric type,
+ -- then probably it is intended to match the other operand.
+
+ elsif Nkind (N) = N_Op_Add or else
+ Nkind (N) = N_Op_Divide or else
+ Nkind (N) = N_Op_Ge or else
+ Nkind (N) = N_Op_Gt or else
+ Nkind (N) = N_Op_Le or else
+ Nkind (N) = N_Op_Lt or else
+ Nkind (N) = N_Op_Mod or else
+ Nkind (N) = N_Op_Multiply or else
+ Nkind (N) = N_Op_Rem or else
+ Nkind (N) = N_Op_Subtract
+ then
+ if Is_Numeric_Type (Etype (L))
+ and then not Is_Numeric_Type (Etype (R))
+ then
+ Resolve (R, Etype (L));
+ return;
+
+ elsif Is_Numeric_Type (Etype (R))
+ and then not Is_Numeric_Type (Etype (L))
+ then
+ Resolve (L, Etype (R));
+ return;
+ end if;
+
+ -- Comparisons on A'Access are common enough to deserve a
+ -- special message.
+
+ elsif (Nkind (N) = N_Op_Eq or else
+ Nkind (N) = N_Op_Ne)
+ and then Ekind (Etype (L)) = E_Access_Attribute_Type
+ and then Ekind (Etype (R)) = E_Access_Attribute_Type
+ then
+ Error_Msg_N
+ ("two access attributes cannot be compared directly", N);
+ Error_Msg_N
+ ("\they must be converted to an explicit type for comparison",
+ N);
+ return;
+
+ -- Another one for C programmers
+
+ elsif Nkind (N) = N_Op_Concat
+ and then Valid_Boolean_Arg (Etype (L))
+ and then Valid_Boolean_Arg (Etype (R))
+ then
+ Error_Msg_N ("invalid operands for concatenation", N);
+ Error_Msg_N ("\maybe AND was meant", N);
+ return;
+
+ -- A special case for comparison of access parameter with null
+
+ elsif Nkind (N) = N_Op_Eq
+ and then Is_Entity_Name (L)
+ and then Nkind (Parent (Entity (L))) = N_Parameter_Specification
+ and then Nkind (Parameter_Type (Parent (Entity (L)))) =
+ N_Access_Definition
+ and then Nkind (R) = N_Null
+ then
+ Error_Msg_N ("access parameter is not allowed to be null", L);
+ Error_Msg_N ("\(call would raise Constraint_Error)", L);
+ return;
+ end if;
+
+ -- If we fall through then just give general message. Note
+ -- that in the following messages, if the operand is overloaded
+ -- we choose an arbitrary type to complain about, but that is
+ -- probably more useful than not giving a type at all.
+
+ if Nkind (N) in N_Unary_Op then
+ Error_Msg_Node_2 := Etype (R);
+ Error_Msg_N ("operator& not defined for}", N);
+ return;
+
+ else
+ Error_Msg_N ("invalid operand types for operator&", N);
+
+ if Nkind (N) in N_Binary_Op
+ and then Nkind (N) /= N_Op_Concat
+ then
+ Error_Msg_NE ("\left operand has}!", N, Etype (L));
+ Error_Msg_NE ("\right operand has}!", N, Etype (R));
+ end if;
+ end if;
+ end;
+ end if;
+ end Operator_Check;
+
+ -----------------------
+ -- Try_Indirect_Call --
+ -----------------------
+
+ function Try_Indirect_Call
+ (N : Node_Id;
+ Nam : Entity_Id;
+ Typ : Entity_Id)
+ return Boolean
+ is
+ Actuals : List_Id := Parameter_Associations (N);
+ Actual : Node_Id := First (Actuals);
+ Formal : Entity_Id := First_Formal (Designated_Type (Typ));
+
+ begin
+ while Present (Actual)
+ and then Present (Formal)
+ loop
+ if not Has_Compatible_Type (Actual, Etype (Formal)) then
+ return False;
+ end if;
+
+ Next (Actual);
+ Next_Formal (Formal);
+ end loop;
+
+ if No (Actual) and then No (Formal) then
+ Add_One_Interp (N, Nam, Etype (Designated_Type (Typ)));
+
+ -- Nam is a candidate interpretation for the name in the call,
+ -- if it is not an indirect call.
+
+ if not Is_Type (Nam)
+ and then Is_Entity_Name (Name (N))
+ then
+ Set_Entity (Name (N), Nam);
+ end if;
+
+ return True;
+ else
+ return False;
+ end if;
+ end Try_Indirect_Call;
+
+ ----------------------
+ -- Try_Indexed_Call --
+ ----------------------
+
+ function Try_Indexed_Call
+ (N : Node_Id;
+ Nam : Entity_Id;
+ Typ : Entity_Id)
+ return Boolean
+ is
+ Actuals : List_Id := Parameter_Associations (N);
+ Actual : Node_Id := First (Actuals);
+ Index : Entity_Id := First_Index (Typ);
+
+ begin
+ while Present (Actual)
+ and then Present (Index)
+ loop
+ -- If the parameter list has a named association, the expression
+ -- is definitely a call and not an indexed component.
+
+ if Nkind (Actual) = N_Parameter_Association then
+ return False;
+ end if;
+
+ if not Has_Compatible_Type (Actual, Etype (Index)) then
+ return False;
+ end if;
+
+ Next (Actual);
+ Next_Index (Index);
+ end loop;
+
+ if No (Actual) and then No (Index) then
+ Add_One_Interp (N, Nam, Component_Type (Typ));
+
+ -- Nam is a candidate interpretation for the name in the call,
+ -- if it is not an indirect call.
+
+ if not Is_Type (Nam)
+ and then Is_Entity_Name (Name (N))
+ then
+ Set_Entity (Name (N), Nam);
+ end if;
+
+ return True;
+ else
+ return False;
+ end if;
+
+ end Try_Indexed_Call;
+
+end Sem_Ch4;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S E M _ C H 4 --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.18 $ --
+-- --
+-- Copyright (C) 1992,1993,1994,1995,1996 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 Types; use Types;
+
+package Sem_Ch4 is
+ procedure Analyze_Aggregate (N : Node_Id);
+ procedure Analyze_Allocator (N : Node_Id);
+ procedure Analyze_Arithmetic_Op (N : Node_Id);
+ procedure Analyze_Call (N : Node_Id);
+ procedure Analyze_Comparison_Op (N : Node_Id);
+ procedure Analyze_Concatenation (N : Node_Id);
+ procedure Analyze_Conditional_Expression (N : Node_Id);
+ procedure Analyze_Equality_Op (N : Node_Id);
+ procedure Analyze_Explicit_Dereference (N : Node_Id);
+ procedure Analyze_Logical_Op (N : Node_Id);
+ procedure Analyze_Membership_Op (N : Node_Id);
+ procedure Analyze_Negation (N : Node_Id);
+ procedure Analyze_Null (N : Node_Id);
+ procedure Analyze_Qualified_Expression (N : Node_Id);
+ procedure Analyze_Range (N : Node_Id);
+ procedure Analyze_Reference (N : Node_Id);
+ procedure Analyze_Selected_Component (N : Node_Id);
+ procedure Analyze_Short_Circuit (N : Node_Id);
+ procedure Analyze_Slice (N : Node_Id);
+ procedure Analyze_Type_Conversion (N : Node_Id);
+ procedure Analyze_Unary_Op (N : Node_Id);
+ procedure Analyze_Unchecked_Expression (N : Node_Id);
+ procedure Analyze_Unchecked_Type_Conversion (N : Node_Id);
+
+ procedure Analyze_Indexed_Component_Form (N : Node_Id);
+ -- Prior to semantic analysis, an indexed component node can denote any
+ -- of the following syntactic constructs:
+ -- a) An indexed component of an array
+ -- b) A function call
+ -- c) A conversion
+ -- d) A slice
+ -- The resolution of the construct requires some semantic information
+ -- on the prefix and the indices.
+
+end Sem_Ch4;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S E M _ C H 5 --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.262 $
+-- --
+-- 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). --
+-- --
+------------------------------------------------------------------------------
+
+with Atree; use Atree;
+with Checks; use Checks;
+with Einfo; use Einfo;
+with Errout; use Errout;
+with Expander; use Expander;
+with Exp_Util; use Exp_Util;
+with Freeze; use Freeze;
+with Lib.Xref; use Lib.Xref;
+with Nlists; use Nlists;
+with Opt; use Opt;
+with Sem; use Sem;
+with Sem_Case; use Sem_Case;
+with Sem_Ch3; use Sem_Ch3;
+with Sem_Ch8; use Sem_Ch8;
+with Sem_Disp; use Sem_Disp;
+with Sem_Eval; use Sem_Eval;
+with Sem_Res; use Sem_Res;
+with Sem_Type; use Sem_Type;
+with Sem_Util; use Sem_Util;
+with Sem_Warn; use Sem_Warn;
+with Stand; use Stand;
+with Sinfo; use Sinfo;
+with Tbuild; use Tbuild;
+with Uintp; use Uintp;
+
+package body Sem_Ch5 is
+
+ Unblocked_Exit_Count : Nat := 0;
+ -- This variable is used when processing if statements or case
+ -- statements, it counts the number of branches of the conditional
+ -- that are not blocked by unconditional transfer instructions. At
+ -- the end of processing, if the count is zero, it means that control
+ -- cannot fall through the conditional statement. This is used for
+ -- the generation of warning messages. This variable is recursively
+ -- saved on entry to processing an if or case, and restored on exit.
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ procedure Analyze_Iteration_Scheme (N : Node_Id);
+
+ ------------------------
+ -- Analyze_Assignment --
+ ------------------------
+
+ procedure Analyze_Assignment (N : Node_Id) is
+ Lhs : constant Node_Id := Name (N);
+ Rhs : constant Node_Id := Expression (N);
+ T1, T2 : Entity_Id;
+ Decl : Node_Id;
+
+ procedure Diagnose_Non_Variable_Lhs (N : Node_Id);
+ -- N is the node for the left hand side of an assignment, and it
+ -- is not a variable. This routine issues an appropriate diagnostic.
+
+ procedure Set_Assignment_Type
+ (Opnd : Node_Id;
+ Opnd_Type : in out Entity_Id);
+ -- Opnd is either the Lhs or Rhs of the assignment, and Opnd_Type
+ -- is the nominal subtype. This procedure is used to deal with cases
+ -- where the nominal subtype must be replaced by the actual subtype.
+
+ -------------------------------
+ -- Diagnose_Non_Variable_Lhs --
+ -------------------------------
+
+ procedure Diagnose_Non_Variable_Lhs (N : Node_Id) is
+ begin
+ -- Not worth posting another error if left hand side already
+ -- flagged as being illegal in some respect
+
+ if Error_Posted (N) then
+ return;
+
+ -- Some special bad cases of entity names
+
+ elsif Is_Entity_Name (N) then
+
+ if Ekind (Entity (N)) = E_In_Parameter then
+ Error_Msg_N
+ ("assignment to IN mode parameter not allowed", N);
+ return;
+
+ -- Private declarations in a protected object are turned into
+ -- constants when compiling a protected function.
+
+ elsif Present (Scope (Entity (N)))
+ and then Is_Protected_Type (Scope (Entity (N)))
+ and then
+ (Ekind (Current_Scope) = E_Function
+ or else
+ Ekind (Enclosing_Dynamic_Scope (Current_Scope)) = E_Function)
+ then
+ Error_Msg_N
+ ("protected function cannot modify protected object", N);
+ return;
+
+ elsif Ekind (Entity (N)) = E_Loop_Parameter then
+ Error_Msg_N
+ ("assignment to loop parameter not allowed", N);
+ return;
+
+ end if;
+
+ -- For indexed components, or selected components, test prefix
+
+ elsif Nkind (N) = N_Indexed_Component
+ or else Nkind (N) = N_Selected_Component
+ then
+ Diagnose_Non_Variable_Lhs (Prefix (N));
+ return;
+ end if;
+
+ -- If we fall through, we have no special message to issue!
+
+ Error_Msg_N ("left hand side of assignment must be a variable", N);
+
+ end Diagnose_Non_Variable_Lhs;
+
+ -------------------------
+ -- Set_Assignment_Type --
+ -------------------------
+
+ procedure Set_Assignment_Type
+ (Opnd : Node_Id;
+ Opnd_Type : in out Entity_Id)
+ is
+ begin
+ -- If the assignment operand is an in-out or out parameter, then we
+ -- get the actual subtype (needed for the unconstrained case).
+
+ if Is_Entity_Name (Opnd)
+ and then (Ekind (Entity (Opnd)) = E_Out_Parameter
+ or else Ekind (Entity (Opnd)) =
+ E_In_Out_Parameter
+ or else Ekind (Entity (Opnd)) =
+ E_Generic_In_Out_Parameter)
+ then
+ Opnd_Type := Get_Actual_Subtype (Opnd);
+
+ -- If assignment operand is a component reference, then we get the
+ -- actual subtype of the component for the unconstrained case.
+
+ elsif Nkind (Opnd) = N_Selected_Component
+ or else Nkind (Opnd) = N_Explicit_Dereference
+ then
+ Decl := Build_Actual_Subtype_Of_Component (Opnd_Type, Opnd);
+
+ if Present (Decl) then
+ Insert_Action (N, Decl);
+ Mark_Rewrite_Insertion (Decl);
+ Analyze (Decl);
+ Opnd_Type := Defining_Identifier (Decl);
+ Set_Etype (Opnd, Opnd_Type);
+ Freeze_Itype (Opnd_Type, N);
+
+ elsif Is_Constrained (Etype (Opnd)) then
+ Opnd_Type := Etype (Opnd);
+ end if;
+
+ -- For slice, use the constrained subtype created for the slice
+
+ elsif Nkind (Opnd) = N_Slice then
+ Opnd_Type := Etype (Opnd);
+ end if;
+ end Set_Assignment_Type;
+
+ -- Start of processing for Analyze_Assignment
+
+ begin
+ Analyze (Rhs);
+ Analyze (Lhs);
+ T1 := Etype (Lhs);
+
+ -- In the most general case, both Lhs and Rhs can be overloaded, and we
+ -- must compute the intersection of the possible types on each side.
+
+ if Is_Overloaded (Lhs) then
+ declare
+ I : Interp_Index;
+ It : Interp;
+
+ begin
+ T1 := Any_Type;
+ Get_First_Interp (Lhs, I, It);
+
+ while Present (It.Typ) loop
+ if Has_Compatible_Type (Rhs, It.Typ) then
+
+ if T1 /= Any_Type then
+
+ -- An explicit dereference is overloaded if the prefix
+ -- is. Try to remove the ambiguity on the prefix, the
+ -- error will be posted there if the ambiguity is real.
+
+ if Nkind (Lhs) = N_Explicit_Dereference then
+ declare
+ PI : Interp_Index;
+ PI1 : Interp_Index := 0;
+ PIt : Interp;
+ Found : Boolean;
+
+ begin
+ Found := False;
+ Get_First_Interp (Prefix (Lhs), PI, PIt);
+
+ while Present (PIt.Typ) loop
+ if Has_Compatible_Type (Rhs,
+ Designated_Type (PIt.Typ))
+ then
+ if Found then
+ PIt :=
+ Disambiguate (Prefix (Lhs),
+ PI1, PI, Any_Type);
+
+ if PIt = No_Interp then
+ return;
+ else
+ Resolve (Prefix (Lhs), PIt.Typ);
+ end if;
+
+ exit;
+ else
+ Found := True;
+ PI1 := PI;
+ end if;
+ end if;
+
+ Get_Next_Interp (PI, PIt);
+ end loop;
+ end;
+
+ else
+ Error_Msg_N
+ ("ambiguous left-hand side in assignment", Lhs);
+ exit;
+ end if;
+ else
+ T1 := It.Typ;
+ end if;
+ end if;
+
+ Get_Next_Interp (I, It);
+ end loop;
+ end;
+
+ if T1 = Any_Type then
+ Error_Msg_N
+ ("no valid types for left-hand side for assignment", Lhs);
+ return;
+ end if;
+ end if;
+
+ Resolve (Lhs, T1);
+
+ if not Is_Variable (Lhs) then
+ Diagnose_Non_Variable_Lhs (Lhs);
+ return;
+
+ elsif Is_Limited_Type (T1)
+ and then not Assignment_OK (Lhs)
+ and then not Assignment_OK (Original_Node (Lhs))
+ then
+ Error_Msg_N
+ ("left hand of assignment must not be limited type", Lhs);
+ return;
+ end if;
+
+ -- Resolution may have updated the subtype, in case the left-hand
+ -- side is a private protected component. Use the correct subtype
+ -- to avoid scoping issues in the back-end.
+
+ T1 := Etype (Lhs);
+ Set_Assignment_Type (Lhs, T1);
+
+ Resolve (Rhs, T1);
+
+ -- Remaining steps are skipped if Rhs was synatactically in error
+
+ if Rhs = Error then
+ return;
+ end if;
+
+ T2 := Etype (Rhs);
+ Check_Unset_Reference (Rhs);
+ Note_Possible_Modification (Lhs);
+
+ if Covers (T1, T2) then
+ null;
+ else
+ Wrong_Type (Rhs, Etype (Lhs));
+ return;
+ end if;
+
+ Set_Assignment_Type (Rhs, T2);
+
+ if T1 = Any_Type or else T2 = Any_Type then
+ return;
+ end if;
+
+ if (Is_Class_Wide_Type (T2) or else Is_Dynamically_Tagged (Rhs))
+ and then not Is_Class_Wide_Type (T1)
+ then
+ Error_Msg_N ("dynamically tagged expression not allowed!", Rhs);
+
+ elsif Is_Class_Wide_Type (T1)
+ and then not Is_Class_Wide_Type (T2)
+ and then not Is_Tag_Indeterminate (Rhs)
+ and then not Is_Dynamically_Tagged (Rhs)
+ then
+ Error_Msg_N ("dynamically tagged expression required!", Rhs);
+ end if;
+
+ -- Tag propagation is done only in semantics mode only. If expansion
+ -- is on, the rhs tag indeterminate function call has been expanded
+ -- and tag propagation would have happened too late, so the
+ -- propagation take place in expand_call instead.
+
+ if not Expander_Active
+ and then Is_Class_Wide_Type (T1)
+ and then Is_Tag_Indeterminate (Rhs)
+ then
+ Propagate_Tag (Lhs, Rhs);
+ end if;
+
+ if Is_Scalar_Type (T1) then
+ Apply_Scalar_Range_Check (Rhs, Etype (Lhs));
+
+ elsif Is_Array_Type (T1) then
+
+ -- Assignment verifies that the length of the Lsh and Rhs are equal,
+ -- but of course the indices do not have to match.
+
+ Apply_Length_Check (Rhs, Etype (Lhs));
+
+ else
+ -- Discriminant checks are applied in the course of expansion.
+ null;
+ end if;
+
+ -- ??? a real accessibility check is needed when ???
+
+ -- Post warning for useless assignment
+
+ if Warn_On_Redundant_Constructs
+
+ -- We only warn for source constructs
+
+ and then Comes_From_Source (N)
+
+ -- Where the entity is the same on both sides
+
+ and then Is_Entity_Name (Lhs)
+ and then Is_Entity_Name (Rhs)
+ and then Entity (Lhs) = Entity (Rhs)
+
+ -- But exclude the case where the right side was an operation
+ -- that got rewritten (e.g. JUNK + K, where K was known to be
+ -- zero). We don't want to warn in such a case, since it is
+ -- reasonable to write such expressions especially when K is
+ -- defined symbolically in some other package.
+
+ and then Nkind (Original_Node (Rhs)) not in N_Op
+ then
+ Error_Msg_NE
+ ("?useless assignment of & to itself", N, Entity (Lhs));
+ end if;
+ end Analyze_Assignment;
+
+ -----------------------------
+ -- Analyze_Block_Statement --
+ -----------------------------
+
+ procedure Analyze_Block_Statement (N : Node_Id) is
+ Decls : constant List_Id := Declarations (N);
+ Id : constant Node_Id := Identifier (N);
+ Ent : Entity_Id;
+
+ begin
+ -- If a label is present analyze it and mark it as referenced
+
+ if Present (Id) then
+ Analyze (Id);
+ Ent := Entity (Id);
+ Set_Ekind (Ent, E_Block);
+ Generate_Reference (Ent, N, ' ');
+ Generate_Definition (Ent);
+
+ if Nkind (Parent (Ent)) = N_Implicit_Label_Declaration then
+ Set_Label_Construct (Parent (Ent), N);
+ end if;
+
+ -- Otherwise create a label entity
+
+ else
+ Ent := New_Internal_Entity (E_Block, Current_Scope, Sloc (N), 'B');
+ Set_Identifier (N, New_Occurrence_Of (Ent, Sloc (N)));
+ end if;
+
+ Set_Etype (Ent, Standard_Void_Type);
+ Set_Block_Node (Ent, N);
+ New_Scope (Ent);
+
+ if Present (Decls) then
+ Analyze_Declarations (Decls);
+ Check_Completion;
+ end if;
+
+ Analyze (Handled_Statement_Sequence (N));
+ Process_End_Label (Handled_Statement_Sequence (N), 'e');
+
+ -- Analyze exception handlers if present. Note that the test for
+ -- HSS being present is an error defence against previous errors.
+
+ if Present (Handled_Statement_Sequence (N))
+ and then Present (Exception_Handlers (Handled_Statement_Sequence (N)))
+ then
+ declare
+ S : Entity_Id := Scope (Ent);
+
+ begin
+ -- Indicate that enclosing scopes contain a block with handlers.
+ -- Only non-generic scopes need to be marked.
+
+ loop
+ Set_Has_Nested_Block_With_Handler (S);
+ exit when Is_Overloadable (S)
+ or else Ekind (S) = E_Package
+ or else Ekind (S) = E_Generic_Function
+ or else Ekind (S) = E_Generic_Package
+ or else Ekind (S) = E_Generic_Procedure;
+ S := Scope (S);
+ end loop;
+ end;
+ end if;
+
+ Check_References (Ent);
+ End_Scope;
+ end Analyze_Block_Statement;
+
+ ----------------------------
+ -- Analyze_Case_Statement --
+ ----------------------------
+
+ procedure Analyze_Case_Statement (N : Node_Id) is
+
+ Statements_Analyzed : Boolean := False;
+ -- Set True if at least some statement sequences get analyzed.
+ -- If False on exit, means we had a serious error that prevented
+ -- full analysis of the case statement, and as a result it is not
+ -- a good idea to output warning messages about unreachable code.
+
+ Save_Unblocked_Exit_Count : constant Nat := Unblocked_Exit_Count;
+ -- Recursively save value of this global, will be restored on exit
+
+ procedure Non_Static_Choice_Error (Choice : Node_Id);
+ -- Error routine invoked by the generic instantiation below when
+ -- the case statment has a non static choice.
+
+ procedure Process_Statements (Alternative : Node_Id);
+ -- Analyzes all the statements associated to a case alternative.
+ -- Needed by the generic instantiation below.
+
+ package Case_Choices_Processing is new
+ Generic_Choices_Processing
+ (Get_Alternatives => Alternatives,
+ Get_Choices => Discrete_Choices,
+ Process_Empty_Choice => No_OP,
+ Process_Non_Static_Choice => Non_Static_Choice_Error,
+ Process_Associated_Node => Process_Statements);
+ use Case_Choices_Processing;
+ -- Instantiation of the generic choice processing package.
+
+ -----------------------------
+ -- Non_Static_Choice_Error --
+ -----------------------------
+
+ procedure Non_Static_Choice_Error (Choice : Node_Id) is
+ begin
+ Error_Msg_N ("choice given in case statement is not static", Choice);
+ end Non_Static_Choice_Error;
+
+ ------------------------
+ -- Process_Statements --
+ ------------------------
+
+ procedure Process_Statements (Alternative : Node_Id) is
+ begin
+ Unblocked_Exit_Count := Unblocked_Exit_Count + 1;
+ Statements_Analyzed := True;
+ Analyze_Statements (Statements (Alternative));
+ end Process_Statements;
+
+ -- Variables local to Analyze_Case_Statement.
+
+ Exp : Node_Id;
+ Exp_Type : Entity_Id;
+ Exp_Btype : Entity_Id;
+
+ Case_Table : Choice_Table_Type (1 .. Number_Of_Choices (N));
+ Last_Choice : Nat;
+ Dont_Care : Boolean;
+ Others_Present : Boolean;
+
+ -- Start of processing for Analyze_Case_Statement
+
+ begin
+ Unblocked_Exit_Count := 0;
+ Exp := Expression (N);
+ Analyze_And_Resolve (Exp, Any_Discrete);
+ Check_Unset_Reference (Exp);
+ Exp_Type := Etype (Exp);
+ Exp_Btype := Base_Type (Exp_Type);
+
+ -- The expression must be of a discrete type which must be determinable
+ -- independently of the context in which the expression occurs, but
+ -- using the fact that the expression must be of a discrete type.
+ -- Moreover, the type this expression must not be a character literal
+ -- (which is always ambiguous) or, for Ada-83, a generic formal type.
+
+ -- If error already reported by Resolve, nothing more to do
+
+ if Exp_Btype = Any_Discrete
+ or else Exp_Btype = Any_Type
+ then
+ return;
+
+ elsif Exp_Btype = Any_Character then
+ Error_Msg_N
+ ("character literal as case expression is ambiguous", Exp);
+ return;
+
+ elsif Ada_83
+ and then (Is_Generic_Type (Exp_Btype)
+ or else Is_Generic_Type (Root_Type (Exp_Btype)))
+ then
+ Error_Msg_N
+ ("(Ada 83) case expression cannot be of a generic type", Exp);
+ return;
+ end if;
+
+ -- If the case expression is a formal object of mode in out,
+ -- then treat it as having a nonstatic subtype by forcing
+ -- use of the base type (which has to get passed to
+ -- Check_Case_Choices below). Also use base type when
+ -- the case expression is parenthesized.
+
+ if Paren_Count (Exp) > 0
+ or else (Is_Entity_Name (Exp)
+ and then Ekind (Entity (Exp)) = E_Generic_In_Out_Parameter)
+ then
+ Exp_Type := Exp_Btype;
+ end if;
+
+ -- Call the instantiated Analyze_Choices which does the rest of the work
+
+ Analyze_Choices
+ (N, Exp_Type, Case_Table, Last_Choice, Dont_Care, Others_Present);
+
+ if Exp_Type = Universal_Integer and then not Others_Present then
+ Error_Msg_N ("case on universal integer requires OTHERS choice", Exp);
+ end if;
+
+ -- If all our exits were blocked by unconditional transfers of control,
+ -- then the entire CASE statement acts as an unconditional transfer of
+ -- control, so treat it like one, and check unreachable code. Skip this
+ -- test if we had serious errors preventing any statement analysis.
+
+ if Unblocked_Exit_Count = 0 and then Statements_Analyzed then
+ Unblocked_Exit_Count := Save_Unblocked_Exit_Count;
+ Check_Unreachable_Code (N);
+ else
+ Unblocked_Exit_Count := Save_Unblocked_Exit_Count;
+ end if;
+ end Analyze_Case_Statement;
+
+ ----------------------------
+ -- Analyze_Exit_Statement --
+ ----------------------------
+
+ -- If the exit includes a name, it must be the name of a currently open
+ -- loop. Otherwise there must be an innermost open loop on the stack,
+ -- to which the statement implicitly refers.
+
+ procedure Analyze_Exit_Statement (N : Node_Id) is
+ Target : constant Node_Id := Name (N);
+ Cond : constant Node_Id := Condition (N);
+ Scope_Id : Entity_Id;
+ U_Name : Entity_Id;
+ Kind : Entity_Kind;
+
+ begin
+ if No (Cond) then
+ Check_Unreachable_Code (N);
+ end if;
+
+ if Present (Target) then
+ Analyze (Target);
+ U_Name := Entity (Target);
+
+ if not In_Open_Scopes (U_Name) or else Ekind (U_Name) /= E_Loop then
+ Error_Msg_N ("invalid loop name in exit statement", N);
+ return;
+ else
+ Set_Has_Exit (U_Name);
+ end if;
+
+ else
+ U_Name := Empty;
+ end if;
+
+ for J in reverse 0 .. Scope_Stack.Last loop
+ Scope_Id := Scope_Stack.Table (J).Entity;
+ Kind := Ekind (Scope_Id);
+
+ if Kind = E_Loop
+ and then (No (Target) or else Scope_Id = U_Name) then
+ Set_Has_Exit (Scope_Id);
+ exit;
+
+ elsif Kind = E_Block or else Kind = E_Loop then
+ null;
+
+ else
+ Error_Msg_N
+ ("cannot exit from program unit or accept statement", N);
+ exit;
+ end if;
+ end loop;
+
+ -- Verify that if present the condition is a Boolean expression.
+
+ if Present (Cond) then
+ Analyze_And_Resolve (Cond, Any_Boolean);
+ Check_Unset_Reference (Cond);
+ end if;
+ end Analyze_Exit_Statement;
+
+ ----------------------------
+ -- Analyze_Goto_Statement --
+ ----------------------------
+
+ procedure Analyze_Goto_Statement (N : Node_Id) is
+ Label : constant Node_Id := Name (N);
+ Scope_Id : Entity_Id;
+ Label_Scope : Entity_Id;
+
+ begin
+ Check_Unreachable_Code (N);
+
+ Analyze (Label);
+
+ if Entity (Label) = Any_Id then
+ return;
+
+ elsif Ekind (Entity (Label)) /= E_Label then
+ Error_Msg_N ("target of goto statement must be a label", Label);
+ return;
+
+ elsif not Reachable (Entity (Label)) then
+ Error_Msg_N ("target of goto statement is not reachable", Label);
+ return;
+ end if;
+
+ Label_Scope := Enclosing_Scope (Entity (Label));
+
+ for J in reverse 0 .. Scope_Stack.Last loop
+ Scope_Id := Scope_Stack.Table (J).Entity;
+
+ if Label_Scope = Scope_Id
+ or else (Ekind (Scope_Id) /= E_Block
+ and then Ekind (Scope_Id) /= E_Loop)
+ then
+ if Scope_Id /= Label_Scope then
+ Error_Msg_N
+ ("cannot exit from program unit or accept statement", N);
+ end if;
+
+ return;
+ end if;
+ end loop;
+
+ raise Program_Error;
+
+ end Analyze_Goto_Statement;
+
+ --------------------------
+ -- Analyze_If_Statement --
+ --------------------------
+
+ -- A special complication arises in the analysis of if statements.
+ -- The expander has circuitry to completely deleted code that it
+ -- can tell will not be executed (as a result of compile time known
+ -- conditions). In the analyzer, we ensure that code that will be
+ -- deleted in this manner is analyzed but not expanded. This is
+ -- obviously more efficient, but more significantly, difficulties
+ -- arise if code is expanded and then eliminated (e.g. exception
+ -- table entries disappear).
+
+ procedure Analyze_If_Statement (N : Node_Id) is
+ E : Node_Id;
+
+ Save_Unblocked_Exit_Count : constant Nat := Unblocked_Exit_Count;
+ -- Recursively save value of this global, will be restored on exit
+
+ Del : Boolean := False;
+ -- This flag gets set True if a True condition has been found,
+ -- which means that remaining ELSE/ELSIF parts are deleted.
+
+ procedure Analyze_Cond_Then (Cnode : Node_Id);
+ -- This is applied to either the N_If_Statement node itself or
+ -- to an N_Elsif_Part node. It deals with analyzing the condition
+ -- and the THEN statements associated with it.
+
+ procedure Analyze_Cond_Then (Cnode : Node_Id) is
+ Cond : constant Node_Id := Condition (Cnode);
+ Tstm : constant List_Id := Then_Statements (Cnode);
+
+ begin
+ Unblocked_Exit_Count := Unblocked_Exit_Count + 1;
+ Analyze_And_Resolve (Cond, Any_Boolean);
+ Check_Unset_Reference (Cond);
+
+ -- If already deleting, then just analyze then statements
+
+ if Del then
+ Analyze_Statements (Tstm);
+
+ -- Compile time known value, not deleting yet
+
+ elsif Compile_Time_Known_Value (Cond) then
+
+ -- If condition is True, then analyze the THEN statements
+ -- and set no expansion for ELSE and ELSIF parts.
+
+ if Is_True (Expr_Value (Cond)) then
+ Analyze_Statements (Tstm);
+ Del := True;
+ Expander_Mode_Save_And_Set (False);
+
+ -- If condition is False, analyze THEN with expansion off
+
+ else -- Is_False (Expr_Value (Cond))
+ Expander_Mode_Save_And_Set (False);
+ Analyze_Statements (Tstm);
+ Expander_Mode_Restore;
+ end if;
+
+ -- Not known at compile time, not deleting, normal analysis
+
+ else
+ Analyze_Statements (Tstm);
+ end if;
+ end Analyze_Cond_Then;
+
+ -- Start of Analyze_If_Statement
+
+ begin
+ -- Initialize exit count for else statements. If there is no else
+ -- part, this count will stay non-zero reflecting the fact that the
+ -- uncovered else case is an unblocked exit.
+
+ Unblocked_Exit_Count := 1;
+ Analyze_Cond_Then (N);
+
+ -- Now to analyze the elsif parts if any are present
+
+ if Present (Elsif_Parts (N)) then
+ E := First (Elsif_Parts (N));
+ while Present (E) loop
+ Analyze_Cond_Then (E);
+ Next (E);
+ end loop;
+ end if;
+
+ if Present (Else_Statements (N)) then
+ Analyze_Statements (Else_Statements (N));
+ end if;
+
+ -- If all our exits were blocked by unconditional transfers of control,
+ -- then the entire IF statement acts as an unconditional transfer of
+ -- control, so treat it like one, and check unreachable code.
+
+ if Unblocked_Exit_Count = 0 then
+ Unblocked_Exit_Count := Save_Unblocked_Exit_Count;
+ Check_Unreachable_Code (N);
+ else
+ Unblocked_Exit_Count := Save_Unblocked_Exit_Count;
+ end if;
+
+ if Del then
+ Expander_Mode_Restore;
+ end if;
+
+ end Analyze_If_Statement;
+
+ ----------------------------------------
+ -- Analyze_Implicit_Label_Declaration --
+ ----------------------------------------
+
+ -- An implicit label declaration is generated in the innermost
+ -- enclosing declarative part. This is done for labels as well as
+ -- block and loop names.
+
+ -- Note: any changes in this routine may need to be reflected in
+ -- Analyze_Label_Entity.
+
+ procedure Analyze_Implicit_Label_Declaration (N : Node_Id) is
+ Id : Node_Id := Defining_Identifier (N);
+
+ begin
+ Enter_Name (Id);
+ Set_Ekind (Id, E_Label);
+ Set_Etype (Id, Standard_Void_Type);
+ Set_Enclosing_Scope (Id, Current_Scope);
+ end Analyze_Implicit_Label_Declaration;
+
+ ------------------------------
+ -- Analyze_Iteration_Scheme --
+ ------------------------------
+
+ procedure Analyze_Iteration_Scheme (N : Node_Id) is
+ begin
+ -- For an infinite loop, there is no iteration scheme
+
+ if No (N) then
+ return;
+
+ else
+ declare
+ Cond : constant Node_Id := Condition (N);
+
+ begin
+ -- For WHILE loop, verify that the condition is a Boolean
+ -- expression and resolve and check it.
+
+ if Present (Cond) then
+ Analyze_And_Resolve (Cond, Any_Boolean);
+ Check_Unset_Reference (Cond);
+
+ -- Else we have a FOR loop
+
+ else
+ declare
+ LP : constant Node_Id := Loop_Parameter_Specification (N);
+ Id : constant Entity_Id := Defining_Identifier (LP);
+ DS : constant Node_Id := Discrete_Subtype_Definition (LP);
+ F : List_Id;
+
+ begin
+ Enter_Name (Id);
+
+ -- We always consider the loop variable to be referenced,
+ -- since the loop may be used just for counting purposes.
+
+ Generate_Reference (Id, N, ' ');
+
+ -- Check for case of loop variable hiding a local
+ -- variable (used later on to give a nice warning
+ -- if the hidden variable is never assigned).
+
+ declare
+ H : constant Entity_Id := Homonym (Id);
+
+ begin
+ if Present (H)
+ and then Enclosing_Dynamic_Scope (H) =
+ Enclosing_Dynamic_Scope (Id)
+ and then Ekind (H) = E_Variable
+ and then Is_Discrete_Type (Etype (H))
+ then
+ Set_Hiding_Loop_Variable (H, Id);
+ end if;
+ end;
+
+ -- Now analyze the subtype definition
+
+ Analyze (DS);
+
+ if DS = Error then
+ return;
+ end if;
+
+ -- The subtype indication may denote the completion
+ -- of an incomplete type declaration.
+
+ if Is_Entity_Name (DS)
+ and then Present (Entity (DS))
+ and then Is_Type (Entity (DS))
+ and then Ekind (Entity (DS)) = E_Incomplete_Type
+ then
+ Set_Entity (DS, Get_Full_View (Entity (DS)));
+ Set_Etype (DS, Entity (DS));
+ end if;
+
+ if not Is_Discrete_Type (Etype (DS)) then
+ Wrong_Type (DS, Any_Discrete);
+ Set_Etype (DS, Any_Type);
+ end if;
+
+ Make_Index (DS, LP);
+
+ Set_Ekind (Id, E_Loop_Parameter);
+ Set_Etype (Id, Etype (DS));
+ Set_Is_Known_Valid (Id, True);
+
+ -- The loop is not a declarative part, so the only entity
+ -- declared "within" must be frozen explicitly. Since the
+ -- type of this entity has already been frozen, this cannot
+ -- generate any freezing actions.
+
+ F := Freeze_Entity (Id, Sloc (LP));
+ pragma Assert (F = No_List);
+
+ -- Check for null or possibly null range and issue warning
+
+ if Nkind (DS) = N_Range
+ and then Comes_From_Source (N)
+ and then not Inside_A_Generic
+ then
+ declare
+ L : constant Node_Id := Low_Bound (DS);
+ H : constant Node_Id := High_Bound (DS);
+
+ Llo : Uint;
+ Lhi : Uint;
+ LOK : Boolean;
+ Hlo : Uint;
+ Hhi : Uint;
+ HOK : Boolean;
+
+ begin
+ Determine_Range (L, LOK, Llo, Lhi);
+ Determine_Range (H, HOK, Hlo, Hhi);
+
+ -- If range of loop is null, issue warning
+
+ if (LOK and HOK) and then Llo > Hhi then
+ Warn_On_Instance := True;
+ Error_Msg_N
+ ("?loop range is null, loop will not execute",
+ DS);
+ Warn_On_Instance := False;
+
+ -- The other case for a warning is a reverse loop
+ -- where the upper bound is the integer literal
+ -- zero or one, and the lower bound can be positive.
+
+ elsif Reverse_Present (LP)
+ and then Nkind (H) = N_Integer_Literal
+ and then (Intval (H) = Uint_0
+ or else
+ Intval (H) = Uint_1)
+ and then Lhi > Hhi
+ then
+ Warn_On_Instance := True;
+ Error_Msg_N ("?loop range may be null", DS);
+ Warn_On_Instance := False;
+ end if;
+ end;
+ end if;
+ end;
+ end if;
+ end;
+ end if;
+ end Analyze_Iteration_Scheme;
+
+ -------------------
+ -- Analyze_Label --
+ -------------------
+
+ -- Important note: normally this routine is called from Analyze_Statements
+ -- which does a prescan, to make sure that the Reachable flags are set on
+ -- all labels before encountering a possible goto to one of these labels.
+ -- If expanded code analyzes labels via the normal Sem path, then it must
+ -- ensure that Reachable is set early enough to avoid problems in the case
+ -- of a forward goto.
+
+ procedure Analyze_Label (N : Node_Id) is
+ Lab : Entity_Id;
+
+ begin
+ Analyze (Identifier (N));
+ Lab := Entity (Identifier (N));
+
+ -- If we found a label mark it as reachable.
+
+ if Ekind (Lab) = E_Label then
+ Generate_Definition (Lab);
+ Set_Reachable (Lab);
+
+ if Nkind (Parent (Lab)) = N_Implicit_Label_Declaration then
+ Set_Label_Construct (Parent (Lab), N);
+ end if;
+
+ -- If we failed to find a label, it means the implicit declaration
+ -- of the label was hidden. A for-loop parameter can do this to a
+ -- label with the same name inside the loop, since the implicit label
+ -- declaration is in the innermost enclosing body or block statement.
+
+ else
+ Error_Msg_Sloc := Sloc (Lab);
+ Error_Msg_N
+ ("implicit label declaration for & is hidden#",
+ Identifier (N));
+ end if;
+ end Analyze_Label;
+
+ --------------------------
+ -- Analyze_Label_Entity --
+ --------------------------
+
+ procedure Analyze_Label_Entity (E : Entity_Id) is
+ begin
+ Set_Ekind (E, E_Label);
+ Set_Etype (E, Standard_Void_Type);
+ Set_Enclosing_Scope (E, Current_Scope);
+ Set_Reachable (E, True);
+ end Analyze_Label_Entity;
+
+ ----------------------------
+ -- Analyze_Loop_Statement --
+ ----------------------------
+
+ procedure Analyze_Loop_Statement (N : Node_Id) is
+ Id : constant Node_Id := Identifier (N);
+ Ent : Entity_Id;
+
+ begin
+ if Present (Id) then
+
+ -- Make name visible, e.g. for use in exit statements. Loop
+ -- labels are always considered to be referenced.
+
+ Analyze (Id);
+ Ent := Entity (Id);
+ Generate_Reference (Ent, N, ' ');
+ Generate_Definition (Ent);
+
+ -- If we found a label, mark its type. If not, ignore it, since it
+ -- means we have a conflicting declaration, which would already have
+ -- been diagnosed at declaration time. Set Label_Construct of the
+ -- implicit label declaration, which is not created by the parser
+ -- for generic units.
+
+ if Ekind (Ent) = E_Label then
+ Set_Ekind (Ent, E_Loop);
+
+ if Nkind (Parent (Ent)) = N_Implicit_Label_Declaration then
+ Set_Label_Construct (Parent (Ent), N);
+ end if;
+ end if;
+
+ -- Case of no identifier present
+
+ else
+ Ent := New_Internal_Entity (E_Loop, Current_Scope, Sloc (N), 'L');
+ Set_Etype (Ent, Standard_Void_Type);
+ Set_Parent (Ent, N);
+ end if;
+
+ New_Scope (Ent);
+ Analyze_Iteration_Scheme (Iteration_Scheme (N));
+ Analyze_Statements (Statements (N));
+ Process_End_Label (N, 'e');
+ End_Scope;
+ end Analyze_Loop_Statement;
+
+ ----------------------------
+ -- Analyze_Null_Statement --
+ ----------------------------
+
+ -- Note: the semantics of the null statement is implemented by a single
+ -- null statement, too bad everything isn't as simple as this!
+
+ procedure Analyze_Null_Statement (N : Node_Id) is
+ begin
+ null;
+ end Analyze_Null_Statement;
+
+ ------------------------
+ -- Analyze_Statements --
+ ------------------------
+
+ procedure Analyze_Statements (L : List_Id) is
+ S : Node_Id;
+
+ begin
+ -- The labels declared in the statement list are reachable from
+ -- statements in the list. We do this as a prepass so that any
+ -- goto statement will be properly flagged if its target is not
+ -- reachable. This is not required, but is nice behavior!
+
+ S := First (L);
+
+ while Present (S) loop
+ if Nkind (S) = N_Label then
+ Analyze_Label (S);
+ end if;
+
+ Next (S);
+ end loop;
+
+ -- Perform semantic analysis on all statements
+
+ S := First (L);
+
+ while Present (S) loop
+
+ if Nkind (S) /= N_Label then
+ Analyze (S);
+ end if;
+
+ Next (S);
+ end loop;
+
+ -- Make labels unreachable. Visibility is not sufficient, because
+ -- labels in one if-branch for example are not reachable from the
+ -- other branch, even though their declarations are in the enclosing
+ -- declarative part.
+
+ S := First (L);
+
+ while Present (S) loop
+ if Nkind (S) = N_Label then
+ Set_Reachable (Entity (Identifier (S)), False);
+ end if;
+
+ Next (S);
+ end loop;
+ end Analyze_Statements;
+
+ ----------------------------
+ -- Check_Unreachable_Code --
+ ----------------------------
+
+ procedure Check_Unreachable_Code (N : Node_Id) is
+ Error_Loc : Source_Ptr;
+ P : Node_Id;
+
+ begin
+ if Is_List_Member (N)
+ and then Comes_From_Source (N)
+ then
+ declare
+ Nxt : Node_Id;
+
+ begin
+ Nxt := Original_Node (Next (N));
+
+ if Present (Nxt)
+ and then Comes_From_Source (Nxt)
+ and then Is_Statement (Nxt)
+ then
+ -- Special very annoying exception. If we have a return that
+ -- follows a raise, then we allow it without a warning, since
+ -- the Ada RM annoyingly requires a useless return here!
+
+ if Nkind (Original_Node (N)) /= N_Raise_Statement
+ or else Nkind (Nxt) /= N_Return_Statement
+ then
+ -- The rather strange shenanigans with the warning message
+ -- here reflects the fact that Kill_Dead_Code is very good
+ -- at removing warnings in deleted code, and this is one
+ -- warning we would prefer NOT to have removed :-)
+
+ Error_Loc := Sloc (Nxt);
+
+ -- If we have unreachable code, analyze and remove the
+ -- unreachable code, since it is useless and we don't
+ -- want to generate junk warnings.
+
+ -- We skip this step if we are not in code generation mode.
+ -- This is the one case where we remove dead code in the
+ -- semantics as opposed to the expander, and we do not want
+ -- to remove code if we are not in code generation mode,
+ -- since this messes up the ASIS trees.
+
+ -- Note that one might react by moving the whole circuit to
+ -- exp_ch5, but then we lose the warning in -gnatc mode.
+
+ if Operating_Mode = Generate_Code then
+ loop
+ Nxt := Next (N);
+ exit when No (Nxt) or else not Is_Statement (Nxt);
+ Analyze (Nxt);
+ Remove (Nxt);
+ Kill_Dead_Code (Nxt);
+ end loop;
+ end if;
+
+ -- Now issue the warning
+
+ Error_Msg ("?unreachable code", Error_Loc);
+ end if;
+
+ -- If the unconditional transfer of control instruction is
+ -- the last statement of a sequence, then see if our parent
+ -- is an IF statement, and if so adjust the unblocked exit
+ -- count of the if statement to reflect the fact that this
+ -- branch of the if is indeed blocked by a transfer of control.
+
+ else
+ P := Parent (N);
+
+ if Nkind (P) = N_If_Statement then
+ null;
+
+ elsif Nkind (P) = N_Elsif_Part then
+ P := Parent (P);
+ pragma Assert (Nkind (P) = N_If_Statement);
+
+ elsif Nkind (P) = N_Case_Statement_Alternative then
+ P := Parent (P);
+ pragma Assert (Nkind (P) = N_Case_Statement);
+
+ else
+ return;
+ end if;
+
+ Unblocked_Exit_Count := Unblocked_Exit_Count - 1;
+ end if;
+ end;
+ end if;
+ end Check_Unreachable_Code;
+
+end Sem_Ch5;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S E M _ C H 5 --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.16 $ --
+-- --
+-- 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). --
+-- --
+------------------------------------------------------------------------------
+
+with Types; use Types;
+
+package Sem_Ch5 is
+
+ procedure Analyze_Assignment (N : Node_Id);
+ procedure Analyze_Block_Statement (N : Node_Id);
+ procedure Analyze_Case_Statement (N : Node_Id);
+ procedure Analyze_Exit_Statement (N : Node_Id);
+ procedure Analyze_Goto_Statement (N : Node_Id);
+ procedure Analyze_If_Statement (N : Node_Id);
+ procedure Analyze_Implicit_Label_Declaration (N : Node_Id);
+ procedure Analyze_Label (N : Node_Id);
+ procedure Analyze_Loop_Statement (N : Node_Id);
+ procedure Analyze_Null_Statement (N : Node_Id);
+ procedure Analyze_Statements (L : List_Id);
+
+ procedure Analyze_Label_Entity (E : Entity_Id);
+ -- This procedure performs direct analysis of the label entity E. It
+ -- is used when a label is created by the expander without bothering
+ -- to insert an N_Implicit_Label_Declaration in the tree. It also takes
+ -- care of setting Reachable, since labels defined by the expander can
+ -- be assumed to be reachable.
+
+ procedure Check_Unreachable_Code (N : Node_Id);
+ -- This procedure is called with N being the node for a statement that
+ -- is an unconditional transfer of control. It checks to see if the
+ -- statement is followed by some other statement, and if so generates
+ -- an appropriate warning for unreachable code.
+
+end Sem_Ch5;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S E M _ C H 6 --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.508 $
+-- --
+-- 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). --
+-- --
+------------------------------------------------------------------------------
+
+with Atree; use Atree;
+with Checks; use Checks;
+with Debug; use Debug;
+with Einfo; use Einfo;
+with Elists; use Elists;
+with Errout; use Errout;
+with Expander; use Expander;
+with Exp_Ch7; use Exp_Ch7;
+with Freeze; use Freeze;
+with Lib.Xref; use Lib.Xref;
+with Namet; use Namet;
+with Lib; use Lib;
+with Nlists; use Nlists;
+with Nmake; use Nmake;
+with Opt; use Opt;
+with Output; use Output;
+with Rtsfind; use Rtsfind;
+with Sem; use Sem;
+with Sem_Cat; use Sem_Cat;
+with Sem_Ch3; use Sem_Ch3;
+with Sem_Ch4; use Sem_Ch4;
+with Sem_Ch5; use Sem_Ch5;
+with Sem_Ch8; use Sem_Ch8;
+with Sem_Ch12; use Sem_Ch12;
+with Sem_Disp; use Sem_Disp;
+with Sem_Dist; use Sem_Dist;
+with Sem_Elim; use Sem_Elim;
+with Sem_Eval; use Sem_Eval;
+with Sem_Mech; use Sem_Mech;
+with Sem_Prag; use Sem_Prag;
+with Sem_Res; use Sem_Res;
+with Sem_Util; use Sem_Util;
+with Sem_Type; use Sem_Type;
+with Sem_Warn; use Sem_Warn;
+with Sinput; use Sinput;
+with Stand; use Stand;
+with Sinfo; use Sinfo;
+with Sinfo.CN; use Sinfo.CN;
+with Snames; use Snames;
+with Stringt; use Stringt;
+with Style;
+with Stylesw; use Stylesw;
+with Tbuild; use Tbuild;
+with Uintp; use Uintp;
+with Urealp; use Urealp;
+with Validsw; use Validsw;
+
+package body Sem_Ch6 is
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ procedure Analyze_Generic_Subprogram_Body (N : Node_Id; Gen_Id : Entity_Id);
+ -- Analyze a generic subprogram body
+
+ function Build_Body_To_Inline
+ (N : Node_Id;
+ Subp : Entity_Id;
+ Orig_Body : Node_Id)
+ return Boolean;
+ -- If a subprogram has pragma Inline and inlining is active, use generic
+ -- machinery to build an unexpanded body for the subprogram. This body is
+ -- subsequenty used for inline expansions at call sites. If subprogram can
+ -- be inlined (depending on size and nature of local declarations) this
+ -- function returns true. Otherwise subprogram body is treated normally.
+
+ type Conformance_Type is
+ (Type_Conformant, Mode_Conformant, Subtype_Conformant, Fully_Conformant);
+
+ procedure Check_Conformance
+ (New_Id : Entity_Id;
+ Old_Id : Entity_Id;
+ Ctype : Conformance_Type;
+ Errmsg : Boolean;
+ Conforms : out Boolean;
+ Err_Loc : Node_Id := Empty;
+ Get_Inst : Boolean := False);
+ -- Given two entities, this procedure checks that the profiles associated
+ -- with these entities meet the conformance criterion given by the third
+ -- parameter. If they conform, Conforms is set True and control returns
+ -- to the caller. If they do not conform, Conforms is set to False, and
+ -- in addition, if Errmsg is True on the call, proper messages are output
+ -- to complain about the conformance failure. If Err_Loc is non_Empty
+ -- the error messages are placed on Err_Loc, if Err_Loc is empty, then
+ -- error messages are placed on the appropriate part of the construct
+ -- denoted by New_Id. If Get_Inst is true, then this is a mode conformance
+ -- against a formal access-to-subprogram type so Get_Instance_Of must
+ -- be called.
+
+ procedure Check_Subprogram_Order (N : Node_Id);
+ -- N is the N_Subprogram_Body node for a subprogram. This routine applies
+ -- the alpha ordering rule for N if this ordering requirement applicable.
+
+ function Is_Non_Overriding_Operation
+ (Prev_E : Entity_Id;
+ New_E : Entity_Id)
+ return Boolean;
+ -- Enforce the rule given in 12.3(18): a private operation in an instance
+ -- overrides an inherited operation only if the corresponding operation
+ -- was overriding in the generic. This can happen for primitive operations
+ -- of types derived (in the generic unit) from formal private or formal
+ -- derived types.
+
+ procedure Check_Returns
+ (HSS : Node_Id;
+ Mode : Character;
+ Err : out Boolean);
+ -- Called to check for missing return statements in a function body,
+ -- or for returns present in a procedure body which has No_Return set.
+ -- L is the handled statement sequence for the subprogram body. This
+ -- procedure checks all flow paths to make sure they either have a
+ -- return (Mode = 'F') or do not have a return (Mode = 'P'). The flag
+ -- Err is set if there are any control paths not explicitly terminated
+ -- by a return in the function case, and is True otherwise.
+
+ function Conforming_Types
+ (T1 : Entity_Id;
+ T2 : Entity_Id;
+ Ctype : Conformance_Type;
+ Get_Inst : Boolean := False)
+ return Boolean;
+ -- Check that two formal parameter types conform, checking both
+ -- for equality of base types, and where required statically
+ -- matching subtypes, depending on the setting of Ctype.
+
+ procedure Enter_Overloaded_Entity (S : Entity_Id);
+ -- This procedure makes S, a new overloaded entity, into the first
+ -- visible entity with that name.
+
+ procedure Install_Entity (E : Entity_Id);
+ -- Make single entity visible. Used for generic formals as well.
+
+ procedure Install_Formals (Id : Entity_Id);
+ -- On entry to a subprogram body, make the formals visible. Note
+ -- that simply placing the subprogram on the scope stack is not
+ -- sufficient: the formals must become the current entities for
+ -- their names.
+
+ procedure Make_Inequality_Operator (S : Entity_Id);
+ -- Create the declaration for an inequality operator that is implicitly
+ -- created by a user-defined equality operator that yields a boolean.
+
+ procedure May_Need_Actuals (Fun : Entity_Id);
+ -- Flag functions that can be called without parameters, i.e. those that
+ -- have no parameters, or those for which defaults exist for all parameters
+
+ procedure Set_Formal_Validity (Formal_Id : Entity_Id);
+ -- Formal_Id is an formal parameter entity. This procedure deals with
+ -- setting the proper validity status for this entity, which depends
+ -- on the kind of parameter and the validity checking mode.
+
+ ---------------------------------------------
+ -- Analyze_Abstract_Subprogram_Declaration --
+ ---------------------------------------------
+
+ procedure Analyze_Abstract_Subprogram_Declaration (N : Node_Id) is
+ Designator : constant Entity_Id := Analyze_Spec (Specification (N));
+ Scop : constant Entity_Id := Current_Scope;
+
+ begin
+ Generate_Definition (Designator);
+ Set_Is_Abstract (Designator);
+ New_Overloaded_Entity (Designator);
+ Check_Delayed_Subprogram (Designator);
+
+ Set_Is_Pure (Designator,
+ Is_Pure (Scop) and then Is_Library_Level_Entity (Designator));
+ Set_Is_Remote_Call_Interface (
+ Designator, Is_Remote_Call_Interface (Scop));
+ Set_Is_Remote_Types (Designator, Is_Remote_Types (Scop));
+
+ if Ekind (Scope (Designator)) = E_Protected_Type then
+ Error_Msg_N
+ ("abstract subprogram not allowed in protected type", N);
+ end if;
+ end Analyze_Abstract_Subprogram_Declaration;
+
+ ----------------------------
+ -- Analyze_Function_Call --
+ ----------------------------
+
+ procedure Analyze_Function_Call (N : Node_Id) is
+ P : constant Node_Id := Name (N);
+ L : constant List_Id := Parameter_Associations (N);
+ Actual : Node_Id;
+
+ begin
+ Analyze (P);
+
+ -- If error analyzing name, then set Any_Type as result type and return
+
+ if Etype (P) = Any_Type then
+ Set_Etype (N, Any_Type);
+ return;
+ end if;
+
+ -- Otherwise analyze the parameters
+
+ if Present (L) then
+ Actual := First (L);
+
+ while Present (Actual) loop
+ Analyze (Actual);
+ Check_Parameterless_Call (Actual);
+ Next (Actual);
+ end loop;
+ end if;
+
+ Analyze_Call (N);
+
+ end Analyze_Function_Call;
+
+ -------------------------------------
+ -- Analyze_Generic_Subprogram_Body --
+ -------------------------------------
+
+ procedure Analyze_Generic_Subprogram_Body
+ (N : Node_Id;
+ Gen_Id : Entity_Id)
+ is
+ Gen_Decl : constant Node_Id := Unit_Declaration_Node (Gen_Id);
+ Spec : Node_Id;
+ Kind : constant Entity_Kind := Ekind (Gen_Id);
+ Nam : Entity_Id;
+ New_N : Node_Id;
+
+ begin
+ -- Copy body and disable expansion while analyzing the generic
+ -- For a stub, do not copy the stub (which would load the proper body),
+ -- this will be done when the proper body is analyzed.
+
+ if Nkind (N) /= N_Subprogram_Body_Stub then
+ New_N := Copy_Generic_Node (N, Empty, Instantiating => False);
+ Rewrite (N, New_N);
+ Start_Generic;
+ end if;
+
+ Spec := Specification (N);
+
+ -- Within the body of the generic, the subprogram is callable, and
+ -- behaves like the corresponding non-generic unit.
+
+ Nam := Defining_Entity (Spec);
+
+ if Kind = E_Generic_Procedure
+ and then Nkind (Spec) /= N_Procedure_Specification
+ then
+ Error_Msg_N ("invalid body for generic procedure ", Nam);
+ return;
+
+ elsif Kind = E_Generic_Function
+ and then Nkind (Spec) /= N_Function_Specification
+ then
+ Error_Msg_N ("invalid body for generic function ", Nam);
+ return;
+ end if;
+
+ Set_Corresponding_Body (Gen_Decl, Nam);
+
+ if Has_Completion (Gen_Id)
+ and then Nkind (Parent (N)) /= N_Subunit
+ then
+ Error_Msg_N ("duplicate generic body", N);
+ return;
+ else
+ Set_Has_Completion (Gen_Id);
+ end if;
+
+ if Nkind (N) = N_Subprogram_Body_Stub then
+ Set_Ekind (Defining_Entity (Specification (N)), Kind);
+ else
+ Set_Corresponding_Spec (N, Gen_Id);
+ end if;
+
+ if Nkind (Parent (N)) = N_Compilation_Unit then
+ Set_Cunit_Entity (Current_Sem_Unit, Defining_Entity (N));
+ end if;
+
+ -- Make generic parameters immediately visible in the body. They are
+ -- needed to process the formals declarations. Then make the formals
+ -- visible in a separate step.
+
+ New_Scope (Gen_Id);
+
+ declare
+ E : Entity_Id;
+ First_Ent : Entity_Id;
+
+ begin
+ First_Ent := First_Entity (Gen_Id);
+
+ E := First_Ent;
+ while Present (E) and then not Is_Formal (E) loop
+ Install_Entity (E);
+ Next_Entity (E);
+ end loop;
+
+ Set_Use (Generic_Formal_Declarations (Gen_Decl));
+
+ -- Now generic formals are visible, and the specification can be
+ -- analyzed, for subsequent conformance check.
+
+ Nam := Analyze_Spec (Spec);
+
+ if Nkind (N) = N_Subprogram_Body_Stub then
+
+ -- Nothing to do if no body to process
+
+ Set_Ekind (Nam, Kind);
+ End_Scope;
+ return;
+ end if;
+
+ if Present (E) then
+
+ -- E is the first formal parameter, which must be the first
+ -- entity in the subprogram body.
+
+ Set_First_Entity (Gen_Id, E);
+
+ -- Now make formal parameters visible
+
+ while Present (E) loop
+ Install_Entity (E);
+ Next_Formal (E);
+ end loop;
+ end if;
+
+ -- Visible generic entity is callable within its own body.
+
+ Set_Ekind (Gen_Id, Ekind (Nam));
+ Set_Convention (Nam, Convention (Gen_Id));
+ Set_Scope (Nam, Scope (Gen_Id));
+ Check_Fully_Conformant (Nam, Gen_Id, Nam);
+
+ -- If this is a compilation unit, it must be made visible
+ -- explicitly, because the compilation of the declaration,
+ -- unlike other library unit declarations, does not. If it
+ -- is not a unit, the following is redundant but harmless.
+
+ Set_Is_Immediately_Visible (Gen_Id);
+
+ Set_Actual_Subtypes (N, Current_Scope);
+ Analyze_Declarations (Declarations (N));
+ Check_Completion;
+ Analyze (Handled_Statement_Sequence (N));
+
+ Save_Global_References (Original_Node (N));
+
+ -- Prior to exiting the scope, include generic formals again
+ -- (if any are present) in the set of local entities.
+
+ if Present (First_Ent) then
+ Set_First_Entity (Gen_Id, First_Ent);
+ end if;
+
+ end;
+
+ End_Scope;
+ Check_Subprogram_Order (N);
+
+ -- Outside of its body, unit is generic again.
+
+ Set_Ekind (Gen_Id, Kind);
+ Set_Ekind (Nam, E_Subprogram_Body);
+ Generate_Reference (Gen_Id, Nam, 'b');
+ Style.Check_Identifier (Nam, Gen_Id);
+ End_Generic;
+
+ end Analyze_Generic_Subprogram_Body;
+
+ -----------------------------
+ -- Analyze_Operator_Symbol --
+ -----------------------------
+
+ -- An operator symbol such as "+" or "and" may appear in context where
+ -- the literal denotes an entity name, such as "+"(x, y) or in a
+ -- context when it is just a string, as in (conjunction = "or"). In
+ -- these cases the parser generates this node, and the semantics does
+ -- the disambiguation. Other such case are actuals in an instantiation,
+ -- the generic unit in an instantiation, and pragma arguments.
+
+ procedure Analyze_Operator_Symbol (N : Node_Id) is
+ Par : constant Node_Id := Parent (N);
+
+ begin
+ if (Nkind (Par) = N_Function_Call and then N = Name (Par))
+ or else Nkind (Par) = N_Function_Instantiation
+ or else (Nkind (Par) = N_Indexed_Component and then N = Prefix (Par))
+ or else (Nkind (Par) = N_Pragma_Argument_Association
+ and then not Is_Pragma_String_Literal (Par))
+ or else Nkind (Par) = N_Subprogram_Renaming_Declaration
+ or else (Nkind (Par) = N_Attribute_Reference
+ and then Attribute_Name (Par) /= Name_Value)
+ then
+ Find_Direct_Name (N);
+
+ else
+ Change_Operator_Symbol_To_String_Literal (N);
+ Analyze (N);
+ end if;
+ end Analyze_Operator_Symbol;
+
+ -----------------------------------
+ -- Analyze_Parameter_Association --
+ -----------------------------------
+
+ procedure Analyze_Parameter_Association (N : Node_Id) is
+ begin
+ Analyze (Explicit_Actual_Parameter (N));
+ end Analyze_Parameter_Association;
+
+ ----------------------------
+ -- Analyze_Procedure_Call --
+ ----------------------------
+
+ procedure Analyze_Procedure_Call (N : Node_Id) is
+ Loc : constant Source_Ptr := Sloc (N);
+ P : constant Node_Id := Name (N);
+ Actuals : constant List_Id := Parameter_Associations (N);
+ Actual : Node_Id;
+ New_N : Node_Id;
+
+ procedure Analyze_Call_And_Resolve;
+ -- Do Analyze and Resolve calls for procedure call
+
+ procedure Analyze_Call_And_Resolve is
+ begin
+ if Nkind (N) = N_Procedure_Call_Statement then
+ Analyze_Call (N);
+ Resolve (N, Standard_Void_Type);
+ else
+ Analyze (N);
+ end if;
+ end Analyze_Call_And_Resolve;
+
+ -- Start of processing for Analyze_Procedure_Call
+
+ begin
+ -- The syntactic construct: PREFIX ACTUAL_PARAMETER_PART can denote
+ -- a procedure call or an entry call. The prefix may denote an access
+ -- to subprogram type, in which case an implicit dereference applies.
+ -- If the prefix is an indexed component (without implicit defererence)
+ -- then the construct denotes a call to a member of an entire family.
+ -- If the prefix is a simple name, it may still denote a call to a
+ -- parameterless member of an entry family. Resolution of these various
+ -- interpretations is delicate.
+
+ Analyze (P);
+
+ -- If error analyzing prefix, then set Any_Type as result and return
+
+ if Etype (P) = Any_Type then
+ Set_Etype (N, Any_Type);
+ return;
+ end if;
+
+ -- Otherwise analyze the parameters
+
+ if Present (Actuals) then
+ Actual := First (Actuals);
+
+ while Present (Actual) loop
+ Analyze (Actual);
+ Check_Parameterless_Call (Actual);
+ Next (Actual);
+ end loop;
+ end if;
+
+ -- Special processing for Elab_Spec and Elab_Body calls
+
+ if Nkind (P) = N_Attribute_Reference
+ and then (Attribute_Name (P) = Name_Elab_Spec
+ or else Attribute_Name (P) = Name_Elab_Body)
+ then
+ if Present (Actuals) then
+ Error_Msg_N
+ ("no parameters allowed for this call", First (Actuals));
+ return;
+ end if;
+
+ Set_Etype (N, Standard_Void_Type);
+ Set_Analyzed (N);
+
+ elsif Is_Entity_Name (P)
+ and then Is_Record_Type (Etype (Entity (P)))
+ and then Remote_AST_I_Dereference (P)
+ then
+ return;
+
+ elsif Is_Entity_Name (P)
+ and then Ekind (Entity (P)) /= E_Entry_Family
+ then
+ if Is_Access_Type (Etype (P))
+ and then Ekind (Designated_Type (Etype (P))) = E_Subprogram_Type
+ and then No (Actuals)
+ and then Comes_From_Source (N)
+ then
+ Error_Msg_N ("missing explicit dereference in call", N);
+ end if;
+
+ Analyze_Call_And_Resolve;
+
+ -- If the prefix is the simple name of an entry family, this is
+ -- a parameterless call from within the task body itself.
+
+ elsif Is_Entity_Name (P)
+ and then Nkind (P) = N_Identifier
+ and then Ekind (Entity (P)) = E_Entry_Family
+ and then Present (Actuals)
+ and then No (Next (First (Actuals)))
+ then
+ -- Can be call to parameterless entry family. What appears to be
+ -- the sole argument is in fact the entry index. Rewrite prefix
+ -- of node accordingly. Source representation is unchanged by this
+ -- transformation.
+
+ New_N :=
+ Make_Indexed_Component (Loc,
+ Prefix =>
+ Make_Selected_Component (Loc,
+ Prefix => New_Occurrence_Of (Scope (Entity (P)), Loc),
+ Selector_Name => New_Occurrence_Of (Entity (P), Loc)),
+ Expressions => Actuals);
+ Set_Name (N, New_N);
+ Set_Etype (New_N, Standard_Void_Type);
+ Set_Parameter_Associations (N, No_List);
+ Analyze_Call_And_Resolve;
+
+ elsif Nkind (P) = N_Explicit_Dereference then
+ if Ekind (Etype (P)) = E_Subprogram_Type then
+ Analyze_Call_And_Resolve;
+ else
+ Error_Msg_N ("expect access to procedure in call", P);
+ end if;
+
+ -- The name can be a selected component or an indexed component
+ -- that yields an access to subprogram. Such a prefix is legal if
+ -- the call has parameter associations.
+
+ elsif Is_Access_Type (Etype (P))
+ and then Ekind (Designated_Type (Etype (P))) = E_Subprogram_Type
+ then
+ if Present (Actuals) then
+ Analyze_Call_And_Resolve;
+ else
+ Error_Msg_N ("missing explicit dereference in call ", N);
+ end if;
+
+ -- If not an access to subprogram, then the prefix must resolve to
+ -- the name of an entry, entry family, or protected operation.
+
+ -- For the case of a simple entry call, P is a selected component
+ -- where the prefix is the task and the selector name is the entry.
+ -- A call to a protected procedure will have the same syntax. If
+ -- the protected object contains overloaded operations, the entity
+ -- may appear as a function, the context will select the operation
+ -- whose type is Void.
+
+ elsif Nkind (P) = N_Selected_Component
+ and then (Ekind (Entity (Selector_Name (P))) = E_Entry
+ or else
+ Ekind (Entity (Selector_Name (P))) = E_Procedure
+ or else
+ Ekind (Entity (Selector_Name (P))) = E_Function)
+ then
+ Analyze_Call_And_Resolve;
+
+ elsif Nkind (P) = N_Selected_Component
+ and then Ekind (Entity (Selector_Name (P))) = E_Entry_Family
+ and then Present (Actuals)
+ and then No (Next (First (Actuals)))
+ then
+ -- Can be call to parameterless entry family. What appears to be
+ -- the sole argument is in fact the entry index. Rewrite prefix
+ -- of node accordingly. Source representation is unchanged by this
+ -- transformation.
+
+ New_N :=
+ Make_Indexed_Component (Loc,
+ Prefix => New_Copy (P),
+ Expressions => Actuals);
+ Set_Name (N, New_N);
+ Set_Etype (New_N, Standard_Void_Type);
+ Set_Parameter_Associations (N, No_List);
+ Analyze_Call_And_Resolve;
+
+ -- For the case of a reference to an element of an entry family, P is
+ -- an indexed component whose prefix is a selected component (task and
+ -- entry family), and whose index is the entry family index.
+
+ elsif Nkind (P) = N_Indexed_Component
+ and then Nkind (Prefix (P)) = N_Selected_Component
+ and then Ekind (Entity (Selector_Name (Prefix (P)))) = E_Entry_Family
+ then
+ Analyze_Call_And_Resolve;
+
+ -- If the prefix is the name of an entry family, it is a call from
+ -- within the task body itself.
+
+ elsif Nkind (P) = N_Indexed_Component
+ and then Nkind (Prefix (P)) = N_Identifier
+ and then Ekind (Entity (Prefix (P))) = E_Entry_Family
+ then
+ New_N :=
+ Make_Selected_Component (Loc,
+ Prefix => New_Occurrence_Of (Scope (Entity (Prefix (P))), Loc),
+ Selector_Name => New_Occurrence_Of (Entity (Prefix (P)), Loc));
+ Rewrite (Prefix (P), New_N);
+ Analyze (P);
+ Analyze_Call_And_Resolve;
+
+ -- Anything else is an error.
+
+ else
+ Error_Msg_N ("Invalid procedure or entry call", N);
+ end if;
+ end Analyze_Procedure_Call;
+
+ ------------------------------
+ -- Analyze_Return_Statement --
+ ------------------------------
+
+ procedure Analyze_Return_Statement (N : Node_Id) is
+ Loc : constant Source_Ptr := Sloc (N);
+ Expr : Node_Id;
+ Scope_Id : Entity_Id;
+ Kind : Entity_Kind;
+ R_Type : Entity_Id;
+
+ begin
+ -- Find subprogram or accept statement enclosing the return statement
+
+ Scope_Id := Empty;
+ for J in reverse 0 .. Scope_Stack.Last loop
+ Scope_Id := Scope_Stack.Table (J).Entity;
+ exit when Ekind (Scope_Id) /= E_Block and then
+ Ekind (Scope_Id) /= E_Loop;
+ end loop;
+
+ pragma Assert (Present (Scope_Id));
+
+ Kind := Ekind (Scope_Id);
+ Expr := Expression (N);
+
+ if Kind /= E_Function
+ and then Kind /= E_Generic_Function
+ and then Kind /= E_Procedure
+ and then Kind /= E_Generic_Procedure
+ and then Kind /= E_Entry
+ and then Kind /= E_Entry_Family
+ then
+ Error_Msg_N ("illegal context for return statement", N);
+
+ elsif Present (Expr) then
+ if Kind = E_Function or else Kind = E_Generic_Function then
+ Set_Return_Present (Scope_Id);
+ R_Type := Etype (Scope_Id);
+ Set_Return_Type (N, R_Type);
+ Analyze_And_Resolve (Expr, R_Type);
+
+ if (Is_Class_Wide_Type (Etype (Expr))
+ or else Is_Dynamically_Tagged (Expr))
+ and then not Is_Class_Wide_Type (R_Type)
+ then
+ Error_Msg_N
+ ("dynamically tagged expression not allowed!", Expr);
+ end if;
+
+ Apply_Constraint_Check (Expr, R_Type);
+
+ -- ??? A real run-time accessibility check is needed
+ -- in cases involving dereferences of access parameters.
+ -- For now we just check the static cases.
+
+ if Is_Return_By_Reference_Type (Etype (Scope_Id))
+ and then Object_Access_Level (Expr)
+ > Subprogram_Access_Level (Scope_Id)
+ then
+ Rewrite (N, Make_Raise_Program_Error (Loc));
+ Analyze (N);
+
+ Error_Msg_N
+ ("cannot return a local value by reference?", N);
+ Error_Msg_NE
+ ("& will be raised at run time?!",
+ N, Standard_Program_Error);
+ end if;
+
+ elsif Kind = E_Procedure or else Kind = E_Generic_Procedure then
+ Error_Msg_N ("procedure cannot return value (use function)", N);
+
+ else
+ Error_Msg_N ("accept statement cannot return value", N);
+ end if;
+
+ -- No expression present
+
+ else
+ if Kind = E_Function or Kind = E_Generic_Function then
+ Error_Msg_N ("missing expression in return from function", N);
+ end if;
+
+ if (Ekind (Scope_Id) = E_Procedure
+ or else Ekind (Scope_Id) = E_Generic_Procedure)
+ and then No_Return (Scope_Id)
+ then
+ Error_Msg_N
+ ("RETURN statement not allowed (No_Return)", N);
+ end if;
+ end if;
+
+ Check_Unreachable_Code (N);
+ end Analyze_Return_Statement;
+
+ ------------------
+ -- Analyze_Spec --
+ ------------------
+
+ function Analyze_Spec (N : Node_Id) return Entity_Id is
+ Designator : constant Entity_Id := Defining_Entity (N);
+ Formals : constant List_Id := Parameter_Specifications (N);
+ Typ : Entity_Id;
+
+ begin
+ Generate_Definition (Designator);
+
+ if Nkind (N) = N_Function_Specification then
+ Set_Ekind (Designator, E_Function);
+ Set_Mechanism (Designator, Default_Mechanism);
+
+ if Subtype_Mark (N) /= Error then
+ Find_Type (Subtype_Mark (N));
+ Typ := Entity (Subtype_Mark (N));
+ Set_Etype (Designator, Typ);
+
+ if (Ekind (Typ) = E_Incomplete_Type
+ or else (Is_Class_Wide_Type (Typ)
+ and then
+ Ekind (Root_Type (Typ)) = E_Incomplete_Type))
+ then
+ Error_Msg_N
+ ("invalid use of incomplete type", Subtype_Mark (N));
+ end if;
+
+ else
+ Set_Etype (Designator, Any_Type);
+ end if;
+
+ else
+ Set_Ekind (Designator, E_Procedure);
+ Set_Etype (Designator, Standard_Void_Type);
+ end if;
+
+ if Present (Formals) then
+ Set_Scope (Designator, Current_Scope);
+ New_Scope (Designator);
+ Process_Formals (Designator, Formals, N);
+ End_Scope;
+ end if;
+
+ if Nkind (N) = N_Function_Specification then
+ if Nkind (Designator) = N_Defining_Operator_Symbol then
+ Valid_Operator_Definition (Designator);
+ end if;
+
+ May_Need_Actuals (Designator);
+
+ if Is_Abstract (Etype (Designator))
+ and then Nkind (Parent (N)) /= N_Abstract_Subprogram_Declaration
+ then
+ Error_Msg_N
+ ("function that returns abstract type must be abstract", N);
+ end if;
+ end if;
+
+ return Designator;
+ end Analyze_Spec;
+
+ -----------------------------
+ -- Analyze_Subprogram_Body --
+ -----------------------------
+
+ -- This procedure is called for regular subprogram bodies, generic bodies,
+ -- and for subprogram stubs of both kinds. In the case of stubs, only the
+ -- specification matters, and is used to create a proper declaration for
+ -- the subprogram, or to perform conformance checks.
+
+ procedure Analyze_Subprogram_Body (N : Node_Id) is
+ Body_Spec : constant Node_Id := Specification (N);
+ Body_Id : Entity_Id := Defining_Entity (Body_Spec);
+ Prev_Id : constant Entity_Id := Current_Entity_In_Scope (Body_Id);
+
+ HSS : Node_Id;
+ Spec_Id : Entity_Id;
+ Spec_Decl : Node_Id := Empty;
+ Last_Formal : Entity_Id := Empty;
+ Conformant : Boolean;
+ Missing_Ret : Boolean;
+
+ begin
+ if Debug_Flag_C then
+ Write_Str ("==== Compiling subprogram body ");
+ Write_Name (Chars (Body_Id));
+ Write_Str (" from ");
+ Write_Location (Sloc (N));
+ Write_Eol;
+ end if;
+
+ Trace_Scope (N, Body_Id, " Analyze subprogram");
+
+ -- Generic subprograms are handled separately. They always have
+ -- a generic specification. Determine whether current scope has
+ -- a previous declaration.
+
+ -- If the subprogram body is defined within an instance of the
+ -- same name, the instance appears as a package renaming, and
+ -- will be hidden within the subprogram.
+
+ if Present (Prev_Id)
+ and then not Is_Overloadable (Prev_Id)
+ and then (Nkind (Parent (Prev_Id)) /= N_Package_Renaming_Declaration
+ or else Comes_From_Source (Prev_Id))
+ then
+ if Ekind (Prev_Id) = E_Generic_Procedure
+ or else Ekind (Prev_Id) = E_Generic_Function
+ then
+ Spec_Id := Prev_Id;
+ Set_Is_Compilation_Unit (Body_Id, Is_Compilation_Unit (Spec_Id));
+ Set_Is_Child_Unit (Body_Id, Is_Child_Unit (Spec_Id));
+
+ Analyze_Generic_Subprogram_Body (N, Spec_Id);
+ return;
+
+ else
+ -- Previous entity conflicts with subprogram name.
+ -- Attempting to enter name will post error.
+
+ Enter_Name (Body_Id);
+ return;
+ end if;
+
+ -- Non-generic case, find the subprogram declaration, if one was
+ -- seen, or enter new overloaded entity in the current scope.
+ -- If the current_entity is the body_id itself, the unit is being
+ -- analyzed as part of the context of one of its subunits. No need
+ -- to redo the analysis.
+
+ elsif Prev_Id = Body_Id
+ and then Has_Completion (Body_Id)
+ then
+ return;
+
+ else
+ Body_Id := Analyze_Spec (Body_Spec);
+
+ if Nkind (N) = N_Subprogram_Body_Stub
+ or else No (Corresponding_Spec (N))
+ then
+ Spec_Id := Find_Corresponding_Spec (N);
+
+ -- If this is a duplicate body, no point in analyzing it
+
+ if Error_Posted (N) then
+ return;
+ end if;
+
+ -- A subprogram body should cause freezing of its own
+ -- declaration, but if there was no previous explicit
+ -- declaration, then the subprogram will get frozen too
+ -- late (there may be code within the body that depends
+ -- on the subprogram having been frozen, such as uses of
+ -- extra formals), so we force it to be frozen here.
+ -- Same holds if the body and the spec are compilation units.
+
+ if No (Spec_Id) then
+ Freeze_Before (N, Body_Id);
+
+ elsif Nkind (Parent (N)) = N_Compilation_Unit then
+ Freeze_Before (N, Spec_Id);
+ end if;
+ else
+ Spec_Id := Corresponding_Spec (N);
+ end if;
+ end if;
+
+ if No (Spec_Id)
+ and then Comes_From_Source (N)
+ and then Is_Protected_Type (Current_Scope)
+ then
+ -- Fully private operation in the body of the protected type. We
+ -- must create a declaration for the subprogram, in order to attach
+ -- the protected subprogram that will be used in internal calls.
+
+ declare
+ Loc : constant Source_Ptr := Sloc (N);
+ Decl : Node_Id;
+ Plist : List_Id;
+ Formal : Entity_Id;
+ New_Spec : Node_Id;
+
+ begin
+ Formal := First_Formal (Body_Id);
+
+ -- The protected operation always has at least one formal,
+ -- namely the object itself, but it is only placed in the
+ -- parameter list if expansion is enabled.
+
+ if Present (Formal)
+ or else Expander_Active
+ then
+ Plist := New_List;
+
+ else
+ Plist := No_List;
+ end if;
+
+ while Present (Formal) loop
+ Append
+ (Make_Parameter_Specification (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Sloc (Formal),
+ Chars => Chars (Formal)),
+ In_Present => In_Present (Parent (Formal)),
+ Out_Present => Out_Present (Parent (Formal)),
+ Parameter_Type =>
+ New_Reference_To (Etype (Formal), Loc),
+ Expression =>
+ New_Copy_Tree (Expression (Parent (Formal)))),
+ Plist);
+
+ Next_Formal (Formal);
+ end loop;
+
+ if Nkind (Body_Spec) = N_Procedure_Specification then
+ New_Spec :=
+ Make_Procedure_Specification (Loc,
+ Defining_Unit_Name =>
+ Make_Defining_Identifier (Sloc (Body_Id),
+ Chars => Chars (Body_Id)),
+ Parameter_Specifications => Plist);
+ else
+ New_Spec :=
+ Make_Function_Specification (Loc,
+ Defining_Unit_Name =>
+ Make_Defining_Identifier (Sloc (Body_Id),
+ Chars => Chars (Body_Id)),
+ Parameter_Specifications => Plist,
+ Subtype_Mark => New_Occurrence_Of (Etype (Body_Id), Loc));
+ end if;
+
+ Decl :=
+ Make_Subprogram_Declaration (Loc,
+ Specification => New_Spec);
+ Insert_Before (N, Decl);
+ Analyze (Decl);
+ Spec_Id := Defining_Unit_Name (New_Spec);
+ Set_Has_Completion (Spec_Id);
+ Set_Convention (Spec_Id, Convention_Protected);
+ end;
+
+ elsif Present (Spec_Id) then
+ Spec_Decl := Unit_Declaration_Node (Spec_Id);
+ end if;
+
+ -- Place subprogram on scope stack, and make formals visible. If there
+ -- is a spec, the visible entity remains that of the spec.
+
+ if Present (Spec_Id) then
+ Generate_Reference (Spec_Id, Body_Id, 'b');
+ Style.Check_Identifier (Body_Id, Spec_Id);
+
+ Set_Is_Compilation_Unit (Body_Id, Is_Compilation_Unit (Spec_Id));
+ Set_Is_Child_Unit (Body_Id, Is_Child_Unit (Spec_Id));
+
+ if Is_Abstract (Spec_Id) then
+ Error_Msg_N ("an abstract subprogram cannot have a body", N);
+ return;
+ else
+ Set_Convention (Body_Id, Convention (Spec_Id));
+ Set_Has_Completion (Spec_Id);
+
+ if Is_Protected_Type (Scope (Spec_Id)) then
+ Set_Privals_Chain (Spec_Id, New_Elmt_List);
+ end if;
+
+ -- If this is a body generated for a renaming, do not check for
+ -- full conformance. The check is redundant, because the spec of
+ -- the body is a copy of the spec in the renaming declaration,
+ -- and the test can lead to spurious errors on nested defaults.
+
+ if Present (Spec_Decl)
+ and then Nkind (Original_Node (Spec_Decl)) =
+ N_Subprogram_Renaming_Declaration
+ and then not Comes_From_Source (N)
+ then
+ Conformant := True;
+ else
+ Check_Conformance
+ (Body_Id, Spec_Id,
+ Fully_Conformant, True, Conformant, Body_Id);
+ end if;
+
+ -- If the body is not fully conformant, we have to decide if we
+ -- should analyze it or not. If it has a really messed up profile
+ -- then we probably should not analyze it, since we will get too
+ -- many bogus messages.
+
+ -- Our decision is to go ahead in the non-fully conformant case
+ -- only if it is at least mode conformant with the spec. Note
+ -- that the call to Check_Fully_Conformant has issued the proper
+ -- error messages to complain about the lack of conformance.
+
+ if not Conformant
+ and then not Mode_Conformant (Body_Id, Spec_Id)
+ then
+ return;
+ end if;
+ end if;
+
+ -- Generate references from body formals to spec formals
+ -- and also set the Spec_Entity fields for all formals
+
+ if Spec_Id /= Body_Id then
+ declare
+ Fs : Entity_Id;
+ Fb : Entity_Id;
+
+ begin
+ Fs := First_Formal (Spec_Id);
+ Fb := First_Formal (Body_Id);
+ while Present (Fs) loop
+ Generate_Reference (Fs, Fb, 'b');
+ Style.Check_Identifier (Fb, Fs);
+ Set_Spec_Entity (Fb, Fs);
+ Next_Formal (Fs);
+ Next_Formal (Fb);
+ end loop;
+ end;
+ end if;
+
+ if Nkind (N) /= N_Subprogram_Body_Stub then
+ Set_Corresponding_Spec (N, Spec_Id);
+ Install_Formals (Spec_Id);
+ Last_Formal := Last_Entity (Spec_Id);
+ New_Scope (Spec_Id);
+
+ -- Make sure that the subprogram is immediately visible. For
+ -- child units that have no separate spec this is indispensable.
+ -- Otherwise it is safe albeit redundant.
+
+ Set_Is_Immediately_Visible (Spec_Id);
+ end if;
+
+ Set_Corresponding_Body (Unit_Declaration_Node (Spec_Id), Body_Id);
+ Set_Ekind (Body_Id, E_Subprogram_Body);
+ Set_Scope (Body_Id, Scope (Spec_Id));
+
+ -- Case of subprogram body with no previous spec
+
+ else
+ if Style_Check
+ and then Comes_From_Source (Body_Id)
+ and then not Suppress_Style_Checks (Body_Id)
+ and then not In_Instance
+ then
+ Style.Body_With_No_Spec (N);
+ end if;
+
+ New_Overloaded_Entity (Body_Id);
+
+ if Nkind (N) /= N_Subprogram_Body_Stub then
+ Set_Acts_As_Spec (N);
+ Generate_Definition (Body_Id);
+ Install_Formals (Body_Id);
+ New_Scope (Body_Id);
+ end if;
+ end if;
+
+ -- If this is the proper body of a stub, we must verify that the stub
+ -- conforms to the body, and to the previous spec if one was present.
+ -- we know already that the body conforms to that spec. This test is
+ -- only required for subprograms that come from source.
+
+ if Nkind (Parent (N)) = N_Subunit
+ and then Comes_From_Source (N)
+ and then not Error_Posted (Body_Id)
+ then
+ declare
+ Conformant : Boolean := False;
+ Old_Id : Entity_Id :=
+ Defining_Entity
+ (Specification (Corresponding_Stub (Parent (N))));
+
+ begin
+ if No (Spec_Id) then
+ Check_Fully_Conformant (Body_Id, Old_Id);
+
+ else
+ Check_Conformance
+ (Body_Id, Old_Id, Fully_Conformant, False, Conformant);
+
+ if not Conformant then
+
+ -- The stub was taken to be a new declaration. Indicate
+ -- that it lacks a body.
+
+ Set_Has_Completion (Old_Id, False);
+ end if;
+ end if;
+ end;
+ end if;
+
+ Set_Has_Completion (Body_Id);
+ Check_Eliminated (Body_Id);
+
+ if Nkind (N) = N_Subprogram_Body_Stub then
+ return;
+
+ elsif Present (Spec_Id)
+ and then Expander_Active
+ and then Has_Pragma_Inline (Spec_Id)
+ and then (Front_End_Inlining
+ or else
+ (No_Run_Time and then Is_Always_Inlined (Spec_Id)))
+ then
+ if Build_Body_To_Inline (N, Spec_Id, Copy_Separate_Tree (N)) then
+ null;
+ end if;
+ end if;
+
+ -- Here we have a real body, not a stub
+
+ HSS := Handled_Statement_Sequence (N);
+ Set_Actual_Subtypes (N, Current_Scope);
+ Analyze_Declarations (Declarations (N));
+ Check_Completion;
+ Analyze (HSS);
+ Process_End_Label (HSS, 't');
+ End_Scope;
+ Check_Subprogram_Order (N);
+
+ -- If we have a separate spec, then the analysis of the declarations
+ -- caused the entities in the body to be chained to the spec id, but
+ -- we want them chained to the body id. Only the formal parameters
+ -- end up chained to the spec id in this case.
+
+ if Present (Spec_Id) then
+
+ -- If a parent unit is categorized, the context of a subunit
+ -- must conform to the categorization. Conversely, if a child
+ -- unit is categorized, the parents themselves must conform.
+
+ if Nkind (Parent (N)) = N_Subunit then
+ Validate_Categorization_Dependency (N, Spec_Id);
+
+ elsif Is_Child_Unit (Spec_Id) then
+ Validate_Categorization_Dependency
+ (Unit_Declaration_Node (Spec_Id), Spec_Id);
+ end if;
+
+ if Present (Last_Formal) then
+ Set_Next_Entity
+ (Last_Entity (Body_Id), Next_Entity (Last_Formal));
+ Set_Next_Entity (Last_Formal, Empty);
+ Set_Last_Entity (Body_Id, Last_Entity (Spec_Id));
+ Set_Last_Entity (Spec_Id, Last_Formal);
+
+ else
+ Set_First_Entity (Body_Id, First_Entity (Spec_Id));
+ Set_Last_Entity (Body_Id, Last_Entity (Spec_Id));
+ Set_First_Entity (Spec_Id, Empty);
+ Set_Last_Entity (Spec_Id, Empty);
+ end if;
+ end if;
+
+ -- If function, check return statements
+
+ if Nkind (Body_Spec) = N_Function_Specification then
+ declare
+ Id : Entity_Id;
+
+ begin
+ if Present (Spec_Id) then
+ Id := Spec_Id;
+ else
+ Id := Body_Id;
+ end if;
+
+ if Return_Present (Id) then
+ Check_Returns (HSS, 'F', Missing_Ret);
+
+ if Missing_Ret then
+ Set_Has_Missing_Return (Id);
+ end if;
+
+ elsif not Is_Machine_Code_Subprogram (Id) then
+ Error_Msg_N ("missing RETURN statement in function body", N);
+ end if;
+ end;
+
+ -- If procedure with No_Return, check returns
+
+ elsif Nkind (Body_Spec) = N_Procedure_Specification
+ and then Present (Spec_Id)
+ and then No_Return (Spec_Id)
+ then
+ Check_Returns (HSS, 'P', Missing_Ret);
+ end if;
+
+ -- Don't worry about checking for variables that are never modified
+ -- if the first statement of the body is a raise statement, since
+ -- we assume this is some kind of stub. We ignore a label generated
+ -- by the exception stuff for the purpose of this test.
+
+ declare
+ Stm : Node_Id := First (Statements (HSS));
+
+ begin
+ if Nkind (Stm) = N_Label then
+ Next (Stm);
+ end if;
+
+ if Nkind (Original_Node (Stm)) = N_Raise_Statement then
+ return;
+ end if;
+ end;
+
+ -- Check for variables that are never modified
+
+ declare
+ E1, E2 : Entity_Id;
+
+ begin
+ -- If there is a separate spec, then transfer Not_Source_Assigned
+ -- flags from out parameters to the corresponding entities in the
+ -- body. The reason we do that is we want to post error flags on
+ -- the body entities, not the spec entities.
+
+ if Present (Spec_Id) then
+ E1 := First_Entity (Spec_Id);
+
+ while Present (E1) loop
+ if Ekind (E1) = E_Out_Parameter then
+ E2 := First_Entity (Body_Id);
+
+ loop
+ -- If no matching body entity, then we already had
+ -- a detected error of some kind, so just forget
+ -- about worrying about these warnings.
+
+ if No (E2) then
+ return;
+ end if;
+
+ exit when Chars (E1) = Chars (E2);
+ Next_Entity (E2);
+ end loop;
+
+ Set_Not_Source_Assigned (E2, Not_Source_Assigned (E1));
+ end if;
+
+ Next_Entity (E1);
+ end loop;
+ end if;
+
+ Check_References (Body_Id);
+ end;
+ end Analyze_Subprogram_Body;
+
+ ------------------------------------
+ -- Analyze_Subprogram_Declaration --
+ ------------------------------------
+
+ procedure Analyze_Subprogram_Declaration (N : Node_Id) is
+ Designator : constant Entity_Id := Analyze_Spec (Specification (N));
+ Scop : constant Entity_Id := Current_Scope;
+
+ -- Start of processing for Analyze_Subprogram_Declaration
+
+ begin
+ Generate_Definition (Designator);
+
+ -- Check for RCI unit subprogram declarations against in-lined
+ -- subprograms and subprograms having access parameter or limited
+ -- parameter without Read and Write (RM E.2.3(12-13)).
+
+ Validate_RCI_Subprogram_Declaration (N);
+
+ Trace_Scope
+ (N,
+ Defining_Entity (N),
+ " Analyze subprogram spec. ");
+
+ if Debug_Flag_C then
+ Write_Str ("==== Compiling subprogram spec ");
+ Write_Name (Chars (Designator));
+ Write_Str (" from ");
+ Write_Location (Sloc (N));
+ Write_Eol;
+ end if;
+
+ New_Overloaded_Entity (Designator);
+ Check_Delayed_Subprogram (Designator);
+ Set_Suppress_Elaboration_Checks
+ (Designator, Elaboration_Checks_Suppressed (Designator));
+
+ if Scop /= Standard_Standard
+ and then not Is_Child_Unit (Designator)
+ then
+ Set_Is_Pure (Designator,
+ Is_Pure (Scop) and then Is_Library_Level_Entity (Designator));
+ Set_Is_Remote_Call_Interface (
+ Designator, Is_Remote_Call_Interface (Scop));
+ Set_Is_Remote_Types (Designator, Is_Remote_Types (Scop));
+
+ else
+ -- For a compilation unit, check for library-unit pragmas.
+
+ New_Scope (Designator);
+ Set_Categorization_From_Pragmas (N);
+ Validate_Categorization_Dependency (N, Designator);
+ Pop_Scope;
+ end if;
+
+ -- For a compilation unit, set body required. This flag will only be
+ -- reset if a valid Import or Interface pragma is processed later on.
+
+ if Nkind (Parent (N)) = N_Compilation_Unit then
+ Set_Body_Required (Parent (N), True);
+ end if;
+
+ Check_Eliminated (Designator);
+ end Analyze_Subprogram_Declaration;
+
+ --------------------------
+ -- Build_Body_To_Inline --
+ --------------------------
+
+ function Build_Body_To_Inline
+ (N : Node_Id;
+ Subp : Entity_Id;
+ Orig_Body : Node_Id) return Boolean
+ is
+ Decl : constant Node_Id := Unit_Declaration_Node (Subp);
+ Original_Body : Node_Id;
+ Body_To_Analyze : Node_Id;
+ Max_Size : constant := 10;
+ Stat_Count : Integer := 0;
+
+ function Has_Excluded_Declaration (Decls : List_Id) return Boolean;
+ -- Check for declarations that make inlining not worthwhile.
+
+ function Has_Excluded_Statement (Stats : List_Id) return Boolean;
+ -- Check for statements that make inlining not worthwhile: any
+ -- tasking statement, nested at any level. Keep track of total
+ -- number of elementary statements, as a measure of acceptable size.
+
+ function Has_Pending_Instantiation return Boolean;
+ -- If some enclosing body contains instantiations that appear before
+ -- the corresponding generic body, the enclosing body has a freeze node
+ -- so that it can be elaborated after the generic itself. This might
+ -- conflict with subsequent inlinings, so that it is unsafe to try to
+ -- inline in such a case.
+
+ -------------------
+ -- Cannot_Inline --
+ -------------------
+
+ procedure Cannot_Inline (Msg : String; N : Node_Id);
+ -- If subprogram has pragma Inline_Always, it is an error if
+ -- it cannot be inlined. Otherwise, emit a warning.
+
+ procedure Cannot_Inline (Msg : String; N : Node_Id) is
+ begin
+ if Is_Always_Inlined (Subp) then
+ Error_Msg_NE (Msg (1 .. Msg'Length - 1), N, Subp);
+
+ elsif Ineffective_Inline_Warnings then
+ Error_Msg_NE (Msg, N, Subp);
+ end if;
+ end Cannot_Inline;
+
+ ------------------------------
+ -- Has_Excluded_Declaration --
+ ------------------------------
+
+ function Has_Excluded_Declaration (Decls : List_Id) return Boolean is
+ D : Node_Id;
+
+ begin
+ D := First (Decls);
+
+ while Present (D) loop
+ if Nkind (D) = N_Function_Instantiation
+ or else Nkind (D) = N_Protected_Type_Declaration
+ or else Nkind (D) = N_Package_Declaration
+ or else Nkind (D) = N_Package_Instantiation
+ or else Nkind (D) = N_Subprogram_Body
+ or else Nkind (D) = N_Procedure_Instantiation
+ or else Nkind (D) = N_Task_Type_Declaration
+ then
+ Cannot_Inline
+ ("\declaration prevents front-end inlining of&?", D);
+ return True;
+ end if;
+
+ Next (D);
+ end loop;
+
+ return False;
+
+ end Has_Excluded_Declaration;
+
+ ----------------------------
+ -- Has_Excluded_Statement --
+ ----------------------------
+
+ function Has_Excluded_Statement (Stats : List_Id) return Boolean is
+ S : Node_Id;
+ E : Node_Id;
+
+ begin
+ S := First (Stats);
+
+ while Present (S) loop
+ Stat_Count := Stat_Count + 1;
+
+ if Nkind (S) = N_Abort_Statement
+ or else Nkind (S) = N_Asynchronous_Select
+ or else Nkind (S) = N_Conditional_Entry_Call
+ or else Nkind (S) = N_Delay_Relative_Statement
+ or else Nkind (S) = N_Delay_Until_Statement
+ or else Nkind (S) = N_Selective_Accept
+ or else Nkind (S) = N_Timed_Entry_Call
+ then
+ Cannot_Inline
+ ("\statement prevents front-end inlining of&?", S);
+ return True;
+
+ elsif Nkind (S) = N_Block_Statement then
+ if Present (Declarations (S))
+ and then Has_Excluded_Declaration (Declarations (S))
+ then
+ return True;
+
+ elsif Present (Handled_Statement_Sequence (S))
+ and then
+ (Present
+ (Exception_Handlers (Handled_Statement_Sequence (S)))
+ or else
+ Has_Excluded_Statement
+ (Statements (Handled_Statement_Sequence (S))))
+ then
+ return True;
+ end if;
+
+ elsif Nkind (S) = N_Case_Statement then
+ E := First (Alternatives (S));
+
+ while Present (E) loop
+ if Has_Excluded_Statement (Statements (E)) then
+ return True;
+ end if;
+
+ Next (E);
+ end loop;
+
+ elsif Nkind (S) = N_If_Statement then
+ if Has_Excluded_Statement (Then_Statements (S)) then
+ return True;
+ end if;
+
+ if Present (Elsif_Parts (S)) then
+ E := First (Elsif_Parts (S));
+
+ while Present (E) loop
+ if Has_Excluded_Statement (Then_Statements (E)) then
+ return True;
+ end if;
+ Next (E);
+ end loop;
+ end if;
+
+ if Present (Else_Statements (S))
+ and then Has_Excluded_Statement (Else_Statements (S))
+ then
+ return True;
+ end if;
+
+ elsif Nkind (S) = N_Loop_Statement
+ and then Has_Excluded_Statement (Statements (S))
+ then
+ return True;
+ end if;
+
+ Next (S);
+ end loop;
+
+ return False;
+ end Has_Excluded_Statement;
+
+ -------------------------------
+ -- Has_Pending_Instantiation --
+ -------------------------------
+
+ function Has_Pending_Instantiation return Boolean is
+ S : Entity_Id := Current_Scope;
+
+ begin
+ while Present (S) loop
+ if Is_Compilation_Unit (S)
+ or else Is_Child_Unit (S)
+ then
+ return False;
+ elsif Ekind (S) = E_Package
+ and then Has_Forward_Instantiation (S)
+ then
+ return True;
+ end if;
+
+ S := Scope (S);
+ end loop;
+
+ return False;
+ end Has_Pending_Instantiation;
+
+ -- Start of processing for Build_Body_To_Inline
+
+ begin
+ if Nkind (Decl) = N_Subprogram_Declaration
+ and then Present (Body_To_Inline (Decl))
+ then
+ return True; -- Done already.
+
+ -- Functions that return unconstrained composite types will require
+ -- secondary stack handling, and cannot currently be inlined.
+
+ elsif Ekind (Subp) = E_Function
+ and then not Is_Scalar_Type (Etype (Subp))
+ and then not Is_Access_Type (Etype (Subp))
+ and then not Is_Constrained (Etype (Subp))
+ then
+ Cannot_Inline
+ ("unconstrained return type prevents front-end inlining of&?", N);
+ return False;
+ end if;
+
+ -- We need to capture references to the formals in order to substitute
+ -- the actuals at the point of inlining, i.e. instantiation. To treat
+ -- the formals as globals to the body to inline, we nest it within
+ -- a dummy parameterless subprogram, declared within the real one.
+
+ Original_Body := Orig_Body;
+
+ -- Within an instance, the current tree is already the result of
+ -- a generic copy, and not what we need for subsequent inlining.
+ -- We create the required body by doing an instantiating copy, to
+ -- obtain the proper partially analyzed tree.
+
+ if In_Instance then
+ if No (Generic_Parent (Specification (N))) then
+ return False;
+
+ elsif Is_Child_Unit (Scope (Current_Scope)) then
+ return False;
+
+ elsif Scope (Current_Scope) = Cunit_Entity (Main_Unit) then
+
+ -- compiling an instantiation. There is no point in generating
+ -- bodies to inline, because they will not be used.
+
+ return False;
+
+ else
+ Body_To_Analyze :=
+ Copy_Generic_Node
+ (Generic_Parent (Specification (N)), Empty,
+ Instantiating => True);
+ end if;
+ else
+ Body_To_Analyze :=
+ Copy_Generic_Node (Original_Body, Empty,
+ Instantiating => False);
+ end if;
+
+ Set_Parameter_Specifications (Specification (Original_Body), No_List);
+ Set_Defining_Unit_Name (Specification (Original_Body),
+ Make_Defining_Identifier (Sloc (N), New_Internal_Name ('S')));
+ Set_Corresponding_Spec (Original_Body, Empty);
+
+ if Ekind (Subp) = E_Function then
+ Set_Subtype_Mark (Specification (Original_Body),
+ New_Occurrence_Of (Etype (Subp), Sloc (N)));
+ end if;
+
+ if Present (Declarations (Orig_Body))
+ and then Has_Excluded_Declaration (Declarations (Orig_Body))
+ then
+ return False;
+ end if;
+
+ if Present (Handled_Statement_Sequence (N)) then
+ if
+ (Present (Exception_Handlers (Handled_Statement_Sequence (N))))
+ then
+ Cannot_Inline ("handler prevents front-end inlining of&?",
+ First (Exception_Handlers (Handled_Statement_Sequence (N))));
+ return False;
+ elsif
+ Has_Excluded_Statement
+ (Statements (Handled_Statement_Sequence (N)))
+ then
+ return False;
+ end if;
+ end if;
+
+ -- We do not inline a subprogram that is too large, unless it is
+ -- marked Inline_Always. This pragma does not suppress the other
+ -- checks on inlining (forbidden declarations, handlers, etc).
+
+ if Stat_Count > Max_Size
+ and then not Is_Always_Inlined (Subp)
+ then
+ Cannot_Inline ("body is too large for front-end inlining of&?", N);
+ return False;
+ end if;
+
+ if Has_Pending_Instantiation then
+ Cannot_Inline
+ ("cannot inline& because of forward instance within enclosing body",
+ N);
+ return False;
+ end if;
+
+ Body_To_Analyze := Copy_Generic_Node (Original_Body, Empty, False);
+
+ -- Set return type of function, which is also global and does not need
+ -- to be resolved.
+
+ if Ekind (Subp) = E_Function then
+ Set_Subtype_Mark (Specification (Body_To_Analyze),
+ New_Occurrence_Of (Etype (Subp), Sloc (N)));
+ end if;
+
+ if No (Declarations (N)) then
+ Set_Declarations (N, New_List (Body_To_Analyze));
+ else
+ Append (Body_To_Analyze, Declarations (N));
+ end if;
+
+ Expander_Mode_Save_And_Set (False);
+
+ Analyze (Body_To_Analyze);
+ New_Scope (Defining_Entity (Body_To_Analyze));
+ Save_Global_References (Original_Body);
+ End_Scope;
+ Remove (Body_To_Analyze);
+
+ Expander_Mode_Restore;
+ Set_Body_To_Inline (Decl, Original_Body);
+ Set_Is_Inlined (Subp);
+ return True;
+
+ end Build_Body_To_Inline;
+
+ -----------------------
+ -- Check_Conformance --
+ -----------------------
+
+ procedure Check_Conformance
+ (New_Id : Entity_Id;
+ Old_Id : Entity_Id;
+ Ctype : Conformance_Type;
+ Errmsg : Boolean;
+ Conforms : out Boolean;
+ Err_Loc : Node_Id := Empty;
+ Get_Inst : Boolean := False)
+ is
+ Old_Type : constant Entity_Id := Etype (Old_Id);
+ New_Type : constant Entity_Id := Etype (New_Id);
+ Old_Formal : Entity_Id;
+ New_Formal : Entity_Id;
+
+ procedure Conformance_Error (Msg : String; N : Node_Id := New_Id);
+ -- Post error message for conformance error on given node.
+ -- Two messages are output. The first points to the previous
+ -- declaration with a general "no conformance" message.
+ -- The second is the detailed reason, supplied as Msg. The
+ -- parameter N provide information for a possible & insertion
+ -- in the message, and also provides the location for posting
+ -- the message in the absence of a specified Err_Loc location.
+
+ -----------------------
+ -- Conformance_Error --
+ -----------------------
+
+ procedure Conformance_Error (Msg : String; N : Node_Id := New_Id) is
+ Enode : Node_Id;
+
+ begin
+ Conforms := False;
+
+ if Errmsg then
+ if No (Err_Loc) then
+ Enode := N;
+ else
+ Enode := Err_Loc;
+ end if;
+
+ Error_Msg_Sloc := Sloc (Old_Id);
+
+ case Ctype is
+ when Type_Conformant =>
+ Error_Msg_N
+ ("not type conformant with declaration#!", Enode);
+
+ when Mode_Conformant =>
+ Error_Msg_N
+ ("not mode conformant with declaration#!", Enode);
+
+ when Subtype_Conformant =>
+ Error_Msg_N
+ ("not subtype conformant with declaration#!", Enode);
+
+ when Fully_Conformant =>
+ Error_Msg_N
+ ("not fully conformant with declaration#!", Enode);
+ end case;
+
+ Error_Msg_NE (Msg, Enode, N);
+ end if;
+ end Conformance_Error;
+
+ -- Start of processing for Check_Conformance
+
+ begin
+ Conforms := True;
+
+ -- We need a special case for operators, since they don't
+ -- appear explicitly.
+
+ if Ctype = Type_Conformant then
+ if Ekind (New_Id) = E_Operator
+ and then Operator_Matches_Spec (New_Id, Old_Id)
+ then
+ return;
+ end if;
+ end if;
+
+ -- If both are functions/operators, check return types conform
+
+ if Old_Type /= Standard_Void_Type
+ and then New_Type /= Standard_Void_Type
+ then
+ if not Conforming_Types (Old_Type, New_Type, Ctype, Get_Inst) then
+ Conformance_Error ("return type does not match!", New_Id);
+ return;
+ end if;
+
+ -- If either is a function/operator and the other isn't, error
+
+ elsif Old_Type /= Standard_Void_Type
+ or else New_Type /= Standard_Void_Type
+ then
+ Conformance_Error ("functions can only match functions!", New_Id);
+ return;
+ end if;
+
+ -- In subtype conformant case, conventions must match (RM 6.3.1(16))
+ -- If this is a renaming as body, refine error message to indicate that
+ -- the conflict is with the original declaration. If the entity is not
+ -- frozen, the conventions don't have to match, the one of the renamed
+ -- entity is inherited.
+
+ if Ctype >= Subtype_Conformant then
+
+ if Convention (Old_Id) /= Convention (New_Id) then
+
+ if not Is_Frozen (New_Id) then
+ null;
+
+ elsif Present (Err_Loc)
+ and then Nkind (Err_Loc) = N_Subprogram_Renaming_Declaration
+ and then Present (Corresponding_Spec (Err_Loc))
+ then
+ Error_Msg_Name_1 := Chars (New_Id);
+ Error_Msg_Name_2 :=
+ Name_Ada + Convention_Id'Pos (Convention (New_Id));
+
+ Conformance_Error ("prior declaration for% has convention %!");
+
+ else
+ Conformance_Error ("calling conventions do not match!");
+ end if;
+
+ return;
+
+ elsif Is_Formal_Subprogram (Old_Id)
+ or else Is_Formal_Subprogram (New_Id)
+ then
+ Conformance_Error ("formal subprograms not allowed!");
+ return;
+ end if;
+ end if;
+
+ -- Deal with parameters
+
+ -- Note: we use the entity information, rather than going directly
+ -- to the specification in the tree. This is not only simpler, but
+ -- absolutely necessary for some cases of conformance tests between
+ -- operators, where the declaration tree simply does not exist!
+
+ Old_Formal := First_Formal (Old_Id);
+ New_Formal := First_Formal (New_Id);
+
+ while Present (Old_Formal) and then Present (New_Formal) loop
+
+ -- Types must always match. In the visible part of an instance,
+ -- usual overloading rules for dispatching operations apply, and
+ -- we check base types (not the actual subtypes).
+
+ if In_Instance_Visible_Part
+ and then Is_Dispatching_Operation (New_Id)
+ then
+ if not Conforming_Types
+ (Base_Type (Etype (Old_Formal)),
+ Base_Type (Etype (New_Formal)), Ctype, Get_Inst)
+ then
+ Conformance_Error ("type of & does not match!", New_Formal);
+ return;
+ end if;
+
+ elsif not Conforming_Types
+ (Etype (Old_Formal), Etype (New_Formal), Ctype, Get_Inst)
+ then
+ Conformance_Error ("type of & does not match!", New_Formal);
+ return;
+ end if;
+
+ -- For mode conformance, mode must match
+
+ if Ctype >= Mode_Conformant
+ and then Parameter_Mode (Old_Formal) /= Parameter_Mode (New_Formal)
+ then
+ Conformance_Error ("mode of & does not match!", New_Formal);
+ return;
+ end if;
+
+ -- Full conformance checks
+
+ if Ctype = Fully_Conformant then
+
+ -- Names must match
+
+ if Chars (Old_Formal) /= Chars (New_Formal) then
+ Conformance_Error ("name & does not match!", New_Formal);
+ return;
+
+ -- And default expressions for in parameters
+
+ elsif Parameter_Mode (Old_Formal) = E_In_Parameter then
+ declare
+ NewD : constant Boolean :=
+ Present (Default_Value (New_Formal));
+ OldD : constant Boolean :=
+ Present (Default_Value (Old_Formal));
+ begin
+ if NewD or OldD then
+
+ -- The old default value has been analyzed and expanded,
+ -- because the current full declaration will have frozen
+ -- everything before. The new default values have not
+ -- been expanded, so expand now to check conformance.
+
+ if NewD then
+ New_Scope (New_Id);
+ Analyze_Default_Expression
+ (Default_Value (New_Formal), Etype (New_Formal));
+ End_Scope;
+ end if;
+
+ if not (NewD and OldD)
+ or else not Fully_Conformant_Expressions
+ (Default_Value (Old_Formal),
+ Default_Value (New_Formal))
+ then
+ Conformance_Error
+ ("default expression for & does not match!",
+ New_Formal);
+ return;
+ end if;
+ end if;
+ end;
+ end if;
+ end if;
+
+ -- A couple of special checks for Ada 83 mode. These checks are
+ -- skipped if either entity is an operator in package Standard.
+ -- or if either old or new instance is not from the source program.
+
+ if Ada_83
+ and then Sloc (Old_Id) > Standard_Location
+ and then Sloc (New_Id) > Standard_Location
+ and then Comes_From_Source (Old_Id)
+ and then Comes_From_Source (New_Id)
+ then
+ declare
+ Old_Param : constant Node_Id := Declaration_Node (Old_Formal);
+ New_Param : constant Node_Id := Declaration_Node (New_Formal);
+
+ begin
+ -- Explicit IN must be present or absent in both cases. This
+ -- test is required only in the full conformance case.
+
+ if In_Present (Old_Param) /= In_Present (New_Param)
+ and then Ctype = Fully_Conformant
+ then
+ Conformance_Error
+ ("(Ada 83) IN must appear in both declarations",
+ New_Formal);
+ return;
+ end if;
+
+ -- Grouping (use of comma in param lists) must be the same
+ -- This is where we catch a misconformance like:
+
+ -- A,B : Integer
+ -- A : Integer; B : Integer
+
+ -- which are represented identically in the tree except
+ -- for the setting of the flags More_Ids and Prev_Ids.
+
+ if More_Ids (Old_Param) /= More_Ids (New_Param)
+ or else Prev_Ids (Old_Param) /= Prev_Ids (New_Param)
+ then
+ Conformance_Error
+ ("grouping of & does not match!", New_Formal);
+ return;
+ end if;
+ end;
+ end if;
+
+ Next_Formal (Old_Formal);
+ Next_Formal (New_Formal);
+ end loop;
+
+ if Present (Old_Formal) then
+ Conformance_Error ("too few parameters!");
+ return;
+
+ elsif Present (New_Formal) then
+ Conformance_Error ("too many parameters!", New_Formal);
+ return;
+ end if;
+
+ end Check_Conformance;
+
+ ------------------------------
+ -- Check_Delayed_Subprogram --
+ ------------------------------
+
+ procedure Check_Delayed_Subprogram (Designator : Entity_Id) is
+ F : Entity_Id;
+
+ procedure Possible_Freeze (T : Entity_Id);
+ -- T is the type of either a formal parameter or of the return type.
+ -- If T is not yet frozen and needs a delayed freeze, then the
+ -- subprogram itself must be delayed.
+
+ procedure Possible_Freeze (T : Entity_Id) is
+ begin
+ if Has_Delayed_Freeze (T)
+ and then not Is_Frozen (T)
+ then
+ Set_Has_Delayed_Freeze (Designator);
+
+ elsif Is_Access_Type (T)
+ and then Has_Delayed_Freeze (Designated_Type (T))
+ and then not Is_Frozen (Designated_Type (T))
+ then
+ Set_Has_Delayed_Freeze (Designator);
+ end if;
+ end Possible_Freeze;
+
+ -- Start of processing for Check_Delayed_Subprogram
+
+ begin
+ -- Never need to freeze abstract subprogram
+
+ if Is_Abstract (Designator) then
+ null;
+ else
+ -- Need delayed freeze if return type itself needs a delayed
+ -- freeze and is not yet frozen.
+
+ Possible_Freeze (Etype (Designator));
+ Possible_Freeze (Base_Type (Etype (Designator))); -- needed ???
+
+ -- Need delayed freeze if any of the formal types themselves need
+ -- a delayed freeze and are not yet frozen.
+
+ F := First_Formal (Designator);
+ while Present (F) loop
+ Possible_Freeze (Etype (F));
+ Possible_Freeze (Base_Type (Etype (F))); -- needed ???
+ Next_Formal (F);
+ end loop;
+ end if;
+
+ -- Mark functions that return by reference. Note that it cannot be
+ -- done for delayed_freeze subprograms because the underlying
+ -- returned type may not be known yet (for private types)
+
+ if not Has_Delayed_Freeze (Designator)
+ and then Expander_Active
+ then
+ declare
+ Typ : constant Entity_Id := Etype (Designator);
+ Utyp : constant Entity_Id := Underlying_Type (Typ);
+
+ begin
+ if Is_Return_By_Reference_Type (Typ) then
+ Set_Returns_By_Ref (Designator);
+
+ elsif Present (Utyp) and then Controlled_Type (Utyp) then
+ Set_Returns_By_Ref (Designator);
+ end if;
+ end;
+ end if;
+ end Check_Delayed_Subprogram;
+
+ ------------------------------------
+ -- Check_Discriminant_Conformance --
+ ------------------------------------
+
+ procedure Check_Discriminant_Conformance
+ (N : Node_Id;
+ Prev : Entity_Id;
+ Prev_Loc : Node_Id)
+ is
+ Old_Discr : Entity_Id := First_Discriminant (Prev);
+ New_Discr : Node_Id := First (Discriminant_Specifications (N));
+ New_Discr_Id : Entity_Id;
+ New_Discr_Type : Entity_Id;
+
+ procedure Conformance_Error (Msg : String; N : Node_Id);
+ -- Post error message for conformance error on given node.
+ -- Two messages are output. The first points to the previous
+ -- declaration with a general "no conformance" message.
+ -- The second is the detailed reason, supplied as Msg. The
+ -- parameter N provide information for a possible & insertion
+ -- in the message.
+
+ -----------------------
+ -- Conformance_Error --
+ -----------------------
+
+ procedure Conformance_Error (Msg : String; N : Node_Id) is
+ begin
+ Error_Msg_Sloc := Sloc (Prev_Loc);
+ Error_Msg_N ("not fully conformant with declaration#!", N);
+ Error_Msg_NE (Msg, N, N);
+ end Conformance_Error;
+
+ -- Start of processing for Check_Discriminant_Conformance
+
+ begin
+ while Present (Old_Discr) and then Present (New_Discr) loop
+
+ New_Discr_Id := Defining_Identifier (New_Discr);
+
+ -- The subtype mark of the discriminant on the full type
+ -- has not been analyzed so we do it here. For an access
+ -- discriminant a new type is created.
+
+ if Nkind (Discriminant_Type (New_Discr)) = N_Access_Definition then
+ New_Discr_Type :=
+ Access_Definition (N, Discriminant_Type (New_Discr));
+
+ else
+ Analyze (Discriminant_Type (New_Discr));
+ New_Discr_Type := Etype (Discriminant_Type (New_Discr));
+ end if;
+
+ if not Conforming_Types
+ (Etype (Old_Discr), New_Discr_Type, Fully_Conformant)
+ then
+ Conformance_Error ("type of & does not match!", New_Discr_Id);
+ return;
+ end if;
+
+ -- Names must match
+
+ if Chars (Old_Discr) /= Chars (Defining_Identifier (New_Discr)) then
+ Conformance_Error ("name & does not match!", New_Discr_Id);
+ return;
+ end if;
+
+ -- Default expressions must match
+
+ declare
+ NewD : constant Boolean :=
+ Present (Expression (New_Discr));
+ OldD : constant Boolean :=
+ Present (Expression (Parent (Old_Discr)));
+
+ begin
+ if NewD or OldD then
+
+ -- The old default value has been analyzed and expanded,
+ -- because the current full declaration will have frozen
+ -- everything before. The new default values have not
+ -- been expanded, so expand now to check conformance.
+
+ if NewD then
+ Analyze_Default_Expression
+ (Expression (New_Discr), New_Discr_Type);
+ end if;
+
+ if not (NewD and OldD)
+ or else not Fully_Conformant_Expressions
+ (Expression (Parent (Old_Discr)),
+ Expression (New_Discr))
+
+ then
+ Conformance_Error
+ ("default expression for & does not match!",
+ New_Discr_Id);
+ return;
+ end if;
+ end if;
+ end;
+
+ -- In Ada 83 case, grouping must match: (A,B : X) /= (A : X; B : X)
+
+ if Ada_83 then
+ declare
+ Old_Disc : constant Node_Id := Declaration_Node (Old_Discr);
+
+ begin
+ -- Grouping (use of comma in param lists) must be the same
+ -- This is where we catch a misconformance like:
+
+ -- A,B : Integer
+ -- A : Integer; B : Integer
+
+ -- which are represented identically in the tree except
+ -- for the setting of the flags More_Ids and Prev_Ids.
+
+ if More_Ids (Old_Disc) /= More_Ids (New_Discr)
+ or else Prev_Ids (Old_Disc) /= Prev_Ids (New_Discr)
+ then
+ Conformance_Error
+ ("grouping of & does not match!", New_Discr_Id);
+ return;
+ end if;
+ end;
+ end if;
+
+ Next_Discriminant (Old_Discr);
+ Next (New_Discr);
+ end loop;
+
+ if Present (Old_Discr) then
+ Conformance_Error ("too few discriminants!", Defining_Identifier (N));
+ return;
+
+ elsif Present (New_Discr) then
+ Conformance_Error
+ ("too many discriminants!", Defining_Identifier (New_Discr));
+ return;
+ end if;
+ end Check_Discriminant_Conformance;
+
+ ----------------------------
+ -- Check_Fully_Conformant --
+ ----------------------------
+
+ procedure Check_Fully_Conformant
+ (New_Id : Entity_Id;
+ Old_Id : Entity_Id;
+ Err_Loc : Node_Id := Empty)
+ is
+ Result : Boolean;
+
+ begin
+ Check_Conformance
+ (New_Id, Old_Id, Fully_Conformant, True, Result, Err_Loc);
+ end Check_Fully_Conformant;
+
+ ---------------------------
+ -- Check_Mode_Conformant --
+ ---------------------------
+
+ procedure Check_Mode_Conformant
+ (New_Id : Entity_Id;
+ Old_Id : Entity_Id;
+ Err_Loc : Node_Id := Empty;
+ Get_Inst : Boolean := False)
+ is
+ Result : Boolean;
+
+ begin
+ Check_Conformance
+ (New_Id, Old_Id, Mode_Conformant, True, Result, Err_Loc, Get_Inst);
+ end Check_Mode_Conformant;
+
+ -------------------
+ -- Check_Returns --
+ -------------------
+
+ procedure Check_Returns
+ (HSS : Node_Id;
+ Mode : Character;
+ Err : out Boolean)
+ is
+ Handler : Node_Id;
+
+ procedure Check_Statement_Sequence (L : List_Id);
+ -- Internal recursive procedure to check a list of statements for proper
+ -- termination by a return statement (or a transfer of control or a
+ -- compound statement that is itself internally properly terminated).
+
+ ------------------------------
+ -- Check_Statement_Sequence --
+ ------------------------------
+
+ procedure Check_Statement_Sequence (L : List_Id) is
+ Last_Stm : Node_Id;
+ Kind : Node_Kind;
+
+ Raise_Exception_Call : Boolean;
+ -- Set True if statement sequence terminated by Raise_Exception call
+ -- or a Reraise_Occurrence call.
+
+ begin
+ Raise_Exception_Call := False;
+
+ -- Get last real statement
+
+ Last_Stm := Last (L);
+
+ -- Don't count pragmas
+
+ while Nkind (Last_Stm) = N_Pragma
+
+ -- Don't count call to SS_Release (can happen after Raise_Exception)
+
+ or else
+ (Nkind (Last_Stm) = N_Procedure_Call_Statement
+ and then
+ Nkind (Name (Last_Stm)) = N_Identifier
+ and then
+ Is_RTE (Entity (Name (Last_Stm)), RE_SS_Release))
+
+ -- Don't count exception junk
+
+ or else
+ ((Nkind (Last_Stm) = N_Goto_Statement
+ or else Nkind (Last_Stm) = N_Label
+ or else Nkind (Last_Stm) = N_Object_Declaration)
+ and then Exception_Junk (Last_Stm))
+ loop
+ Prev (Last_Stm);
+ end loop;
+
+ -- Here we have the "real" last statement
+
+ Kind := Nkind (Last_Stm);
+
+ -- Transfer of control, OK. Note that in the No_Return procedure
+ -- case, we already diagnosed any explicit return statements, so
+ -- we can treat them as OK in this context.
+
+ if Is_Transfer (Last_Stm) then
+ return;
+
+ -- Check cases of explicit non-indirect procedure calls
+
+ elsif Kind = N_Procedure_Call_Statement
+ and then Is_Entity_Name (Name (Last_Stm))
+ then
+ -- Check call to Raise_Exception procedure which is treated
+ -- specially, as is a call to Reraise_Occurrence.
+
+ -- We suppress the warning in these cases since it is likely that
+ -- the programmer really does not expect to deal with the case
+ -- of Null_Occurrence, and thus would find a warning about a
+ -- missing return curious, and raising Program_Error does not
+ -- seem such a bad behavior if this does occur.
+
+ if Is_RTE (Entity (Name (Last_Stm)), RE_Raise_Exception)
+ or else
+ Is_RTE (Entity (Name (Last_Stm)), RE_Reraise_Occurrence)
+ then
+ Raise_Exception_Call := True;
+
+ -- For Raise_Exception call, test first argument, if it is
+ -- an attribute reference for a 'Identity call, then we know
+ -- that the call cannot possibly return.
+
+ declare
+ Arg : constant Node_Id :=
+ Original_Node (First_Actual (Last_Stm));
+
+ begin
+ if Nkind (Arg) = N_Attribute_Reference
+ and then Attribute_Name (Arg) = Name_Identity
+ then
+ return;
+ end if;
+ end;
+ end if;
+
+ -- If statement, need to look inside if there is an else and check
+ -- each constituent statement sequence for proper termination.
+
+ elsif Kind = N_If_Statement
+ and then Present (Else_Statements (Last_Stm))
+ then
+ Check_Statement_Sequence (Then_Statements (Last_Stm));
+ Check_Statement_Sequence (Else_Statements (Last_Stm));
+
+ if Present (Elsif_Parts (Last_Stm)) then
+ declare
+ Elsif_Part : Node_Id := First (Elsif_Parts (Last_Stm));
+
+ begin
+ while Present (Elsif_Part) loop
+ Check_Statement_Sequence (Then_Statements (Elsif_Part));
+ Next (Elsif_Part);
+ end loop;
+ end;
+ end if;
+
+ return;
+
+ -- Case statement, check each case for proper termination
+
+ elsif Kind = N_Case_Statement then
+ declare
+ Case_Alt : Node_Id;
+
+ begin
+ Case_Alt := First_Non_Pragma (Alternatives (Last_Stm));
+ while Present (Case_Alt) loop
+ Check_Statement_Sequence (Statements (Case_Alt));
+ Next_Non_Pragma (Case_Alt);
+ end loop;
+ end;
+
+ return;
+
+ -- Block statement, check its handled sequence of statements
+
+ elsif Kind = N_Block_Statement then
+ declare
+ Err1 : Boolean;
+
+ begin
+ Check_Returns
+ (Handled_Statement_Sequence (Last_Stm), Mode, Err1);
+
+ if Err1 then
+ Err := True;
+ end if;
+
+ return;
+ end;
+
+ -- Loop statement. If there is an iteration scheme, we can definitely
+ -- fall out of the loop. Similarly if there is an exit statement, we
+ -- can fall out. In either case we need a following return.
+
+ elsif Kind = N_Loop_Statement then
+ if Present (Iteration_Scheme (Last_Stm))
+ or else Has_Exit (Entity (Identifier (Last_Stm)))
+ then
+ null;
+
+ -- A loop with no exit statement or iteration scheme if either
+ -- an inifite loop, or it has some other exit (raise/return).
+ -- In either case, no warning is required.
+
+ else
+ return;
+ end if;
+
+ -- Timed entry call, check entry call and delay alternatives
+
+ -- Note: in expanded code, the timed entry call has been converted
+ -- to a set of expanded statements on which the check will work
+ -- correctly in any case.
+
+ elsif Kind = N_Timed_Entry_Call then
+ declare
+ ECA : constant Node_Id := Entry_Call_Alternative (Last_Stm);
+ DCA : constant Node_Id := Delay_Alternative (Last_Stm);
+
+ begin
+ -- If statement sequence of entry call alternative is missing,
+ -- then we can definitely fall through, and we post the error
+ -- message on the entry call alternative itself.
+
+ if No (Statements (ECA)) then
+ Last_Stm := ECA;
+
+ -- If statement sequence of delay alternative is missing, then
+ -- we can definitely fall through, and we post the error
+ -- message on the delay alternative itself.
+
+ -- Note: if both ECA and DCA are missing the return, then we
+ -- post only one message, should be enough to fix the bugs.
+ -- If not we will get a message next time on the DCA when the
+ -- ECA is fixed!
+
+ elsif No (Statements (DCA)) then
+ Last_Stm := DCA;
+
+ -- Else check both statement sequences
+
+ else
+ Check_Statement_Sequence (Statements (ECA));
+ Check_Statement_Sequence (Statements (DCA));
+ return;
+ end if;
+ end;
+
+ -- Conditional entry call, check entry call and else part
+
+ -- Note: in expanded code, the conditional entry call has been
+ -- converted to a set of expanded statements on which the check
+ -- will work correctly in any case.
+
+ elsif Kind = N_Conditional_Entry_Call then
+ declare
+ ECA : constant Node_Id := Entry_Call_Alternative (Last_Stm);
+
+ begin
+ -- If statement sequence of entry call alternative is missing,
+ -- then we can definitely fall through, and we post the error
+ -- message on the entry call alternative itself.
+
+ if No (Statements (ECA)) then
+ Last_Stm := ECA;
+
+ -- Else check statement sequence and else part
+
+ else
+ Check_Statement_Sequence (Statements (ECA));
+ Check_Statement_Sequence (Else_Statements (Last_Stm));
+ return;
+ end if;
+ end;
+ end if;
+
+ -- If we fall through, issue appropriate message
+
+ if Mode = 'F' then
+
+ if not Raise_Exception_Call then
+ Error_Msg_N
+ ("?RETURN statement missing following this statement!",
+ Last_Stm);
+ Error_Msg_N
+ ("\?Program_Error may be raised at run time",
+ Last_Stm);
+ end if;
+
+ -- Note: we set Err even though we have not issued a warning
+ -- because we still have a case of a missing return. This is
+ -- an extremely marginal case, probably will never be noticed
+ -- but we might as well get it right.
+
+ Err := True;
+
+ else
+ Error_Msg_N
+ ("implied return after this statement not allowed (No_Return)",
+ Last_Stm);
+ end if;
+ end Check_Statement_Sequence;
+
+ -- Start of processing for Check_Returns
+
+ begin
+ Err := False;
+ Check_Statement_Sequence (Statements (HSS));
+
+ if Present (Exception_Handlers (HSS)) then
+ Handler := First_Non_Pragma (Exception_Handlers (HSS));
+ while Present (Handler) loop
+ Check_Statement_Sequence (Statements (Handler));
+ Next_Non_Pragma (Handler);
+ end loop;
+ end if;
+ end Check_Returns;
+
+ ----------------------------
+ -- Check_Subprogram_Order --
+ ----------------------------
+
+ procedure Check_Subprogram_Order (N : Node_Id) is
+
+ function Subprogram_Name_Greater (S1, S2 : String) return Boolean;
+ -- This is used to check if S1 > S2 in the sense required by this
+ -- test, for example nameab < namec, but name2 < name10.
+
+ function Subprogram_Name_Greater (S1, S2 : String) return Boolean is
+ L1, L2 : Positive;
+ N1, N2 : Natural;
+
+ begin
+ -- Remove trailing numeric parts
+
+ L1 := S1'Last;
+ while S1 (L1) in '0' .. '9' loop
+ L1 := L1 - 1;
+ end loop;
+
+ L2 := S2'Last;
+ while S2 (L2) in '0' .. '9' loop
+ L2 := L2 - 1;
+ end loop;
+
+ -- If non-numeric parts non-equal, that's decisive
+
+ if S1 (S1'First .. L1) < S2 (S2'First .. L2) then
+ return False;
+
+ elsif S1 (S1'First .. L1) > S2 (S2'First .. L2) then
+ return True;
+
+ -- If non-numeric parts equal, compare suffixed numeric parts. Note
+ -- that a missing suffix is treated as numeric zero in this test.
+
+ else
+ N1 := 0;
+ while L1 < S1'Last loop
+ L1 := L1 + 1;
+ N1 := N1 * 10 + Character'Pos (S1 (L1)) - Character'Pos ('0');
+ end loop;
+
+ N2 := 0;
+ while L2 < S2'Last loop
+ L2 := L2 + 1;
+ N2 := N2 * 10 + Character'Pos (S2 (L2)) - Character'Pos ('0');
+ end loop;
+
+ return N1 > N2;
+ end if;
+ end Subprogram_Name_Greater;
+
+ -- Start of processing for Check_Subprogram_Order
+
+ begin
+ -- Check body in alpha order if this is option
+
+ if Style_Check_Subprogram_Order
+ and then Nkind (N) = N_Subprogram_Body
+ and then Comes_From_Source (N)
+ and then In_Extended_Main_Source_Unit (N)
+ then
+ declare
+ LSN : String_Ptr
+ renames Scope_Stack.Table
+ (Scope_Stack.Last).Last_Subprogram_Name;
+
+ Body_Id : constant Entity_Id :=
+ Defining_Entity (Specification (N));
+
+ begin
+ Get_Decoded_Name_String (Chars (Body_Id));
+
+ if LSN /= null then
+ if Subprogram_Name_Greater
+ (LSN.all, Name_Buffer (1 .. Name_Len))
+ then
+ Style.Subprogram_Not_In_Alpha_Order (Body_Id);
+ end if;
+
+ Free (LSN);
+ end if;
+
+ LSN := new String'(Name_Buffer (1 .. Name_Len));
+ end;
+ end if;
+ end Check_Subprogram_Order;
+
+ ------------------------------
+ -- Check_Subtype_Conformant --
+ ------------------------------
+
+ procedure Check_Subtype_Conformant
+ (New_Id : Entity_Id;
+ Old_Id : Entity_Id;
+ Err_Loc : Node_Id := Empty)
+ is
+ Result : Boolean;
+
+ begin
+ Check_Conformance
+ (New_Id, Old_Id, Subtype_Conformant, True, Result, Err_Loc);
+ end Check_Subtype_Conformant;
+
+ ---------------------------
+ -- Check_Type_Conformant --
+ ---------------------------
+
+ procedure Check_Type_Conformant
+ (New_Id : Entity_Id;
+ Old_Id : Entity_Id;
+ Err_Loc : Node_Id := Empty)
+ is
+ Result : Boolean;
+
+ begin
+ Check_Conformance
+ (New_Id, Old_Id, Type_Conformant, True, Result, Err_Loc);
+ end Check_Type_Conformant;
+
+ ----------------------
+ -- Conforming_Types --
+ ----------------------
+
+ function Conforming_Types
+ (T1 : Entity_Id;
+ T2 : Entity_Id;
+ Ctype : Conformance_Type;
+ Get_Inst : Boolean := False)
+ return Boolean
+ is
+ Type_1 : Entity_Id := T1;
+ Type_2 : Entity_Id := T2;
+
+ function Base_Types_Match (T1, T2 : Entity_Id) return Boolean;
+ -- If neither T1 nor T2 are generic actual types, then verify
+ -- that the base types are equal. Otherwise T1 and T2 must be
+ -- on the same subtype chain. The whole purpose of this procedure
+ -- is to prevent spurious ambiguities in an instantiation that may
+ -- arise if two distinct generic types are instantiated with the
+ -- same actual.
+
+ ----------------------
+ -- Base_Types_Match --
+ ----------------------
+
+ function Base_Types_Match (T1, T2 : Entity_Id) return Boolean is
+ begin
+ if T1 = T2 then
+ return True;
+
+ elsif Base_Type (T1) = Base_Type (T2) then
+
+ -- The following is too permissive. A more precise test must
+ -- check that the generic actual is an ancestor subtype of the
+ -- other ???.
+
+ return not Is_Generic_Actual_Type (T1)
+ or else not Is_Generic_Actual_Type (T2);
+
+ else
+ return False;
+ end if;
+ end Base_Types_Match;
+
+ begin
+ -- The context is an instance association for a formal
+ -- access-to-subprogram type; the formal parameter types
+ -- require mapping because they may denote other formal
+ -- parameters of the generic unit.
+
+ if Get_Inst then
+ Type_1 := Get_Instance_Of (T1);
+ Type_2 := Get_Instance_Of (T2);
+ end if;
+
+ -- First see if base types match
+
+ if Base_Types_Match (Type_1, Type_2) then
+ return Ctype <= Mode_Conformant
+ or else Subtypes_Statically_Match (Type_1, Type_2);
+
+ elsif Is_Incomplete_Or_Private_Type (Type_1)
+ and then Present (Full_View (Type_1))
+ and then Base_Types_Match (Full_View (Type_1), Type_2)
+ then
+ return Ctype <= Mode_Conformant
+ or else Subtypes_Statically_Match (Full_View (Type_1), Type_2);
+
+ elsif Ekind (Type_2) = E_Incomplete_Type
+ and then Present (Full_View (Type_2))
+ and then Base_Types_Match (Type_1, Full_View (Type_2))
+ then
+ return Ctype <= Mode_Conformant
+ or else Subtypes_Statically_Match (Type_1, Full_View (Type_2));
+ end if;
+
+ -- Test anonymous access type case. For this case, static subtype
+ -- matching is required for mode conformance (RM 6.3.1(15))
+
+ if Ekind (Type_1) = E_Anonymous_Access_Type
+ and then Ekind (Type_2) = E_Anonymous_Access_Type
+ then
+ declare
+ Desig_1 : Entity_Id;
+ Desig_2 : Entity_Id;
+
+ begin
+ Desig_1 := Directly_Designated_Type (Type_1);
+
+ -- An access parameter can designate an incomplete type.
+
+ if Ekind (Desig_1) = E_Incomplete_Type
+ and then Present (Full_View (Desig_1))
+ then
+ Desig_1 := Full_View (Desig_1);
+ end if;
+
+ Desig_2 := Directly_Designated_Type (Type_2);
+
+ if Ekind (Desig_2) = E_Incomplete_Type
+ and then Present (Full_View (Desig_2))
+ then
+ Desig_2 := Full_View (Desig_2);
+ end if;
+
+ -- The context is an instance association for a formal
+ -- access-to-subprogram type; formal access parameter
+ -- designated types require mapping because they may
+ -- denote other formal parameters of the generic unit.
+
+ if Get_Inst then
+ Desig_1 := Get_Instance_Of (Desig_1);
+ Desig_2 := Get_Instance_Of (Desig_2);
+ end if;
+
+ -- It is possible for a Class_Wide_Type to be introduced for
+ -- an incomplete type, in which case there is a separate class_
+ -- wide type for the full view. The types conform if their
+ -- Etypes conform, i.e. one may be the full view of the other.
+ -- This can only happen in the context of an access parameter,
+ -- other uses of an incomplete Class_Wide_Type are illegal.
+
+ if Ekind (Desig_1) = E_Class_Wide_Type
+ and then Ekind (Desig_2) = E_Class_Wide_Type
+ then
+ return
+ Conforming_Types (Etype (Desig_1), Etype (Desig_2), Ctype);
+ else
+ return Base_Type (Desig_1) = Base_Type (Desig_2)
+ and then (Ctype = Type_Conformant
+ or else
+ Subtypes_Statically_Match (Desig_1, Desig_2));
+ end if;
+ end;
+
+ -- Otherwise definitely no match
+
+ else
+ return False;
+ end if;
+
+ end Conforming_Types;
+
+ --------------------------
+ -- Create_Extra_Formals --
+ --------------------------
+
+ procedure Create_Extra_Formals (E : Entity_Id) is
+ Formal : Entity_Id;
+ Last_Formal : Entity_Id;
+ Last_Extra : Entity_Id;
+ Formal_Type : Entity_Id;
+ P_Formal : Entity_Id := Empty;
+
+ function Add_Extra_Formal (Typ : Entity_Id) return Entity_Id;
+ -- Add an extra formal, associated with the current Formal. The
+ -- extra formal is added to the list of extra formals, and also
+ -- returned as the result. These formals are always of mode IN.
+
+ function Add_Extra_Formal (Typ : Entity_Id) return Entity_Id is
+ EF : constant Entity_Id :=
+ Make_Defining_Identifier (Sloc (Formal),
+ Chars => New_External_Name (Chars (Formal), 'F'));
+
+ begin
+ -- We never generate extra formals if expansion is not active
+ -- because we don't need them unless we are generating code.
+
+ if not Expander_Active then
+ return Empty;
+ end if;
+
+ -- A little optimization. Never generate an extra formal for
+ -- the _init operand of an initialization procedure, since it
+ -- could never be used.
+
+ if Chars (Formal) = Name_uInit then
+ return Empty;
+ end if;
+
+ Set_Ekind (EF, E_In_Parameter);
+ Set_Actual_Subtype (EF, Typ);
+ Set_Etype (EF, Typ);
+ Set_Scope (EF, Scope (Formal));
+ Set_Mechanism (EF, Default_Mechanism);
+ Set_Formal_Validity (EF);
+
+ Set_Extra_Formal (Last_Extra, EF);
+ Last_Extra := EF;
+ return EF;
+ end Add_Extra_Formal;
+
+ -- Start of processing for Create_Extra_Formals
+
+ begin
+ -- If this is a derived subprogram then the subtypes of the
+ -- parent subprogram's formal parameters will be used to
+ -- to determine the need for extra formals.
+
+ if Is_Overloadable (E) and then Present (Alias (E)) then
+ P_Formal := First_Formal (Alias (E));
+ end if;
+
+ Last_Extra := Empty;
+ Formal := First_Formal (E);
+ while Present (Formal) loop
+ Last_Extra := Formal;
+ Next_Formal (Formal);
+ end loop;
+
+ -- If Extra_formals where already created, don't do it again
+ -- This situation may arise for subprogram types created as part
+ -- of dispatching calls (see Expand_Dispatch_Call)
+
+ if Present (Last_Extra) and then
+ Present (Extra_Formal (Last_Extra))
+ then
+ return;
+ end if;
+
+ Formal := First_Formal (E);
+
+ while Present (Formal) loop
+
+ -- Create extra formal for supporting the attribute 'Constrained.
+ -- The case of a private type view without discriminants also
+ -- requires the extra formal if the underlying type has defaulted
+ -- discriminants.
+
+ if Ekind (Formal) /= E_In_Parameter then
+ if Present (P_Formal) then
+ Formal_Type := Etype (P_Formal);
+ else
+ Formal_Type := Etype (Formal);
+ end if;
+
+ if not Has_Discriminants (Formal_Type)
+ and then Ekind (Formal_Type) in Private_Kind
+ and then Present (Underlying_Type (Formal_Type))
+ then
+ Formal_Type := Underlying_Type (Formal_Type);
+ end if;
+
+ if Has_Discriminants (Formal_Type)
+ and then
+ ((not Is_Constrained (Formal_Type)
+ and then not Is_Indefinite_Subtype (Formal_Type))
+ or else Present (Extra_Formal (Formal)))
+ then
+ Set_Extra_Constrained
+ (Formal, Add_Extra_Formal (Standard_Boolean));
+ end if;
+ end if;
+
+ -- Create extra formal for supporting accessibility checking
+
+ -- This is suppressed if we specifically suppress accessibility
+ -- checks for either the subprogram, or the package in which it
+ -- resides. However, we do not suppress it simply if the scope
+ -- has accessibility checks suppressed, since this could cause
+ -- trouble when clients are compiled with a different suppression
+ -- setting. The explicit checks are safe from this point of view.
+
+ if Ekind (Etype (Formal)) = E_Anonymous_Access_Type
+ and then not
+ (Suppress_Accessibility_Checks (E)
+ or else
+ Suppress_Accessibility_Checks (Scope (E)))
+ and then
+ (not Present (P_Formal)
+ or else Present (Extra_Accessibility (P_Formal)))
+ then
+ -- Temporary kludge: for now we avoid creating the extra
+ -- formal for access parameters of protected operations
+ -- because of problem with the case of internal protected
+ -- calls. ???
+
+ if Nkind (Parent (Parent (Parent (E)))) /= N_Protected_Definition
+ and then Nkind (Parent (Parent (Parent (E)))) /= N_Protected_Body
+ then
+ Set_Extra_Accessibility
+ (Formal, Add_Extra_Formal (Standard_Natural));
+ end if;
+ end if;
+
+ if Present (P_Formal) then
+ Next_Formal (P_Formal);
+ end if;
+
+ Last_Formal := Formal;
+ Next_Formal (Formal);
+ end loop;
+ end Create_Extra_Formals;
+
+ -----------------------------
+ -- Enter_Overloaded_Entity --
+ -----------------------------
+
+ procedure Enter_Overloaded_Entity (S : Entity_Id) is
+ E : Entity_Id := Current_Entity_In_Scope (S);
+ C_E : Entity_Id := Current_Entity (S);
+
+ begin
+ if Present (E) then
+ Set_Has_Homonym (E);
+ Set_Has_Homonym (S);
+ end if;
+
+ Set_Is_Immediately_Visible (S);
+ Set_Scope (S, Current_Scope);
+
+ -- Chain new entity if front of homonym in current scope, so that
+ -- homonyms are contiguous.
+
+ if Present (E)
+ and then E /= C_E
+ then
+ while Homonym (C_E) /= E loop
+ C_E := Homonym (C_E);
+ end loop;
+
+ Set_Homonym (C_E, S);
+
+ else
+ E := C_E;
+ Set_Current_Entity (S);
+ end if;
+
+ Set_Homonym (S, E);
+
+ Append_Entity (S, Current_Scope);
+ Set_Public_Status (S);
+
+ if Debug_Flag_E then
+ Write_Str ("New overloaded entity chain: ");
+ Write_Name (Chars (S));
+ E := S;
+
+ while Present (E) loop
+ Write_Str (" "); Write_Int (Int (E));
+ E := Homonym (E);
+ end loop;
+
+ Write_Eol;
+ end if;
+
+ -- Generate warning for hiding
+
+ if Warn_On_Hiding
+ and then Comes_From_Source (S)
+ and then In_Extended_Main_Source_Unit (S)
+ then
+ E := S;
+ loop
+ E := Homonym (E);
+ exit when No (E);
+
+ -- Warn unless genuine overloading
+
+ if (not Is_Overloadable (E))
+ or else Subtype_Conformant (E, S)
+ then
+ Error_Msg_Sloc := Sloc (E);
+ Error_Msg_N ("declaration of & hides one#?", S);
+ end if;
+ end loop;
+ end if;
+ end Enter_Overloaded_Entity;
+
+ -----------------------------
+ -- Find_Corresponding_Spec --
+ -----------------------------
+
+ function Find_Corresponding_Spec (N : Node_Id) return Entity_Id is
+ Spec : constant Node_Id := Specification (N);
+ Designator : constant Entity_Id := Defining_Entity (Spec);
+
+ E : Entity_Id;
+
+ begin
+ E := Current_Entity (Designator);
+
+ while Present (E) loop
+
+ -- We are looking for a matching spec. It must have the same scope,
+ -- and the same name, and either be type conformant, or be the case
+ -- of a library procedure spec and its body (which belong to one
+ -- another regardless of whether they are type conformant or not).
+
+ if Scope (E) = Current_Scope then
+ if (Current_Scope = Standard_Standard
+ or else (Ekind (E) = Ekind (Designator)
+ and then
+ Type_Conformant (E, Designator)))
+ then
+ -- Within an instantiation, we know that spec and body are
+ -- subtype conformant, because they were subtype conformant
+ -- in the generic. We choose the subtype-conformant entity
+ -- here as well, to resolve spurious ambiguities in the
+ -- instance that were not present in the generic (i.e. when
+ -- two different types are given the same actual). If we are
+ -- looking for a spec to match a body, full conformance is
+ -- expected.
+
+ if In_Instance then
+ Set_Convention (Designator, Convention (E));
+
+ if Nkind (N) = N_Subprogram_Body
+ and then Present (Homonym (E))
+ and then not Fully_Conformant (E, Designator)
+ then
+ goto Next_Entity;
+
+ elsif not Subtype_Conformant (E, Designator) then
+ goto Next_Entity;
+ end if;
+ end if;
+
+ if not Has_Completion (E) then
+
+ if Nkind (N) /= N_Subprogram_Body_Stub then
+ Set_Corresponding_Spec (N, E);
+ end if;
+
+ Set_Has_Completion (E);
+ return E;
+
+ elsif Nkind (Parent (N)) = N_Subunit then
+
+ -- If this is the proper body of a subunit, the completion
+ -- flag is set when analyzing the stub.
+
+ return E;
+
+ -- If body already exists, this is an error unless the
+ -- previous declaration is the implicit declaration of
+ -- a derived subprogram, or this is a spurious overloading
+ -- in an instance.
+
+ elsif No (Alias (E))
+ and then not Is_Intrinsic_Subprogram (E)
+ and then not In_Instance
+ then
+ Error_Msg_Sloc := Sloc (E);
+ Error_Msg_NE ("duplicate body for & declared#", N, E);
+ end if;
+
+ elsif Is_Child_Unit (E)
+ and then
+ Nkind (Unit_Declaration_Node (Designator)) = N_Subprogram_Body
+ and then
+ Nkind (Parent (Unit_Declaration_Node (Designator)))
+ = N_Compilation_Unit
+ then
+
+ -- Child units cannot be overloaded, so a conformance mismatch
+ -- between body and a previous spec is an error.
+
+ Error_Msg_N
+ ("body of child unit does not match previous declaration", N);
+ end if;
+ end if;
+
+ <<Next_Entity>>
+ E := Homonym (E);
+ end loop;
+
+ -- On exit, we know that no previous declaration of subprogram exists
+
+ return Empty;
+ end Find_Corresponding_Spec;
+
+ ----------------------
+ -- Fully_Conformant --
+ ----------------------
+
+ function Fully_Conformant (New_Id, Old_Id : Entity_Id) return Boolean is
+ Result : Boolean;
+
+ begin
+ Check_Conformance (New_Id, Old_Id, Fully_Conformant, False, Result);
+ return Result;
+ end Fully_Conformant;
+
+ ----------------------------------
+ -- Fully_Conformant_Expressions --
+ ----------------------------------
+
+ function Fully_Conformant_Expressions
+ (Given_E1 : Node_Id;
+ Given_E2 : Node_Id)
+ return Boolean
+ is
+ E1 : constant Node_Id := Original_Node (Given_E1);
+ E2 : constant Node_Id := Original_Node (Given_E2);
+ -- We always test conformance on original nodes, since it is possible
+ -- for analysis and/or expansion to make things look as though they
+ -- conform when they do not, e.g. by converting 1+2 into 3.
+
+ function FCE (Given_E1, Given_E2 : Node_Id) return Boolean
+ renames Fully_Conformant_Expressions;
+
+ function FCL (L1, L2 : List_Id) return Boolean;
+ -- Compare elements of two lists for conformance. Elements have to
+ -- be conformant, and actuals inserted as default parameters do not
+ -- match explicit actuals with the same value.
+
+ function FCO (Op_Node, Call_Node : Node_Id) return Boolean;
+ -- Compare an operator node with a function call.
+
+ ---------
+ -- FCL --
+ ---------
+
+ function FCL (L1, L2 : List_Id) return Boolean is
+ N1, N2 : Node_Id;
+
+ begin
+ if L1 = No_List then
+ N1 := Empty;
+ else
+ N1 := First (L1);
+ end if;
+
+ if L2 = No_List then
+ N2 := Empty;
+ else
+ N2 := First (L2);
+ end if;
+
+ -- Compare two lists, skipping rewrite insertions (we want to
+ -- compare the original trees, not the expanded versions!)
+
+ loop
+ if Is_Rewrite_Insertion (N1) then
+ Next (N1);
+ elsif Is_Rewrite_Insertion (N2) then
+ Next (N2);
+ elsif No (N1) then
+ return No (N2);
+ elsif No (N2) then
+ return False;
+ elsif not FCE (N1, N2) then
+ return False;
+ else
+ Next (N1);
+ Next (N2);
+ end if;
+ end loop;
+ end FCL;
+
+ ---------
+ -- FCO --
+ ---------
+
+ function FCO (Op_Node, Call_Node : Node_Id) return Boolean is
+ Actuals : constant List_Id := Parameter_Associations (Call_Node);
+ Act : Node_Id;
+
+ begin
+ if No (Actuals)
+ or else Entity (Op_Node) /= Entity (Name (Call_Node))
+ then
+ return False;
+
+ else
+ Act := First (Actuals);
+
+ if Nkind (Op_Node) in N_Binary_Op then
+
+ if not FCE (Left_Opnd (Op_Node), Act) then
+ return False;
+ end if;
+
+ Next (Act);
+ end if;
+
+ return Present (Act)
+ and then FCE (Right_Opnd (Op_Node), Act)
+ and then No (Next (Act));
+ end if;
+ end FCO;
+
+ -- Start of processing for Fully_Conformant_Expressions
+
+ begin
+ -- Non-conformant if paren count does not match. Note: if some idiot
+ -- complains that we don't do this right for more than 3 levels of
+ -- parentheses, they will be treated with the respect they deserve :-)
+
+ if Paren_Count (E1) /= Paren_Count (E2) then
+ return False;
+
+ -- If same entities are referenced, then they are conformant
+ -- even if they have different forms (RM 8.3.1(19-20)).
+
+ elsif Is_Entity_Name (E1) and then Is_Entity_Name (E2) then
+ if Present (Entity (E1)) then
+ return Entity (E1) = Entity (E2)
+ or else (Chars (Entity (E1)) = Chars (Entity (E2))
+ and then Ekind (Entity (E1)) = E_Discriminant
+ and then Ekind (Entity (E2)) = E_In_Parameter);
+
+ elsif Nkind (E1) = N_Expanded_Name
+ and then Nkind (E2) = N_Expanded_Name
+ and then Nkind (Selector_Name (E1)) = N_Character_Literal
+ and then Nkind (Selector_Name (E2)) = N_Character_Literal
+ then
+ return Chars (Selector_Name (E1)) = Chars (Selector_Name (E2));
+
+ else
+ -- Identifiers in component associations don't always have
+ -- entities, but their names must conform.
+
+ return Nkind (E1) = N_Identifier
+ and then Nkind (E2) = N_Identifier
+ and then Chars (E1) = Chars (E2);
+ end if;
+
+ elsif Nkind (E1) = N_Character_Literal
+ and then Nkind (E2) = N_Expanded_Name
+ then
+ return Nkind (Selector_Name (E2)) = N_Character_Literal
+ and then Chars (E1) = Chars (Selector_Name (E2));
+
+ elsif Nkind (E2) = N_Character_Literal
+ and then Nkind (E1) = N_Expanded_Name
+ then
+ return Nkind (Selector_Name (E1)) = N_Character_Literal
+ and then Chars (E2) = Chars (Selector_Name (E1));
+
+ elsif Nkind (E1) in N_Op
+ and then Nkind (E2) = N_Function_Call
+ then
+ return FCO (E1, E2);
+
+ elsif Nkind (E2) in N_Op
+ and then Nkind (E1) = N_Function_Call
+ then
+ return FCO (E2, E1);
+
+ -- Otherwise we must have the same syntactic entity
+
+ elsif Nkind (E1) /= Nkind (E2) then
+ return False;
+
+ -- At this point, we specialize by node type
+
+ else
+ case Nkind (E1) is
+
+ when N_Aggregate =>
+ return
+ FCL (Expressions (E1), Expressions (E2))
+ and then FCL (Component_Associations (E1),
+ Component_Associations (E2));
+
+ when N_Allocator =>
+ if Nkind (Expression (E1)) = N_Qualified_Expression
+ or else
+ Nkind (Expression (E2)) = N_Qualified_Expression
+ then
+ return FCE (Expression (E1), Expression (E2));
+
+ -- Check that the subtype marks and any constraints
+ -- are conformant
+
+ else
+ declare
+ Indic1 : constant Node_Id := Expression (E1);
+ Indic2 : constant Node_Id := Expression (E2);
+ Elt1 : Node_Id;
+ Elt2 : Node_Id;
+
+ begin
+ if Nkind (Indic1) /= N_Subtype_Indication then
+ return
+ Nkind (Indic2) /= N_Subtype_Indication
+ and then Entity (Indic1) = Entity (Indic2);
+
+ elsif Nkind (Indic2) /= N_Subtype_Indication then
+ return
+ Nkind (Indic1) /= N_Subtype_Indication
+ and then Entity (Indic1) = Entity (Indic2);
+
+ else
+ if Entity (Subtype_Mark (Indic1)) /=
+ Entity (Subtype_Mark (Indic2))
+ then
+ return False;
+ end if;
+
+ Elt1 := First (Constraints (Constraint (Indic1)));
+ Elt2 := First (Constraints (Constraint (Indic2)));
+
+ while Present (Elt1) and then Present (Elt2) loop
+ if not FCE (Elt1, Elt2) then
+ return False;
+ end if;
+
+ Next (Elt1);
+ Next (Elt2);
+ end loop;
+
+ return True;
+ end if;
+ end;
+ end if;
+
+ when N_Attribute_Reference =>
+ return
+ Attribute_Name (E1) = Attribute_Name (E2)
+ and then FCL (Expressions (E1), Expressions (E2));
+
+ when N_Binary_Op =>
+ return
+ Entity (E1) = Entity (E2)
+ and then FCE (Left_Opnd (E1), Left_Opnd (E2))
+ and then FCE (Right_Opnd (E1), Right_Opnd (E2));
+
+ when N_And_Then | N_Or_Else | N_In | N_Not_In =>
+ return
+ FCE (Left_Opnd (E1), Left_Opnd (E2))
+ and then
+ FCE (Right_Opnd (E1), Right_Opnd (E2));
+
+ when N_Character_Literal =>
+ return
+ Char_Literal_Value (E1) = Char_Literal_Value (E2);
+
+ when N_Component_Association =>
+ return
+ FCL (Choices (E1), Choices (E2))
+ and then FCE (Expression (E1), Expression (E2));
+
+ when N_Conditional_Expression =>
+ return
+ FCL (Expressions (E1), Expressions (E2));
+
+ when N_Explicit_Dereference =>
+ return
+ FCE (Prefix (E1), Prefix (E2));
+
+ when N_Extension_Aggregate =>
+ return
+ FCL (Expressions (E1), Expressions (E2))
+ and then Null_Record_Present (E1) =
+ Null_Record_Present (E2)
+ and then FCL (Component_Associations (E1),
+ Component_Associations (E2));
+
+ when N_Function_Call =>
+ return
+ FCE (Name (E1), Name (E2))
+ and then FCL (Parameter_Associations (E1),
+ Parameter_Associations (E2));
+
+ when N_Indexed_Component =>
+ return
+ FCE (Prefix (E1), Prefix (E2))
+ and then FCL (Expressions (E1), Expressions (E2));
+
+ when N_Integer_Literal =>
+ return (Intval (E1) = Intval (E2));
+
+ when N_Null =>
+ return True;
+
+ when N_Operator_Symbol =>
+ return
+ Chars (E1) = Chars (E2);
+
+ when N_Others_Choice =>
+ return True;
+
+ when N_Parameter_Association =>
+ return
+
+ Chars (Selector_Name (E1)) = Chars (Selector_Name (E2))
+ and then FCE (Explicit_Actual_Parameter (E1),
+ Explicit_Actual_Parameter (E2));
+
+ when N_Qualified_Expression =>
+ return
+ FCE (Subtype_Mark (E1), Subtype_Mark (E2))
+ and then FCE (Expression (E1), Expression (E2));
+
+ when N_Range =>
+ return
+ FCE (Low_Bound (E1), Low_Bound (E2))
+ and then FCE (High_Bound (E1), High_Bound (E2));
+
+ when N_Real_Literal =>
+ return (Realval (E1) = Realval (E2));
+
+ when N_Selected_Component =>
+ return
+ FCE (Prefix (E1), Prefix (E2))
+ and then FCE (Selector_Name (E1), Selector_Name (E2));
+
+ when N_Slice =>
+ return
+ FCE (Prefix (E1), Prefix (E2))
+ and then FCE (Discrete_Range (E1), Discrete_Range (E2));
+
+ when N_String_Literal =>
+ declare
+ S1 : constant String_Id := Strval (E1);
+ S2 : constant String_Id := Strval (E2);
+ L1 : constant Nat := String_Length (S1);
+ L2 : constant Nat := String_Length (S2);
+
+ begin
+ if L1 /= L2 then
+ return False;
+
+ else
+ for J in 1 .. L1 loop
+ if Get_String_Char (S1, J) /=
+ Get_String_Char (S2, J)
+ then
+ return False;
+ end if;
+ end loop;
+
+ return True;
+ end if;
+ end;
+
+ when N_Type_Conversion =>
+ return
+ FCE (Subtype_Mark (E1), Subtype_Mark (E2))
+ and then FCE (Expression (E1), Expression (E2));
+
+ when N_Unary_Op =>
+ return
+ Entity (E1) = Entity (E2)
+ and then FCE (Right_Opnd (E1), Right_Opnd (E2));
+
+ when N_Unchecked_Type_Conversion =>
+ return
+ FCE (Subtype_Mark (E1), Subtype_Mark (E2))
+ and then FCE (Expression (E1), Expression (E2));
+
+ -- All other node types cannot appear in this context. Strictly
+ -- we should raise a fatal internal error. Instead we just ignore
+ -- the nodes. This means that if anyone makes a mistake in the
+ -- expander and mucks an expression tree irretrievably, the
+ -- result will be a failure to detect a (probably very obscure)
+ -- case of non-conformance, which is better than bombing on some
+ -- case where two expressions do in fact conform.
+
+ when others =>
+ return True;
+
+ end case;
+ end if;
+ end Fully_Conformant_Expressions;
+
+ --------------------
+ -- Install_Entity --
+ --------------------
+
+ procedure Install_Entity (E : Entity_Id) is
+ Prev : constant Entity_Id := Current_Entity (E);
+
+ begin
+ Set_Is_Immediately_Visible (E);
+ Set_Current_Entity (E);
+ Set_Homonym (E, Prev);
+ end Install_Entity;
+
+ ---------------------
+ -- Install_Formals --
+ ---------------------
+
+ procedure Install_Formals (Id : Entity_Id) is
+ F : Entity_Id;
+
+ begin
+ F := First_Formal (Id);
+
+ while Present (F) loop
+ Install_Entity (F);
+ Next_Formal (F);
+ end loop;
+ end Install_Formals;
+
+ ---------------------------------
+ -- Is_Non_Overriding_Operation --
+ ---------------------------------
+
+ function Is_Non_Overriding_Operation
+ (Prev_E : Entity_Id;
+ New_E : Entity_Id)
+ return Boolean
+ is
+ Formal : Entity_Id;
+ F_Typ : Entity_Id;
+ G_Typ : Entity_Id := Empty;
+
+ function Get_Generic_Parent_Type (F_Typ : Entity_Id) return Entity_Id;
+ -- If F_Type is a derived type associated with a generic actual
+ -- subtype, then return its Generic_Parent_Type attribute, else
+ -- return Empty.
+
+ function Types_Correspond
+ (P_Type : Entity_Id;
+ N_Type : Entity_Id)
+ return Boolean;
+ -- Returns true if and only if the types (or designated types
+ -- in the case of anonymous access types) are the same or N_Type
+ -- is derived directly or indirectly from P_Type.
+
+ -----------------------------
+ -- Get_Generic_Parent_Type --
+ -----------------------------
+
+ function Get_Generic_Parent_Type (F_Typ : Entity_Id) return Entity_Id is
+ G_Typ : Entity_Id;
+ Indic : Node_Id;
+
+ begin
+ if Is_Derived_Type (F_Typ)
+ and then Nkind (Parent (F_Typ)) = N_Full_Type_Declaration
+ then
+ -- The tree must be traversed to determine the parent
+ -- subtype in the generic unit, which unfortunately isn't
+ -- always available via semantic attributes. ???
+ -- (Note: The use of Original_Node is needed for cases
+ -- where a full derived type has been rewritten.)
+
+ Indic := Subtype_Indication
+ (Type_Definition (Original_Node (Parent (F_Typ))));
+
+ if Nkind (Indic) = N_Subtype_Indication then
+ G_Typ := Entity (Subtype_Mark (Indic));
+ else
+ G_Typ := Entity (Indic);
+ end if;
+
+ if Nkind (Parent (G_Typ)) = N_Subtype_Declaration
+ and then Present (Generic_Parent_Type (Parent (G_Typ)))
+ then
+ return Generic_Parent_Type (Parent (G_Typ));
+ end if;
+ end if;
+
+ return Empty;
+ end Get_Generic_Parent_Type;
+
+ ----------------------
+ -- Types_Correspond --
+ ----------------------
+
+ function Types_Correspond
+ (P_Type : Entity_Id;
+ N_Type : Entity_Id)
+ return Boolean
+ is
+ Prev_Type : Entity_Id := Base_Type (P_Type);
+ New_Type : Entity_Id := Base_Type (N_Type);
+
+ begin
+ if Ekind (Prev_Type) = E_Anonymous_Access_Type then
+ Prev_Type := Designated_Type (Prev_Type);
+ end if;
+
+ if Ekind (New_Type) = E_Anonymous_Access_Type then
+ New_Type := Designated_Type (New_Type);
+ end if;
+
+ if Prev_Type = New_Type then
+ return True;
+
+ elsif not Is_Class_Wide_Type (New_Type) then
+ while Etype (New_Type) /= New_Type loop
+ New_Type := Etype (New_Type);
+ if New_Type = Prev_Type then
+ return True;
+ end if;
+ end loop;
+ end if;
+ return False;
+ end Types_Correspond;
+
+ -- Start of processing for Is_Non_Overriding_Operation
+
+ begin
+ -- In the case where both operations are implicit derived
+ -- subprograms then neither overrides the other. This can
+ -- only occur in certain obscure cases (e.g., derivation
+ -- from homographs created in a generic instantiation).
+
+ if Present (Alias (Prev_E)) and then Present (Alias (New_E)) then
+ return True;
+
+ elsif Ekind (Current_Scope) = E_Package
+ and then Is_Generic_Instance (Current_Scope)
+ and then In_Private_Part (Current_Scope)
+ and then Comes_From_Source (New_E)
+ then
+ -- We examine the formals and result subtype of the inherited
+ -- operation, to determine whether their type is derived from
+ -- (the instance of) a generic type.
+
+ Formal := First_Formal (Prev_E);
+
+ while Present (Formal) loop
+ F_Typ := Base_Type (Etype (Formal));
+
+ if Ekind (F_Typ) = E_Anonymous_Access_Type then
+ F_Typ := Designated_Type (F_Typ);
+ end if;
+
+ G_Typ := Get_Generic_Parent_Type (F_Typ);
+
+ Next_Formal (Formal);
+ end loop;
+
+ if not Present (G_Typ) and then Ekind (Prev_E) = E_Function then
+ G_Typ := Get_Generic_Parent_Type (Base_Type (Etype (Prev_E)));
+ end if;
+
+ if No (G_Typ) then
+ return False;
+ end if;
+
+ -- If the generic type is a private type, then the original
+ -- operation was not overriding in the generic, because there was
+ -- no primitive operation to override.
+
+ if Nkind (Parent (G_Typ)) = N_Formal_Type_Declaration
+ and then Nkind (Formal_Type_Definition (Parent (G_Typ))) =
+ N_Formal_Private_Type_Definition
+ then
+ return True;
+
+ -- The generic parent type is the ancestor of a formal derived
+ -- type declaration. We need to check whether it has a primitive
+ -- operation that should be overridden by New_E in the generic.
+
+ else
+ declare
+ P_Formal : Entity_Id;
+ N_Formal : Entity_Id;
+ P_Typ : Entity_Id;
+ N_Typ : Entity_Id;
+ P_Prim : Entity_Id;
+ Prim_Elt : Elmt_Id := First_Elmt (Primitive_Operations (G_Typ));
+
+ begin
+ while Present (Prim_Elt) loop
+ P_Prim := Node (Prim_Elt);
+ if Chars (P_Prim) = Chars (New_E)
+ and then Ekind (P_Prim) = Ekind (New_E)
+ then
+ P_Formal := First_Formal (P_Prim);
+ N_Formal := First_Formal (New_E);
+ while Present (P_Formal) and then Present (N_Formal) loop
+ P_Typ := Etype (P_Formal);
+ N_Typ := Etype (N_Formal);
+
+ if not Types_Correspond (P_Typ, N_Typ) then
+ exit;
+ end if;
+
+ Next_Entity (P_Formal);
+ Next_Entity (N_Formal);
+ end loop;
+
+ -- Found a matching primitive operation belonging to
+ -- the formal ancestor type, so the new subprogram
+ -- is overriding.
+
+ if not Present (P_Formal)
+ and then not Present (N_Formal)
+ and then (Ekind (New_E) /= E_Function
+ or else
+ Types_Correspond
+ (Etype (P_Prim), Etype (New_E)))
+ then
+ return False;
+ end if;
+ end if;
+
+ Next_Elmt (Prim_Elt);
+ end loop;
+
+ -- If no match found, then the new subprogram does
+ -- not override in the generic (nor in the instance).
+
+ return True;
+ end;
+ end if;
+ else
+ return False;
+ end if;
+ end Is_Non_Overriding_Operation;
+
+ ------------------------------
+ -- Make_Inequality_Operator --
+ ------------------------------
+
+ -- S is the defining identifier of an equality operator. We build a
+ -- subprogram declaration with the right signature. This operation is
+ -- intrinsic, because it is always expanded as the negation of the
+ -- call to the equality function.
+
+ procedure Make_Inequality_Operator (S : Entity_Id) is
+ Loc : constant Source_Ptr := Sloc (S);
+ Decl : Node_Id;
+ Formals : List_Id;
+ Op_Name : Entity_Id;
+
+ A : Entity_Id;
+ B : Entity_Id;
+
+ begin
+ -- Check that equality was properly defined.
+
+ if No (Next_Formal (First_Formal (S))) then
+ return;
+ end if;
+
+ A := Make_Defining_Identifier (Loc, Chars (First_Formal (S)));
+ B := Make_Defining_Identifier (Loc,
+ Chars (Next_Formal (First_Formal (S))));
+
+ Op_Name := Make_Defining_Operator_Symbol (Loc, Name_Op_Ne);
+
+ Formals := New_List (
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier => A,
+ Parameter_Type =>
+ New_Reference_To (Etype (First_Formal (S)), Loc)),
+
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier => B,
+ Parameter_Type =>
+ New_Reference_To (Etype (Next_Formal (First_Formal (S))), Loc)));
+
+ Decl :=
+ Make_Subprogram_Declaration (Loc,
+ Specification =>
+ Make_Function_Specification (Loc,
+ Defining_Unit_Name => Op_Name,
+ Parameter_Specifications => Formals,
+ Subtype_Mark => New_Reference_To (Standard_Boolean, Loc)));
+
+ -- Insert inequality right after equality if it is explicit or after
+ -- the derived type when implicit. These entities are created only
+ -- for visibility purposes, and eventually replaced in the course of
+ -- expansion, so they do not need to be attached to the tree and seen
+ -- by the back-end. Keeping them internal also avoids spurious freezing
+ -- problems. The parent field is set simply to make analysis safe.
+
+ if No (Alias (S)) then
+ Set_Parent (Decl, Parent (Unit_Declaration_Node (S)));
+ else
+ Set_Parent (Decl, Parent (Parent (Etype (First_Formal (S)))));
+ end if;
+
+ Mark_Rewrite_Insertion (Decl);
+ Set_Is_Intrinsic_Subprogram (Op_Name);
+ Analyze (Decl);
+ Set_Has_Completion (Op_Name);
+ Set_Corresponding_Equality (Op_Name, S);
+ Set_Is_Abstract (Op_Name, Is_Abstract (S));
+
+ end Make_Inequality_Operator;
+
+ ----------------------
+ -- May_Need_Actuals --
+ ----------------------
+
+ procedure May_Need_Actuals (Fun : Entity_Id) is
+ F : Entity_Id;
+ B : Boolean;
+
+ begin
+ F := First_Formal (Fun);
+ B := True;
+
+ while Present (F) loop
+ if No (Default_Value (F)) then
+ B := False;
+ exit;
+ end if;
+
+ Next_Formal (F);
+ end loop;
+
+ Set_Needs_No_Actuals (Fun, B);
+ end May_Need_Actuals;
+
+ ---------------------
+ -- Mode_Conformant --
+ ---------------------
+
+ function Mode_Conformant (New_Id, Old_Id : Entity_Id) return Boolean is
+ Result : Boolean;
+
+ begin
+ Check_Conformance (New_Id, Old_Id, Mode_Conformant, False, Result);
+ return Result;
+ end Mode_Conformant;
+
+ ---------------------------
+ -- New_Overloaded_Entity --
+ ---------------------------
+
+ procedure New_Overloaded_Entity
+ (S : Entity_Id;
+ Derived_Type : Entity_Id := Empty)
+ is
+ E : Entity_Id := Current_Entity_In_Scope (S);
+ Prev_Vis : Entity_Id := Empty;
+
+ function Is_Private_Declaration (E : Entity_Id) return Boolean;
+ -- Check that E is declared in the private part of the current package,
+ -- or in the package body, where it may hide a previous declaration.
+ -- We can' use In_Private_Part by itself because this flag is also
+ -- set when freezing entities, so we must examine the place of the
+ -- declaration in the tree, and recognize wrapper packages as well.
+
+ procedure Maybe_Primitive_Operation (Overriding : Boolean := False);
+ -- If the subprogram being analyzed is a primitive operation of
+ -- the type of one of its formals, set the corresponding flag.
+
+ ----------------------------
+ -- Is_Private_Declaration --
+ ----------------------------
+
+ function Is_Private_Declaration (E : Entity_Id) return Boolean is
+ Priv_Decls : List_Id;
+ Decl : constant Node_Id := Unit_Declaration_Node (E);
+
+ begin
+ if Is_Package (Current_Scope)
+ and then In_Private_Part (Current_Scope)
+ then
+ Priv_Decls :=
+ Private_Declarations (
+ Specification (Unit_Declaration_Node (Current_Scope)));
+
+ return In_Package_Body (Current_Scope)
+ or else List_Containing (Decl) = Priv_Decls
+ or else (Nkind (Parent (Decl)) = N_Package_Specification
+ and then not Is_Compilation_Unit (
+ Defining_Entity (Parent (Decl)))
+ and then List_Containing (Parent (Parent (Decl)))
+ = Priv_Decls);
+ else
+ return False;
+ end if;
+ end Is_Private_Declaration;
+
+ -------------------------------
+ -- Maybe_Primitive_Operation --
+ -------------------------------
+
+ procedure Maybe_Primitive_Operation (Overriding : Boolean := False) is
+ Formal : Entity_Id;
+ F_Typ : Entity_Id;
+
+ function Visible_Part_Type (T : Entity_Id) return Boolean;
+ -- Returns true if T is declared in the visible part of
+ -- the current package scope; otherwise returns false.
+ -- Assumes that T is declared in a package.
+
+ procedure Check_Private_Overriding (T : Entity_Id);
+ -- Checks that if a primitive abstract subprogram of a visible
+ -- abstract type is declared in a private part, then it must
+ -- override an abstract subprogram declared in the visible part.
+ -- Also checks that if a primitive function with a controlling
+ -- result is declared in a private part, then it must override
+ -- a function declared in the visible part.
+
+ ------------------------------
+ -- Check_Private_Overriding --
+ ------------------------------
+
+ procedure Check_Private_Overriding (T : Entity_Id) is
+ begin
+ if Ekind (Current_Scope) = E_Package
+ and then In_Private_Part (Current_Scope)
+ and then Visible_Part_Type (T)
+ and then not In_Instance
+ then
+ if Is_Abstract (T)
+ and then Is_Abstract (S)
+ and then (not Overriding or else not Is_Abstract (E))
+ then
+ Error_Msg_N ("abstract subprograms must be visible "
+ & "('R'M 3.9.3(10))!", S);
+
+ elsif Ekind (S) = E_Function
+ and then Is_Tagged_Type (T)
+ and then T = Base_Type (Etype (S))
+ and then not Overriding
+ then
+ Error_Msg_N
+ ("private function with tagged result must"
+ & " override visible-part function", S);
+ Error_Msg_N
+ ("\move subprogram to the visible part"
+ & " ('R'M 3.9.3(10))", S);
+ end if;
+ end if;
+ end Check_Private_Overriding;
+
+ -----------------------
+ -- Visible_Part_Type --
+ -----------------------
+
+ function Visible_Part_Type (T : Entity_Id) return Boolean is
+ P : Node_Id := Unit_Declaration_Node (Scope (T));
+ N : Node_Id := First (Visible_Declarations (Specification (P)));
+
+ begin
+ -- If the entity is a private type, then it must be
+ -- declared in a visible part.
+
+ if Ekind (T) in Private_Kind then
+ return True;
+ end if;
+
+ -- Otherwise, we traverse the visible part looking for its
+ -- corresponding declaration. We cannot use the declaration
+ -- node directly because in the private part the entity of a
+ -- private type is the one in the full view, which does not
+ -- indicate that it is the completion of something visible.
+
+ while Present (N) loop
+ if Nkind (N) = N_Full_Type_Declaration
+ and then Present (Defining_Identifier (N))
+ and then T = Defining_Identifier (N)
+ then
+ return True;
+
+ elsif (Nkind (N) = N_Private_Type_Declaration
+ or else
+ Nkind (N) = N_Private_Extension_Declaration)
+ and then Present (Defining_Identifier (N))
+ and then T = Full_View (Defining_Identifier (N))
+ then
+ return True;
+ end if;
+
+ Next (N);
+ end loop;
+
+ return False;
+ end Visible_Part_Type;
+
+ -- Start of processing for Maybe_Primitive_Operation
+
+ begin
+ if not Comes_From_Source (S) then
+ null;
+
+ elsif (Ekind (Current_Scope) = E_Package
+ and then not In_Package_Body (Current_Scope))
+ or else Overriding
+ then
+
+ if Ekind (S) = E_Function
+ and then Scope (Base_Type (Etype (S))) = Current_Scope
+ then
+ Set_Has_Primitive_Operations (Base_Type (Etype (S)));
+ Check_Private_Overriding (Base_Type (Etype (S)));
+ end if;
+
+ Formal := First_Formal (S);
+
+ while Present (Formal) loop
+ if Ekind (Etype (Formal)) = E_Anonymous_Access_Type then
+ F_Typ := Designated_Type (Etype (Formal));
+ else
+ F_Typ := Etype (Formal);
+ end if;
+
+ if Scope (Base_Type (F_Typ)) = Current_Scope then
+ Set_Has_Primitive_Operations (Base_Type (F_Typ));
+ Check_Private_Overriding (Base_Type (F_Typ));
+ end if;
+
+ Next_Formal (Formal);
+ end loop;
+
+ end if;
+ end Maybe_Primitive_Operation;
+
+ -- Start of processing for New_Overloaded_Entity
+
+ begin
+ if No (E) then
+ Enter_Overloaded_Entity (S);
+ Check_Dispatching_Operation (S, Empty);
+ Maybe_Primitive_Operation;
+
+ elsif not Is_Overloadable (E) then
+
+ -- Check for spurious conflict produced by a subprogram that has the
+ -- same name as that of the enclosing generic package. The conflict
+ -- occurs within an instance, between the subprogram and the renaming
+ -- declaration for the package. After the subprogram, the package
+ -- renaming declaration becomes hidden.
+
+ if Ekind (E) = E_Package
+ and then Present (Renamed_Object (E))
+ and then Renamed_Object (E) = Current_Scope
+ and then Nkind (Parent (Renamed_Object (E))) =
+ N_Package_Specification
+ and then Present (Generic_Parent (Parent (Renamed_Object (E))))
+ then
+ Set_Is_Hidden (E);
+ Set_Is_Immediately_Visible (E, False);
+ Enter_Overloaded_Entity (S);
+ Set_Homonym (S, Homonym (E));
+ Check_Dispatching_Operation (S, Empty);
+
+ -- If the subprogram is implicit it is hidden by the previous
+ -- declaration. However if it is dispatching, it must appear in
+ -- the dispatch table anyway, because it can be dispatched to
+ -- even if it cannot be called directly.
+
+ elsif Present (Alias (S))
+ and then not Comes_From_Source (S)
+ then
+ Set_Scope (S, Current_Scope);
+
+ if Is_Dispatching_Operation (Alias (S)) then
+ Check_Dispatching_Operation (S, Empty);
+ end if;
+
+ return;
+
+ else
+ Error_Msg_Sloc := Sloc (E);
+ Error_Msg_N ("& conflicts with declaration#", S);
+
+ -- Useful additional warning.
+
+ if Is_Generic_Unit (E) then
+ Error_Msg_N ("\previous generic unit cannot be overloaded", S);
+ end if;
+
+ return;
+ end if;
+
+ else
+ -- E exists and is overloadable. Determine whether S is the body
+ -- of E, a new overloaded entity with a different signature, or
+ -- an error altogether.
+
+ while Present (E) loop
+ if Scope (E) /= Current_Scope then
+ null;
+
+ elsif Type_Conformant (E, S) then
+
+ -- If the old and new entities have the same profile and
+ -- one is not the body of the other, then this is an error,
+ -- unless one of them is implicitly declared.
+
+ -- There are some cases when both can be implicit, for example
+ -- when both a literal and a function that overrides it are
+ -- inherited in a derivation, or when an inhertited operation
+ -- of a tagged full type overrides the ineherited operation of
+ -- a private extension. Ada 83 had a special rule for the
+ -- the literal case. In Ada95, the later implicit operation
+ -- hides the former, and the literal is always the former.
+ -- In the odd case where both are derived operations declared
+ -- at the same point, both operations should be declared,
+ -- and in that case we bypass the following test and proceed
+ -- to the next part (this can only occur for certain obscure
+ -- cases involving homographs in instances and can't occur for
+ -- dispatching operations ???). Note that the following
+ -- condition is less than clear. For example, it's not at
+ -- all clear why there's a test for E_Entry here. ???
+
+ if Present (Alias (S))
+ and then (No (Alias (E))
+ or else Comes_From_Source (E)
+ or else Is_Dispatching_Operation (E))
+ and then
+ (Ekind (E) = E_Entry
+ or else Ekind (E) /= E_Enumeration_Literal)
+ then
+ -- When an derived operation is overloaded it may be due
+ -- to the fact that the full view of a private extension
+ -- re-inherits. It has to be dealt with.
+
+ if Is_Package (Current_Scope)
+ and then In_Private_Part (Current_Scope)
+ then
+ Check_Operation_From_Private_View (S, E);
+ end if;
+
+ -- In any case the implicit operation remains hidden by
+ -- the existing declaration.
+
+ return;
+
+ -- Within an instance, the renaming declarations for
+ -- actual subprograms may become ambiguous, but they do
+ -- not hide each other.
+
+ elsif Ekind (E) /= E_Entry
+ and then not Comes_From_Source (E)
+ and then not Is_Generic_Instance (E)
+ and then (Present (Alias (E))
+ or else Is_Intrinsic_Subprogram (E))
+ and then (not In_Instance
+ or else No (Parent (E))
+ or else Nkind (Unit_Declaration_Node (E)) /=
+ N_Subprogram_Renaming_Declaration)
+ then
+ -- A subprogram child unit is not allowed to override
+ -- an inherited subprogram (10.1.1(20)).
+
+ if Is_Child_Unit (S) then
+ Error_Msg_N
+ ("child unit overrides inherited subprogram in parent",
+ S);
+ return;
+ end if;
+
+ if Is_Non_Overriding_Operation (E, S) then
+ Enter_Overloaded_Entity (S);
+ if not Present (Derived_Type)
+ or else Is_Tagged_Type (Derived_Type)
+ then
+ Check_Dispatching_Operation (S, Empty);
+ end if;
+
+ return;
+ end if;
+
+ -- E is a derived operation or an internal operator which
+ -- is being overridden. Remove E from further visibility.
+ -- Furthermore, if E is a dispatching operation, it must be
+ -- replaced in the list of primitive operations of its type
+ -- (see Override_Dispatching_Operation).
+
+ declare
+ Prev : Entity_Id;
+
+ begin
+ Prev := First_Entity (Current_Scope);
+
+ while Present (Prev)
+ and then Next_Entity (Prev) /= E
+ loop
+ Next_Entity (Prev);
+ end loop;
+
+ -- It is possible for E to be in the current scope and
+ -- yet not in the entity chain. This can only occur in a
+ -- generic context where E is an implicit concatenation
+ -- in the formal part, because in a generic body the
+ -- entity chain starts with the formals.
+
+ pragma Assert
+ (Present (Prev) or else Chars (E) = Name_Op_Concat);
+
+ -- E must be removed both from the entity_list of the
+ -- current scope, and from the visibility chain
+
+ if Debug_Flag_E then
+ Write_Str ("Override implicit operation ");
+ Write_Int (Int (E));
+ Write_Eol;
+ end if;
+
+ -- If E is a predefined concatenation, it stands for four
+ -- different operations. As a result, a single explicit
+ -- declaration does not hide it. In a possible ambiguous
+ -- situation, Disambiguate chooses the user-defined op,
+ -- so it is correct to retain the previous internal one.
+
+ if Chars (E) /= Name_Op_Concat
+ or else Ekind (E) /= E_Operator
+ then
+ -- For nondispatching derived operations that are
+ -- overridden by a subprogram declared in the private
+ -- part of a package, we retain the derived subprogram
+ -- but mark it as not immediately visible. If the
+ -- derived operation was declared in the visible part
+ -- then this ensures that it will still be visible
+ -- outside the package with the proper signature
+ -- (calls from outside must also be directed to this
+ -- version rather than the overriding one, unlike the
+ -- dispatching case). Calls from inside the package
+ -- will still resolve to the overriding subprogram
+ -- since the derived one is marked as not visible
+ -- within the package.
+
+ -- If the private operation is dispatching, we achieve
+ -- the overriding by keeping the implicit operation
+ -- but setting its alias to be the overring one. In
+ -- this fashion the proper body is executed in all
+ -- cases, but the original signature is used outside
+ -- of the package.
+
+ -- If the overriding is not in the private part, we
+ -- remove the implicit operation altogether.
+
+ if Is_Private_Declaration (S) then
+
+ if not Is_Dispatching_Operation (E) then
+ Set_Is_Immediately_Visible (E, False);
+ else
+
+ -- work done in Override_Dispatching_Operation.
+
+ null;
+ end if;
+ else
+
+ -- Find predecessor of E in Homonym chain.
+
+ if E = Current_Entity (E) then
+ Prev_Vis := Empty;
+ else
+ Prev_Vis := Current_Entity (E);
+ while Homonym (Prev_Vis) /= E loop
+ Prev_Vis := Homonym (Prev_Vis);
+ end loop;
+ end if;
+
+ if Prev_Vis /= Empty then
+
+ -- Skip E in the visibility chain
+
+ Set_Homonym (Prev_Vis, Homonym (E));
+
+ else
+ Set_Name_Entity_Id (Chars (E), Homonym (E));
+ end if;
+
+ Set_Next_Entity (Prev, Next_Entity (E));
+
+ if No (Next_Entity (Prev)) then
+ Set_Last_Entity (Current_Scope, Prev);
+ end if;
+
+ end if;
+ end if;
+
+ Enter_Overloaded_Entity (S);
+
+ if Is_Dispatching_Operation (E) then
+ -- An overriding dispatching subprogram inherits
+ -- the convention of the overridden subprogram
+ -- (by AI-117).
+
+ Set_Convention (S, Convention (E));
+
+ Check_Dispatching_Operation (S, E);
+ else
+ Check_Dispatching_Operation (S, Empty);
+ end if;
+
+ Maybe_Primitive_Operation (Overriding => True);
+ goto Check_Inequality;
+ end;
+
+ -- Apparent redeclarations in instances can occur when two
+ -- formal types get the same actual type. The subprograms in
+ -- in the instance are legal, even if not callable from the
+ -- outside. Calls from within are disambiguated elsewhere.
+ -- For dispatching operations in the visible part, the usual
+ -- rules apply, and operations with the same profile are not
+ -- legal (B830001).
+
+ elsif (In_Instance_Visible_Part
+ and then not Is_Dispatching_Operation (E))
+ or else In_Instance_Not_Visible
+ then
+ null;
+
+ -- Here we have a real error (identical profile)
+
+ else
+ Error_Msg_Sloc := Sloc (E);
+
+ -- Avoid cascaded errors if the entity appears in
+ -- subsequent calls.
+
+ Set_Scope (S, Current_Scope);
+
+ Error_Msg_N ("& conflicts with declaration#", S);
+
+ if Is_Generic_Instance (S)
+ and then not Has_Completion (E)
+ then
+ Error_Msg_N
+ ("\instantiation cannot provide body for it", S);
+ end if;
+
+ return;
+ end if;
+
+ else
+ null;
+ end if;
+
+ Prev_Vis := E;
+ E := Homonym (E);
+ end loop;
+
+ -- On exit, we know that S is a new entity
+
+ Enter_Overloaded_Entity (S);
+ Maybe_Primitive_Operation;
+
+ -- If S is a derived operation for an untagged type then
+ -- by definition it's not a dispatching operation (even
+ -- if the parent operation was dispatching), so we don't
+ -- call Check_Dispatching_Operation in that case.
+
+ if not Present (Derived_Type)
+ or else Is_Tagged_Type (Derived_Type)
+ then
+ Check_Dispatching_Operation (S, Empty);
+ end if;
+ end if;
+
+ -- If this is a user-defined equality operator that is not
+ -- a derived subprogram, create the corresponding inequality.
+ -- If the operation is dispatching, the expansion is done
+ -- elsewhere, and we do not create an explicit inequality
+ -- operation.
+
+ <<Check_Inequality>>
+ if Chars (S) = Name_Op_Eq
+ and then Etype (S) = Standard_Boolean
+ and then Present (Parent (S))
+ and then not Is_Dispatching_Operation (S)
+ then
+ Make_Inequality_Operator (S);
+ end if;
+
+ end New_Overloaded_Entity;
+
+ ---------------------
+ -- Process_Formals --
+ ---------------------
+
+ procedure Process_Formals
+ (S : Entity_Id;
+ T : List_Id;
+ Related_Nod : Node_Id)
+ is
+ Param_Spec : Node_Id;
+ Formal : Entity_Id;
+ Formal_Type : Entity_Id;
+ Default : Node_Id;
+ Ptype : Entity_Id;
+
+ begin
+ -- In order to prevent premature use of the formals in the same formal
+ -- part, the Ekind is left undefined until all default expressions are
+ -- analyzed. The Ekind is established in a separate loop at the end.
+
+ Param_Spec := First (T);
+
+ while Present (Param_Spec) loop
+
+ Formal := Defining_Identifier (Param_Spec);
+ Enter_Name (Formal);
+
+ -- Case of ordinary parameters
+
+ if Nkind (Parameter_Type (Param_Spec)) /= N_Access_Definition then
+ Find_Type (Parameter_Type (Param_Spec));
+ Ptype := Parameter_Type (Param_Spec);
+
+ if Ptype = Error then
+ goto Continue;
+ end if;
+
+ Formal_Type := Entity (Ptype);
+
+ if Ekind (Formal_Type) = E_Incomplete_Type
+ or else (Is_Class_Wide_Type (Formal_Type)
+ and then Ekind (Root_Type (Formal_Type)) =
+ E_Incomplete_Type)
+ then
+ if Nkind (Parent (T)) /= N_Access_Function_Definition
+ and then Nkind (Parent (T)) /= N_Access_Procedure_Definition
+ then
+ Error_Msg_N ("invalid use of incomplete type", Param_Spec);
+ end if;
+
+ elsif Ekind (Formal_Type) = E_Void then
+ Error_Msg_NE ("premature use of&",
+ Parameter_Type (Param_Spec), Formal_Type);
+ end if;
+
+ -- An access formal type
+
+ else
+ Formal_Type :=
+ Access_Definition (Related_Nod, Parameter_Type (Param_Spec));
+ end if;
+
+ Set_Etype (Formal, Formal_Type);
+
+ Default := Expression (Param_Spec);
+
+ if Present (Default) then
+ if Out_Present (Param_Spec) then
+ Error_Msg_N
+ ("default initialization only allowed for IN parameters",
+ Param_Spec);
+ end if;
+
+ -- Do the special preanalysis of the expression (see section on
+ -- "Handling of Default Expressions" in the spec of package Sem).
+
+ Analyze_Default_Expression (Default, Formal_Type);
+
+ -- Check that the designated type of an access parameter's
+ -- default is not a class-wide type unless the parameter's
+ -- designated type is also class-wide.
+
+ if Ekind (Formal_Type) = E_Anonymous_Access_Type
+ and then Is_Class_Wide_Type (Designated_Type (Etype (Default)))
+ and then not Is_Class_Wide_Type (Designated_Type (Formal_Type))
+ then
+ Wrong_Type (Default, Formal_Type);
+ end if;
+ end if;
+
+ <<Continue>>
+ Next (Param_Spec);
+ end loop;
+
+ -- Now set the kind (mode) of each formal
+
+ Param_Spec := First (T);
+
+ while Present (Param_Spec) loop
+ Formal := Defining_Identifier (Param_Spec);
+ Set_Formal_Mode (Formal);
+
+ if Ekind (Formal) = E_In_Parameter then
+ Set_Default_Value (Formal, Expression (Param_Spec));
+
+ if Present (Expression (Param_Spec)) then
+ Default := Expression (Param_Spec);
+
+ if Is_Scalar_Type (Etype (Default)) then
+ if Nkind
+ (Parameter_Type (Param_Spec)) /= N_Access_Definition
+ then
+ Formal_Type := Entity (Parameter_Type (Param_Spec));
+
+ else
+ Formal_Type := Access_Definition
+ (Related_Nod, Parameter_Type (Param_Spec));
+ end if;
+
+ Apply_Scalar_Range_Check (Default, Formal_Type);
+ end if;
+
+ end if;
+ end if;
+
+ Next (Param_Spec);
+ end loop;
+
+ end Process_Formals;
+
+ -------------------------
+ -- Set_Actual_Subtypes --
+ -------------------------
+
+ procedure Set_Actual_Subtypes (N : Node_Id; Subp : Entity_Id) is
+ Loc : constant Source_Ptr := Sloc (N);
+ Decl : Node_Id;
+ Formal : Entity_Id;
+ T : Entity_Id;
+ First_Stmt : Node_Id := Empty;
+ AS_Needed : Boolean;
+
+ begin
+ Formal := First_Formal (Subp);
+ while Present (Formal) loop
+ T := Etype (Formal);
+
+ -- We never need an actual subtype for a constrained formal.
+
+ if Is_Constrained (T) then
+ AS_Needed := False;
+
+ -- If we have unknown discriminants, then we do not need an
+ -- actual subtype, or more accurately we cannot figure it out!
+ -- Note that all class-wide types have unknown discriminants.
+
+ elsif Has_Unknown_Discriminants (T) then
+ AS_Needed := False;
+
+ -- At this stage we have an unconstrained type that may need
+ -- an actual subtype. For sure the actual subtype is needed
+ -- if we have an unconstrained array type.
+
+ elsif Is_Array_Type (T) then
+ AS_Needed := True;
+
+ -- The only other case which needs an actual subtype is an
+ -- unconstrained record type which is an IN parameter (we
+ -- cannot generate actual subtypes for the OUT or IN OUT case,
+ -- since an assignment can change the discriminant values.
+ -- However we exclude the case of initialization procedures,
+ -- since discriminants are handled very specially in this context,
+ -- see the section entitled "Handling of Discriminants" in Einfo.
+ -- We also exclude the case of Discrim_SO_Functions (functions
+ -- used in front end layout mode for size/offset values), since
+ -- in such functions only discriminants are referenced, and not
+ -- only are such subtypes not needed, but they cannot always
+ -- be generated, because of order of elaboration issues.
+
+ elsif Is_Record_Type (T)
+ and then Ekind (Formal) = E_In_Parameter
+ and then Chars (Formal) /= Name_uInit
+ and then not Is_Discrim_SO_Function (Subp)
+ then
+ AS_Needed := True;
+
+ -- All other cases do not need an actual subtype
+
+ else
+ AS_Needed := False;
+ end if;
+
+ -- Generate actual subtypes for unconstrained arrays and
+ -- unconstrained discriminated records.
+
+ if AS_Needed then
+ Decl := Build_Actual_Subtype (T, Formal);
+
+ if Nkind (N) = N_Accept_Statement then
+ if Present (Handled_Statement_Sequence (N)) then
+ First_Stmt :=
+ First (Statements (Handled_Statement_Sequence (N)));
+ Prepend (Decl, Statements (Handled_Statement_Sequence (N)));
+ Mark_Rewrite_Insertion (Decl);
+ else
+ -- If the accept statement has no body, there will be
+ -- no reference to the actuals, so no need to compute
+ -- actual subtypes.
+
+ return;
+ end if;
+
+ else
+ Prepend (Decl, Declarations (N));
+ Mark_Rewrite_Insertion (Decl);
+ end if;
+
+ Analyze (Decl);
+
+ -- We need to freeze manually the generated type when it is
+ -- inserted anywhere else than in a declarative part.
+
+ if Present (First_Stmt) then
+ Insert_List_Before_And_Analyze (First_Stmt,
+ Freeze_Entity (Defining_Identifier (Decl), Loc));
+ end if;
+
+ Set_Actual_Subtype (Formal, Defining_Identifier (Decl));
+ end if;
+
+ Next_Formal (Formal);
+ end loop;
+ end Set_Actual_Subtypes;
+
+ ---------------------
+ -- Set_Formal_Mode --
+ ---------------------
+
+ procedure Set_Formal_Mode (Formal_Id : Entity_Id) is
+ Spec : constant Node_Id := Parent (Formal_Id);
+
+ begin
+ -- Note: we set Is_Known_Valid for IN parameters and IN OUT parameters
+ -- since we ensure that corresponding actuals are always valid at the
+ -- point of the call.
+
+ if Out_Present (Spec) then
+
+ if Ekind (Scope (Formal_Id)) = E_Function
+ or else Ekind (Scope (Formal_Id)) = E_Generic_Function
+ then
+ Error_Msg_N ("functions can only have IN parameters", Spec);
+ Set_Ekind (Formal_Id, E_In_Parameter);
+
+ elsif In_Present (Spec) then
+ Set_Ekind (Formal_Id, E_In_Out_Parameter);
+
+ else
+ Set_Ekind (Formal_Id, E_Out_Parameter);
+ Set_Not_Source_Assigned (Formal_Id);
+ end if;
+
+ else
+ Set_Ekind (Formal_Id, E_In_Parameter);
+ end if;
+
+ Set_Mechanism (Formal_Id, Default_Mechanism);
+ Set_Formal_Validity (Formal_Id);
+ end Set_Formal_Mode;
+
+ -------------------------
+ -- Set_Formal_Validity --
+ -------------------------
+
+ procedure Set_Formal_Validity (Formal_Id : Entity_Id) is
+ begin
+ -- If in full validity checking mode, then we can assume that
+ -- an IN or IN OUT parameter is valid (see Exp_Ch5.Expand_Call)
+
+ if not Validity_Checks_On then
+ return;
+
+ elsif Ekind (Formal_Id) = E_In_Parameter
+ and then Validity_Check_In_Params
+ then
+ Set_Is_Known_Valid (Formal_Id, True);
+
+ elsif Ekind (Formal_Id) = E_In_Out_Parameter
+ and then Validity_Check_In_Out_Params
+ then
+ Set_Is_Known_Valid (Formal_Id, True);
+ end if;
+ end Set_Formal_Validity;
+
+ ------------------------
+ -- Subtype_Conformant --
+ ------------------------
+
+ function Subtype_Conformant (New_Id, Old_Id : Entity_Id) return Boolean is
+ Result : Boolean;
+
+ begin
+ Check_Conformance (New_Id, Old_Id, Subtype_Conformant, False, Result);
+ return Result;
+ end Subtype_Conformant;
+
+ ---------------------
+ -- Type_Conformant --
+ ---------------------
+
+ function Type_Conformant (New_Id, Old_Id : Entity_Id) return Boolean is
+ Result : Boolean;
+
+ begin
+ Check_Conformance (New_Id, Old_Id, Type_Conformant, False, Result);
+ return Result;
+ end Type_Conformant;
+
+ -------------------------------
+ -- Valid_Operator_Definition --
+ -------------------------------
+
+ procedure Valid_Operator_Definition (Designator : Entity_Id) is
+ N : Integer := 0;
+ F : Entity_Id;
+ Id : constant Name_Id := Chars (Designator);
+ N_OK : Boolean;
+
+ begin
+ F := First_Formal (Designator);
+
+ while Present (F) loop
+ N := N + 1;
+
+ if Present (Default_Value (F)) then
+ Error_Msg_N
+ ("default values not allowed for operator parameters",
+ Parent (F));
+ end if;
+
+ Next_Formal (F);
+ end loop;
+
+ -- Verify that user-defined operators have proper number of arguments
+ -- First case of operators which can only be unary
+
+ if Id = Name_Op_Not
+ or else Id = Name_Op_Abs
+ then
+ N_OK := (N = 1);
+
+ -- Case of operators which can be unary or binary
+
+ elsif Id = Name_Op_Add
+ or Id = Name_Op_Subtract
+ then
+ N_OK := (N in 1 .. 2);
+
+ -- All other operators can only be binary
+
+ else
+ N_OK := (N = 2);
+ end if;
+
+ if not N_OK then
+ Error_Msg_N
+ ("incorrect number of arguments for operator", Designator);
+ end if;
+
+ if Id = Name_Op_Ne
+ and then Base_Type (Etype (Designator)) = Standard_Boolean
+ and then not Is_Intrinsic_Subprogram (Designator)
+ then
+ Error_Msg_N
+ ("explicit definition of inequality not allowed", Designator);
+ end if;
+ end Valid_Operator_Definition;
+
+end Sem_Ch6;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S E M _ C H 6 --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.22 $ --
+-- --
+-- Copyright (C) 1992,1993,1994,1995,1996 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 Types; use Types;
+package Sem_Ch6 is
+
+ procedure Analyze_Abstract_Subprogram_Declaration (N : Node_Id);
+ procedure Analyze_Function_Call (N : Node_Id);
+ procedure Analyze_Operator_Symbol (N : Node_Id);
+ procedure Analyze_Parameter_Association (N : Node_Id);
+ procedure Analyze_Procedure_Call (N : Node_Id);
+ procedure Analyze_Return_Statement (N : Node_Id);
+ procedure Analyze_Subprogram_Declaration (N : Node_Id);
+ procedure Analyze_Subprogram_Body (N : Node_Id);
+
+ function Analyze_Spec (N : Node_Id) return Entity_Id;
+ -- Analyze subprogram specification in both subprogram declarations
+ -- and body declarations.
+
+ procedure Check_Delayed_Subprogram (Designator : Entity_Id);
+ -- Designator can be a E_Subrpgram_Type, E_Procedure or E_Function. If a
+ -- type in its profile depends on a private type without a full
+ -- declaration, indicate that the subprogram is delayed.
+
+ procedure Check_Discriminant_Conformance
+ (N : Node_Id;
+ Prev : Entity_Id;
+ Prev_Loc : Node_Id);
+ -- Check that the discriminants of a full type N fully conform to
+ -- the discriminants of the corresponding partial view Prev.
+ -- Prev_Loc indicates the source location of the partial view,
+ -- which may be different than Prev in the case of private types.
+
+ procedure Check_Fully_Conformant
+ (New_Id : Entity_Id;
+ Old_Id : Entity_Id;
+ Err_Loc : Node_Id := Empty);
+ -- Check that two callable entitites (subprograms, entries, literals)
+ -- are fully conformant, post error message if not (RM 6.3.1(17)) with
+ -- the flag being placed on the Err_Loc node if it is specified, and
+ -- on the appropriate component of the New_Id construct if not. Note:
+ -- when checking spec/body conformance, New_Id must be the body entity
+ -- and Old_Id is the spec entity (the code in the implementation relies
+ -- on this ordering, and in any case, this makes sense, since if flags
+ -- are to be placed on the construct, they clearly belong on the body.
+
+ procedure Check_Mode_Conformant
+ (New_Id : Entity_Id;
+ Old_Id : Entity_Id;
+ Err_Loc : Node_Id := Empty;
+ Get_Inst : Boolean := False);
+ -- Check that two callable entitites (subprograms, entries, literals)
+ -- are mode conformant, post error message if not (RM 6.3.1(15)) with
+ -- the flag being placed on the Err_Loc node if it is specified, and
+ -- on the appropriate component of the New_Id construct if not. The
+ -- argument Get_Inst is set to True when this is a check against a
+ -- formal access-to-subprogram type, indicating that mapping of types
+ -- is needed.
+
+ procedure Check_Subtype_Conformant
+ (New_Id : Entity_Id;
+ Old_Id : Entity_Id;
+ Err_Loc : Node_Id := Empty);
+ -- Check that two callable entitites (subprograms, entries, literals)
+ -- are subtype conformant, post error message if not (RM 6.3.1(16))
+ -- the flag being placed on the Err_Loc node if it is specified, and
+ -- on the appropriate component of the New_Id construct if not.
+
+ procedure Check_Type_Conformant
+ (New_Id : Entity_Id;
+ Old_Id : Entity_Id;
+ Err_Loc : Node_Id := Empty);
+ -- Check that two callable entitites (subprograms, entries, literals)
+ -- are type conformant, post error message if not (RM 6.3.1(14)) with
+ -- the flag being placed on the Err_Loc node if it is specified, and
+ -- on the appropriate component of the New_Id construct if not.
+
+ procedure Create_Extra_Formals (E : Entity_Id);
+ -- For each parameter of a subprogram or entry that requires an additional
+ -- formal (such as for access parameters and indefinite discriminated
+ -- parameters), creates the appropriate formal and attach it to its
+ -- associated parameter. Each extra formal will also be appended to
+ -- the end of Subp's parameter list (with each subsequent extra formal
+ -- being attached to the preceding extra formal).
+
+ function Find_Corresponding_Spec (N : Node_Id) return Entity_Id;
+ -- Use the subprogram specification in the body to retrieve the previous
+ -- subprogram declaration, if any.
+
+ function Fully_Conformant (New_Id, Old_Id : Entity_Id) return Boolean;
+ -- Determine whether two callable entities (subprograms, entries,
+ -- literals) are fully conformant (RM 6.3.1(17))
+
+ function Fully_Conformant_Expressions
+ (Given_E1 : Node_Id;
+ Given_E2 : Node_Id)
+ return Boolean;
+ -- Determines if two (non-empty) expressions are fully conformant
+ -- as defined by (RM 6.3.1(18-21))
+
+ function Mode_Conformant (New_Id, Old_Id : Entity_Id) return Boolean;
+ -- Determine whether two callable entities (subprograms, entries,
+ -- literals) are mode conformant (RM 6.3.1(15))
+
+ procedure New_Overloaded_Entity
+ (S : Entity_Id;
+ Derived_Type : Entity_Id := Empty);
+ -- Process new overloaded entity. Overloaded entities are created
+ -- by enumeration type declarations, subprogram specifications,
+ -- entry declarations, and (implicitly) by type derivations.
+ -- If Derived_Type is not Empty, then it indicates that this
+ -- is subprogram derived for that type.
+
+ procedure Process_Formals (
+ S : Entity_Id;
+ T : List_Id;
+ Related_Nod : Node_Id);
+ -- Enter the formals in the scope of the subprogram or entry, and
+ -- analyze default expressions if any. The implicit types created for
+ -- access parameter are attached to the Related_Nod which comes from the
+ -- context.
+
+ procedure Set_Actual_Subtypes (N : Node_Id; Subp : Entity_Id);
+ -- If the formals of a subprogram are unconstrained, build a subtype
+ -- declaration that uses the bounds or discriminants of the actual to
+ -- construct an actual subtype for them. This is an optimization that
+ -- is done only in some cases where the actual subtype cannot change
+ -- during execution of the subprogram. By setting the actual subtype
+ -- once, we avoid recomputing it unnecessarily.
+
+ procedure Set_Formal_Mode (Formal_Id : Entity_Id);
+ -- Set proper Ekind to reflect formal mode (in, out, in out)
+
+ function Subtype_Conformant (New_Id, Old_Id : Entity_Id) return Boolean;
+ -- Determine whether two callable entities (subprograms, entries,
+ -- literals) are subtype conformant (RM6.3.1(16))
+
+ function Type_Conformant (New_Id, Old_Id : Entity_Id) return Boolean;
+ -- Determine whether two callable entities (subprograms, entries,
+ -- literals) are type conformant (RM6.3.1(14))
+
+ procedure Valid_Operator_Definition (Designator : Entity_Id);
+ -- Verify that an operator definition has the proper number of formals
+
+end Sem_Ch6;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S E M . C H 7 --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.335 $
+-- --
+-- 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 contains the routines to process package specifications and
+-- bodies. The most important semantic aspects of package processing are the
+-- handling of private and full declarations, and the construction of
+-- dispatch tables for tagged types.
+
+with Atree; use Atree;
+with Debug; use Debug;
+with Einfo; use Einfo;
+with Elists; use Elists;
+with Errout; use Errout;
+with Exp_Disp; use Exp_Disp;
+with Exp_Dbug; use Exp_Dbug;
+with Lib; use Lib;
+with Lib.Xref; use Lib.Xref;
+with Namet; use Namet;
+with Nmake; use Nmake;
+with Nlists; use Nlists;
+with Opt; use Opt;
+with Output; use Output;
+with Sem; use Sem;
+with Sem_Cat; use Sem_Cat;
+with Sem_Ch3; use Sem_Ch3;
+with Sem_Ch6; use Sem_Ch6;
+with Sem_Ch8; use Sem_Ch8;
+with Sem_Ch12; use Sem_Ch12;
+with Sem_Util; use Sem_Util;
+with Sem_Warn; use Sem_Warn;
+with Snames; use Snames;
+with Stand; use Stand;
+with Sinfo; use Sinfo;
+with Sinput; use Sinput;
+with Style;
+
+package body Sem_Ch7 is
+
+ -----------------------------------
+ -- Handling private declarations --
+ -----------------------------------
+
+ -- The principle that each entity has a single defining occurrence clashes
+ -- with the presence of two separate definitions for private types: the
+ -- first is the private type declaration, and the second is the full type
+ -- declaration. It is important that all references to the type point to
+ -- the same defining occurence, namely the first one. To enforce the two
+ -- separate views of the entity, the corresponding information is swapped
+ -- between the two declarations. Outside of the package, the defining
+ -- occurence only contains the private declaration information, while in
+ -- the private part and the body of the package the defining occurrence
+ -- contains the full declaration. To simplify the swap, the defining
+ -- occurrence that currently holds the private declaration points to the
+ -- full declaration. During semantic processing the defining occurence also
+ -- points to a list of private dependents, that is to say access types or
+ -- composite types whose designated types or component types are subtypes
+ -- or derived types of the private type in question. After the full decla-
+ -- ration has been seen, the private dependents are updated to indicate
+ -- that they have full definitions.
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ procedure Install_Composite_Operations (P : Entity_Id);
+ -- Composite types declared in the current scope may depend on
+ -- types that were private at the point of declaration, and whose
+ -- full view is now in scope. Indicate that the corresponding
+ -- operations on the composite type are available.
+
+ function Is_Private_Base_Type (E : Entity_Id) return Boolean;
+ -- True for a private type that is not a subtype.
+
+ function Is_Visible_Dependent (Dep : Entity_Id) return Boolean;
+ -- If the private dependent is a private type whose full view is
+ -- derived from the parent type, its full properties are revealed
+ -- only if we are in the immediate scope of the private dependent.
+ -- Should this predicate be tightened further???
+
+ procedure Preserve_Full_Attributes (Priv, Full : Entity_Id);
+ -- Copy to the private declaration the attributes of the full view
+ -- that need to be available for the partial view also.
+
+ procedure Declare_Inherited_Private_Subprograms (Id : Entity_Id);
+ -- Called upon entering the private part of a public child package
+ -- and the body of a nested package, to potentially declare certain
+ -- inherited subprograms that were inherited by types in the visible
+ -- part, but whose declaration was deferred because the parent
+ -- operation was private and not visible at that point. These
+ -- subprograms are located by traversing the visible part declarations
+ -- looking for nonprivate type extensions and then examining each of
+ -- the primitive operations of such types to find those that were
+ -- inherited but declared with a special internal name. Each such
+ -- operation is now declared as an operation with a normal name (using
+ -- the name of the parent operation) and replaces the previous implicit
+ -- operation in the primitive operations list of the type. If the
+ -- inherited private operation has been overridden, then it's
+ -- replaced by the overriding operation.
+
+ --------------------------
+ -- Analyze_Package_Body --
+ --------------------------
+
+ procedure Analyze_Package_Body (N : Node_Id) is
+ Loc : constant Source_Ptr := Sloc (N);
+ HSS : Node_Id;
+ Body_Id : Entity_Id;
+ Spec_Id : Entity_Id;
+ Last_Spec_Entity : Entity_Id;
+ New_N : Node_Id;
+ Pack_Decl : Node_Id;
+
+ begin
+ -- Find corresponding package specification, and establish the
+ -- current scope. The visible defining entity for the package is the
+ -- defining occurrence in the spec. On exit from the package body, all
+ -- body declarations are attached to the defining entity for the body,
+ -- but the later is never used for name resolution. In this fashion
+ -- there is only one visible entity that denotes the package.
+
+ if Debug_Flag_C then
+ Write_Str ("==== Compiling package body ");
+ Write_Name (Chars (Defining_Entity (N)));
+ Write_Str (" from ");
+ Write_Location (Loc);
+ Write_Eol;
+ end if;
+
+ -- Set Body_Id. Note that this wil be reset to point to the
+ -- generic copy later on in the generic case.
+
+ Body_Id := Defining_Entity (N);
+
+ if Present (Corresponding_Spec (N)) then
+
+ -- Body is body of package instantiation. Corresponding spec
+ -- has already been set.
+
+ Spec_Id := Corresponding_Spec (N);
+ Pack_Decl := Unit_Declaration_Node (Spec_Id);
+
+ else
+ Spec_Id := Current_Entity_In_Scope (Defining_Entity (N));
+
+ if Present (Spec_Id)
+ and then Is_Package (Spec_Id)
+ then
+ Pack_Decl := Unit_Declaration_Node (Spec_Id);
+
+ if Nkind (Pack_Decl) = N_Package_Renaming_Declaration then
+ Error_Msg_N ("cannot supply body for package renaming", N);
+ return;
+
+ elsif Present (Corresponding_Body (Pack_Decl)) then
+ Error_Msg_N ("redefinition of package body", N);
+ return;
+ end if;
+
+ else
+ Error_Msg_N ("missing specification for package body", N);
+ return;
+ end if;
+
+ if Is_Package (Spec_Id)
+ and then
+ (Scope (Spec_Id) = Standard_Standard
+ or else Is_Child_Unit (Spec_Id))
+ and then not Unit_Requires_Body (Spec_Id)
+ then
+ if Ada_83 then
+ Error_Msg_N
+ ("optional package body (not allowed in Ada 95)?", N);
+ else
+ Error_Msg_N
+ ("spec of this package does not allow a body", N);
+ end if;
+ end if;
+ end if;
+
+ Set_Is_Compilation_Unit (Body_Id, Is_Compilation_Unit (Spec_Id));
+ Style.Check_Identifier (Body_Id, Spec_Id);
+
+ if Is_Child_Unit (Spec_Id) then
+
+ if Nkind (Parent (N)) /= N_Compilation_Unit then
+ Error_Msg_NE
+ ("body of child unit& cannot be an inner package", N, Spec_Id);
+ end if;
+
+ Set_Is_Child_Unit (Body_Id);
+ end if;
+
+ -- Generic package case
+
+ if Ekind (Spec_Id) = E_Generic_Package then
+
+ -- Disable expansion and perform semantic analysis on copy.
+ -- The unannotated body will be used in all instantiations.
+
+ Body_Id := Defining_Entity (N);
+ Set_Ekind (Body_Id, E_Package_Body);
+ Set_Scope (Body_Id, Scope (Spec_Id));
+ Set_Body_Entity (Spec_Id, Body_Id);
+ Set_Spec_Entity (Body_Id, Spec_Id);
+
+ New_N := Copy_Generic_Node (N, Empty, Instantiating => False);
+ Rewrite (N, New_N);
+
+ -- Update Body_Id to point to the copied node for the remainder
+ -- of the processing.
+
+ Body_Id := Defining_Entity (N);
+ Start_Generic;
+ end if;
+
+ -- The Body_Id is that of the copied node in the generic case, the
+ -- current node otherwise. Note that N was rewritten above, so we
+ -- must be sure to get the latest Body_Id value.
+
+ Set_Ekind (Body_Id, E_Package_Body);
+ Set_Body_Entity (Spec_Id, Body_Id);
+ Set_Spec_Entity (Body_Id, Spec_Id);
+
+ -- Defining name for the package body is not a visible entity: Only
+ -- the defining name for the declaration is visible.
+
+ Set_Etype (Body_Id, Standard_Void_Type);
+ Set_Scope (Body_Id, Scope (Spec_Id));
+ Set_Corresponding_Spec (N, Spec_Id);
+ Set_Corresponding_Body (Pack_Decl, Body_Id);
+
+ -- The body entity is not used for semantics or code generation, but
+ -- it is attached to the entity list of the enclosing scope to simplify
+ -- the listing of back-annotations for the types it main contain.
+
+ if Scope (Spec_Id) /= Standard_Standard then
+ Append_Entity (Body_Id, Scope (Spec_Id));
+ end if;
+
+ -- Indicate that we are currently compiling the body of the package.
+
+ Set_In_Package_Body (Spec_Id);
+ Set_Has_Completion (Spec_Id);
+ Last_Spec_Entity := Last_Entity (Spec_Id);
+
+ New_Scope (Spec_Id);
+
+ Set_Categorization_From_Pragmas (N);
+
+ Install_Visible_Declarations (Spec_Id);
+ Install_Private_Declarations (Spec_Id);
+ Install_Composite_Operations (Spec_Id);
+
+ if Ekind (Spec_Id) = E_Generic_Package then
+ Set_Use (Generic_Formal_Declarations (Pack_Decl));
+ end if;
+
+ Set_Use (Visible_Declarations (Specification (Pack_Decl)));
+ Set_Use (Private_Declarations (Specification (Pack_Decl)));
+
+ -- This is a nested package, so it may be necessary to declare
+ -- certain inherited subprograms that are not yet visible because
+ -- the parent type's subprograms are now visible.
+
+ if Ekind (Scope (Spec_Id)) = E_Package
+ and then Scope (Spec_Id) /= Standard_Standard
+ then
+ Declare_Inherited_Private_Subprograms (Spec_Id);
+ end if;
+
+ if Present (Declarations (N)) then
+ Analyze_Declarations (Declarations (N));
+ end if;
+
+ HSS := Handled_Statement_Sequence (N);
+
+ if Present (HSS) then
+ Process_End_Label (HSS, 't');
+ Analyze (HSS);
+
+ -- Check that elaboration code in a preelaborable package body is
+ -- empty other than null statements and labels (RM 10.2.1(6)).
+
+ Validate_Null_Statement_Sequence (N);
+ end if;
+
+ Validate_Categorization_Dependency (N, Spec_Id);
+ Check_Completion (Body_Id);
+
+ -- Generate start of body reference. Note that we do this fairly late,
+ -- because the call will use In_Extended_Main_Source_Unit as a check,
+ -- and we want to make sure that Corresponding_Stub links are set
+
+ Generate_Reference (Spec_Id, Body_Id, 'b');
+
+ -- For a generic package, collect global references and mark
+ -- them on the original body so that they are not resolved
+ -- again at the point of instantiation.
+
+ if Ekind (Spec_Id) /= E_Package then
+ Save_Global_References (Original_Node (N));
+ End_Generic;
+ end if;
+
+ -- The entities of the package body have so far been chained onto
+ -- the declaration chain for the spec. That's been fine while we
+ -- were in the body, since we wanted them to be visible, but now
+ -- that we are leaving the package body, they are no longer visible,
+ -- so we remove them from the entity chain of the package spec entity,
+ -- and copy them to the entity chain of the package body entity, where
+ -- they will never again be visible.
+
+ if Present (Last_Spec_Entity) then
+ Set_First_Entity (Body_Id, Next_Entity (Last_Spec_Entity));
+ Set_Next_Entity (Last_Spec_Entity, Empty);
+ Set_Last_Entity (Body_Id, Last_Entity (Spec_Id));
+ Set_Last_Entity (Spec_Id, Last_Spec_Entity);
+
+ else
+ Set_First_Entity (Body_Id, First_Entity (Spec_Id));
+ Set_Last_Entity (Body_Id, Last_Entity (Spec_Id));
+ Set_First_Entity (Spec_Id, Empty);
+ Set_Last_Entity (Spec_Id, Empty);
+ end if;
+
+ End_Package_Scope (Spec_Id);
+
+ -- All entities declared in body are not visible.
+
+ declare
+ E : Entity_Id;
+
+ begin
+ E := First_Entity (Body_Id);
+
+ while Present (E) loop
+ Set_Is_Immediately_Visible (E, False);
+ Set_Is_Potentially_Use_Visible (E, False);
+ Set_Is_Hidden (E);
+
+ -- Child units may appear on the entity list (for example if
+ -- they appear in the context of a subunit) but they are not
+ -- body entities.
+
+ if not Is_Child_Unit (E) then
+ Set_Is_Package_Body_Entity (E);
+ end if;
+
+ Next_Entity (E);
+ end loop;
+ end;
+
+ Check_References (Body_Id);
+
+ -- The processing so far has made all entities of the package body
+ -- public (i.e. externally visible to the linker). This is in general
+ -- necessary, since inlined or generic bodies, for which code is
+ -- generated in other units, may need to see these entities. The
+ -- following loop runs backwards from the end of the entities of the
+ -- package body making these entities invisible until we reach a
+ -- referencer, i.e. a declaration that could reference a previous
+ -- declaration, a generic body or an inlined body, or a stub (which
+ -- may contain either of these). This is of course an approximation,
+ -- but it is conservative and definitely correct.
+
+ -- We only do this at the outer (library) level non-generic packages.
+ -- The reason is simply to cut down on the number of external symbols
+ -- generated, so this is simply an optimization of the efficiency
+ -- of the compilation process. It has no other effect.
+
+ if (Scope (Spec_Id) = Standard_Standard or else Is_Child_Unit (Spec_Id))
+ and then not Is_Generic_Unit (Spec_Id)
+ and then Present (Declarations (N))
+ then
+ Make_Non_Public_Where_Possible : declare
+ Discard : Boolean;
+
+ function Has_Referencer
+ (L : List_Id;
+ Outer : Boolean)
+ return Boolean;
+ -- Traverse the given list of declarations in reverse order.
+ -- Return True as soon as a referencer is reached. Return
+ -- False if none is found. The Outer parameter is True for
+ -- the outer level call, and False for inner level calls for
+ -- nested packages. If Outer is True, then any entities up
+ -- to the point of hitting a referencer get their Is_Public
+ -- flag cleared, so that the entities will be treated as
+ -- static entities in the C sense, and need not have fully
+ -- qualified names. For inner levels, we need all names to
+ -- be fully qualified to deal with the same name appearing
+ -- in parallel packages (right now this is tied to their
+ -- being external).
+
+ --------------------
+ -- Has_Referencer --
+ --------------------
+
+ function Has_Referencer
+ (L : List_Id;
+ Outer : Boolean)
+ return Boolean
+ is
+ D : Node_Id;
+ E : Entity_Id;
+ K : Node_Kind;
+ S : Entity_Id;
+
+ begin
+ if No (L) then
+ return False;
+ end if;
+
+ D := Last (L);
+
+ while Present (D) loop
+ K := Nkind (D);
+
+ if K in N_Body_Stub then
+ return True;
+
+ elsif K = N_Subprogram_Body then
+ if Acts_As_Spec (D) then
+ E := Defining_Entity (D);
+
+ -- An inlined body acts as a referencer. Note also
+ -- that we never reset Is_Public for an inlined
+ -- subprogram. Gigi requires Is_Public to be set.
+
+ -- Note that we test Has_Pragma_Inline here rather
+ -- than Is_Inlined. We are compiling this for a
+ -- client, and it is the client who will decide
+ -- if actual inlining should occur, so we need to
+ -- assume that the procedure could be inlined for
+ -- the purpose of accessing global entities.
+
+ if Has_Pragma_Inline (E) then
+ return True;
+ else
+ Set_Is_Public (E, False);
+ end if;
+
+ else
+ E := Corresponding_Spec (D);
+
+ if Present (E)
+ and then (Is_Generic_Unit (E)
+ or else Has_Pragma_Inline (E)
+ or else Is_Inlined (E))
+ then
+ return True;
+ end if;
+ end if;
+
+ -- Processing for package bodies
+
+ elsif K = N_Package_Body
+ and then Present (Corresponding_Spec (D))
+ then
+ E := Corresponding_Spec (D);
+
+ -- Generic package body is a referencer. It would
+ -- seem that we only have to consider generics that
+ -- can be exported, i.e. where the corresponding spec
+ -- is the spec of the current package, but because of
+ -- nested instantiations, a fully private generic
+ -- body may export other private body entities.
+
+ if Is_Generic_Unit (E) then
+ return True;
+
+ -- For non-generic package body, recurse into body
+ -- unless this is an instance, we ignore instances
+ -- since they cannot have references that affect
+ -- outer entities.
+
+ elsif not Is_Generic_Instance (E) then
+ if Has_Referencer
+ (Declarations (D), Outer => False)
+ then
+ return True;
+ end if;
+ end if;
+
+ -- Processing for package specs, recurse into declarations.
+ -- Again we skip this for the case of generic instances.
+
+ elsif K = N_Package_Declaration then
+ S := Specification (D);
+
+ if not Is_Generic_Unit (Defining_Entity (S)) then
+ if Has_Referencer
+ (Private_Declarations (S), Outer => False)
+ then
+ return True;
+ elsif Has_Referencer
+ (Visible_Declarations (S), Outer => False)
+ then
+ return True;
+ end if;
+ end if;
+
+ -- Objects and exceptions need not be public if we have
+ -- not encountered a referencer so far. We only reset
+ -- the flag for outer level entities that are not
+ -- imported/exported, and which have no interface name.
+
+ elsif K = N_Object_Declaration
+ or else K = N_Exception_Declaration
+ or else K = N_Subprogram_Declaration
+ then
+ E := Defining_Entity (D);
+
+ if Outer
+ and then not Is_Imported (E)
+ and then not Is_Exported (E)
+ and then No (Interface_Name (E))
+ then
+ Set_Is_Public (E, False);
+ end if;
+ end if;
+
+ Prev (D);
+ end loop;
+
+ return False;
+ end Has_Referencer;
+
+ -- Start of processing for Make_Non_Public_Where_Possible
+
+ begin
+ Discard := Has_Referencer (Declarations (N), Outer => True);
+ end Make_Non_Public_Where_Possible;
+ end if;
+
+ -- If expander is not active, then here is where we turn off the
+ -- In_Package_Body flag, otherwise it is turned off at the end of
+ -- the corresponding expansion routine. If this is an instance body,
+ -- we need to qualify names of local entities, because the body may
+ -- have been compiled as a preliminary to another instantiation.
+
+ if not Expander_Active then
+ Set_In_Package_Body (Spec_Id, False);
+
+ if Is_Generic_Instance (Spec_Id)
+ and then Operating_Mode = Generate_Code
+ then
+ Qualify_Entity_Names (N);
+ end if;
+ end if;
+ end Analyze_Package_Body;
+
+ ---------------------------------
+ -- Analyze_Package_Declaration --
+ ---------------------------------
+
+ procedure Analyze_Package_Declaration (N : Node_Id) is
+ Id : constant Node_Id := Defining_Entity (N);
+ PF : Boolean;
+
+ begin
+ Generate_Definition (Id);
+ Enter_Name (Id);
+ Set_Ekind (Id, E_Package);
+ Set_Etype (Id, Standard_Void_Type);
+ New_Scope (Id);
+
+ PF := Is_Pure (Enclosing_Lib_Unit_Entity);
+ Set_Is_Pure (Id, PF);
+
+ Set_Categorization_From_Pragmas (N);
+
+ if Debug_Flag_C then
+ Write_Str ("==== Compiling package spec ");
+ Write_Name (Chars (Id));
+ Write_Str (" from ");
+ Write_Location (Sloc (N));
+ Write_Eol;
+ end if;
+
+ Analyze (Specification (N));
+ Validate_Categorization_Dependency (N, Id);
+ End_Package_Scope (Id);
+
+ -- For a compilation unit, indicate whether it needs a body, and
+ -- whether elaboration warnings may be meaningful on it.
+
+ if Nkind (Parent (N)) = N_Compilation_Unit then
+ Set_Body_Required (Parent (N), Unit_Requires_Body (Id));
+
+ if not Body_Required (Parent (N)) then
+ Set_Suppress_Elaboration_Warnings (Id);
+ end if;
+
+ Validate_RT_RAT_Component (N);
+ end if;
+
+ -- Clear Not_Source_Assigned on all variables in the package spec,
+ -- because at this stage some client, or the body, or a child package,
+ -- may modify variables in the declaration. Note that we wait till now
+ -- to reset these flags, because during analysis of the declaration,
+ -- the flags correctly indicated the status up to that point. We
+ -- similarly clear any Is_True_Constant indications.
+
+ declare
+ E : Entity_Id;
+
+ begin
+ E := First_Entity (Id);
+ while Present (E) loop
+ if Ekind (E) = E_Variable then
+ Set_Not_Source_Assigned (E, False);
+ Set_Is_True_Constant (E, False);
+ end if;
+
+ Next_Entity (E);
+ end loop;
+ end;
+ end Analyze_Package_Declaration;
+
+ -----------------------------------
+ -- Analyze_Package_Specification --
+ -----------------------------------
+
+ procedure Analyze_Package_Specification (N : Node_Id) is
+ Id : constant Entity_Id := Defining_Entity (N);
+ Orig_Decl : constant Node_Id := Original_Node (Parent (N));
+ Vis_Decls : constant List_Id := Visible_Declarations (N);
+ Priv_Decls : constant List_Id := Private_Declarations (N);
+ E : Entity_Id;
+ L : Entity_Id;
+ Public_Child : Boolean := False;
+
+ function Is_Public_Child (Child, Unit : Entity_Id) return Boolean;
+ -- Child and Unit are entities of compilation units. True if Child
+ -- is a public child of Parent as defined in 10.1.1
+
+ function Is_Public_Child (Child, Unit : Entity_Id) return Boolean is
+ begin
+ if not Is_Private_Descendant (Child) then
+ return True;
+ else
+ if Child = Unit then
+ return not Private_Present (
+ Parent (Unit_Declaration_Node (Child)));
+ else
+ return Is_Public_Child (Scope (Child), Unit);
+ end if;
+ end if;
+ end Is_Public_Child;
+
+ -- Start of processing for Analyze_Package_Specification
+
+ begin
+ if Present (Vis_Decls) then
+ Analyze_Declarations (Vis_Decls);
+ end if;
+
+ -- Verify that incomplete types have received full declarations.
+
+ E := First_Entity (Id);
+
+ while Present (E) loop
+ if Ekind (E) = E_Incomplete_Type
+ and then No (Full_View (E))
+ then
+ Error_Msg_N ("no declaration in visible part for incomplete}", E);
+ end if;
+
+ Next_Entity (E);
+ end loop;
+
+ if Is_Remote_Call_Interface (Id)
+ and then Nkind (Parent (Parent (N))) = N_Compilation_Unit
+ then
+ Validate_RCI_Declarations (Id);
+ end if;
+
+ -- Save global references in the visible declarations, before
+ -- installing private declarations of parent unit if there is one,
+ -- because the privacy status of types defined in the parent will
+ -- change. This is only relevant for generic child units, but is
+ -- done in all cases for uniformity.
+
+ if Ekind (Id) = E_Generic_Package
+ and then Nkind (Orig_Decl) = N_Generic_Package_Declaration
+ then
+ declare
+ Orig_Spec : constant Node_Id := Specification (Orig_Decl);
+ Save_Priv : constant List_Id := Private_Declarations (Orig_Spec);
+
+ begin
+ Set_Private_Declarations (Orig_Spec, Empty_List);
+ Save_Global_References (Orig_Decl);
+ Set_Private_Declarations (Orig_Spec, Save_Priv);
+ end;
+ end if;
+
+ -- If package is a public child unit, then make the private
+ -- declarations of the parent visible.
+
+ if Present (Parent_Spec (Parent (N))) then
+ declare
+ Par : Entity_Id := Id;
+ Pack_Decl : Node_Id;
+
+ begin
+ while Scope (Par) /= Standard_Standard
+ and then Is_Public_Child (Id, Par)
+ loop
+ Public_Child := True;
+ Par := Scope (Par);
+ Install_Private_Declarations (Par);
+ Pack_Decl := Unit_Declaration_Node (Par);
+ Set_Use (Private_Declarations (Specification (Pack_Decl)));
+ end loop;
+ end;
+ end if;
+
+ -- Analyze private part if present. The flag In_Private_Part is
+ -- reset in End_Package_Scope.
+
+ L := Last_Entity (Id);
+
+ if Present (Priv_Decls) then
+ L := Last_Entity (Id);
+ Set_In_Private_Part (Id);
+
+ -- Upon entering a public child's private part, it may be
+ -- necessary to declare subprograms that were derived in
+ -- the package visible part but not yet made visible.
+
+ if Public_Child then
+ Declare_Inherited_Private_Subprograms (Id);
+ end if;
+
+ Analyze_Declarations (Priv_Decls);
+
+ -- The first private entity is the immediate follower of the last
+ -- visible entity, if there was one.
+
+ if Present (L) then
+ Set_First_Private_Entity (Id, Next_Entity (L));
+ else
+ Set_First_Private_Entity (Id, First_Entity (Id));
+ end if;
+
+ -- There may be inherited private subprograms that need to be
+ -- declared, even in the absence of an explicit private part.
+ -- If there are any public declarations in the package and
+ -- the package is a public child unit, then an implicit private
+ -- part is assumed.
+
+ elsif Present (L) and then Public_Child then
+ Set_In_Private_Part (Id);
+ Declare_Inherited_Private_Subprograms (Id);
+ Set_First_Private_Entity (Id, Next_Entity (L));
+ end if;
+
+ -- Check rule of 3.6(11), which in general requires
+ -- waiting till all full types have been seen.
+
+ E := First_Entity (Id);
+ while Present (E) loop
+ if Ekind (E) = E_Record_Type or else Ekind (E) = E_Array_Type then
+ Check_Aliased_Component_Types (E);
+ end if;
+
+ Next_Entity (E);
+ end loop;
+
+ if Ekind (Id) = E_Generic_Package
+ and then Nkind (Orig_Decl) = N_Generic_Package_Declaration
+ and then Present (Priv_Decls)
+ then
+ -- Save global references in private declarations, ignoring the
+ -- visible declarations that were processed earlier.
+
+ declare
+ Orig_Spec : constant Node_Id := Specification (Orig_Decl);
+ Save_Vis : constant List_Id := Visible_Declarations (Orig_Spec);
+ Save_Form : constant List_Id :=
+ Generic_Formal_Declarations (Orig_Decl);
+
+ begin
+ Set_Visible_Declarations (Orig_Spec, Empty_List);
+ Set_Generic_Formal_Declarations (Orig_Decl, Empty_List);
+ Save_Global_References (Orig_Decl);
+ Set_Generic_Formal_Declarations (Orig_Decl, Save_Form);
+ Set_Visible_Declarations (Orig_Spec, Save_Vis);
+ end;
+ end if;
+
+ Process_End_Label (N, 'e');
+ end Analyze_Package_Specification;
+
+ --------------------------------------
+ -- Analyze_Private_Type_Declaration --
+ --------------------------------------
+
+ procedure Analyze_Private_Type_Declaration (N : Node_Id) is
+ PF : constant Boolean := Is_Pure (Enclosing_Lib_Unit_Entity);
+ Id : Entity_Id := Defining_Identifier (N);
+
+ begin
+ Generate_Definition (Id);
+ Set_Is_Pure (Id, PF);
+ Init_Size_Align (Id);
+
+ if (Ekind (Current_Scope) /= E_Package
+ and then Ekind (Current_Scope) /= E_Generic_Package)
+ or else In_Private_Part (Current_Scope)
+ then
+ Error_Msg_N ("invalid context for private declaration", N);
+ end if;
+
+ New_Private_Type (N, Id, N);
+ Set_Depends_On_Private (Id);
+ Set_Has_Delayed_Freeze (Id);
+
+ end Analyze_Private_Type_Declaration;
+
+ -------------------------------------------
+ -- Declare_Inherited_Private_Subprograms --
+ -------------------------------------------
+
+ procedure Declare_Inherited_Private_Subprograms (Id : Entity_Id) is
+ E : Entity_Id;
+
+ begin
+ E := First_Entity (Id);
+
+ while Present (E) loop
+
+ -- If the entity is a nonprivate type extension whose parent
+ -- type is declared in an open scope, then the type may have
+ -- inherited operations that now need to be made visible.
+ -- Ditto if the entity is a formal derived type in a child unit.
+
+ if Is_Tagged_Type (E)
+ and then
+ ((Is_Derived_Type (E) and then not Is_Private_Type (E))
+ or else
+ (Nkind (Parent (E)) = N_Private_Extension_Declaration
+ and then Is_Generic_Type (E)))
+ and then In_Open_Scopes (Scope (Etype (E)))
+ and then E = Base_Type (E)
+ then
+ declare
+ Op_List : constant Elist_Id := Primitive_Operations (E);
+ Op_Elmt : Elmt_Id := First_Elmt (Op_List);
+ Op_Elmt_2 : Elmt_Id;
+ Prim_Op : Entity_Id;
+ New_Op : Entity_Id := Empty;
+ Parent_Subp : Entity_Id;
+ Found_Explicit : Boolean;
+ Decl_Privates : Boolean := False;
+
+ begin
+ while Present (Op_Elmt) loop
+ Prim_Op := Node (Op_Elmt);
+
+ -- If the primitive operation is an implicit operation
+ -- with an internal name whose parent operation has
+ -- a normal name, then we now need to either declare the
+ -- operation (i.e., make it visible), or replace it
+ -- by an overriding operation if one exists.
+
+ if Present (Alias (Prim_Op))
+ and then not Comes_From_Source (Prim_Op)
+ and then Is_Internal_Name (Chars (Prim_Op))
+ and then not Is_Internal_Name (Chars (Alias (Prim_Op)))
+ then
+ Parent_Subp := Alias (Prim_Op);
+
+ Found_Explicit := False;
+ Op_Elmt_2 := Next_Elmt (Op_Elmt);
+ while Present (Op_Elmt_2) loop
+ if Chars (Node (Op_Elmt_2)) = Chars (Parent_Subp)
+ and then Type_Conformant (Prim_Op, Node (Op_Elmt_2))
+ then
+ -- The private inherited operation has been
+ -- overridden by an explicit subprogram, so
+ -- change the private op's list element to
+ -- designate the explicit so the explicit
+ -- one will get the right dispatching slot.
+
+ New_Op := Node (Op_Elmt_2);
+ Replace_Elmt (Op_Elmt, New_Op);
+ Remove_Elmt (Op_List, Op_Elmt_2);
+ Found_Explicit := True;
+ Decl_Privates := True;
+ exit;
+ end if;
+
+ Next_Elmt (Op_Elmt_2);
+ end loop;
+
+ if not Found_Explicit then
+ Derive_Subprogram
+ (New_Op, Alias (Prim_Op), E, Etype (E));
+
+ pragma Assert
+ (Is_Dispatching_Operation (New_Op)
+ and then Node (Last_Elmt (Op_List)) = New_Op);
+
+ -- Substitute the new operation for the old one
+ -- in the type's primitive operations list. Since
+ -- the new operation was also just added to the end
+ -- of list, the last element must be removed.
+
+ -- (Question: is there a simpler way of declaring
+ -- the operation, say by just replacing the name
+ -- of the earlier operation, reentering it in the
+ -- in the symbol table (how?), and marking it as
+ -- private???)
+
+ Replace_Elmt (Op_Elmt, New_Op);
+ Remove_Last_Elmt (Op_List);
+ Decl_Privates := True;
+ end if;
+ end if;
+
+ Next_Elmt (Op_Elmt);
+ end loop;
+
+ -- The type's DT attributes need to be recalculated
+ -- in the case where private dispatching operations
+ -- have been added or overridden. Normally this action
+ -- occurs during type freezing, but we force it here
+ -- since the type may already have been frozen (e.g.,
+ -- if the type's package has an empty private part).
+ -- This can only be done if expansion is active, otherwise
+ -- Tag may not be present.
+
+ if Decl_Privates
+ and then Expander_Active
+ then
+ Set_All_DT_Position (E);
+ end if;
+ end;
+ end if;
+
+ Next_Entity (E);
+ end loop;
+ end Declare_Inherited_Private_Subprograms;
+
+ -----------------------
+ -- End_Package_Scope --
+ -----------------------
+
+ procedure End_Package_Scope (P : Entity_Id) is
+ begin
+ Uninstall_Declarations (P);
+ Pop_Scope;
+ end End_Package_Scope;
+
+ ---------------------------
+ -- Exchange_Declarations --
+ ---------------------------
+
+ procedure Exchange_Declarations (Id : Entity_Id) is
+ Full_Id : constant Entity_Id := Full_View (Id);
+ H1 : constant Entity_Id := Homonym (Id);
+ Next1 : constant Entity_Id := Next_Entity (Id);
+ H2 : Entity_Id;
+ Next2 : Entity_Id;
+
+ begin
+ -- If missing full declaration for type, nothing to exchange
+
+ if No (Full_Id) then
+ return;
+ end if;
+
+ -- Otherwise complete the exchange, and preserve semantic links
+
+ Next2 := Next_Entity (Full_Id);
+ H2 := Homonym (Full_Id);
+
+ -- Reset full declaration pointer to reflect the switched entities
+ -- and readjust the next entity chains.
+
+ Exchange_Entities (Id, Full_Id);
+
+ Set_Next_Entity (Id, Next1);
+ Set_Homonym (Id, H1);
+
+ Set_Full_View (Full_Id, Id);
+ Set_Next_Entity (Full_Id, Next2);
+ Set_Homonym (Full_Id, H2);
+ end Exchange_Declarations;
+
+ ----------------------------------
+ -- Install_Composite_Operations --
+ ----------------------------------
+
+ procedure Install_Composite_Operations (P : Entity_Id) is
+ Id : Entity_Id;
+
+ begin
+ Id := First_Entity (P);
+
+ while Present (Id) loop
+
+ if Is_Type (Id)
+ and then (Is_Limited_Composite (Id)
+ or else Is_Private_Composite (Id))
+ and then No (Private_Component (Id))
+ then
+ Set_Is_Limited_Composite (Id, False);
+ Set_Is_Private_Composite (Id, False);
+ end if;
+
+ Next_Entity (Id);
+ end loop;
+ end Install_Composite_Operations;
+
+ ----------------------------
+ -- Install_Package_Entity --
+ ----------------------------
+
+ procedure Install_Package_Entity (Id : Entity_Id) is
+ begin
+ if not Is_Internal (Id) then
+ if Debug_Flag_E then
+ Write_Str ("Install: ");
+ Write_Name (Chars (Id));
+ Write_Eol;
+ end if;
+
+ if not Is_Child_Unit (Id) then
+ Set_Is_Immediately_Visible (Id);
+ end if;
+
+ end if;
+ end Install_Package_Entity;
+
+ ----------------------------------
+ -- Install_Private_Declarations --
+ ----------------------------------
+
+ procedure Install_Private_Declarations (P : Entity_Id) is
+ Id : Entity_Id;
+ Priv_Elmt : Elmt_Id;
+ Priv : Entity_Id;
+ Full : Entity_Id;
+
+ begin
+ -- First exchange declarations for private types, so that the
+ -- full declaration is visible. For each private type, we check
+ -- its Private_Dependents list and also exchange any subtypes of
+ -- or derived types from it. Finally, if this is a Taft amendment
+ -- type, the incomplete declaration is irrelevant, and we want to
+ -- link the eventual full declaration with the original private
+ -- one so we also skip the exchange.
+
+ Id := First_Entity (P);
+
+ while Present (Id) and then Id /= First_Private_Entity (P) loop
+
+ if Is_Private_Base_Type (Id)
+ and then Comes_From_Source (Full_View (Id))
+ and then Present (Full_View (Id))
+ and then Scope (Full_View (Id)) = Scope (Id)
+ and then Ekind (Full_View (Id)) /= E_Incomplete_Type
+ then
+ Priv_Elmt := First_Elmt (Private_Dependents (Id));
+
+ -- If there is a use-type clause on the private type, set the
+ -- full view accordingly.
+
+ Set_In_Use (Full_View (Id), In_Use (Id));
+ Full := Full_View (Id);
+
+ if Is_Private_Base_Type (Full)
+ and then Has_Private_Declaration (Full)
+ and then Nkind (Parent (Full)) = N_Full_Type_Declaration
+ and then In_Open_Scopes (Scope (Etype (Full)))
+ and then In_Package_Body (Current_Scope)
+ and then not Is_Private_Type (Etype (Full))
+ then
+ -- This is the completion of a private type by a derivation
+ -- from another private type which is not private anymore. This
+ -- can only happen in a package nested within a child package,
+ -- when the parent type is defined in the parent unit. At this
+ -- point the current type is not private either, and we have to
+ -- install the underlying full view, which is now visible.
+
+ if No (Full_View (Full))
+ and then Present (Underlying_Full_View (Full))
+ then
+ Set_Full_View (Id, Underlying_Full_View (Full));
+ Set_Underlying_Full_View (Full, Empty);
+ Set_Is_Frozen (Full_View (Id));
+ end if;
+ end if;
+
+ Exchange_Declarations (Id);
+ Set_Is_Immediately_Visible (Id);
+
+ while Present (Priv_Elmt) loop
+ Priv := Node (Priv_Elmt);
+
+ -- Before the exchange, verify that the presence of the
+ -- Full_View field. It will be empty if the entity
+ -- has already been installed due to a previous call.
+
+ if Present (Full_View (Priv))
+ and then Is_Visible_Dependent (Priv)
+ then
+
+ -- For each subtype that is swapped, we also swap the
+ -- reference to it in Private_Dependents, to allow access
+ -- to it when we swap them out in End_Package_Scope.
+
+ Replace_Elmt (Priv_Elmt, Full_View (Priv));
+ Exchange_Declarations (Priv);
+ Set_Is_Immediately_Visible
+ (Priv, In_Open_Scopes (Scope (Priv)));
+ Set_Is_Potentially_Use_Visible
+ (Priv, Is_Potentially_Use_Visible (Node (Priv_Elmt)));
+ end if;
+
+ Next_Elmt (Priv_Elmt);
+ end loop;
+
+ null;
+ end if;
+
+ Next_Entity (Id);
+ end loop;
+
+ -- Next make other declarations in the private part visible as well.
+
+ Id := First_Private_Entity (P);
+
+ while Present (Id) loop
+ Install_Package_Entity (Id);
+ Next_Entity (Id);
+ end loop;
+
+ -- Indicate that the private part is currently visible, so it can be
+ -- properly reset on exit.
+
+ Set_In_Private_Part (P);
+ end Install_Private_Declarations;
+
+ ----------------------------------
+ -- Install_Visible_Declarations --
+ ----------------------------------
+
+ procedure Install_Visible_Declarations (P : Entity_Id) is
+ Id : Entity_Id;
+
+ begin
+ Id := First_Entity (P);
+
+ while Present (Id) and then Id /= First_Private_Entity (P) loop
+ Install_Package_Entity (Id);
+ Next_Entity (Id);
+ end loop;
+ end Install_Visible_Declarations;
+
+ ----------------------
+ -- Is_Fully_Visible --
+ ----------------------
+
+ -- The full declaration of a private type is visible in the private
+ -- part of the package declaration, and in the package body, at which
+ -- point the full declaration must have been given.
+
+ function Is_Fully_Visible (Type_Id : Entity_Id) return Boolean is
+ S : constant Entity_Id := Scope (Type_Id);
+
+ begin
+ if Is_Generic_Type (Type_Id) then
+ return False;
+
+ elsif In_Private_Part (S) then
+ return Present (Full_View (Type_Id));
+
+ else
+ return In_Package_Body (S);
+ end if;
+ end Is_Fully_Visible;
+
+ --------------------------
+ -- Is_Private_Base_Type --
+ --------------------------
+
+ function Is_Private_Base_Type (E : Entity_Id) return Boolean is
+ begin
+ return Ekind (E) = E_Private_Type
+ or else Ekind (E) = E_Limited_Private_Type
+ or else Ekind (E) = E_Record_Type_With_Private;
+ end Is_Private_Base_Type;
+
+ --------------------------
+ -- Is_Visible_Dependent --
+ --------------------------
+
+ function Is_Visible_Dependent (Dep : Entity_Id) return Boolean
+ is
+ S : constant Entity_Id := Scope (Dep);
+
+ begin
+ -- Renamings created for actual types have the visibility of the
+ -- actual.
+
+ if Ekind (S) = E_Package
+ and then Is_Generic_Instance (S)
+ and then (Is_Generic_Actual_Type (Dep)
+ or else Is_Generic_Actual_Type (Full_View (Dep)))
+ then
+ return True;
+
+ elsif not (Is_Derived_Type (Dep))
+ and then Is_Derived_Type (Full_View (Dep))
+ then
+ return In_Open_Scopes (S);
+ else
+ return True;
+ end if;
+ end Is_Visible_Dependent;
+
+ ----------------------------
+ -- May_Need_Implicit_Body --
+ ----------------------------
+
+ procedure May_Need_Implicit_Body (E : Entity_Id) is
+ P : constant Node_Id := Unit_Declaration_Node (E);
+ S : constant Node_Id := Parent (P);
+ B : Node_Id;
+ Decls : List_Id;
+
+ begin
+ if not Has_Completion (E)
+ and then Nkind (P) = N_Package_Declaration
+ and then Present (Activation_Chain_Entity (P))
+ then
+ B :=
+ Make_Package_Body (Sloc (E),
+ Defining_Unit_Name => Make_Defining_Identifier (Sloc (E),
+ Chars => Chars (E)),
+ Declarations => New_List);
+
+ if Nkind (S) = N_Package_Specification then
+ if Present (Private_Declarations (S)) then
+ Decls := Private_Declarations (S);
+ else
+ Decls := Visible_Declarations (S);
+ end if;
+ else
+ Decls := Declarations (S);
+ end if;
+
+ Append (B, Decls);
+ Analyze (B);
+ end if;
+ end May_Need_Implicit_Body;
+
+ ----------------------
+ -- New_Private_Type --
+ ----------------------
+
+ procedure New_Private_Type (N : Node_Id; Id : Entity_Id; Def : Node_Id) is
+ begin
+ Enter_Name (Id);
+
+ if Limited_Present (Def) then
+ Set_Ekind (Id, E_Limited_Private_Type);
+ else
+ Set_Ekind (Id, E_Private_Type);
+ end if;
+
+ Set_Etype (Id, Id);
+ Set_Has_Delayed_Freeze (Id);
+ Set_Is_First_Subtype (Id);
+ Init_Size_Align (Id);
+
+ Set_Is_Constrained (Id,
+ No (Discriminant_Specifications (N))
+ and then not Unknown_Discriminants_Present (N));
+
+ Set_Discriminant_Constraint (Id, No_Elist);
+ Set_Girder_Constraint (Id, No_Elist);
+
+ if Present (Discriminant_Specifications (N)) then
+ New_Scope (Id);
+ Process_Discriminants (N);
+ End_Scope;
+
+ elsif Unknown_Discriminants_Present (N) then
+ Set_Has_Unknown_Discriminants (Id);
+ end if;
+
+ Set_Private_Dependents (Id, New_Elmt_List);
+
+ if Tagged_Present (Def) then
+ Set_Is_Tagged_Type (Id, True);
+ Set_Ekind (Id, E_Record_Type_With_Private);
+ Make_Class_Wide_Type (Id);
+ Set_Primitive_Operations (Id, New_Elmt_List);
+ Set_Is_Abstract (Id, Abstract_Present (Def));
+ Set_Is_Limited_Record (Id, Limited_Present (Def));
+ Set_Has_Delayed_Freeze (Id, True);
+
+ elsif Abstract_Present (Def) then
+ Error_Msg_N ("only a tagged type can be abstract", N);
+ end if;
+ end New_Private_Type;
+
+ ------------------------------
+ -- Preserve_Full_Attributes --
+ ------------------------------
+
+ procedure Preserve_Full_Attributes (Priv, Full : Entity_Id) is
+ Priv_Is_Base_Type : constant Boolean := Priv = Base_Type (Priv);
+
+ begin
+ Set_Size_Info (Priv, (Full));
+ Set_RM_Size (Priv, RM_Size (Full));
+ Set_Size_Known_At_Compile_Time (Priv, Size_Known_At_Compile_Time
+ (Full));
+
+ if Priv_Is_Base_Type then
+ Set_Is_Controlled (Priv, Is_Controlled (Base_Type (Full)));
+ Set_Has_Task (Priv, Has_Task (Base_Type (Full)));
+ Set_Finalize_Storage_Only (Priv, Finalize_Storage_Only
+ (Base_Type (Full)));
+ Set_Has_Controlled_Component (Priv, Has_Controlled_Component
+ (Base_Type (Full)));
+ end if;
+
+ Set_Freeze_Node (Priv, Freeze_Node (Full));
+
+ if Is_Tagged_Type (Priv)
+ and then Is_Tagged_Type (Full)
+ and then not Error_Posted (Full)
+ then
+ if Priv_Is_Base_Type then
+ Set_Access_Disp_Table (Priv, Access_Disp_Table
+ (Base_Type (Full)));
+ end if;
+
+ Set_First_Entity (Priv, First_Entity (Full));
+ Set_Last_Entity (Priv, Last_Entity (Full));
+ end if;
+ end Preserve_Full_Attributes;
+
+ ----------------------------
+ -- Uninstall_Declarations --
+ ----------------------------
+
+ procedure Uninstall_Declarations (P : Entity_Id) is
+ Id : Entity_Id;
+ Decl : Node_Id := Unit_Declaration_Node (P);
+ Full : Entity_Id;
+ Priv_Elmt : Elmt_Id;
+ Priv_Sub : Entity_Id;
+
+ function Type_In_Use (T : Entity_Id) return Boolean;
+ -- Check whether type or base type appear in an active use_type clause.
+
+ function Type_In_Use (T : Entity_Id) return Boolean is
+ begin
+ return Scope (Base_Type (T)) = P
+ and then (In_Use (T) or else In_Use (Base_Type (T)));
+ end Type_In_Use;
+
+ -- Start of processing for Uninstall_Declarations
+
+ begin
+ Id := First_Entity (P);
+
+ while Present (Id) and then Id /= First_Private_Entity (P) loop
+ if Debug_Flag_E then
+ Write_Str ("unlinking visible entity ");
+ Write_Int (Int (Id));
+ Write_Eol;
+ end if;
+
+ -- On exit from the package scope, we must preserve the visibility
+ -- established by use clauses in the current scope. Two cases:
+
+ -- a) If the entity is an operator, it may be a primitive operator of
+ -- a type for which there is a visible use-type clause.
+
+ -- b) for other entities, their use-visibility is determined by a
+ -- visible use clause for the package itself. For a generic instance,
+ -- the instantiation of the formals appears in the visible part,
+ -- but the formals are private and remain so.
+
+ if Ekind (Id) = E_Function
+ and then Is_Operator_Symbol_Name (Chars (Id))
+ and then not Is_Hidden (Id)
+ then
+ Set_Is_Potentially_Use_Visible (Id,
+ In_Use (P)
+ or else Type_In_Use (Etype (Id))
+ or else Type_In_Use (Etype (First_Formal (Id)))
+ or else (Present (Next_Formal (First_Formal (Id)))
+ and then
+ Type_In_Use
+ (Etype (Next_Formal (First_Formal (Id))))));
+ else
+ Set_Is_Potentially_Use_Visible (Id,
+ In_Use (P) and not Is_Hidden (Id));
+ end if;
+
+ -- Local entities are not immediately visible outside of the package.
+
+ Set_Is_Immediately_Visible (Id, False);
+
+ if Is_Tagged_Type (Id) and then Ekind (Id) = E_Record_Type then
+ Check_Abstract_Overriding (Id);
+ end if;
+
+ if (Ekind (Id) = E_Private_Type
+ or else Ekind (Id) = E_Limited_Private_Type)
+ and then No (Full_View (Id))
+ and then not Is_Generic_Type (Id)
+ and then not Is_Derived_Type (Id)
+ then
+ Error_Msg_N ("missing full declaration for private type&", Id);
+
+ elsif Ekind (Id) = E_Record_Type_With_Private
+ and then not Is_Generic_Type (Id)
+ and then No (Full_View (Id))
+ then
+ if Nkind (Parent (Id)) = N_Private_Type_Declaration then
+ Error_Msg_N ("missing full declaration for private type&", Id);
+ else
+ Error_Msg_N
+ ("missing full declaration for private extension", Id);
+ end if;
+
+ elsif Ekind (Id) = E_Constant
+ and then No (Constant_Value (Id))
+ and then No (Full_View (Id))
+ and then not Is_Imported (Id)
+ and then (Nkind (Parent (Id)) /= N_Object_Declaration
+ or else not No_Initialization (Parent (Id)))
+ then
+ Error_Msg_N ("missing full declaration for deferred constant", Id);
+ end if;
+
+ Next_Entity (Id);
+ end loop;
+
+ -- If the specification was installed as the parent of a public child
+ -- unit, the private declarations were not installed, and there is
+ -- nothing to do.
+
+ if not In_Private_Part (P) then
+ return;
+ else
+ Set_In_Private_Part (P, False);
+ end if;
+
+ -- Make private entities invisible and exchange full and private
+ -- declarations for private types.
+
+ while Present (Id) loop
+ if Debug_Flag_E then
+ Write_Str ("unlinking private entity ");
+ Write_Int (Int (Id));
+ Write_Eol;
+ end if;
+
+ if Is_Tagged_Type (Id) and then Ekind (Id) = E_Record_Type then
+ Check_Abstract_Overriding (Id);
+ end if;
+
+ Set_Is_Immediately_Visible (Id, False);
+
+ if Is_Private_Base_Type (Id)
+ and then Present (Full_View (Id))
+ then
+ Full := Full_View (Id);
+
+ -- If the partial view is not declared in the visible part
+ -- of the package (as is the case when it is a type derived
+ -- from some other private type in the private part if the
+ -- current package), no exchange takes place.
+
+ if No (Parent (Id))
+ or else List_Containing (Parent (Id))
+ /= Visible_Declarations (Specification (Decl))
+ then
+ goto Next_Id;
+ end if;
+
+ -- The entry in the private part points to the full declaration,
+ -- which is currently visible. Exchange them so only the private
+ -- type declaration remains accessible, and link private and
+ -- full declaration in the opposite direction. Before the actual
+ -- exchange, we copy back attributes of the full view that
+ -- must be available to the partial view too.
+
+ Preserve_Full_Attributes (Id, Full);
+
+ Set_Is_Potentially_Use_Visible (Id, In_Use (P));
+
+ if Is_Indefinite_Subtype (Full)
+ and then not Is_Indefinite_Subtype (Id)
+ then
+ Error_Msg_N
+ ("full view of type must be definite subtype", Full);
+ end if;
+
+ Priv_Elmt := First_Elmt (Private_Dependents (Id));
+ Exchange_Declarations (Id);
+
+ -- Swap out the subtypes and derived types of Id that were
+ -- compiled in this scope, or installed previously by
+ -- Install_Private_Declarations.
+ -- Before we do the swap, we verify the presence of the
+ -- Full_View field which may be empty due to a swap by
+ -- a previous call to End_Package_Scope (e.g. from the
+ -- freezing mechanism).
+
+ while Present (Priv_Elmt) loop
+ Priv_Sub := Node (Priv_Elmt);
+
+ if Present (Full_View (Priv_Sub)) then
+
+ if Scope (Priv_Sub) = P
+ or else not In_Open_Scopes (Scope (Priv_Sub))
+ then
+ Set_Is_Immediately_Visible (Priv_Sub, False);
+ end if;
+
+ if Is_Visible_Dependent (Priv_Sub) then
+ Preserve_Full_Attributes
+ (Priv_Sub, Full_View (Priv_Sub));
+ Replace_Elmt (Priv_Elmt, Full_View (Priv_Sub));
+ Exchange_Declarations (Priv_Sub);
+ end if;
+ end if;
+
+ Next_Elmt (Priv_Elmt);
+ end loop;
+
+ elsif Ekind (Id) = E_Incomplete_Type
+ and then No (Full_View (Id))
+ then
+ -- Mark Taft amendment types
+
+ Set_Has_Completion_In_Body (Id);
+
+ elsif not Is_Child_Unit (Id)
+ and then (not Is_Private_Type (Id)
+ or else No (Full_View (Id)))
+ then
+ Set_Is_Hidden (Id);
+ Set_Is_Potentially_Use_Visible (Id, False);
+ end if;
+
+ <<Next_Id>>
+ Next_Entity (Id);
+ end loop;
+
+ end Uninstall_Declarations;
+
+ ------------------------
+ -- Unit_Requires_Body --
+ ------------------------
+
+ function Unit_Requires_Body (P : Entity_Id) return Boolean is
+ E : Entity_Id;
+
+ begin
+ -- Imported entity never requires body. Right now, only
+ -- subprograms can be imported, but perhaps in the future
+ -- we will allow import of packages.
+
+ if Is_Imported (P) then
+ return False;
+
+ -- Body required if library package with pragma Elaborate_Body
+
+ elsif Has_Pragma_Elaborate_Body (P) then
+ return True;
+
+ -- Body required if subprogram
+
+ elsif (Is_Subprogram (P)
+ or else
+ Ekind (P) = E_Generic_Function
+ or else
+ Ekind (P) = E_Generic_Procedure)
+ then
+ return True;
+
+ -- Treat a block as requiring a body
+
+ elsif Ekind (P) = E_Block then
+ return True;
+
+ elsif Ekind (P) = E_Package
+ and then Nkind (Parent (P)) = N_Package_Specification
+ and then Present (Generic_Parent (Parent (P)))
+ then
+ declare
+ G_P : Entity_Id := Generic_Parent (Parent (P));
+
+ begin
+ if Has_Pragma_Elaborate_Body (G_P) then
+ return True;
+ end if;
+ end;
+ end if;
+
+ -- Otherwise search entity chain for entity requiring completion.
+
+ E := First_Entity (P);
+ while Present (E) loop
+
+ -- Always ignore child units. Child units get added to the entity
+ -- list of a parent unit, but are not original entities of the
+ -- parent, and so do not affect whether the parent needs a body.
+
+ if Is_Child_Unit (E) then
+ null;
+
+ -- Otherwise test to see if entity requires a completion
+
+ elsif (Is_Overloadable (E)
+ and then Ekind (E) /= E_Enumeration_Literal
+ and then Ekind (E) /= E_Operator
+ and then not Is_Abstract (E)
+ and then not Has_Completion (E))
+
+ or else
+ (Ekind (E) = E_Package
+ and then E /= P
+ and then not Has_Completion (E)
+ and then Unit_Requires_Body (E))
+
+ or else
+ (Ekind (E) = E_Incomplete_Type and then No (Full_View (E)))
+
+ or else
+ ((Ekind (E) = E_Task_Type or else
+ Ekind (E) = E_Protected_Type)
+ and then not Has_Completion (E))
+
+ or else
+ (Ekind (E) = E_Generic_Package and then E /= P
+ and then not Has_Completion (E)
+ and then Unit_Requires_Body (E))
+
+ or else
+ (Ekind (E) = E_Generic_Function
+ and then not Has_Completion (E))
+
+ or else
+ (Ekind (E) = E_Generic_Procedure
+ and then not Has_Completion (E))
+
+ then
+ return True;
+
+ -- Entity that does not require completion
+
+ else
+ null;
+ end if;
+
+ Next_Entity (E);
+ end loop;
+
+ return False;
+ end Unit_Requires_Body;
+
+end Sem_Ch7;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S E M _ C H 7 --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.19 $ --
+-- --
+-- Copyright (C) 1992,1993,1994 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 Types; use Types;
+package Sem_Ch7 is
+
+ procedure Analyze_Package_Body (N : Node_Id);
+ procedure Analyze_Package_Declaration (N : Node_Id);
+ procedure Analyze_Package_Specification (N : Node_Id);
+ procedure Analyze_Private_Type_Declaration (N : Node_Id);
+
+ procedure End_Package_Scope (P : Entity_Id);
+ -- Calls Uninstall_Declarations, and then pops the scope stack.
+
+ procedure Exchange_Declarations (Id : Entity_Id);
+ -- Exchange private and full declaration on entry/exit from a package
+ -- declaration or body. The semantic links of the respective nodes
+ -- are preserved in the exchange.
+
+ procedure Install_Visible_Declarations (P : Entity_Id);
+ procedure Install_Private_Declarations (P : Entity_Id);
+
+ -- On entrance to a package body, make declarations in package spec
+ -- immediately visible.
+
+ -- When compiling the body of a package, both routines are called in
+ -- succession. When compiling the body of a child package, the call
+ -- to Install_Private_Declaration is immediate for private children,
+ -- but is deffered until the compilation of the private part of the
+ -- child for public child packages.
+
+ procedure Install_Package_Entity (Id : Entity_Id);
+ -- Basic procedure for the previous two. Places one entity on its
+ -- visibility chain, and recurses on the visible part if the entity
+ -- is an inner package.
+
+ function Unit_Requires_Body (P : Entity_Id) return Boolean;
+ -- Check if a unit requires a body. A specification requires a body
+ -- if it contains declarations that require completion in a body.
+
+ procedure May_Need_Implicit_Body (E : Entity_Id);
+ -- If a package declaration contains tasks and does not require a
+ -- body, create an implicit body at the end of the current declarative
+ -- part to activate those tasks.
+
+ function Is_Fully_Visible (Type_Id : Entity_Id) return Boolean;
+ -- Indicates whether the Full Declaration of a private type is visible.
+
+ procedure New_Private_Type (N : Node_Id; Id : Entity_Id; Def : Node_Id);
+ -- Common processing for private type declarations and for formal
+ -- private type declarations. For private types, N and Def are the type
+ -- declaration node; for formal private types, Def is the formal type
+ -- definition.
+
+ procedure Uninstall_Declarations (P : Entity_Id);
+ -- At the end of a package declaration or body, declarations in the
+ -- visible part are no longer immediately visible, and declarations in
+ -- the private part are not visible at all. For inner packages, place
+ -- visible entities at the end of their homonym chains. For compilation
+ -- units, make all entities invisible. In both cases, exchange private
+ -- and visible declarations to restore order of elaboration.
+end Sem_Ch7;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S E M . C H 8 --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.583 $
+-- --
+-- 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). --
+-- --
+------------------------------------------------------------------------------
+
+with Atree; use Atree;
+with Debug; use Debug;
+with Einfo; use Einfo;
+with Elists; use Elists;
+with Errout; use Errout;
+with Exp_Util; use Exp_Util;
+with Fname; use Fname;
+with Freeze; use Freeze;
+with Lib; use Lib;
+with Lib.Load; use Lib.Load;
+with Lib.Xref; use Lib.Xref;
+with Namet; use Namet;
+with Nlists; use Nlists;
+with Nmake; use Nmake;
+with Opt; use Opt;
+with Output; use Output;
+with Restrict; use Restrict;
+with Rtsfind; use Rtsfind;
+with Sem; use Sem;
+with Sem_Ch3; use Sem_Ch3;
+with Sem_Ch4; use Sem_Ch4;
+with Sem_Ch6; use Sem_Ch6;
+with Sem_Ch12; use Sem_Ch12;
+with Sem_Res; use Sem_Res;
+with Sem_Util; use Sem_Util;
+with Sem_Type; use Sem_Type;
+with Stand; use Stand;
+with Sinfo; use Sinfo;
+with Sinfo.CN; use Sinfo.CN;
+with Snames; use Snames;
+with Style; use Style;
+with Table;
+with Tbuild; use Tbuild;
+with Uintp; use Uintp;
+
+with GNAT.Spelling_Checker; use GNAT.Spelling_Checker;
+
+package body Sem_Ch8 is
+
+ ------------------------------------
+ -- Visibility and Name Resolution --
+ ------------------------------------
+
+ -- This package handles name resolution and the collection of
+ -- interpretations for overloaded names, prior to overload resolution.
+
+ -- Name resolution is the process that establishes a mapping between source
+ -- identifiers and the entities they denote at each point in the program.
+ -- Each entity is represented by a defining occurrence. Each identifier
+ -- that denotes an entity points to the corresponding defining occurrence.
+ -- This is the entity of the applied occurrence. Each occurrence holds
+ -- an index into the names table, where source identifiers are stored.
+
+ -- Each entry in the names table for an identifier or designator uses the
+ -- Info pointer to hold a link to the currently visible entity that has
+ -- this name (see subprograms Get_Name_Entity_Id and Set_Name_Entity_Id
+ -- in package Sem_Util). The visibility is initialized at the beginning of
+ -- semantic processing to make entities in package Standard immediately
+ -- visible. The visibility table is used in a more subtle way when
+ -- compiling subunits (see below).
+
+ -- Entities that have the same name (i.e. homonyms) are chained. In the
+ -- case of overloaded entities, this chain holds all the possible meanings
+ -- of a given identifier. The process of overload resolution uses type
+ -- information to select from this chain the unique meaning of a given
+ -- identifier.
+
+ -- Entities are also chained in their scope, through the Next_Entity link.
+ -- As a consequence, the name space is organized as a sparse matrix, where
+ -- each row corresponds to a scope, and each column to a source identifier.
+ -- Open scopes, that is to say scopes currently being compiled, have their
+ -- corresponding rows of entities in order, innermost scope first.
+
+ -- The scopes of packages that are mentioned in context clauses appear in
+ -- no particular order, interspersed among open scopes. This is because
+ -- in the course of analyzing the context of a compilation, a package
+ -- declaration is first an open scope, and subsequently an element of the
+ -- context. If subunits or child units are present, a parent unit may
+ -- appear under various guises at various times in the compilation.
+
+ -- When the compilation of the innermost scope is complete, the entities
+ -- defined therein are no longer visible. If the scope is not a package
+ -- declaration, these entities are never visible subsequently, and can be
+ -- removed from visibility chains. If the scope is a package declaration,
+ -- its visible declarations may still be accessible. Therefore the entities
+ -- defined in such a scope are left on the visibility chains, and only
+ -- their visibility (immediately visibility or potential use-visibility)
+ -- is affected.
+
+ -- The ordering of homonyms on their chain does not necessarily follow
+ -- the order of their corresponding scopes on the scope stack. For
+ -- example, if package P and the enclosing scope both contain entities
+ -- named E, then when compiling the package body the chain for E will
+ -- hold the global entity first, and the local one (corresponding to
+ -- the current inner scope) next. As a result, name resolution routines
+ -- do not assume any relative ordering of the homonym chains, either
+ -- for scope nesting or to order of appearance of context clauses.
+
+ -- When compiling a child unit, entities in the parent scope are always
+ -- immediately visible. When compiling the body of a child unit, private
+ -- entities in the parent must also be made immediately visible. There
+ -- are separate routines to make the visible and private declarations
+ -- visible at various times (see package Sem_Ch7).
+
+ -- +--------+ +-----+
+ -- | In use |-------->| EU1 |-------------------------->
+ -- +--------+ +-----+
+ -- | |
+ -- +--------+ +-----+ +-----+
+ -- | Stand. |---------------->| ES1 |--------------->| ES2 |--->
+ -- +--------+ +-----+ +-----+
+ -- | |
+ -- +---------+ | +-----+
+ -- | with'ed |------------------------------>| EW2 |--->
+ -- +---------+ | +-----+
+ -- | |
+ -- +--------+ +-----+ +-----+
+ -- | Scope2 |---------------->| E12 |--------------->| E22 |--->
+ -- +--------+ +-----+ +-----+
+ -- | |
+ -- +--------+ +-----+ +-----+
+ -- | Scope1 |---------------->| E11 |--------------->| E12 |--->
+ -- +--------+ +-----+ +-----+
+ -- ^ | |
+ -- | | |
+ -- | +---------+ | |
+ -- | | with'ed |----------------------------------------->
+ -- | +---------+ | |
+ -- | | |
+ -- Scope stack | |
+ -- (innermost first) | |
+ -- +----------------------------+
+ -- Names table => | Id1 | | | | Id2 |
+ -- +----------------------------+
+
+ -- Name resolution must deal with several syntactic forms: simple names,
+ -- qualified names, indexed names, and various forms of calls.
+
+ -- Each identifier points to an entry in the names table. The resolution
+ -- of a simple name consists in traversing the homonym chain, starting
+ -- from the names table. If an entry is immediately visible, it is the one
+ -- designated by the identifier. If only potemtially use-visible entities
+ -- are on the chain, we must verify that they do not hide each other. If
+ -- the entity we find is overloadable, we collect all other overloadable
+ -- entities on the chain as long as they are not hidden.
+ --
+ -- To resolve expanded names, we must find the entity at the intersection
+ -- of the entity chain for the scope (the prefix) and the homonym chain
+ -- for the selector. In general, homonym chains will be much shorter than
+ -- entity chains, so it is preferable to start from the names table as
+ -- well. If the entity found is overloadable, we must collect all other
+ -- interpretations that are defined in the scope denoted by the prefix.
+
+ -- For records, protected types, and tasks, their local entities are
+ -- removed from visibility chains on exit from the corresponding scope.
+ -- From the outside, these entities are always accessed by selected
+ -- notation, and the entity chain for the record type, protected type,
+ -- etc. is traversed sequentially in order to find the designated entity.
+
+ -- The discriminants of a type and the operations of a protected type or
+ -- task are unchained on exit from the first view of the type, (such as
+ -- a private or incomplete type declaration, or a protected type speci-
+ -- fication) and rechained when compiling the second view.
+
+ -- In the case of operators, we do not make operators on derived types
+ -- explicit. As a result, the notation P."+" may denote either a user-
+ -- defined function with name "+", or else an implicit declaration of the
+ -- operator "+" in package P. The resolution of expanded names always
+ -- tries to resolve an operator name as such an implicitly defined entity,
+ -- in addition to looking for explicit declarations.
+
+ -- All forms of names that denote entities (simple names, expanded names,
+ -- character literals in some cases) have a Entity attribute, which
+ -- identifies the entity denoted by the name.
+
+ ---------------------
+ -- The Scope Stack --
+ ---------------------
+
+ -- The Scope stack keeps track of the scopes currently been compiled.
+ -- Every entity that contains declarations (including records) is placed
+ -- on the scope stack while it is being processed, and removed at the end.
+ -- Whenever a non-package scope is exited, the entities defined therein
+ -- are removed from the visibility table, so that entities in outer scopes
+ -- become visible (see previous description). On entry to Sem, the scope
+ -- stack only contains the package Standard. As usual, subunits complicate
+ -- this picture ever so slightly.
+
+ -- The Rtsfind mechanism can force a call to Semantics while another
+ -- compilation is in progress. The unit retrieved by Rtsfind must be
+ -- compiled in its own context, and has no access to the visibility of
+ -- the unit currently being compiled. The procedures Save_Scope_Stack and
+ -- Restore_Scope_Stack make entities in current open scopes invisible
+ -- before compiling the retrieved unit, and restore the compilation
+ -- environment afterwards.
+
+ ------------------------
+ -- Compiling subunits --
+ ------------------------
+
+ -- Subunits must be compiled in the environment of the corresponding
+ -- stub, that is to say with the same visibility into the parent (and its
+ -- context) that is available at the point of the stub declaration, but
+ -- with the additional visibility provided by the context clause of the
+ -- subunit itself. As a result, compilation of a subunit forces compilation
+ -- of the parent (see description in lib-). At the point of the stub
+ -- declaration, Analyze is called recursively to compile the proper body
+ -- of the subunit, but without reinitializing the names table, nor the
+ -- scope stack (i.e. standard is not pushed on the stack). In this fashion
+ -- the context of the subunit is added to the context of the parent, and
+ -- the subunit is compiled in the correct environment. Note that in the
+ -- course of processing the context of a subunit, Standard will appear
+ -- twice on the scope stack: once for the parent of the subunit, and
+ -- once for the unit in the context clause being compiled. However, the
+ -- two sets of entities are not linked by homonym chains, so that the
+ -- compilation of any context unit happens in a fresh visibility
+ -- environment.
+
+ -------------------------------
+ -- Processing of USE Clauses --
+ -------------------------------
+
+ -- Every defining occurrence has a flag indicating if it is potentially use
+ -- visible. Resolution of simple names examines this flag. The processing
+ -- of use clauses consists in setting this flag on all visible entities
+ -- defined in the corresponding package. On exit from the scope of the use
+ -- clause, the corresponding flag must be reset. However, a package may
+ -- appear in several nested use clauses (pathological but legal, alas!)
+ -- which forces us to use a slightly more involved scheme:
+
+ -- a) The defining occurrence for a package holds a flag -In_Use- to
+ -- indicate that it is currently in the scope of a use clause. If a
+ -- redundant use clause is encountered, then the corresponding occurence
+ -- of the package name is flagged -Redundant_Use-.
+
+ -- b) On exit from a scope, the use clauses in its declarative part are
+ -- scanned. The visibility flag is reset in all entities declared in
+ -- package named in a use clause, as long as the package is not flagged
+ -- as being in a redundant use clause (in which case the outer use
+ -- clause is still in effect, and the direct visibility of its entities
+ -- must be retained).
+
+ -- Note that entities are not removed from their homonym chains on exit
+ -- from the package specification. A subsequent use clause does not need
+ -- to rechain the visible entities, but only to establish their direct
+ -- visibility.
+
+ -----------------------------------
+ -- Handling private declarations --
+ -----------------------------------
+
+ -- The principle that each entity has a single defining occurrence clashes
+ -- with the presence of two separate definitions for private types: the
+ -- first is the private type declaration, and second is the full type
+ -- declaration. It is important that all references to the type point to
+ -- the same defining occurence, namely the first one. To enforce the two
+ -- separate views of the entity, the corresponding information is swapped
+ -- between the two declarations. Outside of the package, the defining
+ -- occurence only contains the private declaration information, while in
+ -- the private part and the body of the package the defining occurrence
+ -- contains the full declaration. To simplify the swap, the defining
+ -- occurrence that currently holds the private declaration points to the
+ -- full declaration. During semantic processing the defining occurence
+ -- also points to a list of private dependents, that is to say access
+ -- types or composite types whose designated types or component types are
+ -- subtypes or derived types of the private type in question. After the
+ -- full declaration has been seen, the private dependents are updated to
+ -- indicate that they have full definitions.
+
+ ------------------------------------
+ -- Handling of Undefined Messages --
+ ------------------------------------
+
+ -- In normal mode, only the first use of an undefined identifier generates
+ -- a message. The table Urefs is used to record error messages that have
+ -- been issued so that second and subsequent ones do not generate further
+ -- messages. However, the second reference causes text to be added to the
+ -- original undefined message noting "(more references follow)". The
+ -- full error list option (-gnatf) forces messages to be generated for
+ -- every reference and disconnects the use of this table.
+
+ type Uref_Entry is record
+ Node : Node_Id;
+ -- Node for identifier for which original message was posted. The
+ -- Chars field of this identifier is used to detect later references
+ -- to the same identifier.
+
+ Err : Error_Msg_Id;
+ -- Records error message Id of original undefined message. Reset to
+ -- No_Error_Msg after the second occurrence, where it is used to add
+ -- text to the original message as described above.
+
+ Nvis : Boolean;
+ -- Set if the message is not visible rather than undefined
+
+ Loc : Source_Ptr;
+ -- Records location of error message. Used to make sure that we do
+ -- not consider a, b : undefined as two separate instances, which
+ -- would otherwise happen, since the parser converts this sequence
+ -- to a : undefined; b : undefined.
+
+ end record;
+
+ package Urefs is new Table.Table (
+ Table_Component_Type => Uref_Entry,
+ Table_Index_Type => Nat,
+ Table_Low_Bound => 1,
+ Table_Initial => 10,
+ Table_Increment => 100,
+ Table_Name => "Urefs");
+
+ Candidate_Renaming : Entity_Id;
+ -- Holds a candidate interpretation that appears in a subprogram renaming
+ -- declaration and does not match the given specification, but matches at
+ -- least on the first formal. Allows better error message when given
+ -- specification omits defaulted parameters, a common error.
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ procedure Analyze_Generic_Renaming
+ (N : Node_Id;
+ K : Entity_Kind);
+ -- Common processing for all three kinds of generic renaming declarations.
+ -- Enter new name and indicate that it renames the generic unit.
+
+ procedure Analyze_Renamed_Character
+ (N : Node_Id;
+ New_S : Entity_Id;
+ Is_Body : Boolean);
+ -- Renamed entity is given by a character literal, which must belong
+ -- to the return type of the new entity. Is_Body indicates whether the
+ -- declaration is a renaming_as_body. If the original declaration has
+ -- already been frozen (because of an intervening body, e.g.) the body of
+ -- the function must be built now. The same applies to the following
+ -- various renaming procedures.
+
+ procedure Analyze_Renamed_Dereference
+ (N : Node_Id;
+ New_S : Entity_Id;
+ Is_Body : Boolean);
+ -- Renamed entity is given by an explicit dereference. Prefix must be a
+ -- conformant access_to_subprogram type.
+
+ procedure Analyze_Renamed_Entry
+ (N : Node_Id;
+ New_S : Entity_Id;
+ Is_Body : Boolean);
+ -- If the renamed entity in a subprogram renaming is an entry or protected
+ -- subprogram, build a body for the new entity whose only statement is a
+ -- call to the renamed entity.
+
+ procedure Analyze_Renamed_Family_Member
+ (N : Node_Id;
+ New_S : Entity_Id;
+ Is_Body : Boolean);
+ -- Used when the renamed entity is an indexed component. The prefix must
+ -- denote an entry family.
+
+ procedure Attribute_Renaming (N : Node_Id);
+ -- Analyze renaming of attribute as function. The renaming declaration N
+ -- is rewritten as a function body that returns the attribute reference
+ -- applied to the formals of the function.
+
+ procedure Check_Frozen_Renaming (N : Node_Id; Subp : Entity_Id);
+ -- A renaming_as_body may occur after the entity of the original decla-
+ -- ration has been frozen. In that case, the body of the new entity must
+ -- be built now, because the usual mechanism of building the renamed
+ -- body at the point of freezing will not work. Subp is the subprogram
+ -- for which N provides the Renaming_As_Body.
+
+ procedure Check_Library_Unit_Renaming (N : Node_Id; Old_E : Entity_Id);
+ -- Verify that the entity in a renaming declaration that is a library unit
+ -- is itself a library unit and not a nested unit or subunit. Also check
+ -- that if the renaming is a child unit of a generic parent, then the
+ -- renamed unit must also be a child unit of that parent. Finally, verify
+ -- that a renamed generic unit is not an implicit child declared within
+ -- an instance of the parent.
+
+ procedure Chain_Use_Clause (N : Node_Id);
+ -- Chain use clause onto list of uses clauses headed by First_Use_Clause
+ -- in the top scope table entry.
+
+ function Has_Implicit_Character_Literal (N : Node_Id) return Boolean;
+ -- Find a type derived from Character or Wide_Character in the prefix of N.
+ -- Used to resolved qualified names whose selector is a character literal.
+
+ function Find_Renamed_Entity
+ (N : Node_Id;
+ Nam : Node_Id;
+ New_S : Entity_Id;
+ Is_Actual : Boolean := False) return Entity_Id;
+ -- Find the renamed entity that corresponds to the given parameter profile
+ -- in a subprogram renaming declaration. The renamed entity may be an
+ -- operator, a subprogram, an entry, or a protected operation. Is_Actual
+ -- indicates that the renaming is the one generated for an actual subpro-
+ -- gram in an instance, for which special visibility checks apply.
+
+ procedure Inherit_Renamed_Profile (New_S : Entity_Id; Old_S : Entity_Id);
+ -- A subprogram defined by a renaming declaration inherits the parameter
+ -- profile of the renamed entity. The subtypes given in the subprogram
+ -- specification are discarded and replaced with those of the renamed
+ -- subprogram, which are then used to recheck the default values.
+
+ procedure Premature_Usage (N : Node_Id);
+ -- Diagnose usage of an entity before it is visible.
+
+ procedure Write_Info;
+ -- Write debugging information on entities declared in current scope
+
+ procedure Write_Scopes;
+ pragma Warnings (Off, Write_Scopes);
+ -- Debugging information: dump all entities on scope stack
+
+ --------------------------------
+ -- Analyze_Exception_Renaming --
+ --------------------------------
+
+ -- The language only allows a single identifier, but the tree holds
+ -- an identifier list. The parser has already issued an error message
+ -- if there is more than one element in the list.
+
+ procedure Analyze_Exception_Renaming (N : Node_Id) is
+ Id : constant Node_Id := Defining_Identifier (N);
+ Nam : constant Node_Id := Name (N);
+
+ begin
+ Enter_Name (Id);
+ Analyze (Nam);
+
+ Set_Ekind (Id, E_Exception);
+ Set_Exception_Code (Id, Uint_0);
+ Set_Etype (Id, Standard_Exception_Type);
+ Set_Is_Pure (Id, Is_Pure (Current_Scope));
+
+ if not Is_Entity_Name (Nam) or else
+ Ekind (Entity (Nam)) /= E_Exception
+ then
+ Error_Msg_N ("invalid exception name in renaming", Nam);
+ else
+ if Present (Renamed_Object (Entity (Nam))) then
+ Set_Renamed_Object (Id, Renamed_Object (Entity (Nam)));
+ else
+ Set_Renamed_Object (Id, Entity (Nam));
+ end if;
+ end if;
+ end Analyze_Exception_Renaming;
+
+ ---------------------------
+ -- Analyze_Expanded_Name --
+ ---------------------------
+
+ procedure Analyze_Expanded_Name (N : Node_Id) is
+ begin
+ -- If the entity pointer is already set, this is an internal node, or
+ -- a node that is analyzed more than once, after a tree modification.
+ -- In such a case there is no resolution to perform, just set the type.
+ -- For completeness, analyze prefix as well.
+
+ if Present (Entity (N)) then
+ if Is_Type (Entity (N)) then
+ Set_Etype (N, Entity (N));
+ else
+ Set_Etype (N, Etype (Entity (N)));
+ end if;
+
+ Analyze (Prefix (N));
+ return;
+ else
+ Find_Expanded_Name (N);
+ end if;
+ end Analyze_Expanded_Name;
+
+ ----------------------------------------
+ -- Analyze_Generic_Function_Renaming --
+ ----------------------------------------
+
+ procedure Analyze_Generic_Function_Renaming (N : Node_Id) is
+ begin
+ Analyze_Generic_Renaming (N, E_Generic_Function);
+ end Analyze_Generic_Function_Renaming;
+
+ ---------------------------------------
+ -- Analyze_Generic_Package_Renaming --
+ ---------------------------------------
+
+ procedure Analyze_Generic_Package_Renaming (N : Node_Id) is
+ begin
+ -- Apply the Text_IO Kludge here, since we may be renaming
+ -- one of the subpackages of Text_IO, then join common routine.
+
+ Text_IO_Kludge (Name (N));
+
+ Analyze_Generic_Renaming (N, E_Generic_Package);
+ end Analyze_Generic_Package_Renaming;
+
+ -----------------------------------------
+ -- Analyze_Generic_Procedure_Renaming --
+ -----------------------------------------
+
+ procedure Analyze_Generic_Procedure_Renaming (N : Node_Id) is
+ begin
+ Analyze_Generic_Renaming (N, E_Generic_Procedure);
+ end Analyze_Generic_Procedure_Renaming;
+
+ ------------------------------
+ -- Analyze_Generic_Renaming --
+ ------------------------------
+
+ procedure Analyze_Generic_Renaming
+ (N : Node_Id;
+ K : Entity_Kind)
+ is
+ New_P : Entity_Id := Defining_Entity (N);
+ Old_P : Entity_Id;
+ Inst : Boolean := False; -- prevent junk warning
+
+ begin
+ Generate_Definition (New_P);
+
+ if Current_Scope /= Standard_Standard then
+ Set_Is_Pure (New_P, Is_Pure (Current_Scope));
+ end if;
+
+ if Nkind (Name (N)) = N_Selected_Component then
+ Check_Generic_Child_Unit (Name (N), Inst);
+ else
+ Analyze (Name (N));
+ end if;
+
+ if not Is_Entity_Name (Name (N)) then
+ Error_Msg_N ("expect entity name in renaming declaration", Name (N));
+ Old_P := Any_Id;
+ else
+ Old_P := Entity (Name (N));
+ end if;
+
+ Enter_Name (New_P);
+ Set_Ekind (New_P, K);
+
+ if Etype (Old_P) = Any_Type then
+ null;
+
+ elsif Ekind (Old_P) /= K then
+ Error_Msg_N ("invalid generic unit name", Name (N));
+
+ else
+ if Present (Renamed_Object (Old_P)) then
+ Set_Renamed_Object (New_P, Renamed_Object (Old_P));
+ else
+ Set_Renamed_Object (New_P, Old_P);
+ end if;
+
+ Set_Etype (New_P, Etype (Old_P));
+ Set_Has_Completion (New_P);
+
+ if In_Open_Scopes (Old_P) then
+ Error_Msg_N ("within its scope, generic denotes its instance", N);
+ end if;
+
+ Check_Library_Unit_Renaming (N, Old_P);
+ end if;
+
+ end Analyze_Generic_Renaming;
+
+ -----------------------------
+ -- Analyze_Object_Renaming --
+ -----------------------------
+
+ procedure Analyze_Object_Renaming (N : Node_Id) is
+ Id : constant Entity_Id := Defining_Identifier (N);
+ Dec : Node_Id;
+ Nam : constant Node_Id := Name (N);
+ S : constant Entity_Id := Subtype_Mark (N);
+ T : Entity_Id;
+ T2 : Entity_Id;
+
+ begin
+ Set_Is_Pure (Id, Is_Pure (Current_Scope));
+ Enter_Name (Id);
+
+ -- The renaming of a component that depends on a discriminant
+ -- requires an actual subtype, because in subsequent use of the object
+ -- Gigi will be unable to locate the actual bounds. This explicit step
+ -- is required when the renaming is generated in removing side effects
+ -- of an already-analyzed expression.
+
+ if Nkind (Nam) = N_Selected_Component
+ and then Analyzed (Nam)
+ then
+ T := Etype (Nam);
+ Dec := Build_Actual_Subtype_Of_Component (Etype (Nam), Nam);
+
+ if Present (Dec) then
+ Insert_Action (N, Dec);
+ T := Defining_Identifier (Dec);
+ Set_Etype (Nam, T);
+ end if;
+
+ else
+ Find_Type (S);
+ T := Entity (S);
+ Analyze_And_Resolve (Nam, T);
+ end if;
+
+ -- An object renaming requires an exact match of the type;
+ -- class-wide matching is not allowed.
+
+ if Is_Class_Wide_Type (T)
+ and then Base_Type (Etype (Nam)) /= Base_Type (T)
+ then
+ Wrong_Type (Nam, T);
+ end if;
+
+ T2 := Etype (Nam);
+ Set_Ekind (Id, E_Variable);
+ Init_Size_Align (Id);
+
+ if T = Any_Type or else Etype (Nam) = Any_Type then
+ return;
+
+ -- Verify that the renamed entity is an object or a function call.
+ -- It may have been rewritten in several ways.
+
+ elsif Is_Object_Reference (Nam) then
+
+ if Comes_From_Source (N)
+ and then Is_Dependent_Component_Of_Mutable_Object (Nam)
+ then
+ Error_Msg_N
+ ("illegal renaming of discriminant-dependent component", Nam);
+ else
+ null;
+ end if;
+
+ -- A static function call may have been folded into a literal
+
+ elsif Nkind (Original_Node (Nam)) = N_Function_Call
+
+ -- When expansion is disabled, attribute reference is not
+ -- rewritten as function call. Otherwise it may be rewritten
+ -- as a conversion, so check original node.
+
+ or else (Nkind (Original_Node (Nam)) = N_Attribute_Reference
+ and then Is_Function_Attribute_Name
+ (Attribute_Name (Original_Node (Nam))))
+
+ -- Weird but legal, equivalent to renaming a function call.
+
+ or else (Is_Entity_Name (Nam)
+ and then Ekind (Entity (Nam)) = E_Enumeration_Literal)
+
+ or else (Nkind (Nam) = N_Type_Conversion
+ and then Is_Tagged_Type (Entity (Subtype_Mark (Nam))))
+ then
+ null;
+
+ else
+ if Nkind (Nam) = N_Type_Conversion then
+ Error_Msg_N
+ ("renaming of conversion only allowed for tagged types", Nam);
+
+ else
+ Error_Msg_N ("expect object name in renaming", Nam);
+ end if;
+
+ end if;
+
+ Set_Etype (Id, T2);
+
+ if not Is_Variable (Nam) then
+ Set_Ekind (Id, E_Constant);
+ Set_Not_Source_Assigned (Id, True);
+ Set_Is_True_Constant (Id, True);
+ end if;
+
+ Set_Renamed_Object (Id, Nam);
+ end Analyze_Object_Renaming;
+
+ ------------------------------
+ -- Analyze_Package_Renaming --
+ ------------------------------
+
+ procedure Analyze_Package_Renaming (N : Node_Id) is
+ New_P : constant Entity_Id := Defining_Entity (N);
+ Old_P : Entity_Id;
+ Spec : Node_Id;
+
+ begin
+ -- Apply Text_IO kludge here, since we may be renaming one of
+ -- the children of Text_IO
+
+ Text_IO_Kludge (Name (N));
+
+ if Current_Scope /= Standard_Standard then
+ Set_Is_Pure (New_P, Is_Pure (Current_Scope));
+ end if;
+
+ Enter_Name (New_P);
+ Analyze (Name (N));
+ if Is_Entity_Name (Name (N)) then
+ Old_P := Entity (Name (N));
+ else
+ Old_P := Any_Id;
+ end if;
+
+ if Etype (Old_P) = Any_Type then
+ Error_Msg_N
+ ("expect package name in renaming", Name (N));
+
+ elsif Ekind (Old_P) /= E_Package
+ and then not (Ekind (Old_P) = E_Generic_Package
+ and then In_Open_Scopes (Old_P))
+ then
+ if Ekind (Old_P) = E_Generic_Package then
+ Error_Msg_N
+ ("generic package cannot be renamed as a package", Name (N));
+ else
+ Error_Msg_Sloc := Sloc (Old_P);
+ Error_Msg_NE
+ ("expect package name in renaming, found& declared#",
+ Name (N), Old_P);
+ end if;
+
+ -- Set basic attributes to minimize cascaded errors.
+
+ Set_Ekind (New_P, E_Package);
+ Set_Etype (New_P, Standard_Void_Type);
+
+ elsif Ekind (Old_P) = E_Package
+ and then From_With_Type (Old_P)
+ then
+ Error_Msg_N ("imported package cannot be renamed", Name (N));
+
+ else
+ -- Entities in the old package are accessible through the
+ -- renaming entity. The simplest implementation is to have
+ -- both packages share the entity list.
+
+ Set_Ekind (New_P, E_Package);
+ Set_Etype (New_P, Standard_Void_Type);
+
+ if Present (Renamed_Object (Old_P)) then
+ Set_Renamed_Object (New_P, Renamed_Object (Old_P));
+ else
+ Set_Renamed_Object (New_P, Old_P);
+ end if;
+
+ Set_Has_Completion (New_P);
+
+ Set_First_Entity (New_P, First_Entity (Old_P));
+ Set_Last_Entity (New_P, Last_Entity (Old_P));
+ Set_First_Private_Entity (New_P, First_Private_Entity (Old_P));
+ Check_Library_Unit_Renaming (N, Old_P);
+ Generate_Reference (Old_P, Name (N));
+
+ -- If this is the renaming declaration of a package instantiation
+ -- within itself, it is the declaration that ends the list of actuals
+ -- for the instantiation. At this point, the subtypes that rename
+ -- the actuals are flagged as generic, to avoid spurious ambiguities
+ -- if the actuals for two distinct formals happen to coincide. If
+ -- the actual is a private type, the subtype has a private completion
+ -- that is flagged in the same fashion.
+
+ -- Resolution is identical to what is was in the original generic.
+ -- On exit from the generic instance, these are turned into regular
+ -- subtypes again, so they are compatible with types in their class.
+
+ if not Is_Generic_Instance (Old_P) then
+ return;
+ else
+ Spec := Specification (Unit_Declaration_Node (Old_P));
+ end if;
+
+ if Nkind (Spec) = N_Package_Specification
+ and then Present (Generic_Parent (Spec))
+ and then Old_P = Current_Scope
+ and then Chars (New_P) = Chars (Generic_Parent (Spec))
+ then
+ declare
+ E : Entity_Id := First_Entity (Old_P);
+ begin
+ while Present (E)
+ and then E /= New_P
+ loop
+ if Is_Type (E)
+ and then Nkind (Parent (E)) = N_Subtype_Declaration
+ then
+ Set_Is_Generic_Actual_Type (E);
+
+ if Is_Private_Type (E)
+ and then Present (Full_View (E))
+ then
+ Set_Is_Generic_Actual_Type (Full_View (E));
+ end if;
+ end if;
+
+ Next_Entity (E);
+ end loop;
+ end;
+ end if;
+ end if;
+
+ end Analyze_Package_Renaming;
+
+ -------------------------------
+ -- Analyze_Renamed_Character --
+ -------------------------------
+
+ procedure Analyze_Renamed_Character
+ (N : Node_Id;
+ New_S : Entity_Id;
+ Is_Body : Boolean)
+ is
+ C : constant Node_Id := Name (N);
+
+ begin
+ if Ekind (New_S) = E_Function then
+ Resolve (C, Etype (New_S));
+
+ if Is_Body then
+ Check_Frozen_Renaming (N, New_S);
+ end if;
+
+ else
+ Error_Msg_N ("character literal can only be renamed as function", N);
+ end if;
+ end Analyze_Renamed_Character;
+
+ ---------------------------------
+ -- Analyze_Renamed_Dereference --
+ ---------------------------------
+
+ procedure Analyze_Renamed_Dereference
+ (N : Node_Id;
+ New_S : Entity_Id;
+ Is_Body : Boolean)
+ is
+ Nam : constant Node_Id := Name (N);
+ P : constant Node_Id := Prefix (Nam);
+ Typ : Entity_Id;
+ I : Interp_Index;
+ It : Interp;
+
+ begin
+ if not Is_Overloaded (P) then
+
+ if Ekind (Etype (Nam)) /= E_Subprogram_Type
+ or else not Type_Conformant (Etype (Nam), New_S) then
+ Error_Msg_N ("designated type does not match specification", P);
+ else
+ Resolve (P, Etype (P));
+ end if;
+
+ return;
+
+ else
+ Typ := Any_Type;
+ Get_First_Interp (Nam, I, It);
+
+ while Present (It.Nam) loop
+
+ if Ekind (It.Nam) = E_Subprogram_Type
+ and then Type_Conformant (It.Nam, New_S) then
+
+ if Typ /= Any_Id then
+ Error_Msg_N ("ambiguous renaming", P);
+ return;
+ else
+ Typ := It.Nam;
+ end if;
+ end if;
+
+ Get_Next_Interp (I, It);
+ end loop;
+
+ if Typ = Any_Type then
+ Error_Msg_N ("designated type does not match specification", P);
+ else
+ Resolve (N, Typ);
+
+ if Is_Body then
+ Check_Frozen_Renaming (N, New_S);
+ end if;
+ end if;
+ end if;
+ end Analyze_Renamed_Dereference;
+
+ ---------------------------
+ -- Analyze_Renamed_Entry --
+ ---------------------------
+
+ procedure Analyze_Renamed_Entry
+ (N : Node_Id;
+ New_S : Entity_Id;
+ Is_Body : Boolean)
+ is
+ Nam : Node_Id := Name (N);
+ Sel : Node_Id := Selector_Name (Nam);
+ Old_S : Entity_Id;
+
+ begin
+ if Entity (Sel) = Any_Id then
+
+ -- Selector is undefined on prefix. Error emitted already.
+
+ Set_Has_Completion (New_S);
+ return;
+ end if;
+
+ -- Otherwise, find renamed entity, and build body of New_S as a call
+ -- to it.
+
+ Old_S := Find_Renamed_Entity (N, Selector_Name (Nam), New_S);
+
+ if Old_S = Any_Id then
+ Error_Msg_N (" no subprogram or entry matches specification", N);
+ else
+ if Is_Body then
+ Check_Subtype_Conformant (New_S, Old_S, N);
+ Generate_Reference (New_S, Defining_Entity (N), 'b');
+ Style.Check_Identifier (Defining_Entity (N), New_S);
+ end if;
+
+ Inherit_Renamed_Profile (New_S, Old_S);
+ end if;
+
+ Set_Convention (New_S, Convention (Old_S));
+ Set_Has_Completion (New_S, Inside_A_Generic);
+
+ if Is_Body then
+ Check_Frozen_Renaming (N, New_S);
+ end if;
+ end Analyze_Renamed_Entry;
+
+ -----------------------------------
+ -- Analyze_Renamed_Family_Member --
+ -----------------------------------
+
+ procedure Analyze_Renamed_Family_Member
+ (N : Node_Id;
+ New_S : Entity_Id;
+ Is_Body : Boolean)
+ is
+ Nam : Node_Id := Name (N);
+ P : Node_Id := Prefix (Nam);
+ Old_S : Entity_Id;
+
+ begin
+ if (Is_Entity_Name (P) and then Ekind (Entity (P)) = E_Entry_Family)
+ or else (Nkind (P) = N_Selected_Component
+ and then
+ Ekind (Entity (Selector_Name (P))) = E_Entry_Family)
+ then
+ if Is_Entity_Name (P) then
+ Old_S := Entity (P);
+ else
+ Old_S := Entity (Selector_Name (P));
+ end if;
+
+ if not Entity_Matches_Spec (Old_S, New_S) then
+ Error_Msg_N ("entry family does not match specification", N);
+
+ elsif Is_Body then
+ Check_Subtype_Conformant (New_S, Old_S, N);
+ Generate_Reference (New_S, Defining_Entity (N), 'b');
+ Style.Check_Identifier (Defining_Entity (N), New_S);
+ end if;
+ else
+ Error_Msg_N ("no entry family matches specification", N);
+ end if;
+
+ Set_Has_Completion (New_S, Inside_A_Generic);
+
+ if Is_Body then
+ Check_Frozen_Renaming (N, New_S);
+ end if;
+ end Analyze_Renamed_Family_Member;
+
+ ---------------------------------
+ -- Analyze_Subprogram_Renaming --
+ ---------------------------------
+
+ procedure Analyze_Subprogram_Renaming (N : Node_Id) is
+ Nam : Node_Id := Name (N);
+ Spec : constant Node_Id := Specification (N);
+ New_S : Entity_Id;
+ Old_S : Entity_Id := Empty;
+ Rename_Spec : Entity_Id;
+ Is_Actual : Boolean := False;
+ Inst_Node : Node_Id := Empty;
+ Save_83 : Boolean := Ada_83;
+
+ begin
+ -- We must test for the attribute renaming case before the Analyze
+ -- call because otherwise Sem_Attr will complain that the attribute
+ -- is missing an argument when it is analyzed.
+
+ if Nkind (Nam) = N_Attribute_Reference then
+ Attribute_Renaming (N);
+ return;
+ end if;
+
+ -- Check whether this declaration corresponds to the instantiation
+ -- of a formal subprogram. This is indicated by the presence of a
+ -- Corresponding_Spec that is the instantiation declaration.
+
+ -- If this is an instantiation, the corresponding actual is frozen
+ -- and error messages can be made more precise. If this is a default
+ -- subprogram, the entity is already established in the generic, and
+ -- is not retrieved by visibility. If it is a default with a box, the
+ -- candidate interpretations, if any, have been collected when building
+ -- the renaming declaration. If overloaded, the proper interpretation
+ -- is determined in Find_Renamed_Entity. If the entity is an operator,
+ -- Find_Renamed_Entity applies additional visibility checks.
+
+ if Present (Corresponding_Spec (N)) then
+ Is_Actual := True;
+ Inst_Node := Corresponding_Spec (N);
+
+ if Is_Entity_Name (Nam)
+ and then Present (Entity (Nam))
+ and then not Comes_From_Source (Nam)
+ and then not Is_Overloaded (Nam)
+ then
+ Old_S := Entity (Nam);
+ New_S := Analyze_Spec (Spec);
+
+ if Ekind (Entity (Nam)) = E_Operator
+ and then Box_Present (Corresponding_Spec (N))
+ then
+ Old_S := Find_Renamed_Entity (N, Name (N), New_S, Is_Actual);
+ end if;
+
+ else
+ Analyze (Nam);
+ New_S := Analyze_Spec (Spec);
+ end if;
+
+ Set_Corresponding_Spec (N, Empty);
+
+ else
+ -- Renamed entity must be analyzed first, to avoid being hidden by
+ -- new name (which might be the same in a generic instance).
+
+ Analyze (Nam);
+
+ -- The renaming defines a new overloaded entity, which is analyzed
+ -- like a subprogram declaration.
+
+ New_S := Analyze_Spec (Spec);
+ end if;
+
+ if Current_Scope /= Standard_Standard then
+ Set_Is_Pure (New_S, Is_Pure (Current_Scope));
+ end if;
+
+ Rename_Spec := Find_Corresponding_Spec (N);
+
+ if Present (Rename_Spec) then
+
+ -- Renaming_As_Body. Renaming declaration is the completion of
+ -- the declaration of Rename_Spec. We will build an actual body
+ -- for it at the freezing point.
+
+ Set_Corresponding_Spec (N, Rename_Spec);
+ Set_Corresponding_Body (Unit_Declaration_Node (Rename_Spec), New_S);
+
+ -- The body is created when the entity is frozen. If the context
+ -- is generic, freeze_all is not invoked, so we need to indicate
+ -- that the entity has a completion.
+
+ Set_Has_Completion (Rename_Spec, Inside_A_Generic);
+
+ if Ada_83 and then Comes_From_Source (N) then
+ Error_Msg_N ("(Ada 83) renaming cannot serve as a body", N);
+ end if;
+
+ Set_Convention (New_S, Convention (Rename_Spec));
+ Check_Fully_Conformant (New_S, Rename_Spec);
+ Set_Public_Status (New_S);
+
+ -- Indicate that the entity in the declaration functions like
+ -- the corresponding body, and is not a new entity.
+
+ Set_Ekind (New_S, E_Subprogram_Body);
+ New_S := Rename_Spec;
+
+ else
+ Generate_Definition (New_S);
+ New_Overloaded_Entity (New_S);
+ if Is_Entity_Name (Nam)
+ and then Is_Intrinsic_Subprogram (Entity (Nam))
+ then
+ null;
+ else
+ Check_Delayed_Subprogram (New_S);
+ end if;
+ end if;
+
+ -- There is no need for elaboration checks on the new entity, which
+ -- may be called before the next freezing point where the body will
+ -- appear.
+
+ Set_Suppress_Elaboration_Checks (New_S, True);
+
+ if Etype (Nam) = Any_Type then
+ Set_Has_Completion (New_S);
+ return;
+
+ elsif Nkind (Nam) = N_Selected_Component then
+
+ -- Renamed entity is an entry or protected subprogram. For those
+ -- cases an explicit body is built (at the point of freezing of
+ -- this entity) that contains a call to the renamed entity.
+
+ Analyze_Renamed_Entry (N, New_S, Present (Rename_Spec));
+ return;
+
+ elsif Nkind (Nam) = N_Explicit_Dereference then
+
+ -- Renamed entity is designated by access_to_subprogram expression.
+ -- Must build body to encapsulate call, as in the entry case.
+
+ Analyze_Renamed_Dereference (N, New_S, Present (Rename_Spec));
+ return;
+
+ elsif Nkind (Nam) = N_Indexed_Component then
+ Analyze_Renamed_Family_Member (N, New_S, Present (Rename_Spec));
+ return;
+
+ elsif Nkind (Nam) = N_Character_Literal then
+ Analyze_Renamed_Character (N, New_S, Present (Rename_Spec));
+ return;
+
+ elsif (not Is_Entity_Name (Nam)
+ and then Nkind (Nam) /= N_Operator_Symbol)
+ or else not Is_Overloadable (Entity (Nam))
+ then
+ Error_Msg_N ("expect valid subprogram name in renaming", N);
+ return;
+
+ end if;
+
+ -- Most common case: subprogram renames subprogram. No body is
+ -- generated in this case, so we must indicate that the declaration
+ -- is complete as is.
+
+ if No (Rename_Spec) then
+ Set_Has_Completion (New_S);
+ end if;
+
+ -- Find the renamed entity that matches the given specification.
+ -- Disable Ada_83 because there is no requirement of full conformance
+ -- between renamed entity and new entity, even though the same circuit
+ -- is used.
+
+ Ada_83 := False;
+
+ if No (Old_S) then
+ Old_S := Find_Renamed_Entity (N, Name (N), New_S, Is_Actual);
+ end if;
+
+ if Old_S /= Any_Id then
+
+ if Is_Actual
+ and then Box_Present (Inst_Node)
+ then
+ -- This is an implicit reference to the default actual
+
+ Generate_Reference (Old_S, Nam, Typ => 'i', Force => True);
+ else
+ Generate_Reference (Old_S, Nam);
+ end if;
+
+ -- For a renaming-as-body, require subtype conformance,
+ -- but if the declaration being completed has not been
+ -- frozen, then inherit the convention of the renamed
+ -- subprogram prior to checking conformance (unless the
+ -- renaming has an explicit convention established; the
+ -- rule stated in the RM doesn't seem to address this ???).
+
+ if Present (Rename_Spec) then
+ Generate_Reference (Rename_Spec, Defining_Entity (Spec), 'b');
+ Style.Check_Identifier (Defining_Entity (Spec), Rename_Spec);
+
+ if not Is_Frozen (Rename_Spec)
+ and then not Has_Convention_Pragma (Rename_Spec)
+ then
+ Set_Convention (New_S, Convention (Old_S));
+ end if;
+
+ Check_Frozen_Renaming (N, Rename_Spec);
+ Check_Subtype_Conformant (New_S, Old_S, Spec);
+
+ elsif Ekind (Old_S) /= E_Operator then
+ Check_Mode_Conformant (New_S, Old_S);
+
+ if Is_Actual
+ and then Error_Posted (New_S)
+ then
+ Error_Msg_NE ("invalid actual subprogram: & #!", N, Old_S);
+ end if;
+ end if;
+
+ if No (Rename_Spec) then
+
+ -- The parameter profile of the new entity is that of the renamed
+ -- entity: the subtypes given in the specification are irrelevant.
+
+ Inherit_Renamed_Profile (New_S, Old_S);
+
+ -- A call to the subprogram is transformed into a call to the
+ -- renamed entity. This is transitive if the renamed entity is
+ -- itself a renaming.
+
+ if Present (Alias (Old_S)) then
+ Set_Alias (New_S, Alias (Old_S));
+ else
+ Set_Alias (New_S, Old_S);
+ end if;
+
+ -- Note that we do not set Is_Instrinsic_Subprogram if we have
+ -- a renaming as body, since the entity in this case is not an
+ -- intrinsic (it calls an intrinsic, but we have a real body
+ -- for this call, and it is in this body that the required
+ -- intrinsic processing will take place).
+
+ Set_Is_Intrinsic_Subprogram
+ (New_S, Is_Intrinsic_Subprogram (Old_S));
+
+ if Ekind (Alias (New_S)) = E_Operator then
+ Set_Has_Delayed_Freeze (New_S, False);
+ end if;
+
+ end if;
+
+ if not Is_Actual
+ and then (Old_S = New_S
+ or else (Nkind (Nam) /= N_Expanded_Name
+ and then Chars (Old_S) = Chars (New_S)))
+ then
+ Error_Msg_N ("subprogram cannot rename itself", N);
+ end if;
+
+ Set_Convention (New_S, Convention (Old_S));
+ Set_Is_Abstract (New_S, Is_Abstract (Old_S));
+ Check_Library_Unit_Renaming (N, Old_S);
+
+ -- Pathological case: procedure renames entry in the scope of
+ -- its task. Entry is given by simple name, but body must be built
+ -- for procedure. Of course if called it will deadlock.
+
+ if Ekind (Old_S) = E_Entry then
+ Set_Has_Completion (New_S, False);
+ Set_Alias (New_S, Empty);
+ end if;
+
+ if Is_Actual then
+ Freeze_Before (N, Old_S);
+ Set_Has_Delayed_Freeze (New_S, False);
+ Freeze_Before (N, New_S);
+
+ if (Ekind (Old_S) = E_Procedure or else Ekind (Old_S) = E_Function)
+ and then Is_Abstract (Old_S)
+ then
+ Error_Msg_N
+ ("abstract subprogram not allowed as generic actual", Nam);
+ end if;
+ end if;
+
+ else
+ -- A common error is to assume that implicit operators for types
+ -- are defined in Standard, or in the scope of a subtype. In those
+ -- cases where the renamed entity is given with an expanded name,
+ -- it is worth mentioning that operators for the type are not
+ -- declared in the scope given by the prefix.
+
+ if Nkind (Nam) = N_Expanded_Name
+ and then Nkind (Selector_Name (Nam)) = N_Operator_Symbol
+ and then Scope (Entity (Nam)) = Standard_Standard
+ then
+ declare
+ T : constant Entity_Id :=
+ Base_Type (Etype (First_Formal (New_S)));
+
+ begin
+ Error_Msg_Node_2 := Prefix (Nam);
+ Error_Msg_NE ("\operator for type& is not declared in&",
+ Prefix (Nam), T);
+ end;
+ else
+ Error_Msg_NE
+ ("no visible subprogram matches the specification for&",
+ Spec, New_S);
+ end if;
+
+ if Present (Candidate_Renaming) then
+ declare
+ F1 : Entity_Id;
+ F2 : Entity_Id;
+
+ begin
+ F1 := First_Formal (Candidate_Renaming);
+ F2 := First_Formal (New_S);
+
+ while Present (F1) and then Present (F2) loop
+ Next_Formal (F1);
+ Next_Formal (F2);
+ end loop;
+
+ if Present (F1) and then Present (Default_Value (F1)) then
+ if Present (Next_Formal (F1)) then
+ Error_Msg_NE
+ ("\missing specification for &" &
+ " and other formals with defaults", Spec, F1);
+ else
+ Error_Msg_NE
+ ("\missing specification for &", Spec, F1);
+ end if;
+ end if;
+ end;
+ end if;
+ end if;
+
+ Ada_83 := Save_83;
+ end Analyze_Subprogram_Renaming;
+
+ -------------------------
+ -- Analyze_Use_Package --
+ -------------------------
+
+ -- Resolve the package names in the use clause, and make all the visible
+ -- entities defined in the package potentially use-visible. If the package
+ -- is already in use from a previous use clause, its visible entities are
+ -- already use-visible. In that case, mark the occurrence as a redundant
+ -- use. If the package is an open scope, i.e. if the use clause occurs
+ -- within the package itself, ignore it.
+
+ procedure Analyze_Use_Package (N : Node_Id) is
+ Pack_Name : Node_Id;
+ Pack : Entity_Id;
+
+ function In_Previous_With_Clause (P : Entity_Id) return Boolean;
+ -- For use clauses in a context clause, the indicated package may
+ -- be visible and yet illegal, if it did not appear in a previous
+ -- with clause.
+
+ -----------------------------
+ -- In_Previous_With_Clause --
+ -----------------------------
+
+ function In_Previous_With_Clause (P : Entity_Id) return Boolean is
+ Item : Node_Id;
+
+ begin
+ Item := First (Context_Items (Parent (N)));
+
+ while Present (Item)
+ and then Item /= N
+ loop
+ if Nkind (Item) = N_With_Clause
+ and then Entity (Name (Item)) = Pack
+ then
+ return True;
+ end if;
+
+ Next (Item);
+ end loop;
+
+ return False;
+ end In_Previous_With_Clause;
+
+ -- Start of processing for Analyze_Use_Package
+
+ begin
+ Set_Hidden_By_Use_Clause (N, No_Elist);
+
+ -- Use clause is not allowed in a spec of a predefined package
+ -- declaration except that packages whose file name starts a-n
+ -- are OK (these are children of Ada.Numerics, and such packages
+ -- are never loaded by Rtsfind).
+
+ if Is_Predefined_File_Name (Unit_File_Name (Current_Sem_Unit))
+ and then Name_Buffer (1 .. 3) /= "a-n"
+ and then
+ Nkind (Unit (Cunit (Current_Sem_Unit))) = N_Package_Declaration
+ then
+ Error_Msg_N ("use clause not allowed in predefined spec", N);
+ end if;
+
+ -- Chain clause to list of use clauses in current scope.
+
+ if Nkind (Parent (N)) /= N_Compilation_Unit then
+ Chain_Use_Clause (N);
+ end if;
+
+ -- Loop through package names to identify referenced packages
+
+ Pack_Name := First (Names (N));
+
+ while Present (Pack_Name) loop
+ Analyze (Pack_Name);
+
+ if Nkind (Parent (N)) = N_Compilation_Unit
+ and then Nkind (Pack_Name) = N_Expanded_Name
+ then
+ declare
+ Pref : Node_Id := Prefix (Pack_Name);
+
+ begin
+ while Nkind (Pref) = N_Expanded_Name loop
+ Pref := Prefix (Pref);
+ end loop;
+
+ if Entity (Pref) = Standard_Standard then
+ Error_Msg_N
+ ("predefined package Standard cannot appear"
+ & " in a context clause", Pref);
+ end if;
+ end;
+ end if;
+
+ Next (Pack_Name);
+ end loop;
+
+ -- Loop through package names to mark all entities as potentially
+ -- use visible.
+
+ Pack_Name := First (Names (N));
+
+ while Present (Pack_Name) loop
+
+ if Is_Entity_Name (Pack_Name) then
+ Pack := Entity (Pack_Name);
+
+ if Ekind (Pack) /= E_Package
+ and then Etype (Pack) /= Any_Type
+ then
+ if Ekind (Pack) = E_Generic_Package then
+ Error_Msg_N
+ ("a generic package is not allowed in a use clause",
+ Pack_Name);
+ else
+ Error_Msg_N ("& is not a usable package", Pack_Name);
+ end if;
+
+ elsif Nkind (Parent (N)) = N_Compilation_Unit
+ and then Nkind (Pack_Name) /= N_Expanded_Name
+ and then not In_Previous_With_Clause (Pack)
+ then
+ Error_Msg_N ("package is not directly visible", Pack_Name);
+
+ elsif Applicable_Use (Pack_Name) then
+ Use_One_Package (Pack, N);
+ end if;
+ end if;
+
+ Next (Pack_Name);
+ end loop;
+
+ end Analyze_Use_Package;
+
+ ----------------------
+ -- Analyze_Use_Type --
+ ----------------------
+
+ procedure Analyze_Use_Type (N : Node_Id) is
+ Id : Entity_Id;
+
+ begin
+ Set_Hidden_By_Use_Clause (N, No_Elist);
+
+ -- Chain clause to list of use clauses in current scope.
+
+ if Nkind (Parent (N)) /= N_Compilation_Unit then
+ Chain_Use_Clause (N);
+ end if;
+
+ Id := First (Subtype_Marks (N));
+
+ while Present (Id) loop
+ Find_Type (Id);
+
+ if Entity (Id) /= Any_Type then
+ Use_One_Type (Id, N);
+ end if;
+
+ Next (Id);
+ end loop;
+ end Analyze_Use_Type;
+
+ --------------------
+ -- Applicable_Use --
+ --------------------
+
+ function Applicable_Use (Pack_Name : Node_Id) return Boolean is
+ Pack : constant Entity_Id := Entity (Pack_Name);
+
+ begin
+ if In_Open_Scopes (Pack) then
+ return False;
+
+ elsif In_Use (Pack) then
+ Set_Redundant_Use (Pack_Name, True);
+ return False;
+
+ elsif Present (Renamed_Object (Pack))
+ and then In_Use (Renamed_Object (Pack))
+ then
+ Set_Redundant_Use (Pack_Name, True);
+ return False;
+
+ else
+ return True;
+ end if;
+ end Applicable_Use;
+
+ ------------------------
+ -- Attribute_Renaming --
+ ------------------------
+
+ procedure Attribute_Renaming (N : Node_Id) is
+ Loc : constant Source_Ptr := Sloc (N);
+ Nam : constant Node_Id := Name (N);
+ Spec : constant Node_Id := Specification (N);
+ New_S : constant Entity_Id := Defining_Unit_Name (Spec);
+ Aname : constant Name_Id := Attribute_Name (Nam);
+
+ Form_Num : Nat := 0;
+ Expr_List : List_Id := No_List;
+
+ Attr_Node : Node_Id;
+ Body_Node : Node_Id;
+ Param_Spec : Node_Id;
+
+ begin
+ Generate_Definition (New_S);
+
+ -- This procedure is called in the context of subprogram renaming,
+ -- and thus the attribute must be one that is a subprogram. All of
+ -- those have at least one formal parameter, with the singular
+ -- exception of AST_Entry (which is a real oddity, it is odd that
+ -- this can be renamed at all!)
+
+ if not Is_Non_Empty_List (Parameter_Specifications (Spec)) then
+ if Aname /= Name_AST_Entry then
+ Error_Msg_N
+ ("subprogram renaming an attribute must have formals", N);
+ return;
+ end if;
+
+ else
+ Param_Spec := First (Parameter_Specifications (Spec));
+
+ while Present (Param_Spec) loop
+ Form_Num := Form_Num + 1;
+
+ if Nkind (Parameter_Type (Param_Spec)) /= N_Access_Definition then
+ Find_Type (Parameter_Type (Param_Spec));
+
+ -- The profile of the new entity denotes the base type (s) of
+ -- the types given in the specification. For access parameters
+ -- there are no subtypes involved.
+
+ Rewrite (Parameter_Type (Param_Spec),
+ New_Reference_To
+ (Base_Type (Entity (Parameter_Type (Param_Spec))), Loc));
+ end if;
+
+ if No (Expr_List) then
+ Expr_List := New_List;
+ end if;
+
+ Append_To (Expr_List,
+ Make_Identifier (Loc,
+ Chars => Chars (Defining_Identifier (Param_Spec))));
+
+ Next (Param_Spec);
+ end loop;
+ end if;
+
+ -- Immediate error if too many formals. Other mismatches in numbers
+ -- of number of types of parameters are detected when we analyze the
+ -- body of the subprogram that we construct.
+
+ if Form_Num > 2 then
+ Error_Msg_N ("too many formals for attribute", N);
+
+ elsif
+ Aname = Name_Compose or else
+ Aname = Name_Exponent or else
+ Aname = Name_Leading_Part or else
+ Aname = Name_Pos or else
+ Aname = Name_Round or else
+ Aname = Name_Scaling or else
+ Aname = Name_Val
+ then
+ if Nkind (N) = N_Subprogram_Renaming_Declaration
+ and then Present (Corresponding_Spec (N))
+ and then Nkind (Corresponding_Spec (N)) =
+ N_Formal_Subprogram_Declaration
+ then
+ Error_Msg_N
+ ("generic actual cannot be attribute involving universal type",
+ Nam);
+ else
+ Error_Msg_N
+ ("attribute involving a universal type cannot be renamed",
+ Nam);
+ end if;
+ end if;
+
+ -- AST_Entry is an odd case. It doesn't really make much sense to
+ -- allow it to be renamed, but that's the DEC rule, so we have to
+ -- do it right. The point is that the AST_Entry call should be made
+ -- now, and what the function will return is the returned value.
+
+ -- Note that there is no Expr_List in this case anyway
+
+ if Aname = Name_AST_Entry then
+
+ declare
+ Ent : Entity_Id;
+ Decl : Node_Id;
+
+ begin
+ Ent := Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
+
+ Decl :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Ent,
+ Object_Definition =>
+ New_Occurrence_Of (RTE (RE_AST_Handler), Loc),
+ Expression => Nam,
+ Constant_Present => True);
+
+ Set_Assignment_OK (Decl, True);
+ Insert_Action (N, Decl);
+ Attr_Node := Make_Identifier (Loc, Chars (Ent));
+ end;
+
+ -- For all other attributes, we rewrite the attribute node to have
+ -- a list of expressions corresponding to the subprogram formals.
+ -- A renaming declaration is not a freeze point, and the analysis of
+ -- the attribute reference should not freeze the type of the prefix.
+
+ else
+ Attr_Node :=
+ Make_Attribute_Reference (Loc,
+ Prefix => Prefix (Nam),
+ Attribute_Name => Aname,
+ Expressions => Expr_List);
+
+ Set_Must_Not_Freeze (Attr_Node);
+ Set_Must_Not_Freeze (Prefix (Nam));
+ end if;
+
+ -- Case of renaming a function
+
+ if Nkind (Spec) = N_Function_Specification then
+
+ if Is_Procedure_Attribute_Name (Aname) then
+ Error_Msg_N ("attribute can only be renamed as procedure", Nam);
+ return;
+ end if;
+
+ Find_Type (Subtype_Mark (Spec));
+ Rewrite (Subtype_Mark (Spec),
+ New_Reference_To (Base_Type (Entity (Subtype_Mark (Spec))), Loc));
+
+ Body_Node :=
+ Make_Subprogram_Body (Loc,
+ Specification => Spec,
+ Declarations => New_List,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => New_List (
+ Make_Return_Statement (Loc,
+ Expression => Attr_Node))));
+
+ -- Case of renaming a procedure
+
+ else
+ if not Is_Procedure_Attribute_Name (Aname) then
+ Error_Msg_N ("attribute can only be renamed as function", Nam);
+ return;
+ end if;
+
+ Body_Node :=
+ Make_Subprogram_Body (Loc,
+ Specification => Spec,
+ Declarations => New_List,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => New_List (Attr_Node)));
+ end if;
+
+ Rewrite (N, Body_Node);
+ Analyze (N);
+
+ Set_Etype (New_S, Base_Type (Etype (New_S)));
+
+ -- We suppress elaboration warnings for the resulting entity, since
+ -- clearly they are not needed, and more particularly, in the case
+ -- of a generic formal subprogram, the resulting entity can appear
+ -- after the instantiation itself, and thus look like a bogus case
+ -- of access before elaboration.
+
+ Set_Suppress_Elaboration_Warnings (New_S);
+
+ end Attribute_Renaming;
+
+ ----------------------
+ -- Chain_Use_Clause --
+ ----------------------
+
+ procedure Chain_Use_Clause (N : Node_Id) is
+ begin
+ Set_Next_Use_Clause (N,
+ Scope_Stack.Table (Scope_Stack.Last).First_Use_Clause);
+ Scope_Stack.Table (Scope_Stack.Last).First_Use_Clause := N;
+ end Chain_Use_Clause;
+
+ ----------------------------
+ -- Check_Frozen_Renaming --
+ ----------------------------
+
+ procedure Check_Frozen_Renaming (N : Node_Id; Subp : Entity_Id) is
+ B_Node : Node_Id;
+ Old_S : Entity_Id;
+
+ begin
+ if Is_Frozen (Subp)
+ and then not Has_Completion (Subp)
+ then
+ B_Node :=
+ Build_Renamed_Body
+ (Parent (Declaration_Node (Subp)), Defining_Entity (N));
+
+ if Is_Entity_Name (Name (N)) then
+ Old_S := Entity (Name (N));
+
+ if not Is_Frozen (Old_S) then
+ Ensure_Freeze_Node (Old_S);
+ if No (Actions (Freeze_Node (Old_S))) then
+ Set_Actions (Freeze_Node (Old_S), New_List (B_Node));
+ else
+ Append (B_Node, Actions (Freeze_Node (Old_S)));
+ end if;
+ else
+ Insert_After (N, B_Node);
+ Analyze (B_Node);
+ end if;
+
+ if Is_Intrinsic_Subprogram (Old_S)
+ and then not In_Instance
+ then
+ Error_Msg_N
+ ("subprogram used in renaming_as_body cannot be intrinsic",
+ Name (N));
+ end if;
+
+ else
+ Insert_After (N, B_Node);
+ Analyze (B_Node);
+ end if;
+ end if;
+ end Check_Frozen_Renaming;
+
+ ---------------------------------
+ -- Check_Library_Unit_Renaming --
+ ---------------------------------
+
+ procedure Check_Library_Unit_Renaming (N : Node_Id; Old_E : Entity_Id) is
+ New_E : Entity_Id;
+
+ begin
+ if Nkind (Parent (N)) /= N_Compilation_Unit then
+ return;
+
+ elsif Scope (Old_E) /= Standard_Standard
+ and then not Is_Child_Unit (Old_E)
+ then
+ Error_Msg_N ("renamed unit must be a library unit", Name (N));
+
+ elsif Present (Parent_Spec (N))
+ and then Nkind (Unit (Parent_Spec (N))) = N_Generic_Package_Declaration
+ and then not Is_Child_Unit (Old_E)
+ then
+ Error_Msg_N
+ ("renamed unit must be a child unit of generic parent", Name (N));
+
+ elsif Nkind (N) in N_Generic_Renaming_Declaration
+ and then Nkind (Name (N)) = N_Expanded_Name
+ and then Is_Generic_Instance (Entity (Prefix (Name (N))))
+ and then Is_Generic_Unit (Old_E)
+ then
+ Error_Msg_N
+ ("renamed generic unit must be a library unit", Name (N));
+
+ elsif Ekind (Old_E) = E_Package
+ or else Ekind (Old_E) = E_Generic_Package
+ then
+ -- Inherit categorization flags
+
+ New_E := Defining_Entity (N);
+ Set_Is_Pure (New_E, Is_Pure (Old_E));
+ Set_Is_Preelaborated (New_E, Is_Preelaborated (Old_E));
+ Set_Is_Remote_Call_Interface (New_E,
+ Is_Remote_Call_Interface (Old_E));
+ Set_Is_Remote_Types (New_E, Is_Remote_Types (Old_E));
+ Set_Is_Shared_Passive (New_E, Is_Shared_Passive (Old_E));
+ end if;
+ end Check_Library_Unit_Renaming;
+
+ ---------------
+ -- End_Scope --
+ ---------------
+
+ procedure End_Scope is
+ Id : Entity_Id;
+ Prev : Entity_Id;
+ Outer : Entity_Id;
+
+ begin
+ Id := First_Entity (Current_Scope);
+
+ while Present (Id) loop
+ -- An entity in the current scope is not necessarily the first one
+ -- on its homonym chain. Find its predecessor if any,
+ -- If it is an internal entity, it will not be in the visibility
+ -- chain altogether, and there is nothing to unchain.
+
+ if Id /= Current_Entity (Id) then
+ Prev := Current_Entity (Id);
+ while Present (Prev)
+ and then Present (Homonym (Prev))
+ and then Homonym (Prev) /= Id
+ loop
+ Prev := Homonym (Prev);
+ end loop;
+
+ -- Skip to end of loop if Id is not in the visibility chain
+
+ if No (Prev) or else Homonym (Prev) /= Id then
+ goto Next_Ent;
+ end if;
+
+ else
+ Prev := Empty;
+ end if;
+
+ Outer := Homonym (Id);
+ Set_Is_Immediately_Visible (Id, False);
+
+ while Present (Outer) and then Scope (Outer) = Current_Scope loop
+ Outer := Homonym (Outer);
+ end loop;
+
+ -- Reset homonym link of other entities, but do not modify link
+ -- between entities in current scope, so that the back-end can have
+ -- a proper count of local overloadings.
+
+ if No (Prev) then
+ Set_Name_Entity_Id (Chars (Id), Outer);
+
+ elsif Scope (Prev) /= Scope (Id) then
+ Set_Homonym (Prev, Outer);
+ end if;
+
+ <<Next_Ent>>
+ Next_Entity (Id);
+ end loop;
+
+ -- If the scope generated freeze actions, place them before the
+ -- current declaration and analyze them. Type declarations and
+ -- the bodies of initialization procedures can generate such nodes.
+ -- We follow the parent chain until we reach a list node, which is
+ -- the enclosing list of declarations. If the list appears within
+ -- a protected definition, move freeze nodes outside the protected
+ -- type altogether.
+
+ if Present
+ (Scope_Stack.Table (Scope_Stack.Last).Pending_Freeze_Actions)
+ then
+ declare
+ Decl : Node_Id;
+ L : constant List_Id := Scope_Stack.Table
+ (Scope_Stack.Last).Pending_Freeze_Actions;
+
+ begin
+ if Is_Itype (Current_Scope) then
+ Decl := Associated_Node_For_Itype (Current_Scope);
+ else
+ Decl := Parent (Current_Scope);
+ end if;
+
+ Pop_Scope;
+
+ while not (Is_List_Member (Decl))
+ or else Nkind (Parent (Decl)) = N_Protected_Definition
+ or else Nkind (Parent (Decl)) = N_Task_Definition
+ loop
+ Decl := Parent (Decl);
+ end loop;
+
+ Insert_List_Before_And_Analyze (Decl, L);
+ end;
+
+ else
+ Pop_Scope;
+ end if;
+
+ end End_Scope;
+
+ ---------------------
+ -- End_Use_Clauses --
+ ---------------------
+
+ procedure End_Use_Clauses (Clause : Node_Id) is
+ U : Node_Id := Clause;
+
+ begin
+ while Present (U) loop
+ if Nkind (U) = N_Use_Package_Clause then
+ End_Use_Package (U);
+ elsif Nkind (U) = N_Use_Type_Clause then
+ End_Use_Type (U);
+ end if;
+
+ Next_Use_Clause (U);
+ end loop;
+ end End_Use_Clauses;
+
+ ---------------------
+ -- End_Use_Package --
+ ---------------------
+
+ procedure End_Use_Package (N : Node_Id) is
+ Pack_Name : Node_Id;
+ Pack : Entity_Id;
+ Id : Entity_Id;
+ Elmt : Elmt_Id;
+
+ begin
+ Pack_Name := First (Names (N));
+
+ while Present (Pack_Name) loop
+ Pack := Entity (Pack_Name);
+
+ if Ekind (Pack) = E_Package then
+
+ if In_Open_Scopes (Pack) then
+ null;
+
+ elsif not Redundant_Use (Pack_Name) then
+ Set_In_Use (Pack, False);
+ Id := First_Entity (Pack);
+
+ while Present (Id) loop
+
+ -- Preserve use-visibility of operators whose formals have
+ -- a type that is use_visible thanks to a previous use_type
+ -- clause.
+
+ if Nkind (Id) = N_Defining_Operator_Symbol
+ and then
+ (In_Use (Etype (First_Formal (Id)))
+ or else
+ (Present (Next_Formal (First_Formal (Id)))
+ and then In_Use (Etype (Next_Formal
+ (First_Formal (Id))))))
+ then
+ null;
+
+ else
+ Set_Is_Potentially_Use_Visible (Id, False);
+ end if;
+
+ if Is_Private_Type (Id)
+ and then Present (Full_View (Id))
+ then
+ Set_Is_Potentially_Use_Visible (Full_View (Id), False);
+ end if;
+
+ Next_Entity (Id);
+ end loop;
+
+ if Present (Renamed_Object (Pack)) then
+ Set_In_Use (Renamed_Object (Pack), False);
+ end if;
+
+ if Chars (Pack) = Name_System
+ and then Scope (Pack) = Standard_Standard
+ and then Present_System_Aux
+ then
+ Id := First_Entity (System_Aux_Id);
+
+ while Present (Id) loop
+ Set_Is_Potentially_Use_Visible (Id, False);
+
+ if Is_Private_Type (Id)
+ and then Present (Full_View (Id))
+ then
+ Set_Is_Potentially_Use_Visible (Full_View (Id), False);
+ end if;
+
+ Next_Entity (Id);
+ end loop;
+
+ Set_In_Use (System_Aux_Id, False);
+ end if;
+
+ else
+ Set_Redundant_Use (Pack_Name, False);
+ end if;
+
+ end if;
+
+ Next (Pack_Name);
+ end loop;
+
+ if Present (Hidden_By_Use_Clause (N)) then
+ Elmt := First_Elmt (Hidden_By_Use_Clause (N));
+
+ while Present (Elmt) loop
+ Set_Is_Immediately_Visible (Node (Elmt));
+ Next_Elmt (Elmt);
+ end loop;
+
+ Set_Hidden_By_Use_Clause (N, No_Elist);
+ end if;
+ end End_Use_Package;
+
+ ------------------
+ -- End_Use_Type --
+ ------------------
+
+ procedure End_Use_Type (N : Node_Id) is
+ Id : Entity_Id;
+ Op_List : Elist_Id;
+ Elmt : Elmt_Id;
+ T : Entity_Id;
+
+ begin
+ Id := First (Subtype_Marks (N));
+
+ while Present (Id) loop
+ T := Entity (Id);
+
+ if T = Any_Type then
+ null;
+
+ -- Note that the use_Type clause may mention a subtype of the
+ -- type whose primitive operations have been made visible. Here
+ -- as elsewhere, it is the base type that matters for visibility.
+
+ elsif In_Open_Scopes (Scope (Base_Type (T))) then
+ null;
+
+ elsif not Redundant_Use (Id) then
+ Set_In_Use (T, False);
+ Set_In_Use (Base_Type (T), False);
+ Op_List := Collect_Primitive_Operations (T);
+ Elmt := First_Elmt (Op_List);
+
+ while Present (Elmt) loop
+
+ if Nkind (Node (Elmt)) = N_Defining_Operator_Symbol then
+ Set_Is_Potentially_Use_Visible (Node (Elmt), False);
+ end if;
+
+ Next_Elmt (Elmt);
+ end loop;
+ end if;
+
+ Next (Id);
+ end loop;
+ end End_Use_Type;
+
+ ----------------------
+ -- Find_Direct_Name --
+ ----------------------
+
+ procedure Find_Direct_Name (N : Node_Id) is
+ E : Entity_Id;
+ E2 : Entity_Id;
+ Msg : Boolean;
+
+ Inst : Entity_Id := Empty;
+ -- Enclosing instance, if any.
+
+ Homonyms : Entity_Id;
+ -- Saves start of homonym chain
+
+ Nvis_Entity : Boolean;
+ -- Set True to indicate that at there is at least one entity on the
+ -- homonym chain which, while not visible, is visible enough from the
+ -- user point of view to warrant an error message of "not visible"
+ -- rather than undefined.
+
+ function From_Actual_Package (E : Entity_Id) return Boolean;
+ -- Returns true if the entity is declared in a package that is
+ -- an actual for a formal package of the current instance. Such an
+ -- entity requires special handling because it may be use-visible
+ -- but hides directly visible entities defined outside the instance.
+
+ function Known_But_Invisible (E : Entity_Id) return Boolean;
+ -- This function determines whether the entity E (which is not
+ -- visible) can reasonably be considered to be known to the writer
+ -- of the reference. This is a heuristic test, used only for the
+ -- purposes of figuring out whether we prefer to complain that an
+ -- entity is undefined or invisible (and identify the declaration
+ -- of the invisible entity in the latter case). The point here is
+ -- that we don't want to complain that something is invisible and
+ -- then point to something entirely mysterious to the writer.
+
+ procedure Nvis_Messages;
+ -- Called if there are no visible entries for N, but there is at least
+ -- one non-directly visible, or hidden declaration. This procedure
+ -- outputs an appropriate set of error messages.
+
+ procedure Undefined (Nvis : Boolean);
+ -- This function is called if the current node has no corresponding
+ -- visible entity or entities. The value set in Msg indicates whether
+ -- an error message was generated (multiple error messages for the
+ -- same variable are generally suppressed, see body for details).
+ -- Msg is True if an error message was generated, False if not. This
+ -- value is used by the caller to determine whether or not to output
+ -- additional messages where appropriate. The parameter is set False
+ -- to get the message "X is undefined", and True to get the message
+ -- "X is not visible".
+
+ -------------------------
+ -- From_Actual_Package --
+ -------------------------
+
+ function From_Actual_Package (E : Entity_Id) return Boolean is
+ Scop : constant Entity_Id := Scope (E);
+ Act : Entity_Id;
+
+ begin
+ if not In_Instance then
+ return False;
+ else
+ Inst := Current_Scope;
+
+ while Present (Inst)
+ and then Ekind (Inst) /= E_Package
+ and then not Is_Generic_Instance (Inst)
+ loop
+ Inst := Scope (Inst);
+ end loop;
+
+ if No (Inst) then
+ return False;
+ end if;
+
+ Act := First_Entity (Inst);
+
+ while Present (Act) loop
+ if Ekind (Act) = E_Package then
+
+ -- Check for end of actuals list
+
+ if Renamed_Object (Act) = Inst then
+ return False;
+
+ elsif Present (Associated_Formal_Package (Act))
+ and then Renamed_Object (Act) = Scop
+ then
+ -- Entity comes from (instance of) formal package
+
+ return True;
+
+ else
+ Next_Entity (Act);
+ end if;
+
+ else
+ Next_Entity (Act);
+ end if;
+ end loop;
+
+ return False;
+ end if;
+ end From_Actual_Package;
+
+ -------------------------
+ -- Known_But_Invisible --
+ -------------------------
+
+ function Known_But_Invisible (E : Entity_Id) return Boolean is
+ Fname : File_Name_Type;
+
+ begin
+ -- Entities in Standard are always considered to be known
+
+ if Sloc (E) <= Standard_Location then
+ return True;
+
+ -- An entity that does not come from source is always considered
+ -- to be unknown, since it is an artifact of code expansion.
+
+ elsif not Comes_From_Source (E) then
+ return False;
+
+ -- In gnat internal mode, we consider all entities known
+
+ elsif GNAT_Mode then
+ return True;
+ end if;
+
+ -- Here we have an entity that is not from package Standard, and
+ -- which comes from Source. See if it comes from an internal file.
+
+ Fname := Unit_File_Name (Get_Source_Unit (E));
+
+ -- Case of from internal file
+
+ if Is_Internal_File_Name (Fname) then
+
+ -- Private part entities in internal files are never considered
+ -- to be known to the writer of normal application code.
+
+ if Is_Hidden (E) then
+ return False;
+ end if;
+
+ -- Entities from System packages other than System and
+ -- System.Storage_Elements are not considered to be known.
+ -- System.Auxxxx files are also considered known to the user.
+
+ -- Should refine this at some point to generally distinguish
+ -- between known and unknown internal files ???
+
+ Get_Name_String (Fname);
+
+ return
+ Name_Len < 2
+ or else
+ Name_Buffer (1 .. 2) /= "s-"
+ or else
+ Name_Buffer (3 .. 8) = "stoele"
+ or else
+ Name_Buffer (3 .. 5) = "aux";
+
+ -- If not an internal file, then entity is definitely known,
+ -- even if it is in a private part (the message generated will
+ -- note that it is in a private part)
+
+ else
+ return True;
+ end if;
+ end Known_But_Invisible;
+
+ -------------------
+ -- Nvis_Messages --
+ -------------------
+
+ procedure Nvis_Messages is
+ Ent : Entity_Id;
+ Hidden : Boolean := False;
+
+ begin
+ Undefined (Nvis => True);
+
+ if Msg then
+
+ -- First loop does hidden declarations
+
+ Ent := Homonyms;
+ while Present (Ent) loop
+ if Is_Potentially_Use_Visible (Ent) then
+
+ if not Hidden then
+ Error_Msg_N ("multiple use clauses cause hiding!", N);
+ Hidden := True;
+ end if;
+
+ Error_Msg_Sloc := Sloc (Ent);
+ Error_Msg_N ("hidden declaration#!", N);
+ end if;
+
+ Ent := Homonym (Ent);
+ end loop;
+
+ -- If we found hidden declarations, then that's enough, don't
+ -- bother looking for non-visible declarations as well.
+
+ if Hidden then
+ return;
+ end if;
+
+ -- Second loop does non-directly visible declarations
+
+ Ent := Homonyms;
+ while Present (Ent) loop
+ if not Is_Potentially_Use_Visible (Ent) then
+
+ -- Do not bother the user with unknown entities
+
+ if not Known_But_Invisible (Ent) then
+ goto Continue;
+ end if;
+
+ Error_Msg_Sloc := Sloc (Ent);
+
+ -- Output message noting that there is a non-visible
+ -- declaration, distinguishing the private part case.
+
+ if Is_Hidden (Ent) then
+ Error_Msg_N ("non-visible (private) declaration#!", N);
+ else
+ Error_Msg_N ("non-visible declaration#!", N);
+ end if;
+ end if;
+
+ <<Continue>>
+ Ent := Homonym (Ent);
+ end loop;
+
+ end if;
+ end Nvis_Messages;
+
+ ---------------
+ -- Undefined --
+ ---------------
+
+ procedure Undefined (Nvis : Boolean) is
+ Emsg : Error_Msg_Id;
+
+ begin
+ -- A very specialized error check, if the undefined variable is
+ -- a case tag, and the case type is an enumeration type, check
+ -- for a possible misspelling, and if so, modify the identifier
+
+ -- Named aggregate should also be handled similarly ???
+
+ if Nkind (N) = N_Identifier
+ and then Nkind (Parent (N)) = N_Case_Statement_Alternative
+ then
+ Get_Name_String (Chars (N));
+
+ declare
+ Case_Str : constant String := Name_Buffer (1 .. Name_Len);
+ Case_Stm : constant Node_Id := Parent (Parent (N));
+ Case_Typ : constant Entity_Id := Etype (Expression (Case_Stm));
+
+ Lit : Node_Id;
+
+ begin
+ if Is_Enumeration_Type (Case_Typ)
+ and then Case_Typ /= Standard_Character
+ and then Case_Typ /= Standard_Wide_Character
+ then
+ Lit := First_Literal (Case_Typ);
+ Get_Name_String (Chars (Lit));
+
+ if Chars (Lit) /= Chars (N)
+ and then Is_Bad_Spelling_Of
+ (Case_Str, Name_Buffer (1 .. Name_Len))
+ then
+ Error_Msg_Node_2 := Lit;
+ Error_Msg_N
+ ("& is undefined, assume misspelling of &", N);
+ Rewrite (N, New_Occurrence_Of (Lit, Sloc (N)));
+ return;
+ end if;
+
+ Lit := Next_Literal (Lit);
+ end if;
+ end;
+ end if;
+
+ -- Normal processing
+
+ Set_Entity (N, Any_Id);
+ Set_Etype (N, Any_Type);
+
+ -- We use the table Urefs to keep track of entities for which we
+ -- have issued errors for undefined references. Multiple errors
+ -- for a single name are normally suppressed, however we modify
+ -- the error message to alert the programmer to this effect.
+
+ for J in Urefs.First .. Urefs.Last loop
+ if Chars (N) = Chars (Urefs.Table (J).Node) then
+ if Urefs.Table (J).Err /= No_Error_Msg
+ and then Sloc (N) /= Urefs.Table (J).Loc
+ then
+ Error_Msg_Node_1 := Urefs.Table (J).Node;
+
+ if Urefs.Table (J).Nvis then
+ Change_Error_Text (Urefs.Table (J).Err,
+ "& is not visible (more references follow)");
+ else
+ Change_Error_Text (Urefs.Table (J).Err,
+ "& is undefined (more references follow)");
+ end if;
+
+ Urefs.Table (J).Err := No_Error_Msg;
+ end if;
+
+ -- Although we will set Msg False, and thus suppress the
+ -- message, we also set Error_Posted True, to avoid any
+ -- cascaded messages resulting from the undefined reference.
+
+ Msg := False;
+ Set_Error_Posted (N, True);
+ return;
+ end if;
+ end loop;
+
+ -- If entry not found, this is first undefined occurrence
+
+ if Nvis then
+ Error_Msg_N ("& is not visible!", N);
+ Emsg := Get_Msg_Id;
+
+ else
+ Error_Msg_N ("& is undefined!", N);
+ Emsg := Get_Msg_Id;
+
+ -- A very bizarre special check, if the undefined identifier
+ -- is put or put_line, then add a special error message (since
+ -- this is a very common error for beginners to make).
+
+ if Chars (N) = Name_Put or else Chars (N) = Name_Put_Line then
+ Error_Msg_N ("\possible missing with of 'Text_'I'O!", N);
+ end if;
+
+ -- Now check for possible misspellings
+
+ Get_Name_String (Chars (N));
+
+ declare
+ E : Entity_Id;
+ Ematch : Entity_Id := Empty;
+
+ Last_Name_Id : constant Name_Id :=
+ Name_Id (Nat (First_Name_Id) +
+ Name_Entries_Count - 1);
+
+ S : constant String (1 .. Name_Len) :=
+ Name_Buffer (1 .. Name_Len);
+
+ begin
+ for N in First_Name_Id .. Last_Name_Id loop
+ E := Get_Name_Entity_Id (N);
+
+ if Present (E)
+ and then (Is_Immediately_Visible (E)
+ or else
+ Is_Potentially_Use_Visible (E))
+ then
+ Get_Name_String (N);
+
+ if Is_Bad_Spelling_Of
+ (Name_Buffer (1 .. Name_Len), S)
+ then
+ Ematch := E;
+ exit;
+ end if;
+ end if;
+ end loop;
+
+ if Present (Ematch) then
+ Error_Msg_NE ("\possible misspelling of&", N, Ematch);
+ end if;
+ end;
+ end if;
+
+ -- Make entry in undefined references table unless the full
+ -- errors switch is set, in which case by refraining from
+ -- generating the table entry, we guarantee that we get an
+ -- error message for every undefined reference.
+
+ if not All_Errors_Mode then
+ Urefs.Increment_Last;
+ Urefs.Table (Urefs.Last).Node := N;
+ Urefs.Table (Urefs.Last).Err := Emsg;
+ Urefs.Table (Urefs.Last).Nvis := Nvis;
+ Urefs.Table (Urefs.Last).Loc := Sloc (N);
+ end if;
+
+ Msg := True;
+ end Undefined;
+
+ -- Start of processing for Find_Direct_Name
+
+ begin
+ -- If the entity pointer is already set, this is an internal node, or
+ -- a node that is analyzed more than once, after a tree modification.
+ -- In such a case there is no resolution to perform, just set the type.
+
+ if Present (Entity (N)) then
+ if Is_Type (Entity (N)) then
+ Set_Etype (N, Entity (N));
+
+ else
+ declare
+ Entyp : constant Entity_Id := Etype (Entity (N));
+
+ begin
+ -- One special case here. If the Etype field is already set,
+ -- and references the packed array type corresponding to the
+ -- etype of the referenced entity, then leave it alone. This
+ -- happens for trees generated from Exp_Pakd, where expressions
+ -- can be deliberately "mis-typed" to the packed array type.
+
+ if Is_Array_Type (Entyp)
+ and then Is_Packed (Entyp)
+ and then Present (Etype (N))
+ and then Etype (N) = Packed_Array_Type (Entyp)
+ then
+ null;
+
+ -- If not that special case, then just reset the Etype
+
+ else
+ Set_Etype (N, Etype (Entity (N)));
+ end if;
+ end;
+ end if;
+
+ return;
+ end if;
+
+ -- Here if Entity pointer was not set, we need full visibility analysis
+ -- First we generate debugging output if the debug E flag is set.
+
+ if Debug_Flag_E then
+ Write_Str ("Looking for ");
+ Write_Name (Chars (N));
+ Write_Eol;
+ end if;
+
+ Homonyms := Current_Entity (N);
+ Nvis_Entity := False;
+
+ E := Homonyms;
+ while Present (E) loop
+
+ -- If entity is immediately visible or potentially use
+ -- visible, then process the entity and we are done.
+
+ if Is_Immediately_Visible (E) then
+ goto Immediately_Visible_Entity;
+
+ elsif Is_Potentially_Use_Visible (E) then
+ goto Potentially_Use_Visible_Entity;
+
+ -- Note if a known but invisible entity encountered
+
+ elsif Known_But_Invisible (E) then
+ Nvis_Entity := True;
+ end if;
+
+ -- Move to next entity in chain and continue search
+
+ E := Homonym (E);
+ end loop;
+
+ -- If no entries on homonym chain that were potentially visible,
+ -- and no entities reasonably considered as non-visible, then
+ -- we have a plain undefined reference, with no additional
+ -- explanation required!
+
+ if not Nvis_Entity then
+ Undefined (Nvis => False);
+ return;
+
+ -- Otherwise there is at least one entry on the homonym chain that
+ -- is reasonably considered as being known and non-visible.
+
+ else
+ Nvis_Messages;
+ return;
+ end if;
+
+ -- Processing for a potentially use visible entry found. We must search
+ -- the rest of the homonym chain for two reasons. First, if there is a
+ -- directly visible entry, then none of the potentially use-visible
+ -- entities are directly visible (RM 8.4(10)). Second, we need to check
+ -- for the case of multiple potentially use-visible entries hiding one
+ -- another and as a result being non-directly visible (RM 8.4(11)).
+
+ <<Potentially_Use_Visible_Entity>> declare
+ Only_One_Visible : Boolean := True;
+ All_Overloadable : Boolean := Is_Overloadable (E);
+
+ begin
+ E2 := Homonym (E);
+
+ while Present (E2) loop
+ if Is_Immediately_Visible (E2) then
+
+ -- If the use-visible entity comes from the actual for a
+ -- formal package, it hides a directly visible entity from
+ -- outside the instance.
+
+ if From_Actual_Package (E)
+ and then Scope_Depth (E2) < Scope_Depth (Inst)
+ then
+ goto Found;
+ else
+ E := E2;
+ goto Immediately_Visible_Entity;
+ end if;
+
+ elsif Is_Potentially_Use_Visible (E2) then
+ Only_One_Visible := False;
+ All_Overloadable := All_Overloadable and Is_Overloadable (E2);
+ end if;
+
+ E2 := Homonym (E2);
+ end loop;
+
+ -- On falling through this loop, we have checked that there are no
+ -- immediately visible entities. Only_One_Visible is set if exactly
+ -- one potentially use visible entity exists. All_Overloadable is
+ -- set if all the potentially use visible entities are overloadable.
+ -- The condition for legality is that either there is one potentially
+ -- use visible entity, or if there is more than one, then all of them
+ -- are overloadable.
+
+ if Only_One_Visible or All_Overloadable then
+ goto Found;
+
+ -- If there is more than one potentially use-visible entity and at
+ -- least one of them non-overloadable, we have an error (RM 8.4(11).
+ -- Note that E points to the first such entity on the homonym list.
+ -- Special case: if one of the entities is declared in an actual
+ -- package, it was visible in the generic, and takes precedence over
+ -- other entities that are potentially use-visible.
+
+ else
+ if In_Instance then
+ E2 := E;
+
+ while Present (E2) loop
+ if Is_Generic_Instance (Scope (E2)) then
+ E := E2;
+ goto Found;
+ end if;
+
+ E2 := Homonym (E2);
+ end loop;
+
+ Nvis_Messages;
+ return;
+
+ else
+ Nvis_Messages;
+ return;
+ end if;
+ end if;
+ end;
+
+ -- Come here with E set to the first immediately visible entity on
+ -- the homonym chain. This is the one we want unless there is another
+ -- immediately visible entity further on in the chain for a more
+ -- inner scope (RM 8.3(8)).
+
+ <<Immediately_Visible_Entity>> declare
+ Level : Int;
+ Scop : Entity_Id;
+
+ begin
+ -- Find scope level of initial entity. When compiling through
+ -- Rtsfind, the previous context is not completely invisible, and
+ -- an outer entity may appear on the chain, whose scope is below
+ -- the entry for Standard that delimits the current scope stack.
+ -- Indicate that the level for this spurious entry is outside of
+ -- the current scope stack.
+
+ Level := Scope_Stack.Last;
+ loop
+ Scop := Scope_Stack.Table (Level).Entity;
+ exit when Scop = Scope (E);
+ Level := Level - 1;
+ exit when Scop = Standard_Standard;
+ end loop;
+
+ -- Now search remainder of homonym chain for more inner entry
+ -- If the entity is Standard itself, it has no scope, and we
+ -- compare it with the stack entry directly.
+
+ E2 := Homonym (E);
+ while Present (E2) loop
+ if Is_Immediately_Visible (E2) then
+ for J in Level + 1 .. Scope_Stack.Last loop
+ if Scope_Stack.Table (J).Entity = Scope (E2)
+ or else Scope_Stack.Table (J).Entity = E2
+ then
+ Level := J;
+ E := E2;
+ exit;
+ end if;
+ end loop;
+ end if;
+
+ E2 := Homonym (E2);
+ end loop;
+
+ -- At the end of that loop, E is the innermost immediately
+ -- visible entity, so we are all set.
+ end;
+
+ -- Come here with entity found, and stored in E
+
+ <<Found>> begin
+
+ if Comes_From_Source (N)
+ and then Is_Remote_Access_To_Subprogram_Type (E)
+ and then Expander_Active
+ then
+ Rewrite (N,
+ New_Occurrence_Of (Equivalent_Type (E), Sloc (N)));
+ return;
+ end if;
+
+ Set_Entity (N, E);
+ -- Why no Style_Check here???
+
+ if Is_Type (E) then
+ Set_Etype (N, E);
+ else
+ Set_Etype (N, Get_Full_View (Etype (E)));
+ end if;
+
+ if Debug_Flag_E then
+ Write_Str (" found ");
+ Write_Entity_Info (E, " ");
+ end if;
+
+ -- If the Ekind of the entity is Void, it means that all homonyms
+ -- are hidden from all visibility (RM 8.3(5,14-20)). However, this
+ -- test is skipped if the current scope is a record and the name is
+ -- a pragma argument expression (case of Atomic and Volatile pragmas
+ -- and possibly other similar pragmas added later, which are allowed
+ -- to reference components in the current record).
+
+ if Ekind (E) = E_Void
+ and then
+ (not Is_Record_Type (Current_Scope)
+ or else Nkind (Parent (N)) /= N_Pragma_Argument_Association)
+ then
+ Premature_Usage (N);
+
+ -- If the entity is overloadable, collect all interpretations
+ -- of the name for subsequent overload resolution. We optimize
+ -- a bit here to do this only if we have an overloadable entity
+ -- that is not on its own on the homonym chain.
+
+ elsif Is_Overloadable (E)
+ and then (Present (Homonym (E)) or else Current_Entity (N) /= E)
+ then
+ Collect_Interps (N);
+
+ -- If no homonyms were visible, the entity is unambiguous.
+
+ if not Is_Overloaded (N) then
+ Generate_Reference (E, N);
+ end if;
+
+ -- Case of non-overloadable entity, set the entity providing that
+ -- we do not have the case of a discriminant reference within a
+ -- default expression. Such references are replaced with the
+ -- corresponding discriminal, which is the formal corresponding to
+ -- to the discriminant in the initialization procedure.
+
+ -- This replacement must not be done if we are currently processing
+ -- a generic spec or body.
+
+ -- The replacement is not done either for a task discriminant that
+ -- appears in a default expression of an entry parameter. See
+ -- Expand_Discriminant in exp_ch2 for details on their handling.
+
+ else
+ -- Entity is unambiguous, indicate that it is referenced here
+ -- One slightly odd case is that we do not want to set the
+ -- Referenced flag if the entity is a label, and the identifier
+ -- is the label in the source, since this is not a reference
+ -- from the point of view of the user
+
+ if Nkind (Parent (N)) = N_Label then
+ declare
+ R : constant Boolean := Referenced (E);
+
+ begin
+ Generate_Reference (E, N);
+ Set_Referenced (E, R);
+ end;
+
+ else
+ Generate_Reference (E, N);
+ end if;
+
+ if not In_Default_Expression
+ or else Ekind (E) /= E_Discriminant
+ or else Inside_A_Generic
+ then
+ Set_Entity_With_Style_Check (N, E);
+
+ elsif Is_Concurrent_Type (Scope (E)) then
+ declare
+ P : Node_Id := Parent (N);
+
+ begin
+ while Present (P)
+ and then Nkind (P) /= N_Parameter_Specification
+ and then Nkind (P) /= N_Component_Declaration
+ loop
+ P := Parent (P);
+ end loop;
+
+ if Present (P)
+ and then Nkind (P) = N_Parameter_Specification
+ then
+ null;
+ else
+ Set_Entity (N, Discriminal (E));
+ end if;
+ end;
+
+ else
+ Set_Entity (N, Discriminal (E));
+ end if;
+ end if;
+ end;
+ end Find_Direct_Name;
+
+ ------------------------
+ -- Find_Expanded_Name --
+ ------------------------
+
+ -- This routine searches the homonym chain of the entity until it finds
+ -- an entity declared in the scope denoted by the prefix. If the entity
+ -- is private, it may nevertheless be immediately visible, if we are in
+ -- the scope of its declaration.
+
+ procedure Find_Expanded_Name (N : Node_Id) is
+ Candidate : Entity_Id := Empty;
+ Selector : constant Node_Id := Selector_Name (N);
+ P_Name : Entity_Id;
+ O_Name : Entity_Id;
+ Id : Entity_Id;
+
+ begin
+ P_Name := Entity (Prefix (N));
+ O_Name := P_Name;
+
+ -- If the prefix is a renamed package, look for the entity
+ -- in the original package.
+
+ if Ekind (P_Name) = E_Package
+ and then Present (Renamed_Object (P_Name))
+ then
+ P_Name := Renamed_Object (P_Name);
+
+ -- Rewrite node with entity field pointing to renamed object
+
+ Rewrite (Prefix (N), New_Copy (Prefix (N)));
+ Set_Entity (Prefix (N), P_Name);
+
+ -- If the prefix is an object of a concurrent type, look for
+ -- the entity in the associated task or protected type.
+
+ elsif Is_Concurrent_Type (Etype (P_Name)) then
+ P_Name := Etype (P_Name);
+ end if;
+
+ Id := Current_Entity (Selector);
+
+ while Present (Id) loop
+
+ if Scope (Id) = P_Name then
+ Candidate := Id;
+
+ if Is_Child_Unit (Id) then
+ exit when
+ (Is_Visible_Child_Unit (Id)
+ or else Is_Immediately_Visible (Id));
+
+ else
+ exit when
+ (not Is_Hidden (Id) or else Is_Immediately_Visible (Id));
+ end if;
+ end if;
+
+ Id := Homonym (Id);
+ end loop;
+
+ if No (Id)
+ and then (Ekind (P_Name) = E_Procedure
+ or else
+ Ekind (P_Name) = E_Function)
+ and then Is_Generic_Instance (P_Name)
+ then
+ -- Expanded name denotes entity in (instance of) generic subprogram.
+ -- The entity may be in the subprogram instance, or may denote one of
+ -- the formals, which is declared in the enclosing wrapper package.
+
+ P_Name := Scope (P_Name);
+ Id := Current_Entity (Selector);
+
+ while Present (Id) loop
+ exit when Scope (Id) = P_Name;
+ Id := Homonym (Id);
+ end loop;
+ end if;
+
+ if No (Id) or else Chars (Id) /= Chars (Selector) then
+
+ Set_Etype (N, Any_Type);
+
+ -- If we are looking for an entity defined in System, try to
+ -- find it in the child package that may have been provided as
+ -- an extension to System. The Extend_System pragma will have
+ -- supplied the name of the extension, which may have to be loaded.
+
+ if Chars (P_Name) = Name_System
+ and then Scope (P_Name) = Standard_Standard
+ and then Present (System_Extend_Pragma_Arg)
+ and then Present_System_Aux (N)
+ then
+ Set_Entity (Prefix (N), System_Aux_Id);
+ Find_Expanded_Name (N);
+ return;
+
+ elsif (Nkind (Selector) = N_Operator_Symbol
+ and then Has_Implicit_Operator (N))
+ then
+ -- There is an implicit instance of the predefined operator in
+ -- the given scope. The operator entity is defined in Standard.
+ -- Has_Implicit_Operator makes the node into an Expanded_Name.
+
+ return;
+
+ elsif Nkind (Selector) = N_Character_Literal
+ and then Has_Implicit_Character_Literal (N)
+ then
+ -- If there is no literal defined in the scope denoted by the
+ -- prefix, the literal may belong to (a type derived from)
+ -- Standard_Character, for which we have no explicit literals.
+
+ return;
+
+ else
+ -- If the prefix is a single concurrent object, use its
+ -- name in the error message, rather than that of the
+ -- anonymous type.
+
+ if Is_Concurrent_Type (P_Name)
+ and then Is_Internal_Name (Chars (P_Name))
+ then
+ Error_Msg_Node_2 := Entity (Prefix (N));
+ else
+ Error_Msg_Node_2 := P_Name;
+ end if;
+
+ if P_Name = System_Aux_Id then
+ P_Name := Scope (P_Name);
+ Set_Entity (Prefix (N), P_Name);
+ end if;
+
+ if Present (Candidate) then
+
+ if Is_Child_Unit (Candidate) then
+ Error_Msg_N
+ ("missing with_clause for child unit &", Selector);
+ else
+ Error_Msg_NE ("& is not a visible entity of&", N, Selector);
+ end if;
+
+ else
+ -- Within the instantiation of a child unit, the prefix may
+ -- denote the parent instance, but the selector has the
+ -- name of the original child. Find whether we are within
+ -- the corresponding instance, and get the proper entity, which
+ -- can only be an enclosing scope.
+
+ if O_Name /= P_Name
+ and then In_Open_Scopes (P_Name)
+ and then Is_Generic_Instance (P_Name)
+ then
+ declare
+ S : Entity_Id := Current_Scope;
+ P : Entity_Id;
+
+ begin
+ for J in reverse 0 .. Scope_Stack.Last loop
+ S := Scope_Stack.Table (J).Entity;
+
+ exit when S = Standard_Standard;
+
+ if Ekind (S) = E_Function
+ or else Ekind (S) = E_Package
+ or else Ekind (S) = E_Procedure
+ then
+ P := Generic_Parent (Specification
+ (Unit_Declaration_Node (S)));
+
+ if Present (P)
+ and then Chars (Scope (P)) = Chars (O_Name)
+ and then Chars (P) = Chars (Selector)
+ then
+ Id := S;
+ goto found;
+ end if;
+ end if;
+
+ end loop;
+ end;
+ end if;
+
+ if (Chars (P_Name) = Name_Ada
+ and then Scope (P_Name) = Standard_Standard)
+ then
+ Error_Msg_Node_2 := Selector;
+ Error_Msg_NE
+ ("\missing with for `&.&`", N, P_Name);
+
+ -- If this is a selection from a dummy package, then
+ -- suppress the error message, of course the entity
+ -- is missing if the package is missing!
+
+ elsif Sloc (Error_Msg_Node_2) = No_Location then
+ null;
+
+ -- Here we have the case of an undefined component
+
+ else
+
+ Error_Msg_NE ("& not declared in&", N, Selector);
+
+ -- Check for misspelling of some entity in prefix.
+
+ Id := First_Entity (P_Name);
+ Get_Name_String (Chars (Selector));
+
+ declare
+ S : constant String (1 .. Name_Len) :=
+ Name_Buffer (1 .. Name_Len);
+ begin
+ while Present (Id) loop
+ Get_Name_String (Chars (Id));
+ if Is_Bad_Spelling_Of
+ (Name_Buffer (1 .. Name_Len), S)
+ and then not Is_Internal_Name (Chars (Id))
+ then
+ Error_Msg_NE
+ ("possible misspelling of&", Selector, Id);
+ exit;
+ end if;
+
+ Next_Entity (Id);
+ end loop;
+ end;
+
+ -- Specialize the message if this may be an instantiation
+ -- of a child unit that was not mentioned in the context.
+
+ if Nkind (Parent (N)) = N_Package_Instantiation
+ and then Is_Generic_Instance (Entity (Prefix (N)))
+ and then Is_Compilation_Unit
+ (Generic_Parent (Parent (Entity (Prefix (N)))))
+ then
+ Error_Msg_NE
+ ("\possible missing with clause on child unit&",
+ N, Selector);
+ end if;
+ end if;
+ end if;
+
+ Id := Any_Id;
+ end if;
+ end if;
+
+ <<found>>
+ if Comes_From_Source (N)
+ and then Is_Remote_Access_To_Subprogram_Type (Id)
+ then
+ Id := Equivalent_Type (Id);
+ Set_Chars (Selector, Chars (Id));
+ end if;
+
+ if Ekind (P_Name) = E_Package
+ and then From_With_Type (P_Name)
+ then
+ if From_With_Type (Id)
+ or else (Ekind (Id) = E_Package and then From_With_Type (Id))
+ then
+ null;
+ else
+ Error_Msg_N
+ ("imported package can only be used to access imported type",
+ N);
+ end if;
+ end if;
+
+ if Is_Task_Type (P_Name)
+ and then ((Ekind (Id) = E_Entry
+ and then Nkind (Parent (N)) /= N_Attribute_Reference)
+ or else
+ (Ekind (Id) = E_Entry_Family
+ and then
+ Nkind (Parent (Parent (N))) /= N_Attribute_Reference))
+ then
+ -- It is an entry call after all, either to the current task
+ -- (which will deadlock) or to an enclosing task.
+
+ Analyze_Selected_Component (N);
+ return;
+ end if;
+
+ Change_Selected_Component_To_Expanded_Name (N);
+ Set_Entity_With_Style_Check (N, Id);
+ Generate_Reference (Id, N);
+
+ if Is_Type (Id) then
+ Set_Etype (N, Id);
+ else
+ Set_Etype (N, Get_Full_View (Etype (Id)));
+ end if;
+
+ -- If the Ekind of the entity is Void, it means that all homonyms
+ -- are hidden from all visibility (RM 8.3(5,14-20)).
+
+ if Ekind (Id) = E_Void then
+ Premature_Usage (N);
+
+ elsif Is_Overloadable (Id)
+ and then Present (Homonym (Id))
+ then
+ declare
+ H : Entity_Id := Homonym (Id);
+
+ begin
+ while Present (H) loop
+ if Scope (H) = Scope (Id) then
+ Collect_Interps (N);
+ exit;
+ end if;
+
+ H := Homonym (H);
+ end loop;
+ end;
+ end if;
+
+ if Nkind (Selector_Name (N)) = N_Operator_Symbol
+ and then Scope (Id) /= Standard_Standard
+ then
+ -- In addition to user-defined operators in the given scope,
+ -- there may be an implicit instance of the predefined
+ -- operator. The operator (defined in Standard) is found
+ -- in Has_Implicit_Operator, and added to the interpretations.
+ -- Procedure Add_One_Interp will determine which hides which.
+
+ if Has_Implicit_Operator (N) then
+ null;
+ end if;
+ end if;
+ end Find_Expanded_Name;
+
+ -------------------------
+ -- Find_Renamed_Entity --
+ -------------------------
+
+ function Find_Renamed_Entity
+ (N : Node_Id;
+ Nam : Node_Id;
+ New_S : Entity_Id;
+ Is_Actual : Boolean := False) return Entity_Id
+ is
+ I : Interp_Index;
+ I1 : Interp_Index := 0; -- Suppress junk warnings
+ It : Interp;
+ It1 : Interp;
+ Old_S : Entity_Id;
+ Inst : Entity_Id;
+
+ function Enclosing_Instance return Entity_Id;
+ -- If the renaming determines the entity for the default of a formal
+ -- subprogram nested within another instance, choose the innermost
+ -- candidate. This is because if the formal has a box, and we are within
+ -- an enclosing instance where some candidate interpretations are local
+ -- to this enclosing instance, we know that the default was properly
+ -- resolved when analyzing the generic, so we prefer the local
+ -- candidates to those that are external. This is not always the case
+ -- but is a reasonable heuristic on the use of nested generics.
+ -- The proper solution requires a full renaming model.
+
+ function Within (Inner, Outer : Entity_Id) return Boolean;
+ -- Determine whether a candidate subprogram is defined within
+ -- the enclosing instance. If yes, it has precedence over outer
+ -- candidates.
+
+ function Is_Visible_Operation (Op : Entity_Id) return Boolean;
+ -- If the renamed entity is an implicit operator, check whether it is
+ -- visible because its operand type is properly visible. This
+ -- check applies to explicit renamed entities that appear in the
+ -- source in a renaming declaration or a formal subprogram instance,
+ -- but not to default generic actuals with a name.
+
+ ------------------------
+ -- Enclosing_Instance --
+ ------------------------
+
+ function Enclosing_Instance return Entity_Id is
+ S : Entity_Id;
+
+ begin
+ if not Is_Generic_Instance (Current_Scope)
+ and then not Is_Actual
+ then
+ return Empty;
+ end if;
+
+ S := Scope (Current_Scope);
+
+ while S /= Standard_Standard loop
+
+ if Is_Generic_Instance (S) then
+ return S;
+ end if;
+
+ S := Scope (S);
+ end loop;
+
+ return Empty;
+ end Enclosing_Instance;
+
+ --------------------------
+ -- Is_Visible_Operation --
+ --------------------------
+
+ function Is_Visible_Operation (Op : Entity_Id) return Boolean is
+ Scop : Entity_Id;
+ Typ : Entity_Id;
+ Btyp : Entity_Id;
+
+ begin
+ if Ekind (Op) /= E_Operator
+ or else Scope (Op) /= Standard_Standard
+ or else (In_Instance
+ and then
+ (not Is_Actual
+ or else Present (Enclosing_Instance)))
+ then
+ return True;
+
+ else
+ -- For a fixed point type operator, check the resulting type,
+ -- because it may be a mixed mode integer * fixed operation.
+
+ if Present (Next_Formal (First_Formal (New_S)))
+ and then Is_Fixed_Point_Type (Etype (New_S))
+ then
+ Typ := Etype (New_S);
+ else
+ Typ := Etype (First_Formal (New_S));
+ end if;
+
+ Btyp := Base_Type (Typ);
+
+ if Nkind (Nam) /= N_Expanded_Name then
+ return (In_Open_Scopes (Scope (Btyp))
+ or else Is_Potentially_Use_Visible (Btyp)
+ or else In_Use (Btyp)
+ or else In_Use (Scope (Btyp)));
+
+ else
+ Scop := Entity (Prefix (Nam));
+
+ if Ekind (Scop) = E_Package
+ and then Present (Renamed_Object (Scop))
+ then
+ Scop := Renamed_Object (Scop);
+ end if;
+
+ -- Operator is visible if prefix of expanded name denotes
+ -- scope of type, or else type type is defined in System_Aux
+ -- and the prefix denotes System.
+
+ return Scope (Btyp) = Scop
+ or else (Scope (Btyp) = System_Aux_Id
+ and then Scope (Scope (Btyp)) = Scop);
+ end if;
+ end if;
+ end Is_Visible_Operation;
+
+ ------------
+ -- Within --
+ ------------
+
+ function Within (Inner, Outer : Entity_Id) return Boolean is
+ Sc : Entity_Id := Scope (Inner);
+
+ begin
+ while Sc /= Standard_Standard loop
+
+ if Sc = Outer then
+ return True;
+ else
+ Sc := Scope (Sc);
+ end if;
+ end loop;
+
+ return False;
+ end Within;
+
+ -- Start of processing for Find_Renamed_Entry
+
+ begin
+ Old_S := Any_Id;
+ Candidate_Renaming := Empty;
+
+ if not Is_Overloaded (Nam) then
+ if Entity_Matches_Spec (Entity (Nam), New_S)
+ and then Is_Visible_Operation (Entity (Nam))
+ then
+ Old_S := Entity (Nam);
+
+ elsif
+ Present (First_Formal (Entity (Nam)))
+ and then Present (First_Formal (New_S))
+ and then (Base_Type (Etype (First_Formal (Entity (Nam))))
+ = Base_Type (Etype (First_Formal (New_S))))
+ then
+ Candidate_Renaming := Entity (Nam);
+ end if;
+
+ else
+ Get_First_Interp (Nam, I, It);
+
+ while Present (It.Nam) loop
+
+ if Entity_Matches_Spec (It.Nam, New_S)
+ and then Is_Visible_Operation (It.Nam)
+ then
+ if Old_S /= Any_Id then
+
+ -- Note: The call to Disambiguate only happens if a
+ -- previous interpretation was found, in which case I1
+ -- has received a value.
+
+ It1 := Disambiguate (Nam, I1, I, Etype (Old_S));
+
+ if It1 = No_Interp then
+
+ Inst := Enclosing_Instance;
+
+ if Present (Inst) then
+
+ if Within (It.Nam, Inst) then
+ return (It.Nam);
+
+ elsif Within (Old_S, Inst) then
+ return (Old_S);
+
+ else
+ Error_Msg_N ("ambiguous renaming", N);
+ return Old_S;
+ end if;
+
+ else
+ Error_Msg_N ("ambiguous renaming", N);
+ return Old_S;
+ end if;
+
+ else
+ Old_S := It1.Nam;
+ exit;
+ end if;
+
+ else
+ I1 := I;
+ Old_S := It.Nam;
+ end if;
+
+ elsif
+ Present (First_Formal (It.Nam))
+ and then Present (First_Formal (New_S))
+ and then (Base_Type (Etype (First_Formal (It.Nam)))
+ = Base_Type (Etype (First_Formal (New_S))))
+ then
+ Candidate_Renaming := It.Nam;
+ end if;
+
+ Get_Next_Interp (I, It);
+ end loop;
+
+ Set_Entity (Nam, Old_S);
+ Set_Is_Overloaded (Nam, False);
+ end if;
+
+ return Old_S;
+ end Find_Renamed_Entity;
+
+ -----------------------------
+ -- Find_Selected_Component --
+ -----------------------------
+
+ procedure Find_Selected_Component (N : Node_Id) is
+ P : Node_Id := Prefix (N);
+
+ P_Name : Entity_Id;
+ -- Entity denoted by prefix
+
+ P_Type : Entity_Id;
+ -- and its type
+
+ Nam : Node_Id;
+
+ begin
+ Analyze (P);
+
+ if Nkind (P) = N_Error then
+ return;
+
+ -- If the selector already has an entity, the node has been
+ -- constructed in the course of expansion, and is known to be
+ -- valid. Do not verify that it is defined for the type (it may
+ -- be a private component used in the expansion of record equality).
+
+ elsif Present (Entity (Selector_Name (N))) then
+
+ if No (Etype (N))
+ or else Etype (N) = Any_Type
+ then
+ declare
+ Sel_Name : Node_Id := Selector_Name (N);
+ Selector : Entity_Id := Entity (Sel_Name);
+ C_Etype : Node_Id;
+
+ begin
+ Set_Etype (Sel_Name, Etype (Selector));
+
+ if not Is_Entity_Name (P) then
+ Resolve (P, Etype (P));
+ end if;
+
+ -- Build an actual subtype except for the first parameter
+ -- of an init_proc, where this actual subtype is by
+ -- definition incorrect, since the object is uninitialized
+ -- (and does not even have defined discriminants etc.)
+
+ if Is_Entity_Name (P)
+ and then Ekind (Entity (P)) = E_Function
+ then
+ Nam := New_Copy (P);
+
+ if Is_Overloaded (P) then
+ Save_Interps (P, Nam);
+ end if;
+
+ Rewrite (P,
+ Make_Function_Call (Sloc (P), Name => Nam));
+ Analyze_Call (P);
+ Analyze_Selected_Component (N);
+ return;
+
+ elsif Ekind (Selector) = E_Component
+ and then (not Is_Entity_Name (P)
+ or else Chars (Entity (P)) /= Name_uInit)
+ then
+ C_Etype :=
+ Build_Actual_Subtype_Of_Component (
+ Etype (Selector), N);
+ else
+ C_Etype := Empty;
+ end if;
+
+ if No (C_Etype) then
+ C_Etype := Etype (Selector);
+ else
+ Insert_Action (N, C_Etype);
+ C_Etype := Defining_Identifier (C_Etype);
+ end if;
+
+ Set_Etype (N, C_Etype);
+ end;
+
+ -- If this is the name of an entry or protected operation, and
+ -- the prefix is an access type, insert an explicit dereference,
+ -- so that entry calls are treated uniformly.
+
+ if Is_Access_Type (Etype (P))
+ and then Is_Concurrent_Type (Designated_Type (Etype (P)))
+ then
+ declare
+ New_P : Node_Id :=
+ Make_Explicit_Dereference (Sloc (P),
+ Prefix => Relocate_Node (P));
+ begin
+ Rewrite (P, New_P);
+ Set_Etype (P, Designated_Type (Etype (Prefix (P))));
+ end;
+ end if;
+
+ -- If the selected component appears within a default expression
+ -- and it has an actual subtype, the pre-analysis has not yet
+ -- completed its analysis, because Insert_Actions is disabled in
+ -- that context. Within the init_proc of the enclosing type we
+ -- must complete this analysis, if an actual subtype was created.
+
+ elsif Inside_Init_Proc then
+ declare
+ Typ : constant Entity_Id := Etype (N);
+ Decl : constant Node_Id := Declaration_Node (Typ);
+
+ begin
+ if Nkind (Decl) = N_Subtype_Declaration
+ and then not Analyzed (Decl)
+ and then Is_List_Member (Decl)
+ and then No (Parent (Decl))
+ then
+ Remove (Decl);
+ Insert_Action (N, Decl);
+ end if;
+ end;
+ end if;
+
+ return;
+
+ elsif Is_Entity_Name (P) then
+ P_Name := Entity (P);
+
+ -- The prefix may denote an enclosing type which is the completion
+ -- of an incomplete type declaration.
+
+ if Is_Type (P_Name) then
+ Set_Entity (P, Get_Full_View (P_Name));
+ Set_Etype (P, Entity (P));
+ P_Name := Entity (P);
+ end if;
+
+ P_Type := Base_Type (Etype (P));
+
+ if Debug_Flag_E then
+ Write_Str ("Found prefix type to be ");
+ Write_Entity_Info (P_Type, " "); Write_Eol;
+ end if;
+
+ -- First check for components of a record object (not the
+ -- result of a call, which is handled below).
+
+ if Is_Appropriate_For_Record (P_Type)
+ and then not Is_Overloadable (P_Name)
+ and then not Is_Type (P_Name)
+ then
+ -- Selected component of record. Type checking will validate
+ -- name of selector.
+
+ Analyze_Selected_Component (N);
+
+ elsif Is_Appropriate_For_Entry_Prefix (P_Type)
+ and then not In_Open_Scopes (P_Name)
+ and then (not Is_Concurrent_Type (Etype (P_Name))
+ or else not In_Open_Scopes (Etype (P_Name)))
+ then
+ -- Call to protected operation or entry. Type checking is
+ -- needed on the prefix.
+
+ Analyze_Selected_Component (N);
+
+ elsif (In_Open_Scopes (P_Name)
+ and then Ekind (P_Name) /= E_Void
+ and then not Is_Overloadable (P_Name))
+ or else (Is_Concurrent_Type (Etype (P_Name))
+ and then In_Open_Scopes (Etype (P_Name)))
+ then
+ -- Prefix denotes an enclosing loop, block, or task, i.e. an
+ -- enclosing construct that is not a subprogram or accept.
+
+ Find_Expanded_Name (N);
+
+ elsif Ekind (P_Name) = E_Package then
+ Find_Expanded_Name (N);
+
+ elsif Is_Overloadable (P_Name) then
+
+ -- The subprogram may be a renaming (of an enclosing scope) as
+ -- in the case of the name of the generic within an instantiation.
+
+ if (Ekind (P_Name) = E_Procedure
+ or else Ekind (P_Name) = E_Function)
+ and then Present (Alias (P_Name))
+ and then Is_Generic_Instance (Alias (P_Name))
+ then
+ P_Name := Alias (P_Name);
+ end if;
+
+ if Is_Overloaded (P) then
+
+ -- The prefix must resolve to a unique enclosing construct.
+
+ declare
+ Found : Boolean := False;
+ I : Interp_Index;
+ It : Interp;
+
+ begin
+ Get_First_Interp (P, I, It);
+
+ while Present (It.Nam) loop
+
+ if In_Open_Scopes (It.Nam) then
+ if Found then
+ Error_Msg_N (
+ "prefix must be unique enclosing scope", N);
+ Set_Entity (N, Any_Id);
+ Set_Etype (N, Any_Type);
+ return;
+
+ else
+ Found := True;
+ P_Name := It.Nam;
+ end if;
+ end if;
+
+ Get_Next_Interp (I, It);
+ end loop;
+ end;
+ end if;
+
+ if In_Open_Scopes (P_Name) then
+ Set_Entity (P, P_Name);
+ Set_Is_Overloaded (P, False);
+ Find_Expanded_Name (N);
+
+ else
+ -- If no interpretation as an expanded name is possible, it
+ -- must be a selected component of a record returned by a
+ -- function call. Reformat prefix as a function call, the
+ -- rest is done by type resolution. If the prefix is a
+ -- procedure or entry, as is P.X; this is an error.
+
+ if Ekind (P_Name) /= E_Function
+ and then (not Is_Overloaded (P)
+ or else
+ Nkind (Parent (N)) = N_Procedure_Call_Statement)
+ then
+
+ -- Prefix may mention a package that is hidden by a local
+ -- declaration: let the user know.
+
+ if Present (Homonym (P_Name)) then
+
+ while Present (P_Name) loop
+ exit when Ekind (P_Name) = E_Package;
+ P_Name := Homonym (P_Name);
+ end loop;
+
+ if Present (P_Name) then
+ Error_Msg_Sloc := Sloc (Entity (Prefix (N)));
+
+ Error_Msg_NE
+ ("package& is hidden by declaration#",
+ N, P_Name);
+
+ Set_Entity (Prefix (N), P_Name);
+ Find_Expanded_Name (N);
+ return;
+ else
+ P_Name := Entity (Prefix (N));
+ end if;
+ end if;
+
+ Error_Msg_NE
+ ("invalid prefix in selected component&", N, P_Name);
+ Change_Selected_Component_To_Expanded_Name (N);
+ Set_Entity (N, Any_Id);
+ Set_Etype (N, Any_Type);
+
+ else
+ Nam := New_Copy (P);
+ Save_Interps (P, Nam);
+ Rewrite (P,
+ Make_Function_Call (Sloc (P), Name => Nam));
+ Analyze_Call (P);
+ Analyze_Selected_Component (N);
+ end if;
+ end if;
+
+ -- Remaining cases generate various error messages
+
+ else
+ -- Format node as expanded name, to avoid cascaded errors
+
+ Change_Node (N, N_Expanded_Name);
+ Set_Prefix (N, P);
+ Set_Entity (N, Any_Id);
+ Set_Etype (N, Any_Type);
+
+ -- Set_Selector_Name (N, Empty); ????
+
+ -- Issue error message, but avoid this if error issued already.
+ -- Use identifier of prefix if one is available.
+
+ if P_Name = Any_Id then
+ null;
+
+ elsif Ekind (P_Name) = E_Void then
+ Premature_Usage (P);
+
+ elsif Nkind (P) /= N_Attribute_Reference then
+ Error_Msg_N (
+ "invalid prefix in selected component&", P);
+
+ else
+ Error_Msg_N (
+ "invalid prefix in selected component", P);
+ end if;
+ end if;
+
+ else
+ -- If prefix is not the name of an entity, it must be an expression,
+ -- whose type is appropriate for a record. This is determined by
+ -- type resolution.
+
+ Analyze_Selected_Component (N);
+ end if;
+ end Find_Selected_Component;
+
+ ---------------
+ -- Find_Type --
+ ---------------
+
+ procedure Find_Type (N : Node_Id) is
+ C : Entity_Id;
+ Typ : Entity_Id;
+ T : Entity_Id;
+ T_Name : Entity_Id;
+
+ begin
+ if N = Error then
+ return;
+
+ elsif Nkind (N) = N_Attribute_Reference then
+
+ -- Class attribute. This is only valid in Ada 95 mode, but we don't
+ -- do a check, since the tagged type referenced could only exist if
+ -- we were in 95 mode when it was declared (or, if we were in Ada
+ -- 83 mode, then an error message would already have been issued).
+
+ if Attribute_Name (N) = Name_Class then
+ Check_Restriction (No_Dispatch, N);
+ Find_Type (Prefix (N));
+
+ -- Propagate error from bad prefix
+
+ if Etype (Prefix (N)) = Any_Type then
+ Set_Entity (N, Any_Type);
+ Set_Etype (N, Any_Type);
+ return;
+ end if;
+
+ T := Base_Type (Entity (Prefix (N)));
+
+ -- Case of non-tagged type
+
+ if not Is_Tagged_Type (T) then
+ if Ekind (T) = E_Incomplete_Type then
+
+ -- It is legal to denote the class type of an incomplete
+ -- type. The full type will have to be tagged, of course.
+
+ Set_Is_Tagged_Type (T);
+ Make_Class_Wide_Type (T);
+ Set_Entity (N, Class_Wide_Type (T));
+ Set_Etype (N, Class_Wide_Type (T));
+
+ elsif Ekind (T) = E_Private_Type
+ and then not Is_Generic_Type (T)
+ and then In_Private_Part (Scope (T))
+ then
+ -- The Class attribute can be applied to an untagged
+ -- private type fulfilled by a tagged type prior to
+ -- the full type declaration (but only within the
+ -- parent package's private part). Create the class-wide
+ -- type now and check that the full type is tagged
+ -- later during its analysis. Note that we do not
+ -- mark the private type as tagged, unlike the case
+ -- of incomplete types, because the type must still
+ -- appear untagged to outside units.
+
+ if not Present (Class_Wide_Type (T)) then
+ Make_Class_Wide_Type (T);
+ end if;
+
+ Set_Entity (N, Class_Wide_Type (T));
+ Set_Etype (N, Class_Wide_Type (T));
+
+ else
+ -- Should we introduce a type Any_Tagged and use
+ -- Wrong_Type here, it would be a bit more consistent???
+
+ Error_Msg_NE
+ ("tagged type required, found}",
+ Prefix (N), First_Subtype (T));
+ Set_Entity (N, Any_Type);
+ return;
+ end if;
+
+ -- Case of tagged type
+
+ else
+ C := Class_Wide_Type (Entity (Prefix (N)));
+ Set_Entity_With_Style_Check (N, C);
+ Generate_Reference (C, N);
+ Set_Etype (N, C);
+
+ if From_With_Type (C)
+ and then Nkind (Parent (N)) /= N_Access_Definition
+ and then not Analyzed (T)
+ then
+ Error_Msg_N
+ ("imported class-wide type can only be used" &
+ " for access parameters", N);
+ end if;
+ end if;
+
+ -- Base attribute, allowed in Ada 95 mode only
+
+ elsif Attribute_Name (N) = Name_Base then
+ if Ada_83 and then Comes_From_Source (N) then
+ Error_Msg_N
+ ("(Ada 83) Base attribute not allowed in subtype mark", N);
+
+ else
+ Find_Type (Prefix (N));
+ Typ := Entity (Prefix (N));
+
+ if Sloc (Typ) = Standard_Location
+ and then Base_Type (Typ) = Typ
+ and then Warn_On_Redundant_Constructs
+ then
+ Error_Msg_NE
+ ("?redudant attribute, & is its own base type", N, Typ);
+ end if;
+
+ T := Base_Type (Typ);
+ Set_Entity (N, T);
+ Set_Etype (N, T);
+
+ -- Rewrite attribute reference with type itself (see similar
+ -- processing in Analyze_Attribute, case Base)
+
+ Rewrite (N,
+ New_Reference_To (Entity (N), Sloc (N)));
+ Set_Etype (N, T);
+ end if;
+
+ -- All other attributes are invalid in a subtype mark
+
+ else
+ Error_Msg_N ("invalid attribute in subtype mark", N);
+ end if;
+
+ else
+ Analyze (N);
+
+ if Is_Entity_Name (N) then
+ T_Name := Entity (N);
+ else
+ Error_Msg_N ("subtype mark required in this context", N);
+ Set_Etype (N, Any_Type);
+ return;
+ end if;
+
+ if T_Name = Any_Id or else Etype (N) = Any_Type then
+
+ -- Undefined id. Make it into a valid type
+
+ Set_Entity (N, Any_Type);
+
+ elsif not Is_Type (T_Name)
+ and then T_Name /= Standard_Void_Type
+ then
+ Error_Msg_Sloc := Sloc (T_Name);
+ Error_Msg_N ("subtype mark required in this context", N);
+ Error_Msg_NE ("\found & declared#", N, T_Name);
+ Set_Entity (N, Any_Type);
+
+ else
+ T_Name := Get_Full_View (T_Name);
+
+ if In_Open_Scopes (T_Name) then
+ if Ekind (Base_Type (T_Name)) = E_Task_Type then
+ Error_Msg_N ("task type cannot be used as type mark " &
+ "within its own body", N);
+ else
+ Error_Msg_N ("type declaration cannot refer to itself", N);
+ end if;
+
+ Set_Etype (N, Any_Type);
+ Set_Entity (N, Any_Type);
+ Set_Error_Posted (T_Name);
+ return;
+ end if;
+
+ Set_Entity (N, T_Name);
+ Set_Etype (N, T_Name);
+ end if;
+ end if;
+
+ if Present (Etype (N)) then
+ if Is_Fixed_Point_Type (Etype (N)) then
+ Check_Restriction (No_Fixed_Point, N);
+ elsif Is_Floating_Point_Type (Etype (N)) then
+ Check_Restriction (No_Floating_Point, N);
+ end if;
+ end if;
+ end Find_Type;
+
+ -------------------
+ -- Get_Full_View --
+ -------------------
+
+ function Get_Full_View (T_Name : Entity_Id) return Entity_Id is
+ begin
+ if (Ekind (T_Name) = E_Incomplete_Type
+ and then Present (Full_View (T_Name)))
+ then
+ return Full_View (T_Name);
+
+ elsif Is_Class_Wide_Type (T_Name)
+ and then Ekind (Root_Type (T_Name)) = E_Incomplete_Type
+ and then Present (Full_View (Root_Type (T_Name)))
+ then
+ return Class_Wide_Type (Full_View (Root_Type (T_Name)));
+
+ else
+ return T_Name;
+ end if;
+ end Get_Full_View;
+
+ ------------------------------------
+ -- Has_Implicit_Character_Literal --
+ ------------------------------------
+
+ function Has_Implicit_Character_Literal (N : Node_Id) return Boolean is
+ Id : Entity_Id;
+ Found : Boolean := False;
+ P : constant Entity_Id := Entity (Prefix (N));
+ Priv_Id : Entity_Id := Empty;
+
+ begin
+ if Ekind (P) = E_Package
+ and then not In_Open_Scopes (P)
+ then
+ Priv_Id := First_Private_Entity (P);
+ end if;
+
+ if P = Standard_Standard then
+ Change_Selected_Component_To_Expanded_Name (N);
+ Rewrite (N, Selector_Name (N));
+ Analyze (N);
+ Set_Etype (Original_Node (N), Standard_Character);
+ return True;
+ end if;
+
+ Id := First_Entity (P);
+
+ while Present (Id)
+ and then Id /= Priv_Id
+ loop
+ if Is_Character_Type (Id)
+ and then (Root_Type (Id) = Standard_Character
+ or else Root_Type (Id) = Standard_Wide_Character)
+ and then Id = Base_Type (Id)
+ then
+ -- We replace the node with the literal itself, resolve as a
+ -- character, and set the type correctly.
+
+ if not Found then
+ Change_Selected_Component_To_Expanded_Name (N);
+ Rewrite (N, Selector_Name (N));
+ Analyze (N);
+ Set_Etype (N, Id);
+ Set_Etype (Original_Node (N), Id);
+ Found := True;
+
+ else
+ -- More than one type derived from Character in given scope.
+ -- Collect all possible interpretations.
+
+ Add_One_Interp (N, Id, Id);
+ end if;
+ end if;
+
+ Next_Entity (Id);
+ end loop;
+
+ return Found;
+ end Has_Implicit_Character_Literal;
+
+ ---------------------------
+ -- Has_Implicit_Operator --
+ ---------------------------
+
+ function Has_Implicit_Operator (N : Node_Id) return Boolean is
+ Op_Id : constant Name_Id := Chars (Selector_Name (N));
+ P : constant Entity_Id := Entity (Prefix (N));
+ Id : Entity_Id;
+ Priv_Id : Entity_Id := Empty;
+
+ procedure Add_Implicit_Operator (T : Entity_Id);
+ -- Add implicit interpretation to node N, using the type for which
+ -- a predefined operator exists.
+
+ ---------------------------
+ -- Add_Implicit_Operator --
+ ---------------------------
+
+ procedure Add_Implicit_Operator (T : Entity_Id) is
+ Predef_Op : Entity_Id;
+
+ begin
+ Predef_Op := Current_Entity (Selector_Name (N));
+
+ while Present (Predef_Op)
+ and then Scope (Predef_Op) /= Standard_Standard
+ loop
+ Predef_Op := Homonym (Predef_Op);
+ end loop;
+
+ if Nkind (N) = N_Selected_Component then
+ Change_Selected_Component_To_Expanded_Name (N);
+ end if;
+
+ Add_One_Interp (N, Predef_Op, T);
+
+ -- For operators with unary and binary interpretations, add both
+
+ if Present (Homonym (Predef_Op)) then
+ Add_One_Interp (N, Homonym (Predef_Op), T);
+ end if;
+ end Add_Implicit_Operator;
+
+ -- Start of processing for Has_Implicit_Operator
+
+ begin
+
+ if Ekind (P) = E_Package
+ and then not In_Open_Scopes (P)
+ then
+ Priv_Id := First_Private_Entity (P);
+ end if;
+
+ Id := First_Entity (P);
+
+ case Op_Id is
+
+ -- Boolean operators: an implicit declaration exists if the scope
+ -- contains a declaration for a derived Boolean type, or for an
+ -- array of Boolean type.
+
+ when Name_Op_And | Name_Op_Not | Name_Op_Or | Name_Op_Xor =>
+
+ while Id /= Priv_Id loop
+
+ if Valid_Boolean_Arg (Id)
+ and then Id = Base_Type (Id)
+ then
+ Add_Implicit_Operator (Id);
+ return True;
+ end if;
+
+ Next_Entity (Id);
+ end loop;
+
+ -- Equality: look for any non-limited type. Result is Boolean.
+
+ when Name_Op_Eq | Name_Op_Ne =>
+
+ while Id /= Priv_Id loop
+
+ if Is_Type (Id)
+ and then not Is_Limited_Type (Id)
+ and then Id = Base_Type (Id)
+ then
+ Add_Implicit_Operator (Standard_Boolean);
+ return True;
+ end if;
+
+ Next_Entity (Id);
+ end loop;
+
+ -- Comparison operators: scalar type, or array of scalar.
+
+ when Name_Op_Lt | Name_Op_Le | Name_Op_Gt | Name_Op_Ge =>
+
+ while Id /= Priv_Id loop
+ if (Is_Scalar_Type (Id)
+ or else (Is_Array_Type (Id)
+ and then Is_Scalar_Type (Component_Type (Id))))
+ and then Id = Base_Type (Id)
+ then
+ Add_Implicit_Operator (Standard_Boolean);
+ return True;
+ end if;
+
+ Next_Entity (Id);
+ end loop;
+
+ -- Arithmetic operators: any numeric type
+
+ when Name_Op_Abs |
+ Name_Op_Add |
+ Name_Op_Mod |
+ Name_Op_Rem |
+ Name_Op_Subtract |
+ Name_Op_Multiply |
+ Name_Op_Divide |
+ Name_Op_Expon =>
+
+ while Id /= Priv_Id loop
+ if Is_Numeric_Type (Id)
+ and then Id = Base_Type (Id)
+ then
+ Add_Implicit_Operator (Id);
+ return True;
+ end if;
+
+ Next_Entity (Id);
+ end loop;
+
+ -- Concatenation: any one-dimensional array type
+
+ when Name_Op_Concat =>
+
+ while Id /= Priv_Id loop
+ if Is_Array_Type (Id) and then Number_Dimensions (Id) = 1
+ and then Id = Base_Type (Id)
+ then
+ Add_Implicit_Operator (Id);
+ return True;
+ end if;
+
+ Next_Entity (Id);
+ end loop;
+
+ -- What is the others condition here? Should we be using a
+ -- subtype of Name_Id that would restrict to operators ???
+
+ when others => null;
+
+ end case;
+
+ -- If we fall through, then we do not have an implicit operator
+
+ return False;
+
+ end Has_Implicit_Operator;
+
+ --------------------
+ -- In_Open_Scopes --
+ --------------------
+
+ function In_Open_Scopes (S : Entity_Id) return Boolean is
+ begin
+ -- Since there are several scope stacks maintained by Scope_Stack each
+ -- delineated by Standard (see comments by definition of Scope_Stack)
+ -- it is necessary to end the search when Standard is reached.
+
+ for J in reverse 0 .. Scope_Stack.Last loop
+ if Scope_Stack.Table (J).Entity = S then
+ return True;
+ end if;
+
+ -- We need Is_Active_Stack_Base to tell us when to stop rather
+ -- than checking for Standard_Standard because there are cases
+ -- where Standard_Standard appears in the middle of the active
+ -- set of scopes. This affects the declaration and overriding
+ -- of private inherited operations in instantiations of generic
+ -- child units.
+
+ exit when Scope_Stack.Table (J).Is_Active_Stack_Base;
+ end loop;
+
+ return False;
+ end In_Open_Scopes;
+
+ -----------------------------
+ -- Inherit_Renamed_Profile --
+ -----------------------------
+
+ procedure Inherit_Renamed_Profile (New_S : Entity_Id; Old_S : Entity_Id) is
+ New_F : Entity_Id;
+ Old_F : Entity_Id;
+ Old_T : Entity_Id;
+ New_T : Entity_Id;
+
+ begin
+ if Ekind (Old_S) = E_Operator then
+
+ New_F := First_Formal (New_S);
+
+ while Present (New_F) loop
+ Set_Etype (New_F, Base_Type (Etype (New_F)));
+ Next_Formal (New_F);
+ end loop;
+
+ Set_Etype (New_S, Base_Type (Etype (New_S)));
+
+ else
+ New_F := First_Formal (New_S);
+ Old_F := First_Formal (Old_S);
+
+ while Present (New_F) loop
+ New_T := Etype (New_F);
+ Old_T := Etype (Old_F);
+
+ -- If the new type is a renaming of the old one, as is the
+ -- case for actuals in instances, retain its name, to simplify
+ -- later disambiguation.
+
+ if Nkind (Parent (New_T)) = N_Subtype_Declaration
+ and then Is_Entity_Name (Subtype_Indication (Parent (New_T)))
+ and then Entity (Subtype_Indication (Parent (New_T))) = Old_T
+ then
+ null;
+ else
+ Set_Etype (New_F, Old_T);
+ end if;
+
+ Next_Formal (New_F);
+ Next_Formal (Old_F);
+ end loop;
+
+ if Ekind (Old_S) = E_Function
+ or else Ekind (Old_S) = E_Enumeration_Literal
+ then
+ Set_Etype (New_S, Etype (Old_S));
+ end if;
+ end if;
+ end Inherit_Renamed_Profile;
+
+ ----------------
+ -- Initialize --
+ ----------------
+
+ procedure Initialize is
+ begin
+ Urefs.Init;
+ end Initialize;
+
+ -------------------------
+ -- Install_Use_Clauses --
+ -------------------------
+
+ procedure Install_Use_Clauses (Clause : Node_Id) is
+ U : Node_Id := Clause;
+ P : Node_Id;
+ Id : Entity_Id;
+
+ begin
+ while Present (U) loop
+
+ -- Case of USE package
+
+ if Nkind (U) = N_Use_Package_Clause then
+ P := First (Names (U));
+
+ while Present (P) loop
+ Id := Entity (P);
+
+ if Ekind (Id) = E_Package then
+
+ if In_Use (Id) then
+ Set_Redundant_Use (P, True);
+
+ elsif Present (Renamed_Object (Id))
+ and then In_Use (Renamed_Object (Id))
+ then
+ Set_Redundant_Use (P, True);
+
+ else
+ Use_One_Package (Id, U);
+ end if;
+ end if;
+
+ Next (P);
+ end loop;
+
+ -- case of USE TYPE
+
+ else
+ P := First (Subtype_Marks (U));
+
+ while Present (P) loop
+
+ if Entity (P) /= Any_Type then
+ Use_One_Type (P, U);
+ end if;
+
+ Next (P);
+ end loop;
+ end if;
+
+ Next_Use_Clause (U);
+ end loop;
+ end Install_Use_Clauses;
+
+ -------------------------------------
+ -- Is_Appropriate_For_Entry_Prefix --
+ -------------------------------------
+
+ function Is_Appropriate_For_Entry_Prefix (T : Entity_Id) return Boolean is
+ P_Type : Entity_Id := T;
+
+ begin
+ if Is_Access_Type (P_Type) then
+ P_Type := Designated_Type (P_Type);
+ end if;
+
+ return Is_Task_Type (P_Type) or else Is_Protected_Type (P_Type);
+ end Is_Appropriate_For_Entry_Prefix;
+
+ -------------------------------
+ -- Is_Appropriate_For_Record --
+ -------------------------------
+
+ function Is_Appropriate_For_Record
+ (T : Entity_Id)
+ return Boolean
+ is
+ function Has_Components (T1 : Entity_Id) return Boolean;
+ -- Determine if given type has components (i.e. is either a record
+ -- type or a type that has discriminants).
+
+ function Has_Components (T1 : Entity_Id) return Boolean is
+ begin
+ return Is_Record_Type (T1)
+ or else (Is_Private_Type (T1) and then Has_Discriminants (T1))
+ or else (Is_Task_Type (T1) and then Has_Discriminants (T1));
+ end Has_Components;
+
+ -- Start of processing for Is_Appropriate_For_Record
+
+ begin
+ return
+ Present (T)
+ and then (Has_Components (T)
+ or else (Is_Access_Type (T)
+ and then
+ Has_Components (Designated_Type (T))));
+ end Is_Appropriate_For_Record;
+
+ ---------------
+ -- New_Scope --
+ ---------------
+
+ procedure New_Scope (S : Entity_Id) is
+ E : Entity_Id;
+
+ begin
+ if Ekind (S) = E_Void then
+ null;
+
+ -- Set scope depth if not a non-concurrent type, and we have not
+ -- yet set the scope depth. This means that we have the first
+ -- occurrence of the scope, and this is where the depth is set.
+
+ elsif (not Is_Type (S) or else Is_Concurrent_Type (S))
+ and then not Scope_Depth_Set (S)
+ then
+ if S = Standard_Standard then
+ Set_Scope_Depth_Value (S, Uint_0);
+
+ elsif Is_Child_Unit (S) then
+ Set_Scope_Depth_Value (S, Uint_1);
+
+ elsif not Is_Record_Type (Current_Scope) then
+ if Ekind (S) = E_Loop then
+ Set_Scope_Depth_Value (S, Scope_Depth (Current_Scope));
+ else
+ Set_Scope_Depth_Value (S, Scope_Depth (Current_Scope) + 1);
+ end if;
+ end if;
+ end if;
+
+ Scope_Stack.Increment_Last;
+
+ Scope_Stack.Table (Scope_Stack.Last).Entity := S;
+
+ Scope_Stack.Table (Scope_Stack.Last).Save_Scope_Suppress :=
+ Scope_Suppress;
+
+ Scope_Stack.Table (Scope_Stack.Last).Save_Entity_Suppress :=
+ Entity_Suppress.Last;
+
+ if Scope_Stack.Last > Scope_Stack.First then
+ Scope_Stack.Table (Scope_Stack.Last).Component_Alignment_Default :=
+ Scope_Stack.Table (Scope_Stack.Last - 1).Component_Alignment_Default;
+ end if;
+
+ Scope_Stack.Table (Scope_Stack.Last).Last_Subprogram_Name := null;
+ Scope_Stack.Table (Scope_Stack.Last).Is_Transient := False;
+ Scope_Stack.Table (Scope_Stack.Last).Node_To_Be_Wrapped := Empty;
+ Scope_Stack.Table (Scope_Stack.Last).Pending_Freeze_Actions := No_List;
+ Scope_Stack.Table
+ (Scope_Stack.Last).Actions_To_Be_Wrapped_Before := No_List;
+ Scope_Stack.Table
+ (Scope_Stack.Last).Actions_To_Be_Wrapped_After := No_List;
+ Scope_Stack.Table (Scope_Stack.Last).First_Use_Clause := Empty;
+ Scope_Stack.Table (Scope_Stack.Last).Is_Active_Stack_Base := False;
+
+ if Debug_Flag_W then
+ Write_Str ("--> new scope: ");
+ Write_Name (Chars (Current_Scope));
+ Write_Str (", Id=");
+ Write_Int (Int (Current_Scope));
+ Write_Str (", Depth=");
+ Write_Int (Int (Scope_Stack.Last));
+ Write_Eol;
+ end if;
+
+ -- Copy from Scope (S) the categorization flags to S, this is not
+ -- done in case Scope (S) is Standard_Standard since propagation
+ -- is from library unit entity inwards.
+
+ if S /= Standard_Standard
+ and then Scope (S) /= Standard_Standard
+ and then not Is_Child_Unit (S)
+ then
+ E := Scope (S);
+
+ if Nkind (E) not in N_Entity then
+ return;
+ end if;
+
+ -- We only propagate inwards for library level entities,
+ -- inner level subprograms do not inherit the categorization.
+
+ if Is_Library_Level_Entity (S) then
+ Set_Is_Pure (S, Is_Pure (E));
+ Set_Is_Preelaborated (S, Is_Preelaborated (E));
+ Set_Is_Remote_Call_Interface (S, Is_Remote_Call_Interface (E));
+ Set_Is_Remote_Types (S, Is_Remote_Types (E));
+ Set_Is_Shared_Passive (S, Is_Shared_Passive (E));
+ end if;
+ end if;
+ end New_Scope;
+
+ ---------------
+ -- Pop_Scope --
+ ---------------
+
+ procedure Pop_Scope is
+ E : Entity_Id;
+
+ begin
+ if Debug_Flag_E then
+ Write_Info;
+ end if;
+
+ Scope_Suppress :=
+ Scope_Stack.Table (Scope_Stack.Last).Save_Scope_Suppress;
+
+ while Entity_Suppress.Last >
+ Scope_Stack.Table (Scope_Stack.Last).Save_Entity_Suppress
+ loop
+ E := Entity_Suppress.Table (Entity_Suppress.Last).Entity;
+
+ case Entity_Suppress.Table (Entity_Suppress.Last).Check is
+
+ when Access_Check =>
+ Set_Suppress_Access_Checks (E, False);
+
+ when Accessibility_Check =>
+ Set_Suppress_Accessibility_Checks (E, False);
+
+ when Discriminant_Check =>
+ Set_Suppress_Discriminant_Checks (E, False);
+
+ when Division_Check =>
+ Set_Suppress_Division_Checks (E, False);
+
+ when Elaboration_Check =>
+ Set_Suppress_Elaboration_Checks (E, False);
+
+ when Index_Check =>
+ Set_Suppress_Index_Checks (E, False);
+
+ when Length_Check =>
+ Set_Suppress_Length_Checks (E, False);
+
+ when Overflow_Check =>
+ Set_Suppress_Overflow_Checks (E, False);
+
+ when Range_Check =>
+ Set_Suppress_Range_Checks (E, False);
+
+ when Storage_Check =>
+ Set_Suppress_Storage_Checks (E, False);
+
+ when Tag_Check =>
+ Set_Suppress_Tag_Checks (E, False);
+
+ -- All_Checks should not appear here (since it is entered as a
+ -- series of its separate checks). Bomb if it is encountered
+
+ when All_Checks =>
+ raise Program_Error;
+ end case;
+
+ Entity_Suppress.Decrement_Last;
+ end loop;
+
+ if Debug_Flag_W then
+ Write_Str ("--> exiting scope: ");
+ Write_Name (Chars (Current_Scope));
+ Write_Str (", Depth=");
+ Write_Int (Int (Scope_Stack.Last));
+ Write_Eol;
+ end if;
+
+ End_Use_Clauses (Scope_Stack.Table (Scope_Stack.Last).First_Use_Clause);
+
+ -- If the actions to be wrapped are still there they will get lost
+ -- causing incomplete code to be generated. It is better to abort in
+ -- this case.
+
+ pragma Assert (Scope_Stack.Table
+ (Scope_Stack.Last).Actions_To_Be_Wrapped_Before = No_List);
+
+ pragma Assert (Scope_Stack.Table
+ (Scope_Stack.Last).Actions_To_Be_Wrapped_After = No_List);
+
+ -- Free last subprogram name if allocated, and pop scope
+
+ Free (Scope_Stack.Table (Scope_Stack.Last).Last_Subprogram_Name);
+ Scope_Stack.Decrement_Last;
+ end Pop_Scope;
+
+ ---------------------
+ -- Premature_Usage --
+ ---------------------
+
+ procedure Premature_Usage (N : Node_Id) is
+ Kind : Node_Kind := Nkind (Parent (Entity (N)));
+ E : Entity_Id := Entity (N);
+
+ begin
+ -- Within an instance, the analysis of the actual for a formal object
+ -- does not see the name of the object itself. This is significant
+ -- only if the object is an aggregate, where its analysis does not do
+ -- any name resolution on component associations. (see 4717-008). In
+ -- such a case, look for the visible homonym on the chain.
+
+ if In_Instance
+ and then Present (Homonym (E))
+ then
+ E := Homonym (E);
+
+ while Present (E)
+ and then not In_Open_Scopes (Scope (E))
+ loop
+ E := Homonym (E);
+ end loop;
+
+ if Present (E) then
+ Set_Entity (N, E);
+ Set_Etype (N, Etype (E));
+ return;
+ end if;
+ end if;
+
+ if Kind = N_Component_Declaration then
+ Error_Msg_N
+ ("component&! cannot be used before end of record declaration", N);
+
+ elsif Kind = N_Parameter_Specification then
+ Error_Msg_N
+ ("formal parameter&! cannot be used before end of specification",
+ N);
+
+ elsif Kind = N_Discriminant_Specification then
+ Error_Msg_N
+ ("discriminant&! cannot be used before end of discriminant part",
+ N);
+
+ elsif Kind = N_Procedure_Specification
+ or else Kind = N_Function_Specification
+ then
+ Error_Msg_N
+ ("subprogram&! cannot be used before end of its declaration",
+ N);
+ else
+ Error_Msg_N
+ ("object& cannot be used before end of its declaration!", N);
+ end if;
+ end Premature_Usage;
+
+ ------------------------
+ -- Present_System_Aux --
+ ------------------------
+
+ function Present_System_Aux (N : Node_Id := Empty) return Boolean is
+ Loc : Source_Ptr;
+ Aux_Name : Name_Id;
+ Unum : Unit_Number_Type;
+ Withn : Node_Id;
+ With_Sys : Node_Id;
+ The_Unit : Node_Id;
+
+ function Find_System (C_Unit : Node_Id) return Entity_Id;
+ -- Scan context clause of compilation unit to find a with_clause
+ -- for System.
+
+ function Find_System (C_Unit : Node_Id) return Entity_Id is
+ With_Clause : Node_Id;
+
+ begin
+ With_Clause := First (Context_Items (C_Unit));
+
+ while Present (With_Clause) loop
+ if (Nkind (With_Clause) = N_With_Clause
+ and then Chars (Name (With_Clause)) = Name_System)
+ and then Comes_From_Source (With_Clause)
+ then
+ return With_Clause;
+ end if;
+
+ Next (With_Clause);
+ end loop;
+
+ return Empty;
+ end Find_System;
+
+ -- Start of processing for Present_System_Aux
+
+ begin
+ -- The child unit may have been loaded and analyzed already.
+
+ if Present (System_Aux_Id) then
+ return True;
+
+ -- If no previous pragma for System.Aux, nothing to load
+
+ elsif No (System_Extend_Pragma_Arg) then
+ return False;
+
+ -- Use the unit name given in the pragma to retrieve the unit.
+ -- Verify that System itself appears in the context clause of the
+ -- current compilation. If System is not present, an error will
+ -- have been reported already.
+
+ else
+ With_Sys := Find_System (Cunit (Current_Sem_Unit));
+
+ The_Unit := Unit (Cunit (Current_Sem_Unit));
+
+ if No (With_Sys)
+ and then (Nkind (The_Unit) = N_Package_Body
+ or else (Nkind (The_Unit) = N_Subprogram_Body
+ and then not Acts_As_Spec (Cunit (Current_Sem_Unit))))
+ then
+ With_Sys := Find_System (Library_Unit (Cunit (Current_Sem_Unit)));
+ end if;
+
+ if No (With_Sys)
+ and then Present (N)
+ then
+ -- If we are compiling a subunit, we need to examine its
+ -- context as well (Current_Sem_Unit is the parent unit);
+
+ The_Unit := Parent (N);
+
+ while Nkind (The_Unit) /= N_Compilation_Unit loop
+ The_Unit := Parent (The_Unit);
+ end loop;
+
+ if Nkind (Unit (The_Unit)) = N_Subunit then
+ With_Sys := Find_System (The_Unit);
+ end if;
+ end if;
+
+ if No (With_Sys) then
+ return False;
+ end if;
+
+ Loc := Sloc (With_Sys);
+ Get_Name_String (Chars (Expression (System_Extend_Pragma_Arg)));
+ Name_Buffer (8 .. Name_Len + 7) := Name_Buffer (1 .. Name_Len);
+ Name_Buffer (1 .. 7) := "system.";
+ Name_Buffer (Name_Len + 8) := '%';
+ Name_Buffer (Name_Len + 9) := 's';
+ Name_Len := Name_Len + 9;
+ Aux_Name := Name_Find;
+
+ Unum :=
+ Load_Unit
+ (Load_Name => Aux_Name,
+ Required => False,
+ Subunit => False,
+ Error_Node => With_Sys);
+
+ if Unum /= No_Unit then
+ Semantics (Cunit (Unum));
+ System_Aux_Id :=
+ Defining_Entity (Specification (Unit (Cunit (Unum))));
+
+ Withn := Make_With_Clause (Loc,
+ Name =>
+ Make_Expanded_Name (Loc,
+ Chars => Chars (System_Aux_Id),
+ Prefix =>
+ New_Reference_To (Scope (System_Aux_Id), Loc),
+ Selector_Name =>
+ New_Reference_To (System_Aux_Id, Loc)));
+
+ Set_Entity (Name (Withn), System_Aux_Id);
+
+ Set_Library_Unit (Withn, Cunit (Unum));
+ Set_Corresponding_Spec (Withn, System_Aux_Id);
+ Set_First_Name (Withn, True);
+ Set_Implicit_With (Withn, True);
+
+ Insert_After (With_Sys, Withn);
+ Mark_Rewrite_Insertion (Withn);
+ Set_Context_Installed (Withn);
+
+ return True;
+
+ -- Here if unit load failed
+
+ else
+ Error_Msg_Name_1 := Name_System;
+ Error_Msg_Name_2 := Chars (Expression (System_Extend_Pragma_Arg));
+ Error_Msg_N
+ ("extension package `%.%` does not exist",
+ Opt.System_Extend_Pragma_Arg);
+ return False;
+ end if;
+ end if;
+ end Present_System_Aux;
+
+ -------------------------
+ -- Restore_Scope_Stack --
+ -------------------------
+
+ procedure Restore_Scope_Stack is
+ E : Entity_Id;
+ S : Entity_Id;
+ Comp_Unit : Node_Id;
+ In_Child : Boolean := False;
+ Full_Vis : Boolean := True;
+
+ begin
+ -- Restore visibility of previous scope stack, if any.
+
+ for J in reverse 0 .. Scope_Stack.Last loop
+ exit when Scope_Stack.Table (J).Entity = Standard_Standard
+ or else No (Scope_Stack.Table (J).Entity);
+
+ S := Scope_Stack.Table (J).Entity;
+
+ if not Is_Hidden_Open_Scope (S) then
+
+ -- If the parent scope is hidden, its entities are hidden as
+ -- well, unless the entity is the instantiation currently
+ -- being analyzed.
+
+ if not Is_Hidden_Open_Scope (Scope (S))
+ or else not Analyzed (Parent (S))
+ or else Scope (S) = Standard_Standard
+ then
+ Set_Is_Immediately_Visible (S, True);
+ end if;
+
+ E := First_Entity (S);
+
+ while Present (E) loop
+ if Is_Child_Unit (E) then
+ Set_Is_Immediately_Visible (E,
+ Is_Visible_Child_Unit (E) or else In_Open_Scopes (E));
+ else
+ Set_Is_Immediately_Visible (E, True);
+ end if;
+
+ Next_Entity (E);
+
+ if not Full_Vis then
+ exit when E = First_Private_Entity (S);
+ end if;
+ end loop;
+
+ -- The visibility of child units (siblings of current compilation)
+ -- must be restored in any case. Their declarations may appear
+ -- after the private part of the parent.
+
+ if not Full_Vis
+ and then Present (E)
+ then
+ while Present (E) loop
+ if Is_Child_Unit (E) then
+ Set_Is_Immediately_Visible (E,
+ Is_Visible_Child_Unit (E) or else In_Open_Scopes (E));
+ end if;
+
+ Next_Entity (E);
+ end loop;
+ end if;
+ end if;
+
+ if Is_Child_Unit (S)
+ and not In_Child -- check only for current unit.
+ then
+ In_Child := True;
+
+ -- restore visibility of parents according to whether the child
+ -- is private and whether we are in its visible part.
+
+ Comp_Unit := Parent (Unit_Declaration_Node (S));
+
+ if Nkind (Comp_Unit) = N_Compilation_Unit
+ and then Private_Present (Comp_Unit)
+ then
+ Full_Vis := True;
+
+ elsif (Ekind (S) = E_Package
+ or else Ekind (S) = E_Generic_Package)
+ and then (In_Private_Part (S)
+ or else In_Package_Body (S))
+ then
+ Full_Vis := True;
+
+ elsif (Ekind (S) = E_Procedure
+ or else Ekind (S) = E_Function)
+ and then Has_Completion (S)
+ then
+ Full_Vis := True;
+ else
+ Full_Vis := False;
+ end if;
+ else
+ Full_Vis := True;
+ end if;
+ end loop;
+ end Restore_Scope_Stack;
+
+ ----------------------
+ -- Save_Scope_Stack --
+ ----------------------
+
+ procedure Save_Scope_Stack is
+ E : Entity_Id;
+ S : Entity_Id;
+ SS_Last : constant Int := Scope_Stack.Last;
+
+ begin
+ if SS_Last >= Scope_Stack.First
+ and then Scope_Stack.Table (SS_Last).Entity /= Standard_Standard
+ then
+
+ -- If the call is from within a compilation unit, as when
+ -- called from Rtsfind, make current entries in scope stack
+ -- invisible while we analyze the new unit.
+
+ for J in reverse 0 .. SS_Last loop
+ exit when Scope_Stack.Table (J).Entity = Standard_Standard
+ or else No (Scope_Stack.Table (J).Entity);
+
+ S := Scope_Stack.Table (J).Entity;
+ Set_Is_Immediately_Visible (S, False);
+ E := First_Entity (S);
+
+ while Present (E) loop
+ Set_Is_Immediately_Visible (E, False);
+ Next_Entity (E);
+ end loop;
+ end loop;
+
+ end if;
+ end Save_Scope_Stack;
+
+ -------------
+ -- Set_Use --
+ -------------
+
+ procedure Set_Use (L : List_Id) is
+ Decl : Node_Id;
+ Pack_Name : Node_Id;
+ Pack : Entity_Id;
+ Id : Entity_Id;
+
+ begin
+ if Present (L) then
+ Decl := First (L);
+
+ while Present (Decl) loop
+ if Nkind (Decl) = N_Use_Package_Clause then
+ Chain_Use_Clause (Decl);
+ Pack_Name := First (Names (Decl));
+
+ while Present (Pack_Name) loop
+ Pack := Entity (Pack_Name);
+
+ if Ekind (Pack) = E_Package
+ and then Applicable_Use (Pack_Name)
+ then
+ Use_One_Package (Pack, Decl);
+ end if;
+
+ Next (Pack_Name);
+ end loop;
+
+ elsif Nkind (Decl) = N_Use_Type_Clause then
+ Chain_Use_Clause (Decl);
+ Id := First (Subtype_Marks (Decl));
+
+ while Present (Id) loop
+ if Entity (Id) /= Any_Type then
+ Use_One_Type (Id, Decl);
+ end if;
+
+ Next (Id);
+ end loop;
+ end if;
+
+ Next (Decl);
+ end loop;
+ end if;
+ end Set_Use;
+
+ ---------------------
+ -- Use_One_Package --
+ ---------------------
+
+ procedure Use_One_Package (P : Entity_Id; N : Node_Id) is
+ Id : Entity_Id;
+ Prev : Entity_Id;
+ Current_Instance : Entity_Id := Empty;
+ Real_P : Entity_Id;
+
+ begin
+ if Ekind (P) /= E_Package then
+ return;
+ end if;
+
+ Set_In_Use (P);
+
+ if From_With_Type (P) then
+ Error_Msg_N ("imported package cannot appear in use clause", N);
+ end if;
+
+ -- Find enclosing instance, if any.
+
+ if In_Instance then
+ Current_Instance := Current_Scope;
+
+ while not Is_Generic_Instance (Current_Instance) loop
+ Current_Instance := Scope (Current_Instance);
+ end loop;
+
+ if No (Hidden_By_Use_Clause (N)) then
+ Set_Hidden_By_Use_Clause (N, New_Elmt_List);
+ end if;
+ end if;
+
+ -- If unit is a package renaming, indicate that the renamed
+ -- package is also in use (the flags on both entities must
+ -- remain consistent, and a subsequent use of either of them
+ -- should be recognized as redundant).
+
+ if Present (Renamed_Object (P)) then
+ Set_In_Use (Renamed_Object (P));
+ Real_P := Renamed_Object (P);
+ else
+ Real_P := P;
+ end if;
+
+ -- Loop through entities in one package making them potentially
+ -- use-visible.
+
+ Id := First_Entity (P);
+ while Present (Id)
+ and then Id /= First_Private_Entity (P)
+ loop
+ Prev := Current_Entity (Id);
+
+ while Present (Prev) loop
+ if Is_Immediately_Visible (Prev)
+ and then (not Is_Overloadable (Prev)
+ or else not Is_Overloadable (Id)
+ or else (Type_Conformant (Id, Prev)))
+ then
+ if No (Current_Instance) then
+
+ -- Potentially use-visible entity remains hidden
+
+ goto Next_Usable_Entity;
+
+ -- A use clause within an instance hides outer global
+ -- entities, which are not used to resolve local entities
+ -- in the instance. Note that the predefined entities in
+ -- Standard could not have been hidden in the generic by
+ -- a use clause, and therefore remain visible. Other
+ -- compilation units whose entities appear in Standard must
+ -- be hidden in an instance.
+
+ -- To determine whether an entity is external to the instance
+ -- we compare the scope depth of its scope with that of the
+ -- current instance. However, a generic actual of a subprogram
+ -- instance is declared in the wrapper package but will not be
+ -- hidden by a use-visible entity.
+
+ elsif not Is_Hidden (Id)
+ and then not Is_Wrapper_Package (Scope (Prev))
+ and then Scope_Depth (Scope (Prev)) <
+ Scope_Depth (Current_Instance)
+ and then (Scope (Prev) /= Standard_Standard
+ or else Sloc (Prev) > Standard_Location)
+ then
+ Set_Is_Potentially_Use_Visible (Id);
+ Set_Is_Immediately_Visible (Prev, False);
+ Append_Elmt (Prev, Hidden_By_Use_Clause (N));
+ end if;
+
+ -- A user-defined operator is not use-visible if the
+ -- predefined operator for the type is immediately visible,
+ -- which is the case if the type of the operand is in an open
+ -- scope. This does not apply to user-defined operators that
+ -- have operands of different types, because the predefined
+ -- mixed mode operations (multiplication and division) apply to
+ -- universal types and do not hide anything.
+
+ elsif Ekind (Prev) = E_Operator
+ and then Operator_Matches_Spec (Prev, Id)
+ and then In_Open_Scopes
+ (Scope (Base_Type (Etype (First_Formal (Id)))))
+ and then (No (Next_Formal (First_Formal (Id)))
+ or else Etype (First_Formal (Id))
+ = Etype (Next_Formal (First_Formal (Id)))
+ or else Chars (Prev) = Name_Op_Expon)
+ then
+ goto Next_Usable_Entity;
+ end if;
+
+ Prev := Homonym (Prev);
+ end loop;
+
+ -- On exit, we know entity is not hidden, unless it is private.
+
+ if not Is_Hidden (Id)
+ and then ((not Is_Child_Unit (Id))
+ or else Is_Visible_Child_Unit (Id))
+ then
+ Set_Is_Potentially_Use_Visible (Id);
+
+ if Is_Private_Type (Id)
+ and then Present (Full_View (Id))
+ then
+ Set_Is_Potentially_Use_Visible (Full_View (Id));
+ end if;
+ end if;
+
+ <<Next_Usable_Entity>>
+ Next_Entity (Id);
+ end loop;
+
+ -- Child units are also made use-visible by a use clause, but they
+ -- may appear after all visible declarations in the parent entity list.
+
+ while Present (Id) loop
+
+ if Is_Child_Unit (Id)
+ and then Is_Visible_Child_Unit (Id)
+ then
+ Set_Is_Potentially_Use_Visible (Id);
+ end if;
+
+ Next_Entity (Id);
+ end loop;
+
+ if Chars (Real_P) = Name_System
+ and then Scope (Real_P) = Standard_Standard
+ and then Present_System_Aux (N)
+ then
+ Use_One_Package (System_Aux_Id, N);
+ end if;
+
+ end Use_One_Package;
+
+ ------------------
+ -- Use_One_Type --
+ ------------------
+
+ procedure Use_One_Type (Id : Node_Id; N : Node_Id) is
+ T : Entity_Id;
+ Op_List : Elist_Id;
+ Elmt : Elmt_Id;
+
+ begin
+ -- It is the type determined by the subtype mark (8.4(8)) whose
+ -- operations become potentially use-visible.
+
+ T := Base_Type (Entity (Id));
+
+ -- Save current visibility status of type, before setting.
+
+ Set_Redundant_Use
+ (Id, In_Use (T) or else Is_Potentially_Use_Visible (T));
+
+ if In_Open_Scopes (Scope (T)) then
+ null;
+
+ elsif not Redundant_Use (Id) then
+ Set_In_Use (T);
+ Op_List := Collect_Primitive_Operations (T);
+ Elmt := First_Elmt (Op_List);
+
+ while Present (Elmt) loop
+
+ if (Nkind (Node (Elmt)) = N_Defining_Operator_Symbol
+ or else Chars (Node (Elmt)) in Any_Operator_Name)
+ and then not Is_Hidden (Node (Elmt))
+ then
+ Set_Is_Potentially_Use_Visible (Node (Elmt));
+ end if;
+
+ Next_Elmt (Elmt);
+ end loop;
+ end if;
+
+ end Use_One_Type;
+
+ ----------------
+ -- Write_Info --
+ ----------------
+
+ procedure Write_Info is
+ Id : Entity_Id := First_Entity (Current_Scope);
+
+ begin
+ -- No point in dumping standard entities
+
+ if Current_Scope = Standard_Standard then
+ return;
+ end if;
+
+ Write_Str ("========================================================");
+ Write_Eol;
+ Write_Str (" Defined Entities in ");
+ Write_Name (Chars (Current_Scope));
+ Write_Eol;
+ Write_Str ("========================================================");
+ Write_Eol;
+
+ if No (Id) then
+ Write_Str ("-- none --");
+ Write_Eol;
+
+ else
+ while Present (Id) loop
+ Write_Entity_Info (Id, " ");
+ Next_Entity (Id);
+ end loop;
+ end if;
+
+ if Scope (Current_Scope) = Standard_Standard then
+
+ -- Print information on the current unit itself
+
+ Write_Entity_Info (Current_Scope, " ");
+ end if;
+
+ Write_Eol;
+ end Write_Info;
+
+ -----------------
+ -- Write_Scopes --
+ -----------------
+
+ procedure Write_Scopes is
+ S : Entity_Id;
+
+ begin
+ for J in reverse 1 .. Scope_Stack.Last loop
+ S := Scope_Stack.Table (J).Entity;
+ Write_Int (Int (S));
+ Write_Str (" === ");
+ Write_Name (Chars (S));
+ Write_Eol;
+ end loop;
+ end Write_Scopes;
+
+end Sem_Ch8;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S E M _ C H 8 --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.33 $ --
+-- --
+-- 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). --
+-- --
+------------------------------------------------------------------------------
+
+with Types; use Types;
+package Sem_Ch8 is
+
+ -----------------------------------
+ -- Handling extensions of System --
+ -----------------------------------
+
+ -- For targets that define a much larger System package than given in
+ -- the RM, we use a child package containing additional declarations,
+ -- which is loaded when needed, and whose entities are conceptually
+ -- within System itself. The presence of this auxiliary package is
+ -- controlled with the pragma Extend_System. The following variable
+ -- holds the entity of the auxiliary package, to simplify the special
+ -- visibility rules that apply to it.
+
+ System_Aux_Id : Entity_Id := Empty;
+
+ -----------------
+ -- Subprograms --
+ -----------------
+
+ procedure Analyze_Exception_Renaming (N : Node_Id);
+ procedure Analyze_Expanded_Name (N : Node_Id);
+ procedure Analyze_Generic_Function_Renaming (N : Node_Id);
+ procedure Analyze_Generic_Package_Renaming (N : Node_Id);
+ procedure Analyze_Generic_Procedure_Renaming (N : Node_Id);
+ procedure Analyze_Object_Renaming (N : Node_Id);
+ procedure Analyze_Package_Renaming (N : Node_Id);
+ procedure Analyze_Subprogram_Renaming (N : Node_Id);
+ procedure Analyze_Use_Package (N : Node_Id);
+ procedure Analyze_Use_Type (N : Node_Id);
+
+ function Applicable_Use (Pack_Name : Node_Id) return Boolean;
+ -- Common code to Use_One_Package and Set_Use, to determine whether
+ -- use clause must be processed. Pack_Name is an entity name that
+ -- references the package in question.
+
+ procedure End_Scope;
+ -- Called at end of scope. On exit from blocks and bodies (subprogram,
+ -- package, task, and protected bodies), the name of the current scope
+ -- must be removed from the scope stack, and the local entities must be
+ -- removed from their homonym chains. On exit from record declarations,
+ -- from package specifications, and from tasks and protected type
+ -- specifications, more specialized procedures are invoked.
+
+ procedure End_Use_Clauses (Clause : Node_Id);
+ -- Invoked on scope exit, to undo the effect of local use clauses. U is
+ -- the first Use clause of a scope being exited. This can be the current
+ -- scope, or some enclosing scopes when building a clean environment to
+ -- compile an instance body for inlining.
+
+ procedure End_Use_Package (N : Node_Id);
+ procedure End_Use_Type (N : Node_Id);
+ -- Subsidiaries of End_Use_Clauses. Also called directly for use clauses
+ -- appearing in context clauses.
+
+ procedure Find_Direct_Name (N : Node_Id);
+ -- Given a direct name (Identifier or Operator_Symbol), this routine
+ -- scans the homonym chain for the name searching for corresponding
+ -- visible entities to find the referenced entity (or in the case of
+ -- overloading), entities. On return, the Entity, and Etype fields
+ -- are set. In the non-overloaded case, these are the correct final
+ -- entries. In the overloaded case, Is_Overloaded is set, Etype and
+ -- Entity refer to an arbitrary element of the overloads set, and
+ -- an appropriate list of entries has been made in the overload
+ -- interpretation table (to be disambiguated in the resolve phase).
+
+ procedure Find_Expanded_Name (N : Node_Id);
+ -- Selected component is known to be expanded name. Verify legality
+ -- of selector given the scope denoted by prefix.
+
+ procedure Find_Selected_Component (N : Node_Id);
+ -- Resolve various cases of selected components, recognize expanded names
+
+ procedure Find_Type (N : Node_Id);
+ -- Perform name resolution, and verify that the name found is that of a
+ -- type. On return the Entity and Etype fields of the node N are set
+ -- appropriately. If it is an incomplete type whose full declaration has
+ -- been seen, return the entity in the full declaration. Similarly, if
+ -- the type is private, it has receivd a full declaration, and we are
+ -- in the private part or body of the package, return the full
+ -- declaration as well. Special processing for Class types as well.
+
+ function Get_Full_View (T_Name : Entity_Id) return Entity_Id;
+ -- If T_Name is an incomplete type and the full declaration has been
+ -- seen, or is the name of a class_wide type whose root is incomplete.
+ -- return the corresponding full declaration.
+
+ function Has_Implicit_Operator (N : Node_Id) return Boolean;
+ -- N is an expanded name whose selector is an operator name (eg P."+").
+ -- A declarative part contains an implicit declaration of an operator
+ -- if it has a declaration of a type to which one of the predefined
+ -- operators apply. The existence of this routine is an artifact of
+ -- our implementation: a more straightforward but more space-consuming
+ -- choice would be to make all inherited operators explicit in the
+ -- symbol table.
+
+ procedure Initialize;
+ -- Initializes data structures used for visibility analysis. Must be
+ -- called before analyzing each new main source program.
+
+ procedure Install_Use_Clauses (Clause : Node_Id);
+ -- applies the use clauses appearing in a given declarative part,
+ -- when the corresponding scope has been placed back on the scope
+ -- stack after unstacking to compile a different context (subunit or
+ -- parent of generic body).
+
+ function In_Open_Scopes (S : Entity_Id) return Boolean;
+ -- S is the entity of a scope. This function determines if this scope
+ -- is currently open (i.e. it appears somewhere in the scope stack).
+
+ function Is_Appropriate_For_Record (T : Entity_Id) return Boolean;
+ -- Prefix is appropriate for record if it is of a record type, or
+ -- an access to such.
+
+ function Is_Appropriate_For_Entry_Prefix (T : Entity_Id) return Boolean;
+ -- True if it is of a task type, a protected type, or else an access
+ -- to one of these types.
+
+ procedure New_Scope (S : Entity_Id);
+ -- Make new scope stack entry, pushing S, the entity for a scope
+ -- onto the top of the scope table. The current setting of the scope
+ -- suppress flags is saved for restoration on exit.
+
+ procedure Pop_Scope;
+ -- Remove top entry from scope stack, restoring the saved setting
+ -- of the scope suppress flags.
+
+ function Present_System_Aux (N : Node_Id := Empty) return Boolean;
+ -- Return True if the auxiliary system file has been sucessfully loaded.
+ -- Otherwise attempt to load it, using the name supplied by a previous
+ -- Extend_System pragma, and report on the success of the load.
+ -- If N is present, it is a selected component whose prefix is System,
+ -- or else a with-clause on system. N is absent when the function is
+ -- called to find the visibility of implicit operators.
+
+ procedure Restore_Scope_Stack;
+ procedure Save_Scope_Stack;
+ -- These two procedures are called from Semantics, when a unit U1 is
+ -- to be compiled in the course of the compilation of another unit U2.
+ -- This happens whenever Rtsfind is called. U1, the unit retrieved by
+ -- Rtsfind, must be compiled in its own context, and the current scope
+ -- stack containing U2 and local scopes must be made unreachable. On
+ -- return, the contents of the scope stack must be made accessible again.
+
+ procedure Use_One_Package (P : Entity_Id; N : Node_Id);
+ -- Make visible entities declarated in package P potentially use-visible
+ -- in the current context. Also used in the analysis of subunits, when
+ -- re-installing use clauses of parent units. N is the use_clause that
+ -- names P (and possibly other packages).
+
+ procedure Use_One_Type (Id : Node_Id; N : Node_Id);
+ -- Id is the subtype mark from a use type clause. This procedure makes
+ -- the primitive operators of the type potentially use-visible.
+ -- N is the Use_Type_Clause that names Id.
+
+ procedure Set_Use (L : List_Id);
+ -- Find use clauses that are declarative items in a package declaration
+ -- and set the potentially use-visible flags of imported entities before
+ -- analyzing the corresponding package body.
+
+end Sem_Ch8;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S E M _ C H 9 --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.235 $
+-- --
+-- 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). --
+-- --
+------------------------------------------------------------------------------
+
+with Atree; use Atree;
+with Checks; use Checks;
+with Einfo; use Einfo;
+with Errout; use Errout;
+with Exp_Ch9;
+with Elists; use Elists;
+with Itypes; use Itypes;
+with Lib.Xref; use Lib.Xref;
+with Nlists; use Nlists;
+with Nmake; use Nmake;
+with Opt; use Opt;
+with Restrict; use Restrict;
+with Rtsfind; use Rtsfind;
+with Sem; use Sem;
+with Sem_Ch3; use Sem_Ch3;
+with Sem_Ch5; use Sem_Ch5;
+with Sem_Ch6; use Sem_Ch6;
+with Sem_Ch8; use Sem_Ch8;
+with Sem_Eval; use Sem_Eval;
+with Sem_Res; use Sem_Res;
+with Sem_Type; use Sem_Type;
+with Sem_Util; use Sem_Util;
+with Sem_Warn; use Sem_Warn;
+with Snames; use Snames;
+with Stand; use Stand;
+with Sinfo; use Sinfo;
+with Style;
+with Tbuild; use Tbuild;
+with Uintp; use Uintp;
+
+package body Sem_Ch9 is
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ procedure Check_Max_Entries (Def : Node_Id; R : Restriction_Parameter_Id);
+ -- Given either a protected definition or a task definition in Def, check
+ -- the corresponding restriction parameter identifier R, and if it is set,
+ -- count the entries (checking the static requirement), and compare with
+ -- the given maximum.
+
+ function Find_Concurrent_Spec (Body_Id : Entity_Id) return Entity_Id;
+ -- Find entity in corresponding task or protected declaration. Use full
+ -- view if first declaration was for an incomplete type.
+
+ procedure Install_Declarations (Spec : Entity_Id);
+ -- Utility to make visible in corresponding body the entities defined
+ -- in task, protected type declaration, or entry declaration.
+
+ -----------------------------
+ -- Analyze_Abort_Statement --
+ -----------------------------
+
+ procedure Analyze_Abort_Statement (N : Node_Id) is
+ T_Name : Node_Id;
+
+ begin
+ Tasking_Used := True;
+ T_Name := First (Names (N));
+ while Present (T_Name) loop
+ Analyze (T_Name);
+
+ if not Is_Task_Type (Etype (T_Name)) then
+ Error_Msg_N ("expect task name for ABORT", T_Name);
+ return;
+ else
+ Resolve (T_Name, Etype (T_Name));
+ end if;
+
+ Next (T_Name);
+ end loop;
+
+ Check_Restriction (No_Abort_Statements, N);
+ Check_Potentially_Blocking_Operation (N);
+ end Analyze_Abort_Statement;
+
+ --------------------------------
+ -- Analyze_Accept_Alternative --
+ --------------------------------
+
+ procedure Analyze_Accept_Alternative (N : Node_Id) is
+ begin
+ Tasking_Used := True;
+
+ if Present (Pragmas_Before (N)) then
+ Analyze_List (Pragmas_Before (N));
+ end if;
+
+ Analyze (Accept_Statement (N));
+
+ if Present (Condition (N)) then
+ Analyze_And_Resolve (Condition (N), Any_Boolean);
+ end if;
+
+ if Is_Non_Empty_List (Statements (N)) then
+ Analyze_Statements (Statements (N));
+ end if;
+ end Analyze_Accept_Alternative;
+
+ ------------------------------
+ -- Analyze_Accept_Statement --
+ ------------------------------
+
+ procedure Analyze_Accept_Statement (N : Node_Id) is
+ Nam : constant Entity_Id := Entry_Direct_Name (N);
+ Formals : constant List_Id := Parameter_Specifications (N);
+ Index : constant Node_Id := Entry_Index (N);
+ Stats : constant Node_Id := Handled_Statement_Sequence (N);
+ Ityp : Entity_Id;
+ Entry_Nam : Entity_Id;
+ E : Entity_Id;
+ Kind : Entity_Kind;
+ Task_Nam : Entity_Id;
+
+ -----------------------
+ -- Actual_Index_Type --
+ -----------------------
+
+ function Actual_Index_Type (E : Entity_Id) return Entity_Id;
+ -- If the bounds of an entry family depend on task discriminants,
+ -- create a new index type where a discriminant is replaced by the
+ -- local variable that renames it in the task body.
+
+ function Actual_Index_Type (E : Entity_Id) return Entity_Id is
+ Typ : Entity_Id := Entry_Index_Type (E);
+ Lo : Node_Id := Type_Low_Bound (Typ);
+ Hi : Node_Id := Type_High_Bound (Typ);
+ New_T : Entity_Id;
+
+ function Actual_Discriminant_Ref (Bound : Node_Id) return Node_Id;
+ -- If bound is discriminant reference, replace with corresponding
+ -- local variable of the same name.
+
+ function Actual_Discriminant_Ref (Bound : Node_Id) return Node_Id is
+ Typ : Entity_Id := Etype (Bound);
+ Ref : Node_Id;
+
+ begin
+ if not Is_Entity_Name (Bound)
+ or else Ekind (Entity (Bound)) /= E_Discriminant
+ then
+ return Bound;
+
+ else
+ Ref := Make_Identifier (Sloc (N), Chars (Entity (Bound)));
+ Analyze (Ref);
+ Resolve (Ref, Typ);
+ return Ref;
+ end if;
+ end Actual_Discriminant_Ref;
+
+ -- Start of processing for Actual_Index_Type
+
+ begin
+ if not Has_Discriminants (Task_Nam)
+ or else (not Is_Entity_Name (Lo)
+ and then not Is_Entity_Name (Hi))
+ then
+ return Entry_Index_Type (E);
+ else
+ New_T := Create_Itype (Ekind (Typ), N);
+ Set_Etype (New_T, Base_Type (Typ));
+ Set_Size_Info (New_T, Typ);
+ Set_RM_Size (New_T, RM_Size (Typ));
+ Set_Scalar_Range (New_T,
+ Make_Range (Sloc (N),
+ Low_Bound => Actual_Discriminant_Ref (Lo),
+ High_Bound => Actual_Discriminant_Ref (Hi)));
+
+ return New_T;
+ end if;
+ end Actual_Index_Type;
+
+ -- Start of processing for Analyze_Accept_Statement
+
+ begin
+ Tasking_Used := True;
+
+ -- Entry name is initialized to Any_Id. It should get reset to the
+ -- matching entry entity. An error is signalled if it is not reset.
+
+ Entry_Nam := Any_Id;
+
+ for J in reverse 0 .. Scope_Stack.Last loop
+ Task_Nam := Scope_Stack.Table (J).Entity;
+ exit when Ekind (Etype (Task_Nam)) = E_Task_Type;
+ Kind := Ekind (Task_Nam);
+
+ if Kind /= E_Block and then Kind /= E_Loop
+ and then not Is_Entry (Task_Nam)
+ then
+ Error_Msg_N ("enclosing body of accept must be a task", N);
+ return;
+ end if;
+ end loop;
+
+ if Ekind (Etype (Task_Nam)) /= E_Task_Type then
+ Error_Msg_N ("invalid context for accept statement", N);
+ return;
+ end if;
+
+ -- In order to process the parameters, we create a defining
+ -- identifier that can be used as the name of the scope. The
+ -- name of the accept statement itself is not a defining identifier.
+
+ if Present (Index) then
+ Ityp := New_Internal_Entity
+ (E_Entry_Family, Current_Scope, Sloc (N), 'E');
+ else
+ Ityp := New_Internal_Entity
+ (E_Entry, Current_Scope, Sloc (N), 'E');
+ end if;
+
+ Set_Etype (Ityp, Standard_Void_Type);
+ Set_Accept_Address (Ityp, New_Elmt_List);
+
+ if Present (Formals) then
+ New_Scope (Ityp);
+ Process_Formals (Ityp, Formals, N);
+ Create_Extra_Formals (Ityp);
+ End_Scope;
+ end if;
+
+ -- We set the default expressions processed flag because we don't
+ -- need default expression functions. This is really more like a
+ -- body entity than a spec entity anyway.
+
+ Set_Default_Expressions_Processed (Ityp);
+
+ E := First_Entity (Etype (Task_Nam));
+
+ while Present (E) loop
+ if Chars (E) = Chars (Nam)
+ and then (Ekind (E) = Ekind (Ityp))
+ and then Type_Conformant (Ityp, E)
+ then
+ Entry_Nam := E;
+ exit;
+ end if;
+
+ Next_Entity (E);
+ end loop;
+
+ if Entry_Nam = Any_Id then
+ Error_Msg_N ("no entry declaration matches accept statement", N);
+ return;
+ else
+ Set_Entity (Nam, Entry_Nam);
+ Generate_Reference (Entry_Nam, Nam, 'b');
+ Style.Check_Identifier (Nam, Entry_Nam);
+ end if;
+
+ -- Verify that the entry is not hidden by a procedure declared in
+ -- the current block (pathological but possible).
+
+ if Current_Scope /= Task_Nam then
+ declare
+ E1 : Entity_Id;
+
+ begin
+ E1 := First_Entity (Current_Scope);
+
+ while Present (E1) loop
+
+ if Ekind (E1) = E_Procedure
+ and then Type_Conformant (E1, Entry_Nam)
+ then
+ Error_Msg_N ("entry name is not visible", N);
+ end if;
+
+ Next_Entity (E1);
+ end loop;
+ end;
+ end if;
+
+ Set_Convention (Ityp, Convention (Entry_Nam));
+ Check_Fully_Conformant (Ityp, Entry_Nam, N);
+
+ for J in reverse 0 .. Scope_Stack.Last loop
+ exit when Task_Nam = Scope_Stack.Table (J).Entity;
+
+ if Entry_Nam = Scope_Stack.Table (J).Entity then
+ Error_Msg_N ("duplicate accept statement for same entry", N);
+ end if;
+
+ end loop;
+
+ declare
+ P : Node_Id := N;
+ begin
+ loop
+ P := Parent (P);
+ case Nkind (P) is
+ when N_Task_Body | N_Compilation_Unit =>
+ exit;
+ when N_Asynchronous_Select =>
+ Error_Msg_N ("accept statements are not allowed within" &
+ " an asynchronous select inner" &
+ " to the enclosing task body", N);
+ exit;
+ when others =>
+ null;
+ end case;
+ end loop;
+ end;
+
+ if Ekind (E) = E_Entry_Family then
+ if No (Index) then
+ Error_Msg_N ("missing entry index in accept for entry family", N);
+ else
+ Analyze_And_Resolve (Index, Entry_Index_Type (E));
+ Apply_Range_Check (Index, Actual_Index_Type (E));
+ end if;
+
+ elsif Present (Index) then
+ Error_Msg_N ("invalid entry index in accept for simple entry", N);
+ end if;
+
+ -- If statements are present, they must be analyzed in the context
+ -- of the entry, so that references to formals are correctly resolved.
+ -- We also have to add the declarations that are required by the
+ -- expansion of the accept statement in this case if expansion active.
+
+ -- In the case of a select alternative of a selective accept,
+ -- the expander references the address declaration even if there
+ -- is no statement list.
+
+ Exp_Ch9.Expand_Accept_Declarations (N, Entry_Nam);
+
+ -- If label declarations present, analyze them. They are declared
+ -- in the enclosing task, but their enclosing scope is the entry itself,
+ -- so that goto's to the label are recognized as local to the accept.
+
+ if Present (Declarations (N)) then
+
+ declare
+ Decl : Node_Id;
+ Id : Entity_Id;
+
+ begin
+ Decl := First (Declarations (N));
+
+ while Present (Decl) loop
+ Analyze (Decl);
+
+ pragma Assert
+ (Nkind (Decl) = N_Implicit_Label_Declaration);
+
+ Id := Defining_Identifier (Decl);
+ Set_Enclosing_Scope (Id, Entry_Nam);
+ Next (Decl);
+ end loop;
+ end;
+ end if;
+
+ -- Set Not_Source_Assigned flag on all entry formals
+
+ E := First_Entity (Entry_Nam);
+
+ while Present (E) loop
+ Set_Not_Source_Assigned (E, True);
+ Next_Entity (E);
+ end loop;
+
+ -- Analyze statements if present
+
+ if Present (Stats) then
+ New_Scope (Entry_Nam);
+ Install_Declarations (Entry_Nam);
+
+ Set_Actual_Subtypes (N, Current_Scope);
+ Analyze (Stats);
+ Process_End_Label (Handled_Statement_Sequence (N), 't');
+ End_Scope;
+ end if;
+
+ -- Some warning checks
+
+ Check_Potentially_Blocking_Operation (N);
+ Check_References (Entry_Nam, N);
+ Set_Entry_Accepted (Entry_Nam);
+
+ end Analyze_Accept_Statement;
+
+ ---------------------------------
+ -- Analyze_Asynchronous_Select --
+ ---------------------------------
+
+ procedure Analyze_Asynchronous_Select (N : Node_Id) is
+ begin
+ Tasking_Used := True;
+ Check_Restriction (Max_Asynchronous_Select_Nesting, N);
+ Check_Restriction (No_Select_Statements, N);
+
+ Analyze (Triggering_Alternative (N));
+
+ Analyze_Statements (Statements (Abortable_Part (N)));
+ end Analyze_Asynchronous_Select;
+
+ ------------------------------------
+ -- Analyze_Conditional_Entry_Call --
+ ------------------------------------
+
+ procedure Analyze_Conditional_Entry_Call (N : Node_Id) is
+ begin
+ Check_Restriction (No_Select_Statements, N);
+ Tasking_Used := True;
+ Analyze (Entry_Call_Alternative (N));
+ Analyze_Statements (Else_Statements (N));
+ end Analyze_Conditional_Entry_Call;
+
+ --------------------------------
+ -- Analyze_Delay_Alternative --
+ --------------------------------
+
+ procedure Analyze_Delay_Alternative (N : Node_Id) is
+ Expr : Node_Id;
+
+ begin
+ Tasking_Used := True;
+ Check_Restriction (No_Delay, N);
+
+ if Present (Pragmas_Before (N)) then
+ Analyze_List (Pragmas_Before (N));
+ end if;
+
+ if Nkind (Parent (N)) = N_Selective_Accept
+ or else Nkind (Parent (N)) = N_Timed_Entry_Call
+ then
+ Expr := Expression (Delay_Statement (N));
+
+ -- defer full analysis until the statement is expanded, to insure
+ -- that generated code does not move past the guard. The delay
+ -- expression is only evaluated if the guard is open.
+
+ if Nkind (Delay_Statement (N)) = N_Delay_Relative_Statement then
+ Pre_Analyze_And_Resolve (Expr, Standard_Duration);
+
+ else
+ Pre_Analyze_And_Resolve (Expr);
+ end if;
+
+ Check_Restriction (No_Fixed_Point, Expr);
+ else
+ Analyze (Delay_Statement (N));
+ end if;
+
+ if Present (Condition (N)) then
+ Analyze_And_Resolve (Condition (N), Any_Boolean);
+ end if;
+
+ if Is_Non_Empty_List (Statements (N)) then
+ Analyze_Statements (Statements (N));
+ end if;
+ end Analyze_Delay_Alternative;
+
+ ----------------------------
+ -- Analyze_Delay_Relative --
+ ----------------------------
+
+ procedure Analyze_Delay_Relative (N : Node_Id) is
+ E : constant Node_Id := Expression (N);
+
+ begin
+ Check_Restriction (No_Relative_Delay, N);
+ Tasking_Used := True;
+ Check_Restriction (No_Delay, N);
+ Check_Potentially_Blocking_Operation (N);
+ Analyze_And_Resolve (E, Standard_Duration);
+ Check_Restriction (No_Fixed_Point, E);
+ end Analyze_Delay_Relative;
+
+ -------------------------
+ -- Analyze_Delay_Until --
+ -------------------------
+
+ procedure Analyze_Delay_Until (N : Node_Id) is
+ E : constant Node_Id := Expression (N);
+
+ begin
+ Tasking_Used := True;
+ Check_Restriction (No_Delay, N);
+ Check_Potentially_Blocking_Operation (N);
+ Analyze (E);
+
+ if not Is_RTE (Base_Type (Etype (E)), RO_CA_Time) and then
+ not Is_RTE (Base_Type (Etype (E)), RO_RT_Time)
+ then
+ Error_Msg_N ("expect Time types for `DELAY UNTIL`", E);
+ end if;
+ end Analyze_Delay_Until;
+
+ ------------------------
+ -- Analyze_Entry_Body --
+ ------------------------
+
+ procedure Analyze_Entry_Body (N : Node_Id) is
+ Id : constant Entity_Id := Defining_Identifier (N);
+ Decls : constant List_Id := Declarations (N);
+ Stats : constant Node_Id := Handled_Statement_Sequence (N);
+ Formals : constant Node_Id := Entry_Body_Formal_Part (N);
+ P_Type : constant Entity_Id := Current_Scope;
+ Entry_Name : Entity_Id;
+ E : Entity_Id;
+
+ begin
+ Tasking_Used := True;
+
+ -- Entry_Name is initialized to Any_Id. It should get reset to the
+ -- matching entry entity. An error is signalled if it is not reset
+
+ Entry_Name := Any_Id;
+
+ Analyze (Formals);
+
+ if Present (Entry_Index_Specification (Formals)) then
+ Set_Ekind (Id, E_Entry_Family);
+ else
+ Set_Ekind (Id, E_Entry);
+ end if;
+
+ Set_Scope (Id, Current_Scope);
+ Set_Etype (Id, Standard_Void_Type);
+ Set_Accept_Address (Id, New_Elmt_List);
+
+ E := First_Entity (P_Type);
+ while Present (E) loop
+ if Chars (E) = Chars (Id)
+ and then (Ekind (E) = Ekind (Id))
+ and then Type_Conformant (Id, E)
+ then
+ Entry_Name := E;
+ Set_Convention (Id, Convention (E));
+ Check_Fully_Conformant (Id, E, N);
+ exit;
+ end if;
+
+ Next_Entity (E);
+ end loop;
+
+ if Entry_Name = Any_Id then
+ Error_Msg_N ("no entry declaration matches entry body", N);
+ return;
+
+ elsif Has_Completion (Entry_Name) then
+ Error_Msg_N ("duplicate entry body", N);
+ return;
+
+ else
+ Set_Has_Completion (Entry_Name);
+ Generate_Reference (Entry_Name, Id, 'b');
+ Style.Check_Identifier (Id, Entry_Name);
+ end if;
+
+ Exp_Ch9.Expand_Entry_Barrier (N, Entry_Name);
+ New_Scope (Entry_Name);
+
+ Exp_Ch9.Expand_Entry_Body_Declarations (N);
+ Install_Declarations (Entry_Name);
+ Set_Actual_Subtypes (N, Current_Scope);
+
+ -- The entity for the protected subprogram corresponding to the entry
+ -- has been created. We retain the name of this entity in the entry
+ -- body, for use when the corresponding subprogram body is created.
+ -- Note that entry bodies have to corresponding_spec, and there is no
+ -- easy link back in the tree between the entry body and the entity for
+ -- the entry itself.
+
+ Set_Protected_Body_Subprogram (Id,
+ Protected_Body_Subprogram (Entry_Name));
+
+ if Present (Decls) then
+ Analyze_Declarations (Decls);
+ end if;
+
+ if Present (Stats) then
+ Analyze (Stats);
+ end if;
+
+ Check_References (Entry_Name);
+ Process_End_Label (Handled_Statement_Sequence (N), 't');
+ End_Scope;
+
+ -- If this is an entry family, remove the loop created to provide
+ -- a scope for the entry index.
+
+ if Ekind (Id) = E_Entry_Family
+ and then Present (Entry_Index_Specification (Formals))
+ then
+ End_Scope;
+ end if;
+
+ end Analyze_Entry_Body;
+
+ ------------------------------------
+ -- Analyze_Entry_Body_Formal_Part --
+ ------------------------------------
+
+ procedure Analyze_Entry_Body_Formal_Part (N : Node_Id) is
+ Id : constant Entity_Id := Defining_Identifier (Parent (N));
+ Index : constant Node_Id := Entry_Index_Specification (N);
+ Formals : constant List_Id := Parameter_Specifications (N);
+
+ begin
+ Tasking_Used := True;
+
+ if Present (Index) then
+ Analyze (Index);
+ end if;
+
+ if Present (Formals) then
+ Set_Scope (Id, Current_Scope);
+ New_Scope (Id);
+ Process_Formals (Id, Formals, Parent (N));
+ End_Scope;
+ end if;
+
+ end Analyze_Entry_Body_Formal_Part;
+
+ ------------------------------------
+ -- Analyze_Entry_Call_Alternative --
+ ------------------------------------
+
+ procedure Analyze_Entry_Call_Alternative (N : Node_Id) is
+ begin
+ Tasking_Used := True;
+
+ if Present (Pragmas_Before (N)) then
+ Analyze_List (Pragmas_Before (N));
+ end if;
+
+ Analyze (Entry_Call_Statement (N));
+
+ if Is_Non_Empty_List (Statements (N)) then
+ Analyze_Statements (Statements (N));
+ end if;
+ end Analyze_Entry_Call_Alternative;
+
+ -------------------------------
+ -- Analyze_Entry_Declaration --
+ -------------------------------
+
+ procedure Analyze_Entry_Declaration (N : Node_Id) is
+ Id : Entity_Id := Defining_Identifier (N);
+ D_Sdef : Node_Id := Discrete_Subtype_Definition (N);
+ Formals : List_Id := Parameter_Specifications (N);
+
+ begin
+ Generate_Definition (Id);
+ Tasking_Used := True;
+
+ if No (D_Sdef) then
+ Set_Ekind (Id, E_Entry);
+ else
+ Enter_Name (Id);
+ Set_Ekind (Id, E_Entry_Family);
+ Analyze (D_Sdef);
+ Make_Index (D_Sdef, N, Id);
+ end if;
+
+ Set_Etype (Id, Standard_Void_Type);
+ Set_Convention (Id, Convention_Entry);
+ Set_Accept_Address (Id, New_Elmt_List);
+
+ if Present (Formals) then
+ Set_Scope (Id, Current_Scope);
+ New_Scope (Id);
+ Process_Formals (Id, Formals, N);
+ Create_Extra_Formals (Id);
+ End_Scope;
+ end if;
+
+ if Ekind (Id) = E_Entry then
+ New_Overloaded_Entity (Id);
+ end if;
+
+ end Analyze_Entry_Declaration;
+
+ ---------------------------------------
+ -- Analyze_Entry_Index_Specification --
+ ---------------------------------------
+
+ -- The defining_Identifier of the entry index specification is local
+ -- to the entry body, but must be available in the entry barrier,
+ -- which is evaluated outside of the entry body. The index is eventually
+ -- renamed as a run-time object, so is visibility is strictly a front-end
+ -- concern. In order to make it available to the barrier, we create
+ -- an additional scope, as for a loop, whose only declaration is the
+ -- index name. This loop is not attached to the tree and does not appear
+ -- as an entity local to the protected type, so its existence need only
+ -- be knwown to routines that process entry families.
+
+ procedure Analyze_Entry_Index_Specification (N : Node_Id) is
+ Iden : constant Node_Id := Defining_Identifier (N);
+ Def : constant Node_Id := Discrete_Subtype_Definition (N);
+ Loop_Id : Entity_Id :=
+ Make_Defining_Identifier (Sloc (N),
+ Chars => New_Internal_Name ('L'));
+
+ begin
+ Tasking_Used := True;
+ Analyze (Def);
+ Make_Index (Def, N);
+ Set_Ekind (Loop_Id, E_Loop);
+ Set_Scope (Loop_Id, Current_Scope);
+ New_Scope (Loop_Id);
+ Enter_Name (Iden);
+ Set_Ekind (Iden, E_Entry_Index_Parameter);
+ Set_Etype (Iden, Etype (Def));
+ end Analyze_Entry_Index_Specification;
+
+ ----------------------------
+ -- Analyze_Protected_Body --
+ ----------------------------
+
+ procedure Analyze_Protected_Body (N : Node_Id) is
+ Body_Id : constant Entity_Id := Defining_Identifier (N);
+ Spec_Id : Entity_Id;
+ Last_E : Entity_Id;
+
+ begin
+ Tasking_Used := True;
+ Set_Ekind (Body_Id, E_Protected_Body);
+ Spec_Id := Find_Concurrent_Spec (Body_Id);
+
+ if Present (Spec_Id)
+ and then Ekind (Spec_Id) = E_Protected_Type
+ then
+ null;
+
+ elsif Present (Spec_Id)
+ and then Ekind (Etype (Spec_Id)) = E_Protected_Type
+ and then not Comes_From_Source (Etype (Spec_Id))
+ then
+ null;
+
+ else
+ Error_Msg_N ("missing specification for protected body", Body_Id);
+ return;
+ end if;
+
+ Generate_Reference (Spec_Id, Body_Id, 'b');
+ Style.Check_Identifier (Body_Id, Spec_Id);
+
+ -- The declarations are always attached to the type
+
+ if Ekind (Spec_Id) /= E_Protected_Type then
+ Spec_Id := Etype (Spec_Id);
+ end if;
+
+ New_Scope (Spec_Id);
+ Set_Corresponding_Spec (N, Spec_Id);
+ Set_Corresponding_Body (Parent (Spec_Id), Body_Id);
+ Set_Has_Completion (Spec_Id);
+ Install_Declarations (Spec_Id);
+
+ Exp_Ch9.Expand_Protected_Body_Declarations (N, Spec_Id);
+
+ Last_E := Last_Entity (Spec_Id);
+
+ Analyze_Declarations (Declarations (N));
+
+ -- For visibility purposes, all entities in the body are private.
+ -- Set First_Private_Entity accordingly, if there was no private
+ -- part in the protected declaration.
+
+ if No (First_Private_Entity (Spec_Id)) then
+ if Present (Last_E) then
+ Set_First_Private_Entity (Spec_Id, Next_Entity (Last_E));
+ else
+ Set_First_Private_Entity (Spec_Id, First_Entity (Spec_Id));
+ end if;
+ end if;
+
+ Check_Completion (Body_Id);
+ Check_References (Spec_Id);
+ Process_End_Label (N, 't');
+ End_Scope;
+ end Analyze_Protected_Body;
+
+ ----------------------------------
+ -- Analyze_Protected_Definition --
+ ----------------------------------
+
+ procedure Analyze_Protected_Definition (N : Node_Id) is
+ E : Entity_Id;
+ L : Entity_Id;
+
+ begin
+ Tasking_Used := True;
+ Analyze_Declarations (Visible_Declarations (N));
+
+ if Present (Private_Declarations (N))
+ and then not Is_Empty_List (Private_Declarations (N))
+ then
+ L := Last_Entity (Current_Scope);
+ Analyze_Declarations (Private_Declarations (N));
+
+ if Present (L) then
+ Set_First_Private_Entity (Current_Scope, Next_Entity (L));
+
+ else
+ Set_First_Private_Entity (Current_Scope,
+ First_Entity (Current_Scope));
+ end if;
+ end if;
+
+ E := First_Entity (Current_Scope);
+
+ while Present (E) loop
+
+ if Ekind (E) = E_Function
+ or else Ekind (E) = E_Procedure
+ then
+ Set_Convention (E, Convention_Protected);
+
+ elsif Is_Task_Type (Etype (E)) then
+ Set_Has_Task (Current_Scope);
+ end if;
+
+ Next_Entity (E);
+ end loop;
+
+ Check_Max_Entries (N, Max_Protected_Entries);
+ Process_End_Label (N, 'e');
+ end Analyze_Protected_Definition;
+
+ ----------------------------
+ -- Analyze_Protected_Type --
+ ----------------------------
+
+ procedure Analyze_Protected_Type (N : Node_Id) is
+ E : Entity_Id;
+ T : Entity_Id;
+ Def_Id : constant Entity_Id := Defining_Identifier (N);
+
+ begin
+ Tasking_Used := True;
+ Check_Restriction (No_Protected_Types, N);
+
+ T := Find_Type_Name (N);
+
+ if Ekind (T) = E_Incomplete_Type then
+ T := Full_View (T);
+ end if;
+
+ Set_Ekind (T, E_Protected_Type);
+ Init_Size_Align (T);
+ Set_Etype (T, T);
+ Set_Is_First_Subtype (T, True);
+ Set_Has_Delayed_Freeze (T, True);
+ Set_Girder_Constraint (T, No_Elist);
+ New_Scope (T);
+
+ if Present (Discriminant_Specifications (N)) then
+ if Has_Discriminants (T) then
+
+ -- Install discriminants. Also, verify conformance of
+ -- discriminants of previous and current view. ???
+
+ Install_Declarations (T);
+ else
+ Process_Discriminants (N);
+ end if;
+ end if;
+
+ Analyze (Protected_Definition (N));
+
+ -- Protected types with entries are controlled (because of the
+ -- Protection component if nothing else), same for any protected type
+ -- with interrupt handlers. Note that we need to analyze the protected
+ -- definition to set Has_Entries and such.
+
+ if (Abort_Allowed or else Restrictions (No_Entry_Queue) = False
+ or else Number_Entries (T) > 1)
+ and then
+ (Has_Entries (T)
+ or else Has_Interrupt_Handler (T)
+ or else Has_Attach_Handler (T))
+ then
+ Set_Has_Controlled_Component (T, True);
+ end if;
+
+ -- The Ekind of components is E_Void during analysis to detect
+ -- illegal uses. Now it can be set correctly.
+
+ E := First_Entity (Current_Scope);
+
+ while Present (E) loop
+ if Ekind (E) = E_Void then
+ Set_Ekind (E, E_Component);
+ Init_Component_Location (E);
+ end if;
+
+ Next_Entity (E);
+ end loop;
+
+ End_Scope;
+
+ if T /= Def_Id
+ and then Is_Private_Type (Def_Id)
+ and then Has_Discriminants (Def_Id)
+ and then Expander_Active
+ then
+ Exp_Ch9.Expand_N_Protected_Type_Declaration (N);
+ Process_Full_View (N, T, Def_Id);
+ end if;
+
+ end Analyze_Protected_Type;
+
+ ---------------------
+ -- Analyze_Requeue --
+ ---------------------
+
+ procedure Analyze_Requeue (N : Node_Id) is
+ Entry_Name : Node_Id := Name (N);
+ Entry_Id : Entity_Id;
+ Found : Boolean;
+ I : Interp_Index;
+ It : Interp;
+ Enclosing : Entity_Id;
+ Target_Obj : Node_Id := Empty;
+ Req_Scope : Entity_Id;
+ Outer_Ent : Entity_Id;
+
+ begin
+ Check_Restriction (No_Requeue, N);
+ Check_Unreachable_Code (N);
+ Tasking_Used := True;
+
+ Enclosing := Empty;
+ for J in reverse 0 .. Scope_Stack.Last loop
+ Enclosing := Scope_Stack.Table (J).Entity;
+ exit when Is_Entry (Enclosing);
+
+ if Ekind (Enclosing) /= E_Block
+ and then Ekind (Enclosing) /= E_Loop
+ then
+ Error_Msg_N ("requeue must appear within accept or entry body", N);
+ return;
+ end if;
+ end loop;
+
+ Analyze (Entry_Name);
+
+ if Etype (Entry_Name) = Any_Type then
+ return;
+ end if;
+
+ if Nkind (Entry_Name) = N_Selected_Component then
+ Target_Obj := Prefix (Entry_Name);
+ Entry_Name := Selector_Name (Entry_Name);
+ end if;
+
+ -- If an explicit target object is given then we have to check
+ -- the restrictions of 9.5.4(6).
+
+ if Present (Target_Obj) then
+ -- Locate containing concurrent unit and determine
+ -- enclosing entry body or outermost enclosing accept
+ -- statement within the unit.
+
+ Outer_Ent := Empty;
+ for S in reverse 0 .. Scope_Stack.Last loop
+ Req_Scope := Scope_Stack.Table (S).Entity;
+
+ exit when Ekind (Req_Scope) in Task_Kind
+ or else Ekind (Req_Scope) in Protected_Kind;
+
+ if Is_Entry (Req_Scope) then
+ Outer_Ent := Req_Scope;
+ end if;
+ end loop;
+
+ pragma Assert (Present (Outer_Ent));
+
+ -- Check that the accessibility level of the target object
+ -- is not greater or equal to the outermost enclosing accept
+ -- statement (or entry body) unless it is a parameter of the
+ -- innermost enclosing accept statement (or entry body).
+
+ if Object_Access_Level (Target_Obj) >= Scope_Depth (Outer_Ent)
+ and then
+ (not Is_Entity_Name (Target_Obj)
+ or else Ekind (Entity (Target_Obj)) not in Formal_Kind
+ or else Enclosing /= Scope (Entity (Target_Obj)))
+ then
+ Error_Msg_N
+ ("target object has invalid level for requeue", Target_Obj);
+ end if;
+ end if;
+
+ -- Overloaded case, find right interpretation
+
+ if Is_Overloaded (Entry_Name) then
+ Get_First_Interp (Entry_Name, I, It);
+ Found := False;
+ Entry_Id := Empty;
+
+ while Present (It.Nam) loop
+
+ if No (First_Formal (It.Nam))
+ or else Subtype_Conformant (Enclosing, It.Nam)
+ then
+ if not Found then
+ Found := True;
+ Entry_Id := It.Nam;
+ else
+ Error_Msg_N ("ambiguous entry name in requeue", N);
+ return;
+ end if;
+ end if;
+
+ Get_Next_Interp (I, It);
+ end loop;
+
+ if not Found then
+ Error_Msg_N ("no entry matches context", N);
+ return;
+ else
+ Set_Entity (Entry_Name, Entry_Id);
+ end if;
+
+ -- Non-overloaded cases
+
+ -- For the case of a reference to an element of an entry family,
+ -- the Entry_Name is an indexed component.
+
+ elsif Nkind (Entry_Name) = N_Indexed_Component then
+
+ -- Requeue to an entry out of the body
+
+ if Nkind (Prefix (Entry_Name)) = N_Selected_Component then
+ Entry_Id := Entity (Selector_Name (Prefix (Entry_Name)));
+
+ -- Requeue from within the body itself
+
+ elsif Nkind (Prefix (Entry_Name)) = N_Identifier then
+ Entry_Id := Entity (Prefix (Entry_Name));
+
+ else
+ Error_Msg_N ("invalid entry_name specified", N);
+ return;
+ end if;
+
+ -- If we had a requeue of the form REQUEUE A (B), then the parser
+ -- accepted it (because it could have been a requeue on an entry
+ -- index. If A turns out not to be an entry family, then the analysis
+ -- of A (B) turned it into a function call.
+
+ elsif Nkind (Entry_Name) = N_Function_Call then
+ Error_Msg_N
+ ("arguments not allowed in requeue statement",
+ First (Parameter_Associations (Entry_Name)));
+ return;
+
+ -- Normal case of no entry family, no argument
+
+ else
+ Entry_Id := Entity (Entry_Name);
+ end if;
+
+ -- Resolve entry, and check that it is subtype conformant with the
+ -- enclosing construct if this construct has formals (RM 9.5.4(5)).
+
+ if not Is_Entry (Entry_Id) then
+ Error_Msg_N ("expect entry name in requeue statement", Name (N));
+ elsif Ekind (Entry_Id) = E_Entry_Family
+
+ and then Nkind (Entry_Name) /= N_Indexed_Component
+ then
+ Error_Msg_N ("missing index for entry family component", Name (N));
+
+ else
+ Resolve_Entry (Name (N));
+
+ if Present (First_Formal (Entry_Id)) then
+ Check_Subtype_Conformant (Enclosing, Entry_Id, Name (N));
+
+ -- Mark any output parameters as assigned
+
+ declare
+ Ent : Entity_Id := First_Formal (Enclosing);
+
+ begin
+ while Present (Ent) loop
+ if Ekind (Ent) = E_Out_Parameter then
+ Set_Not_Source_Assigned (Ent, False);
+ end if;
+
+ Next_Formal (Ent);
+ end loop;
+ end;
+ end if;
+ end if;
+
+ end Analyze_Requeue;
+
+ ------------------------------
+ -- Analyze_Selective_Accept --
+ ------------------------------
+
+ procedure Analyze_Selective_Accept (N : Node_Id) is
+ Alts : constant List_Id := Select_Alternatives (N);
+ Alt : Node_Id;
+
+ Accept_Present : Boolean := False;
+ Terminate_Present : Boolean := False;
+ Delay_Present : Boolean := False;
+ Relative_Present : Boolean := False;
+ Alt_Count : Uint := Uint_0;
+
+ begin
+ Check_Restriction (No_Select_Statements, N);
+ Tasking_Used := True;
+
+ Alt := First (Alts);
+ while Present (Alt) loop
+ Alt_Count := Alt_Count + 1;
+ Analyze (Alt);
+
+ if Nkind (Alt) = N_Delay_Alternative then
+ if Delay_Present then
+
+ if (Relative_Present /=
+ (Nkind (Delay_Statement (Alt)) = N_Delay_Relative_Statement))
+ then
+ Error_Msg_N
+ ("delay_until and delay_relative alternatives ", Alt);
+ Error_Msg_N
+ ("\cannot appear in the same selective_wait", Alt);
+ end if;
+
+ else
+ Delay_Present := True;
+ Relative_Present :=
+ Nkind (Delay_Statement (Alt)) = N_Delay_Relative_Statement;
+ end if;
+
+ elsif Nkind (Alt) = N_Terminate_Alternative then
+ if Terminate_Present then
+ Error_Msg_N ("Only one terminate alternative allowed", N);
+ else
+ Terminate_Present := True;
+ Check_Restriction (No_Terminate_Alternatives, N);
+ end if;
+
+ elsif Nkind (Alt) = N_Accept_Alternative then
+ Accept_Present := True;
+
+ -- Check for duplicate accept
+
+ declare
+ Alt1 : Node_Id;
+ Stm : constant Node_Id := Accept_Statement (Alt);
+ EDN : constant Node_Id := Entry_Direct_Name (Stm);
+ Ent : Entity_Id;
+
+ begin
+ if Nkind (EDN) = N_Identifier
+ and then No (Condition (Alt))
+ and then Present (Entity (EDN)) -- defend against junk
+ and then Ekind (Entity (EDN)) = E_Entry
+ then
+ Ent := Entity (EDN);
+
+ Alt1 := First (Alts);
+ while Alt1 /= Alt loop
+ if Nkind (Alt1) = N_Accept_Alternative
+ and then No (Condition (Alt1))
+ then
+ declare
+ Stm1 : constant Node_Id := Accept_Statement (Alt1);
+ EDN1 : constant Node_Id := Entry_Direct_Name (Stm1);
+
+ begin
+ if Nkind (EDN1) = N_Identifier then
+ if Entity (EDN1) = Ent then
+ Error_Msg_Sloc := Sloc (Stm1);
+ Error_Msg_N
+ ("?accept duplicates one on line#", Stm);
+ exit;
+ end if;
+ end if;
+ end;
+ end if;
+
+ Next (Alt1);
+ end loop;
+ end if;
+ end;
+ end if;
+
+ Next (Alt);
+ end loop;
+
+ Check_Restriction (Max_Select_Alternatives, Alt_Count, N);
+ Check_Potentially_Blocking_Operation (N);
+
+ if Terminate_Present and Delay_Present then
+ Error_Msg_N ("at most one of terminate or delay alternative", N);
+
+ elsif not Accept_Present then
+ Error_Msg_N
+ ("select must contain at least one accept alternative", N);
+ end if;
+
+ if Present (Else_Statements (N)) then
+ if Terminate_Present or Delay_Present then
+ Error_Msg_N ("else part not allowed with other alternatives", N);
+ end if;
+
+ Analyze_Statements (Else_Statements (N));
+ end if;
+ end Analyze_Selective_Accept;
+
+ ------------------------------
+ -- Analyze_Single_Protected --
+ ------------------------------
+
+ procedure Analyze_Single_Protected (N : Node_Id) is
+ Loc : constant Source_Ptr := Sloc (N);
+ Id : constant Node_Id := Defining_Identifier (N);
+ T : Entity_Id;
+ T_Decl : Node_Id;
+ O_Decl : Node_Id;
+ O_Name : constant Entity_Id := New_Copy (Id);
+
+ begin
+ Generate_Definition (Id);
+ Tasking_Used := True;
+
+ -- The node is rewritten as a protected type declaration,
+ -- in exact analogy with what is done with single tasks.
+
+ T :=
+ Make_Defining_Identifier (Sloc (Id),
+ New_External_Name (Chars (Id), 'T'));
+
+ T_Decl :=
+ Make_Protected_Type_Declaration (Loc,
+ Defining_Identifier => T,
+ Protected_Definition => Relocate_Node (Protected_Definition (N)));
+
+ O_Decl :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => O_Name,
+ Object_Definition => Make_Identifier (Loc, Chars (T)));
+
+ Rewrite (N, T_Decl);
+ Insert_After (N, O_Decl);
+ Mark_Rewrite_Insertion (O_Decl);
+
+ -- Enter names of type and object before analysis, because the name
+ -- of the object may be used in its own body.
+
+ Enter_Name (T);
+ Set_Ekind (T, E_Protected_Type);
+ Set_Etype (T, T);
+
+ Enter_Name (O_Name);
+ Set_Ekind (O_Name, E_Variable);
+ Set_Etype (O_Name, T);
+
+ -- Instead of calling Analyze on the new node, call directly
+ -- the proper analysis procedure. Otherwise the node would be
+ -- expanded twice, with disastrous result.
+
+ Analyze_Protected_Type (N);
+
+ end Analyze_Single_Protected;
+
+ -------------------------
+ -- Analyze_Single_Task --
+ -------------------------
+
+ procedure Analyze_Single_Task (N : Node_Id) is
+ Loc : constant Source_Ptr := Sloc (N);
+ Id : constant Node_Id := Defining_Identifier (N);
+ T : Entity_Id;
+ T_Decl : Node_Id;
+ O_Decl : Node_Id;
+ O_Name : constant Entity_Id := New_Copy (Id);
+
+ begin
+ Generate_Definition (Id);
+ Tasking_Used := True;
+
+ -- The node is rewritten as a task type declaration, followed
+ -- by an object declaration of that anonymous task type.
+
+ T :=
+ Make_Defining_Identifier (Sloc (Id),
+ New_External_Name (Chars (Id), Suffix => "TK"));
+
+ T_Decl :=
+ Make_Task_Type_Declaration (Loc,
+ Defining_Identifier => T,
+ Task_Definition => Relocate_Node (Task_Definition (N)));
+
+ O_Decl :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => O_Name,
+ Object_Definition => Make_Identifier (Loc, Chars (T)));
+
+ Rewrite (N, T_Decl);
+ Insert_After (N, O_Decl);
+ Mark_Rewrite_Insertion (O_Decl);
+
+ -- Enter names of type and object before analysis, because the name
+ -- of the object may be used in its own body.
+
+ Enter_Name (T);
+ Set_Ekind (T, E_Task_Type);
+ Set_Etype (T, T);
+
+ Enter_Name (O_Name);
+ Set_Ekind (O_Name, E_Variable);
+ Set_Etype (O_Name, T);
+
+ -- Instead of calling Analyze on the new node, call directly
+ -- the proper analysis procedure. Otherwise the node would be
+ -- expanded twice, with disastrous result.
+
+ Analyze_Task_Type (N);
+
+ end Analyze_Single_Task;
+
+ -----------------------
+ -- Analyze_Task_Body --
+ -----------------------
+
+ procedure Analyze_Task_Body (N : Node_Id) is
+ Body_Id : constant Entity_Id := Defining_Identifier (N);
+ Spec_Id : Entity_Id;
+ Last_E : Entity_Id;
+
+ begin
+ Tasking_Used := True;
+ Set_Ekind (Body_Id, E_Task_Body);
+ Set_Scope (Body_Id, Current_Scope);
+ Spec_Id := Find_Concurrent_Spec (Body_Id);
+
+ -- The spec is either a task type declaration, or a single task
+ -- declaration for which we have created an anonymous type.
+
+ if Present (Spec_Id)
+ and then Ekind (Spec_Id) = E_Task_Type
+ then
+ null;
+
+ elsif Present (Spec_Id)
+ and then Ekind (Etype (Spec_Id)) = E_Task_Type
+ and then not Comes_From_Source (Etype (Spec_Id))
+ then
+ null;
+
+ else
+ Error_Msg_N ("missing specification for task body", Body_Id);
+ return;
+ end if;
+
+ Generate_Reference (Spec_Id, Body_Id, 'b');
+ Style.Check_Identifier (Body_Id, Spec_Id);
+
+ -- Deal with case of body of single task (anonymous type was created)
+
+ if Ekind (Spec_Id) = E_Variable then
+ Spec_Id := Etype (Spec_Id);
+ end if;
+
+ New_Scope (Spec_Id);
+ Set_Corresponding_Spec (N, Spec_Id);
+ Set_Corresponding_Body (Parent (Spec_Id), Body_Id);
+ Set_Has_Completion (Spec_Id);
+ Install_Declarations (Spec_Id);
+ Last_E := Last_Entity (Spec_Id);
+
+ Analyze_Declarations (Declarations (N));
+
+ -- For visibility purposes, all entities in the body are private.
+ -- Set First_Private_Entity accordingly, if there was no private
+ -- part in the protected declaration.
+
+ if No (First_Private_Entity (Spec_Id)) then
+ if Present (Last_E) then
+ Set_First_Private_Entity (Spec_Id, Next_Entity (Last_E));
+ else
+ Set_First_Private_Entity (Spec_Id, First_Entity (Spec_Id));
+ end if;
+ end if;
+
+ Analyze (Handled_Statement_Sequence (N));
+ Check_Completion (Body_Id);
+ Check_References (Body_Id);
+
+ -- Check for entries with no corresponding accept
+
+ declare
+ Ent : Entity_Id;
+
+ begin
+ Ent := First_Entity (Spec_Id);
+
+ while Present (Ent) loop
+ if Is_Entry (Ent)
+ and then not Entry_Accepted (Ent)
+ and then Comes_From_Source (Ent)
+ then
+ Error_Msg_NE ("no accept for entry &?", N, Ent);
+ end if;
+
+ Next_Entity (Ent);
+ end loop;
+ end;
+
+ Process_End_Label (Handled_Statement_Sequence (N), 't');
+ End_Scope;
+ end Analyze_Task_Body;
+
+ -----------------------------
+ -- Analyze_Task_Definition --
+ -----------------------------
+
+ procedure Analyze_Task_Definition (N : Node_Id) is
+ L : Entity_Id;
+
+ begin
+ Tasking_Used := True;
+
+ if Present (Visible_Declarations (N)) then
+ Analyze_Declarations (Visible_Declarations (N));
+ end if;
+
+ if Present (Private_Declarations (N)) then
+ L := Last_Entity (Current_Scope);
+ Analyze_Declarations (Private_Declarations (N));
+
+ if Present (L) then
+ Set_First_Private_Entity
+ (Current_Scope, Next_Entity (L));
+ else
+ Set_First_Private_Entity
+ (Current_Scope, First_Entity (Current_Scope));
+ end if;
+ end if;
+
+ Check_Max_Entries (N, Max_Task_Entries);
+ Process_End_Label (N, 'e');
+ end Analyze_Task_Definition;
+
+ -----------------------
+ -- Analyze_Task_Type --
+ -----------------------
+
+ procedure Analyze_Task_Type (N : Node_Id) is
+ T : Entity_Id;
+ Def_Id : constant Entity_Id := Defining_Identifier (N);
+
+ begin
+ Tasking_Used := True;
+ Check_Restriction (Max_Tasks, N);
+ T := Find_Type_Name (N);
+ Generate_Definition (T);
+
+ if Ekind (T) = E_Incomplete_Type then
+ T := Full_View (T);
+ end if;
+
+ Set_Ekind (T, E_Task_Type);
+ Set_Is_First_Subtype (T, True);
+ Set_Has_Task (T, True);
+ Init_Size_Align (T);
+ Set_Etype (T, T);
+ Set_Has_Delayed_Freeze (T, True);
+ Set_Girder_Constraint (T, No_Elist);
+ New_Scope (T);
+
+ if Present (Discriminant_Specifications (N)) then
+ if Ada_83 and then Comes_From_Source (N) then
+ Error_Msg_N ("(Ada 83) task discriminant not allowed!", N);
+ end if;
+
+ if Has_Discriminants (T) then
+
+ -- Install discriminants. Also, verify conformance of
+ -- discriminants of previous and current view. ???
+
+ Install_Declarations (T);
+ else
+ Process_Discriminants (N);
+ end if;
+ end if;
+
+ if Present (Task_Definition (N)) then
+ Analyze_Task_Definition (Task_Definition (N));
+ end if;
+
+ if not Is_Library_Level_Entity (T) then
+ Check_Restriction (No_Task_Hierarchy, N);
+ end if;
+
+ End_Scope;
+
+ if T /= Def_Id
+ and then Is_Private_Type (Def_Id)
+ and then Has_Discriminants (Def_Id)
+ and then Expander_Active
+ then
+ Exp_Ch9.Expand_N_Task_Type_Declaration (N);
+ Process_Full_View (N, T, Def_Id);
+ end if;
+ end Analyze_Task_Type;
+
+ -----------------------------------
+ -- Analyze_Terminate_Alternative --
+ -----------------------------------
+
+ procedure Analyze_Terminate_Alternative (N : Node_Id) is
+ begin
+ Tasking_Used := True;
+
+ if Present (Pragmas_Before (N)) then
+ Analyze_List (Pragmas_Before (N));
+ end if;
+
+ if Present (Condition (N)) then
+ Analyze_And_Resolve (Condition (N), Any_Boolean);
+ end if;
+ end Analyze_Terminate_Alternative;
+
+ ------------------------------
+ -- Analyze_Timed_Entry_Call --
+ ------------------------------
+
+ procedure Analyze_Timed_Entry_Call (N : Node_Id) is
+ begin
+ Check_Restriction (No_Select_Statements, N);
+ Tasking_Used := True;
+ Analyze (Entry_Call_Alternative (N));
+ Analyze (Delay_Alternative (N));
+ end Analyze_Timed_Entry_Call;
+
+ ------------------------------------
+ -- Analyze_Triggering_Alternative --
+ ------------------------------------
+
+ procedure Analyze_Triggering_Alternative (N : Node_Id) is
+ Trigger : Node_Id := Triggering_Statement (N);
+ begin
+ Tasking_Used := True;
+
+ if Present (Pragmas_Before (N)) then
+ Analyze_List (Pragmas_Before (N));
+ end if;
+
+ Analyze (Trigger);
+ if Comes_From_Source (Trigger)
+ and then Nkind (Trigger) /= N_Delay_Until_Statement
+ and then Nkind (Trigger) /= N_Delay_Relative_Statement
+ and then Nkind (Trigger) /= N_Entry_Call_Statement
+ then
+ Error_Msg_N
+ ("triggering statement must be delay or entry call", Trigger);
+ end if;
+
+ if Is_Non_Empty_List (Statements (N)) then
+ Analyze_Statements (Statements (N));
+ end if;
+ end Analyze_Triggering_Alternative;
+
+ -----------------------
+ -- Check_Max_Entries --
+ -----------------------
+
+ procedure Check_Max_Entries (Def : Node_Id; R : Restriction_Parameter_Id) is
+ Ecount : Uint;
+
+ procedure Count (L : List_Id);
+ -- Count entries in given declaration list
+
+ procedure Count (L : List_Id) is
+ D : Node_Id;
+
+ begin
+ if No (L) then
+ return;
+ end if;
+
+ D := First (L);
+ while Present (D) loop
+ if Nkind (D) = N_Entry_Declaration then
+ declare
+ DSD : constant Node_Id :=
+ Discrete_Subtype_Definition (D);
+
+ begin
+ if No (DSD) then
+ Ecount := Ecount + 1;
+
+ elsif Is_OK_Static_Subtype (Etype (DSD)) then
+ declare
+ Lo : constant Uint :=
+ Expr_Value
+ (Type_Low_Bound (Etype (DSD)));
+ Hi : constant Uint :=
+ Expr_Value
+ (Type_High_Bound (Etype (DSD)));
+
+ begin
+ if Hi >= Lo then
+ Ecount := Ecount + Hi - Lo + 1;
+ end if;
+ end;
+
+ else
+ Error_Msg_N
+ ("static subtype required by Restriction pragma", DSD);
+ end if;
+ end;
+ end if;
+
+ Next (D);
+ end loop;
+ end Count;
+
+ -- Start of processing for Check_Max_Entries
+
+ begin
+ if Restriction_Parameters (R) >= 0 then
+ Ecount := Uint_0;
+ Count (Visible_Declarations (Def));
+ Count (Private_Declarations (Def));
+ Check_Restriction (R, Ecount, Def);
+ end if;
+ end Check_Max_Entries;
+
+ --------------------------
+ -- Find_Concurrent_Spec --
+ --------------------------
+
+ function Find_Concurrent_Spec (Body_Id : Entity_Id) return Entity_Id is
+ Spec_Id : Entity_Id := Current_Entity_In_Scope (Body_Id);
+
+ begin
+ -- The type may have been given by an incomplete type declaration.
+ -- Find full view now.
+
+ if Present (Spec_Id) and then Ekind (Spec_Id) = E_Incomplete_Type then
+ Spec_Id := Full_View (Spec_Id);
+ end if;
+
+ return Spec_Id;
+ end Find_Concurrent_Spec;
+
+ --------------------------
+ -- Install_Declarations --
+ --------------------------
+
+ procedure Install_Declarations (Spec : Entity_Id) is
+ E : Entity_Id;
+ Prev : Entity_Id;
+
+ begin
+ E := First_Entity (Spec);
+
+ while Present (E) loop
+ Prev := Current_Entity (E);
+ Set_Current_Entity (E);
+ Set_Is_Immediately_Visible (E);
+ Set_Homonym (E, Prev);
+ Next_Entity (E);
+ end loop;
+ end Install_Declarations;
+
+end Sem_Ch9;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S E M _ C H 9 --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.8 $
+-- --
+-- 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). --
+-- --
+------------------------------------------------------------------------------
+
+with Types; use Types;
+
+package Sem_Ch9 is
+ procedure Analyze_Abort_Statement (N : Node_Id);
+ procedure Analyze_Accept_Alternative (N : Node_Id);
+ procedure Analyze_Accept_Statement (N : Node_Id);
+ procedure Analyze_Asynchronous_Select (N : Node_Id);
+ procedure Analyze_Conditional_Entry_Call (N : Node_Id);
+ procedure Analyze_Delay_Alternative (N : Node_Id);
+ procedure Analyze_Delay_Relative (N : Node_Id);
+ procedure Analyze_Delay_Until (N : Node_Id);
+ procedure Analyze_Entry_Body (N : Node_Id);
+ procedure Analyze_Entry_Body_Formal_Part (N : Node_Id);
+ procedure Analyze_Entry_Call_Alternative (N : Node_Id);
+ procedure Analyze_Entry_Declaration (N : Node_Id);
+ procedure Analyze_Entry_Index_Specification (N : Node_Id);
+ procedure Analyze_Protected_Body (N : Node_Id);
+ procedure Analyze_Protected_Definition (N : Node_Id);
+ procedure Analyze_Protected_Type (N : Node_Id);
+ procedure Analyze_Requeue (N : Node_Id);
+ procedure Analyze_Selective_Accept (N : Node_Id);
+ procedure Analyze_Single_Protected (N : Node_Id);
+ procedure Analyze_Single_Task (N : Node_Id);
+ procedure Analyze_Task_Body (N : Node_Id);
+ procedure Analyze_Task_Definition (N : Node_Id);
+ procedure Analyze_Task_Type (N : Node_Id);
+ procedure Analyze_Terminate_Alternative (N : Node_Id);
+ procedure Analyze_Timed_Entry_Call (N : Node_Id);
+ procedure Analyze_Triggering_Alternative (N : Node_Id);
+end Sem_Ch9;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S E M _ D I S P --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.114 $
+-- --
+-- 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). --
+-- --
+------------------------------------------------------------------------------
+
+with Atree; use Atree;
+with Debug; use Debug;
+with Elists; use Elists;
+with Einfo; use Einfo;
+with Exp_Disp; use Exp_Disp;
+with Errout; use Errout;
+with Hostparm; use Hostparm;
+with Nlists; use Nlists;
+with Output; use Output;
+with Sem_Ch6; use Sem_Ch6;
+with Sem_Eval; use Sem_Eval;
+with Sem_Util; use Sem_Util;
+with Sinfo; use Sinfo;
+with Uintp; use Uintp;
+
+package body Sem_Disp is
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ procedure Override_Dispatching_Operation
+ (Tagged_Type : Entity_Id;
+ Prev_Op : Entity_Id;
+ New_Op : Entity_Id);
+ -- Replace an implicit dispatching operation with an explicit one.
+ -- Prev_Op is an inherited primitive operation which is overridden
+ -- by the explicit declaration of New_Op.
+
+ procedure Add_Dispatching_Operation
+ (Tagged_Type : Entity_Id;
+ New_Op : Entity_Id);
+ -- Add New_Op in the list of primitive operations of Tagged_Type
+
+ function Check_Controlling_Type
+ (T : Entity_Id;
+ Subp : Entity_Id)
+ return Entity_Id;
+ -- T is the type of a formal parameter of subp. Returns the tagged
+ -- if the parameter can be a controlling argument, empty otherwise
+
+ --------------------------------
+ -- Add_Dispatching_Operation --
+ --------------------------------
+
+ procedure Add_Dispatching_Operation
+ (Tagged_Type : Entity_Id;
+ New_Op : Entity_Id)
+ is
+ List : constant Elist_Id := Primitive_Operations (Tagged_Type);
+
+ begin
+ Append_Elmt (New_Op, List);
+ end Add_Dispatching_Operation;
+
+ -------------------------------
+ -- Check_Controlling_Formals --
+ -------------------------------
+
+ procedure Check_Controlling_Formals
+ (Typ : Entity_Id;
+ Subp : Entity_Id)
+ is
+ Formal : Entity_Id;
+ Ctrl_Type : Entity_Id;
+ Remote : constant Boolean :=
+ Is_Remote_Types (Current_Scope)
+ and then Comes_From_Source (Subp)
+ and then Scope (Typ) = Current_Scope;
+
+ begin
+ Formal := First_Formal (Subp);
+
+ while Present (Formal) loop
+ Ctrl_Type := Check_Controlling_Type (Etype (Formal), Subp);
+
+ if Present (Ctrl_Type) then
+ if Ctrl_Type = Typ then
+ Set_Is_Controlling_Formal (Formal);
+
+ -- Check that the parameter's nominal subtype statically
+ -- matches the first subtype.
+
+ if Ekind (Etype (Formal)) = E_Anonymous_Access_Type then
+ if not Subtypes_Statically_Match
+ (Typ, Designated_Type (Etype (Formal)))
+ then
+ Error_Msg_N
+ ("parameter subtype does not match controlling type",
+ Formal);
+ end if;
+
+ elsif not Subtypes_Statically_Match (Typ, Etype (Formal)) then
+ Error_Msg_N
+ ("parameter subtype does not match controlling type",
+ Formal);
+ end if;
+
+ if Present (Default_Value (Formal)) then
+ if Ekind (Etype (Formal)) = E_Anonymous_Access_Type then
+ Error_Msg_N
+ ("default not allowed for controlling access parameter",
+ Default_Value (Formal));
+
+ elsif not Is_Tag_Indeterminate (Default_Value (Formal)) then
+ Error_Msg_N
+ ("default expression must be a tag indeterminate" &
+ " function call", Default_Value (Formal));
+ end if;
+ end if;
+
+ elsif Comes_From_Source (Subp) then
+ Error_Msg_N
+ ("operation can be dispatching in only one type", Subp);
+ end if;
+
+ -- Verify that the restriction in E.2.2 (1) is obeyed.
+
+ elsif Remote
+ and then Ekind (Etype (Formal)) = E_Anonymous_Access_Type
+ then
+ Error_Msg_N
+ ("Access parameter of a remote subprogram must be controlling",
+ Formal);
+ end if;
+
+ Next_Formal (Formal);
+ end loop;
+
+ if Present (Etype (Subp)) then
+ Ctrl_Type := Check_Controlling_Type (Etype (Subp), Subp);
+
+ if Present (Ctrl_Type) then
+ if Ctrl_Type = Typ then
+ Set_Has_Controlling_Result (Subp);
+
+ -- Check that the result subtype statically matches
+ -- the first subtype.
+
+ if not Subtypes_Statically_Match (Typ, Etype (Subp)) then
+ Error_Msg_N
+ ("result subtype does not match controlling type", Subp);
+ end if;
+
+ elsif Comes_From_Source (Subp) then
+ Error_Msg_N
+ ("operation can be dispatching in only one type", Subp);
+ end if;
+
+ -- The following check is clearly required, although the RM says
+ -- nothing about return types. If the return type is a limited
+ -- class-wide type declared in the current scope, there is no way
+ -- to declare stream procedures for it, so the return cannot be
+ -- marshalled.
+
+ elsif Remote
+ and then Is_Limited_Type (Typ)
+ and then Etype (Subp) = Class_Wide_Type (Typ)
+ then
+ Error_Msg_N ("return type has no stream attributes", Subp);
+ end if;
+ end if;
+ end Check_Controlling_Formals;
+
+ ----------------------------
+ -- Check_Controlling_Type --
+ ----------------------------
+
+ function Check_Controlling_Type
+ (T : Entity_Id;
+ Subp : Entity_Id)
+ return Entity_Id
+ is
+ Tagged_Type : Entity_Id := Empty;
+
+ begin
+ if Is_Tagged_Type (T) then
+ if Is_First_Subtype (T) then
+ Tagged_Type := T;
+ else
+ Tagged_Type := Base_Type (T);
+ end if;
+
+ elsif Ekind (T) = E_Anonymous_Access_Type
+ and then Is_Tagged_Type (Designated_Type (T))
+ and then Ekind (Designated_Type (T)) /= E_Incomplete_Type
+ then
+ if Is_First_Subtype (Designated_Type (T)) then
+ Tagged_Type := Designated_Type (T);
+ else
+ Tagged_Type := Base_Type (Designated_Type (T));
+ end if;
+ end if;
+
+ if No (Tagged_Type)
+ or else Is_Class_Wide_Type (Tagged_Type)
+ then
+ return Empty;
+
+ -- The dispatching type and the primitive operation must be defined
+ -- in the same scope except for internal operations.
+
+ elsif (Scope (Subp) = Scope (Tagged_Type)
+ or else Is_Internal (Subp))
+ and then
+ (not Is_Generic_Type (Tagged_Type)
+ or else not Comes_From_Source (Subp))
+ then
+ return Tagged_Type;
+
+ else
+ return Empty;
+ end if;
+ end Check_Controlling_Type;
+
+ ----------------------------
+ -- Check_Dispatching_Call --
+ ----------------------------
+
+ procedure Check_Dispatching_Call (N : Node_Id) is
+ Actual : Node_Id;
+ Control : Node_Id := Empty;
+ Func : Entity_Id;
+
+ procedure Check_Dispatching_Context;
+ -- If the call is tag-indeterminate and the entity being called is
+ -- abstract, verify that the context is a call that will eventually
+ -- provide a tag for dispatching, or has provided one already.
+
+ -------------------------------
+ -- Check_Dispatching_Context --
+ -------------------------------
+
+ procedure Check_Dispatching_Context is
+ Func : constant Entity_Id := Entity (Name (N));
+ Par : Node_Id;
+
+ begin
+ if Is_Abstract (Func)
+ and then No (Controlling_Argument (N))
+ then
+ Par := Parent (N);
+
+ while Present (Par) loop
+
+ if Nkind (Par) = N_Function_Call or else
+ Nkind (Par) = N_Procedure_Call_Statement or else
+ Nkind (Par) = N_Assignment_Statement or else
+ Nkind (Par) = N_Op_Eq or else
+ Nkind (Par) = N_Op_Ne
+ then
+ return;
+
+ elsif Nkind (Par) = N_Qualified_Expression
+ or else Nkind (Par) = N_Unchecked_Type_Conversion
+ then
+ Par := Parent (Par);
+
+ else
+ Error_Msg_N
+ ("call to abstract function must be dispatching", N);
+ return;
+ end if;
+ end loop;
+ end if;
+ end Check_Dispatching_Context;
+
+ -- Start of processing for Check_Dispatching_Call
+
+ begin
+ -- Find a controlling argument, if any
+
+ if Present (Parameter_Associations (N)) then
+ Actual := First_Actual (N);
+
+ while Present (Actual) loop
+ Control := Find_Controlling_Arg (Actual);
+ exit when Present (Control);
+ Next_Actual (Actual);
+ end loop;
+
+ if Present (Control) then
+
+ -- Verify that no controlling arguments are statically tagged
+
+ if Debug_Flag_E then
+ Write_Str ("Found Dispatching call");
+ Write_Int (Int (N));
+ Write_Eol;
+ end if;
+
+ Actual := First_Actual (N);
+
+ while Present (Actual) loop
+ if Actual /= Control then
+
+ if not Is_Controlling_Actual (Actual) then
+ null; -- can be anything
+
+ elsif (Is_Dynamically_Tagged (Actual)) then
+ null; -- valid parameter
+
+ elsif Is_Tag_Indeterminate (Actual) then
+
+ -- The tag is inherited from the enclosing call (the
+ -- node we are currently analyzing). Explicitly expand
+ -- the actual, since the previous call to Expand
+ -- (from Resolve_Call) had no way of knowing about
+ -- the required dispatching.
+
+ Propagate_Tag (Control, Actual);
+
+ else
+ Error_Msg_N
+ ("controlling argument is not dynamically tagged",
+ Actual);
+ return;
+ end if;
+ end if;
+
+ Next_Actual (Actual);
+ end loop;
+
+ -- Mark call as a dispatching call
+
+ Set_Controlling_Argument (N, Control);
+
+ else
+ -- The call is not dispatching, check that there isn't any
+ -- tag indeterminate abstract call left
+
+ Actual := First_Actual (N);
+
+ while Present (Actual) loop
+ if Is_Tag_Indeterminate (Actual) then
+
+ -- Function call case
+
+ if Nkind (Original_Node (Actual)) = N_Function_Call then
+ Func := Entity (Name (Original_Node (Actual)));
+
+ -- Only other possibility is a qualified expression whose
+ -- consituent expression is itself a call.
+
+ else
+ Func :=
+ Entity (Name
+ (Original_Node
+ (Expression (Original_Node (Actual)))));
+ end if;
+
+ if Is_Abstract (Func) then
+ Error_Msg_N (
+ "call to abstract function must be dispatching", N);
+ end if;
+ end if;
+
+ Next_Actual (Actual);
+ end loop;
+
+ Check_Dispatching_Context;
+ end if;
+
+ else
+ -- If dispatching on result, the enclosing call, if any, will
+ -- determine the controlling argument. Otherwise this is the
+ -- primitive operation of the root type.
+
+ Check_Dispatching_Context;
+ end if;
+ end Check_Dispatching_Call;
+
+ ---------------------------------
+ -- Check_Dispatching_Operation --
+ ---------------------------------
+
+ procedure Check_Dispatching_Operation (Subp, Old_Subp : Entity_Id) is
+ Tagged_Seen : Entity_Id;
+ Has_Dispatching_Parent : Boolean := False;
+ Body_Is_Last_Primitive : Boolean := False;
+
+ begin
+ if Ekind (Subp) /= E_Procedure and then Ekind (Subp) /= E_Function then
+ return;
+ end if;
+
+ Set_Is_Dispatching_Operation (Subp, False);
+ Tagged_Seen := Find_Dispatching_Type (Subp);
+
+ -- If Subp is derived from a dispatching operation then it should
+ -- always be treated as dispatching. In this case various checks
+ -- below will be bypassed. Makes sure that late declarations for
+ -- inherited private subprograms are treated as dispatching, even
+ -- if the associated tagged type is already frozen.
+
+ Has_Dispatching_Parent := Present (Alias (Subp))
+ and then Is_Dispatching_Operation (Alias (Subp));
+
+ if No (Tagged_Seen) then
+ return;
+
+ -- The subprograms build internally after the freezing point (such as
+ -- the Init procedure) are not primitives
+
+ elsif Is_Frozen (Tagged_Seen)
+ and then not Comes_From_Source (Subp)
+ and then not Has_Dispatching_Parent
+ then
+ return;
+
+ -- The operation may be a child unit, whose scope is the defining
+ -- package, but which is not a primitive operation of the type.
+
+ elsif Is_Child_Unit (Subp) then
+ return;
+
+ -- If the subprogram is not defined in a package spec, the only case
+ -- where it can be a dispatching op is when it overrides an operation
+ -- before the freezing point of the type.
+
+ elsif ((not Is_Package (Scope (Subp)))
+ or else In_Package_Body (Scope (Subp)))
+ and then not Has_Dispatching_Parent
+ then
+ if not Comes_From_Source (Subp)
+ or else (Present (Old_Subp) and then not Is_Frozen (Tagged_Seen))
+ then
+ null;
+
+ -- If the type is already frozen, the overriding is not allowed
+ -- except when Old_Subp is not a dispatching operation (which
+ -- can occur when Old_Subp was inherited by an untagged type).
+ -- However, a body with no previous spec freezes the type "after"
+ -- its declaration, and therefore is a legal overriding (unless
+ -- the type has already been frozen). Only the first such body
+ -- is legal.
+
+ elsif Present (Old_Subp)
+ and then Is_Dispatching_Operation (Old_Subp)
+ then
+ if Nkind (Unit_Declaration_Node (Subp)) = N_Subprogram_Body
+ and then Comes_From_Source (Subp)
+ then
+ declare
+ Subp_Body : constant Node_Id := Unit_Declaration_Node (Subp);
+ Decl_Item : Node_Id := Next (Parent (Tagged_Seen));
+
+ begin
+ -- ??? The checks here for whether the type has been
+ -- frozen prior to the new body are not complete. It's
+ -- not simple to check frozenness at this point since
+ -- the body has already caused the type to be prematurely
+ -- frozen in Analyze_Declarations, but we're forced to
+ -- recheck this here because of the odd rule interpretation
+ -- that allows the overriding if the type wasn't frozen
+ -- prior to the body. The freezing action should probably
+ -- be delayed until after the spec is seen, but that's
+ -- a tricky change to the delicate freezing code.
+
+ -- Look at each declaration following the type up
+ -- until the new subprogram body. If any of the
+ -- declarations is a body then the type has been
+ -- frozen already so the overriding primitive is
+ -- illegal.
+
+ while Present (Decl_Item)
+ and then (Decl_Item /= Subp_Body)
+ loop
+ if Comes_From_Source (Decl_Item)
+ and then (Nkind (Decl_Item) in N_Proper_Body
+ or else Nkind (Decl_Item) in N_Body_Stub)
+ then
+ Error_Msg_N ("overriding of& is too late!", Subp);
+ Error_Msg_N
+ ("\spec should appear immediately after the type!",
+ Subp);
+ exit;
+ end if;
+
+ Next (Decl_Item);
+ end loop;
+
+ -- If the subprogram doesn't follow in the list of
+ -- declarations including the type then the type
+ -- has definitely been frozen already and the body
+ -- is illegal.
+
+ if not Present (Decl_Item) then
+ Error_Msg_N ("overriding of& is too late!", Subp);
+ Error_Msg_N
+ ("\spec should appear immediately after the type!",
+ Subp);
+
+ elsif Is_Frozen (Subp) then
+
+ -- the subprogram body declares a primitive operation.
+ -- if the subprogram is already frozen, we must update
+ -- its dispatching information explicitly here. The
+ -- information is taken from the overridden subprogram.
+
+ Body_Is_Last_Primitive := True;
+
+ if Present (DTC_Entity (Old_Subp)) then
+ Set_DTC_Entity (Subp, DTC_Entity (Old_Subp));
+ Set_DT_Position (Subp, DT_Position (Old_Subp));
+ Insert_After (
+ Subp_Body, Fill_DT_Entry (Sloc (Subp_Body), Subp));
+ end if;
+ end if;
+ end;
+
+ else
+ Error_Msg_N ("overriding of& is too late!", Subp);
+ Error_Msg_N
+ ("\subprogram spec should appear immediately after the type!",
+ Subp);
+ end if;
+
+ -- If the type is not frozen yet and we are not in the overridding
+ -- case it looks suspiciously like an attempt to define a primitive
+ -- operation.
+
+ elsif not Is_Frozen (Tagged_Seen) then
+ Error_Msg_N
+ ("?not dispatching (must be defined in a package spec)", Subp);
+ return;
+
+ -- When the type is frozen, it is legitimate to define a new
+ -- non-primitive operation.
+
+ else
+ return;
+ end if;
+
+ -- Now, we are sure that the scope is a package spec. If the subprogram
+ -- is declared after the freezing point ot the type that's an error
+
+ elsif Is_Frozen (Tagged_Seen) and then not Has_Dispatching_Parent then
+ Error_Msg_N ("this primitive operation is declared too late", Subp);
+ Error_Msg_NE
+ ("?no primitive operations for& after this line",
+ Freeze_Node (Tagged_Seen),
+ Tagged_Seen);
+ return;
+ end if;
+
+ Check_Controlling_Formals (Tagged_Seen, Subp);
+
+ -- Now it should be a correct primitive operation, put it in the list
+
+ if Present (Old_Subp) then
+ Check_Subtype_Conformant (Subp, Old_Subp);
+ Override_Dispatching_Operation (Tagged_Seen, Old_Subp, Subp);
+
+ else
+ Add_Dispatching_Operation (Tagged_Seen, Subp);
+ end if;
+
+ Set_Is_Dispatching_Operation (Subp, True);
+
+ if not Body_Is_Last_Primitive then
+ Set_DT_Position (Subp, No_Uint);
+ end if;
+
+ end Check_Dispatching_Operation;
+
+ ------------------------------------------
+ -- Check_Operation_From_Incomplete_Type --
+ ------------------------------------------
+
+ procedure Check_Operation_From_Incomplete_Type
+ (Subp : Entity_Id;
+ Typ : Entity_Id)
+ is
+ Full : constant Entity_Id := Full_View (Typ);
+ Parent_Typ : constant Entity_Id := Etype (Full);
+ Old_Prim : constant Elist_Id := Primitive_Operations (Parent_Typ);
+ New_Prim : constant Elist_Id := Primitive_Operations (Full);
+ Op1, Op2 : Elmt_Id;
+ Prev : Elmt_Id := No_Elmt;
+
+ function Derives_From (Proc : Entity_Id) return Boolean;
+ -- Check that Subp has the signature of an operation derived from Proc.
+ -- Subp has an access parameter that designates Typ.
+
+ ------------------
+ -- Derives_From --
+ ------------------
+
+ function Derives_From (Proc : Entity_Id) return Boolean is
+ F1, F2 : Entity_Id;
+
+ begin
+ if Chars (Proc) /= Chars (Subp) then
+ return False;
+ end if;
+
+ F1 := First_Formal (Proc);
+ F2 := First_Formal (Subp);
+
+ while Present (F1) and then Present (F2) loop
+
+ if Ekind (Etype (F1)) = E_Anonymous_Access_Type then
+
+ if Ekind (Etype (F2)) /= E_Anonymous_Access_Type then
+ return False;
+
+ elsif Designated_Type (Etype (F1)) = Parent_Typ
+ and then Designated_Type (Etype (F2)) /= Full
+ then
+ return False;
+ end if;
+
+ elsif Ekind (Etype (F2)) = E_Anonymous_Access_Type then
+ return False;
+
+ elsif Etype (F1) /= Etype (F2) then
+ return False;
+ end if;
+
+ Next_Formal (F1);
+ Next_Formal (F2);
+ end loop;
+
+ return No (F1) and then No (F2);
+ end Derives_From;
+
+ -- Start of processing for Check_Operation_From_Incomplete_Type
+
+ begin
+ -- The operation may override an inherited one, or may be a new one
+ -- altogether. The inherited operation will have been hidden by the
+ -- current one at the point of the type derivation, so it does not
+ -- appear in the list of primitive operations of the type. We have to
+ -- find the proper place of insertion in the list of primitive opera-
+ -- tions by iterating over the list for the parent type.
+
+ Op1 := First_Elmt (Old_Prim);
+ Op2 := First_Elmt (New_Prim);
+
+ while Present (Op1) and then Present (Op2) loop
+
+ if Derives_From (Node (Op1)) then
+
+ if No (Prev) then
+ Prepend_Elmt (Subp, New_Prim);
+ else
+ Insert_Elmt_After (Subp, Prev);
+ end if;
+
+ return;
+ end if;
+
+ Prev := Op2;
+ Next_Elmt (Op1);
+ Next_Elmt (Op2);
+ end loop;
+
+ -- Operation is a new primitive.
+
+ Append_Elmt (Subp, New_Prim);
+
+ end Check_Operation_From_Incomplete_Type;
+
+ ---------------------------------------
+ -- Check_Operation_From_Private_View --
+ ---------------------------------------
+
+ procedure Check_Operation_From_Private_View (Subp, Old_Subp : Entity_Id) is
+ Tagged_Type : Entity_Id;
+
+ begin
+ if Is_Dispatching_Operation (Alias (Subp)) then
+ Set_Scope (Subp, Current_Scope);
+ Tagged_Type := Find_Dispatching_Type (Subp);
+
+ if Present (Tagged_Type) and then Is_Tagged_Type (Tagged_Type) then
+ Append_Elmt (Old_Subp, Primitive_Operations (Tagged_Type));
+
+ -- If Old_Subp isn't already marked as dispatching then
+ -- this is the case of an operation of an untagged private
+ -- type fulfilled by a tagged type that overrides an
+ -- inherited dispatching operation, so we set the necessary
+ -- dispatching attributes here.
+
+ if not Is_Dispatching_Operation (Old_Subp) then
+ Check_Controlling_Formals (Tagged_Type, Old_Subp);
+ Set_Is_Dispatching_Operation (Old_Subp, True);
+ Set_DT_Position (Old_Subp, No_Uint);
+ end if;
+
+ -- If the old subprogram is an explicit renaming of some other
+ -- entity, it is not overridden by the inherited subprogram.
+ -- Otherwise, update its alias and other attributes.
+
+ if Present (Alias (Old_Subp))
+ and then Nkind (Unit_Declaration_Node (Old_Subp))
+ /= N_Subprogram_Renaming_Declaration
+ then
+ Set_Alias (Old_Subp, Alias (Subp));
+
+ -- The derived subprogram should inherit the abstractness
+ -- of the parent subprogram (except in the case of a function
+ -- returning the type). This sets the abstractness properly
+ -- for cases where a private extension may have inherited
+ -- an abstract operation, but the full type is derived from
+ -- a descendant type and inherits a nonabstract version.
+
+ if Etype (Subp) /= Tagged_Type then
+ Set_Is_Abstract (Old_Subp, Is_Abstract (Alias (Subp)));
+ end if;
+ end if;
+ end if;
+ end if;
+ end Check_Operation_From_Private_View;
+
+ --------------------------
+ -- Find_Controlling_Arg --
+ --------------------------
+
+ function Find_Controlling_Arg (N : Node_Id) return Node_Id is
+ Orig_Node : constant Node_Id := Original_Node (N);
+ Typ : Entity_Id;
+
+ begin
+ if Nkind (Orig_Node) = N_Qualified_Expression then
+ return Find_Controlling_Arg (Expression (Orig_Node));
+ end if;
+
+ -- Dispatching on result case
+
+ if Nkind (Orig_Node) = N_Function_Call
+ and then Present (Controlling_Argument (Orig_Node))
+ and then Has_Controlling_Result (Entity (Name (Orig_Node)))
+ then
+ return Controlling_Argument (Orig_Node);
+
+ -- Normal case
+
+ elsif Is_Controlling_Actual (N) then
+ Typ := Etype (N);
+
+ if Is_Access_Type (Typ) then
+ -- In the case of an Access attribute, use the type of
+ -- the prefix, since in the case of an actual for an
+ -- access parameter, the attribute's type may be of a
+ -- specific designated type, even though the prefix
+ -- type is class-wide.
+
+ if Nkind (N) = N_Attribute_Reference then
+ Typ := Etype (Prefix (N));
+ else
+ Typ := Designated_Type (Typ);
+ end if;
+ end if;
+
+ if Is_Class_Wide_Type (Typ) then
+ return N;
+ end if;
+ end if;
+
+ return Empty;
+ end Find_Controlling_Arg;
+
+ ---------------------------
+ -- Find_Dispatching_Type --
+ ---------------------------
+
+ function Find_Dispatching_Type (Subp : Entity_Id) return Entity_Id is
+ Formal : Entity_Id;
+ Ctrl_Type : Entity_Id;
+
+ begin
+ if Present (DTC_Entity (Subp)) then
+ return Scope (DTC_Entity (Subp));
+
+ else
+ Formal := First_Formal (Subp);
+ while Present (Formal) loop
+ Ctrl_Type := Check_Controlling_Type (Etype (Formal), Subp);
+
+ if Present (Ctrl_Type) then
+ return Ctrl_Type;
+ end if;
+
+ Next_Formal (Formal);
+ end loop;
+
+ -- The subprogram may also be dispatching on result
+
+ if Present (Etype (Subp)) then
+ Ctrl_Type := Check_Controlling_Type (Etype (Subp), Subp);
+
+ if Present (Ctrl_Type) then
+ return Ctrl_Type;
+ end if;
+ end if;
+ end if;
+
+ return Empty;
+ end Find_Dispatching_Type;
+
+ ---------------------------
+ -- Is_Dynamically_Tagged --
+ ---------------------------
+
+ function Is_Dynamically_Tagged (N : Node_Id) return Boolean is
+ begin
+ return Find_Controlling_Arg (N) /= Empty;
+ end Is_Dynamically_Tagged;
+
+ --------------------------
+ -- Is_Tag_Indeterminate --
+ --------------------------
+
+ function Is_Tag_Indeterminate (N : Node_Id) return Boolean is
+ Nam : Entity_Id;
+ Actual : Node_Id;
+ Orig_Node : constant Node_Id := Original_Node (N);
+
+ begin
+ if Nkind (Orig_Node) = N_Function_Call
+ and then Is_Entity_Name (Name (Orig_Node))
+ then
+ Nam := Entity (Name (Orig_Node));
+
+ if not Has_Controlling_Result (Nam) then
+ return False;
+
+ -- If there are no actuals, the call is tag-indeterminate
+
+ elsif No (Parameter_Associations (Orig_Node)) then
+ return True;
+
+ else
+ Actual := First_Actual (Orig_Node);
+
+ while Present (Actual) loop
+ if Is_Controlling_Actual (Actual)
+ and then not Is_Tag_Indeterminate (Actual)
+ then
+ return False; -- one operand is dispatching
+ end if;
+
+ Next_Actual (Actual);
+ end loop;
+
+ return True;
+
+ end if;
+
+ elsif Nkind (Orig_Node) = N_Qualified_Expression then
+ return Is_Tag_Indeterminate (Expression (Orig_Node));
+
+ else
+ return False;
+ end if;
+ end Is_Tag_Indeterminate;
+
+ ------------------------------------
+ -- Override_Dispatching_Operation --
+ ------------------------------------
+
+ procedure Override_Dispatching_Operation
+ (Tagged_Type : Entity_Id;
+ Prev_Op : Entity_Id;
+ New_Op : Entity_Id)
+ is
+ Op_Elmt : Elmt_Id := First_Elmt (Primitive_Operations (Tagged_Type));
+
+ begin
+ -- Patch the primitive operation list
+
+ while Present (Op_Elmt)
+ and then Node (Op_Elmt) /= Prev_Op
+ loop
+ Next_Elmt (Op_Elmt);
+ end loop;
+
+ -- If there is no previous operation to override, the type declaration
+ -- was malformed, and an error must have been emitted already.
+
+ if No (Op_Elmt) then
+ return;
+ end if;
+
+ Replace_Elmt (Op_Elmt, New_Op);
+
+ if (not Is_Package (Current_Scope))
+ or else not In_Private_Part (Current_Scope)
+ then
+ -- Not a private primitive
+
+ null;
+
+ else pragma Assert (Is_Inherited_Operation (Prev_Op));
+
+ -- Make the overriding operation into an alias of the implicit one.
+ -- In this fashion a call from outside ends up calling the new
+ -- body even if non-dispatching, and a call from inside calls the
+ -- overriding operation because it hides the implicit one.
+ -- To indicate that the body of Prev_Op is never called, set its
+ -- dispatch table entity to Empty.
+
+ Set_Alias (Prev_Op, New_Op);
+ Set_DTC_Entity (Prev_Op, Empty);
+ return;
+ end if;
+ end Override_Dispatching_Operation;
+
+ -------------------
+ -- Propagate_Tag --
+ -------------------
+
+ procedure Propagate_Tag (Control : Node_Id; Actual : Node_Id) is
+ Call_Node : Node_Id;
+ Arg : Node_Id;
+
+ begin
+ if Nkind (Actual) = N_Function_Call then
+ Call_Node := Actual;
+
+ elsif Nkind (Actual) = N_Identifier
+ and then Nkind (Original_Node (Actual)) = N_Function_Call
+ then
+ -- Call rewritten as object declaration when stack-checking
+ -- is enabled. Propagate tag to expression in declaration, which
+ -- is original call.
+
+ Call_Node := Expression (Parent (Entity (Actual)));
+
+ -- Only other possibility is parenthesized or qualified expression
+
+ else
+ Call_Node := Expression (Actual);
+ end if;
+
+ -- Do not set the Controlling_Argument if already set. This happens
+ -- in the special case of _Input (see Exp_Attr, case Input).
+
+ if No (Controlling_Argument (Call_Node)) then
+ Set_Controlling_Argument (Call_Node, Control);
+ end if;
+
+ Arg := First_Actual (Call_Node);
+
+ while Present (Arg) loop
+ if Is_Tag_Indeterminate (Arg) then
+ Propagate_Tag (Control, Arg);
+ end if;
+
+ Next_Actual (Arg);
+ end loop;
+
+ -- Expansion of dispatching calls is suppressed when Java_VM, because
+ -- the JVM back end directly handles the generation of dispatching
+ -- calls and would have to undo any expansion to an indirect call.
+
+ if not Java_VM then
+ Expand_Dispatch_Call (Call_Node);
+ end if;
+ end Propagate_Tag;
+
+end Sem_Disp;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S E M _ D I S P --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.16 $ --
+-- --
+-- Copyright (C) 1992-1999 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 contains routines involved in tagged types and dynamic
+-- dispatching.
+
+with Types; use Types;
+package Sem_Disp is
+
+ procedure Check_Controlling_Formals (Typ : Entity_Id; Subp : Entity_Id);
+ -- Check that all controlling parameters of Subp are of type Typ,
+ -- that defaults for controlling parameters are tag-indeterminate,
+ -- and that the nominal subtype of the parameters and result
+ -- statically match the first subtype of the controlling type.
+
+ procedure Check_Dispatching_Call (N : Node_Id);
+ -- Check if a call is a dispatching call. The subprogram is known to
+ -- be a dispatching operation. The call is dispatching if all the
+ -- controlling actuals are dynamically tagged. This procedure is called
+ -- after overload resolution, so the call is known to be unambiguous.
+
+ procedure Check_Dispatching_Operation (Subp, Old_Subp : Entity_Id);
+ -- Add "Subp" to the list of primitive operations of the corresponding type
+ -- if it has a parameter of this type and is defined at a proper place for
+ -- primitive operations. (new primitives are only defined in package spec,
+ -- overridden operation can be defined in any scope). If Old_Subp is not
+ -- Empty we are in the overriding case.
+
+ procedure Check_Operation_From_Incomplete_Type
+ (Subp : Entity_Id;
+ Typ : Entity_Id);
+ -- If a primitive operation was defined for the incomplete view of the
+ -- type, and the full type declaration is a derived type definition,
+ -- the operation may override an inherited one.
+
+ procedure Check_Operation_From_Private_View (Subp, Old_Subp : Entity_Id);
+ -- Add "Old_Subp" to the list of primitive operations of the corresponding
+ -- tagged type if it is the full view of a private tagged type. The Alias
+ -- of "OldSubp" is adjusted to point to the inherited procedure of the
+ -- full view because it is always this one which has to be called.
+
+ function Find_Controlling_Arg (N : Node_Id) return Node_Id;
+ -- Returns the actual controlling argument if N is dynamically tagged,
+ -- and Empty if it is not dynamically tagged.
+
+ function Find_Dispatching_Type (Subp : Entity_Id) return Entity_Id;
+ -- Check whether a subprogram is dispatching, and find the tagged
+ -- type of the controlling argument or arguments.
+
+ function Is_Dynamically_Tagged (N : Node_Id) return Boolean;
+ -- Used to determine whether a call is dispatching, i.e. if is an
+ -- an expression of a class_Wide type, or a call to a function with
+ -- controlling result where at least one operand is dynamically tagged.
+
+ function Is_Tag_Indeterminate (N : Node_Id) return Boolean;
+ -- An expression is tag-indeterminate if it is a call that dispatches
+ -- on result, and all controlling operands are also indeterminate.
+ -- Such a function call may inherit a tag from an enclosing call.
+
+ procedure Propagate_Tag (Control : Node_Id; Actual : Node_Id);
+ -- If a function call is tag-indeterminate, its controlling argument is
+ -- found in the context; either an enclosing call, or the left-hand side
+ -- of the enclosing assignment statement. The tag must be propagated
+ -- recursively to the tag-indeterminate actuals of the call.
+
+end Sem_Disp;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S E M _ D I S T --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.182 $
+-- --
+-- 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). --
+-- --
+------------------------------------------------------------------------------
+
+with Atree; use Atree;
+with Casing; use Casing;
+with Einfo; use Einfo;
+with Errout; use Errout;
+with Exp_Dist; use Exp_Dist;
+with Exp_Tss; use Exp_Tss;
+with Nlists; use Nlists;
+with Nmake; use Nmake;
+with Namet; use Namet;
+with Opt; use Opt;
+with Rtsfind; use Rtsfind;
+with Sem; use Sem;
+with Sem_Res; use Sem_Res;
+with Sem_Util; use Sem_Util;
+with Sinfo; use Sinfo;
+with Snames; use Snames;
+with Stand; use Stand;
+with Stringt; use Stringt;
+with Tbuild; use Tbuild;
+with Uname; use Uname;
+
+package body Sem_Dist is
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ procedure RAS_E_Dereference (Pref : Node_Id);
+ -- Handles explicit dereference of Remote Access to Subprograms.
+
+ function Full_Qualified_Name (E : Entity_Id) return String_Id;
+ -- returns the full qualified name of the entity in lower case.
+
+ -------------------------
+ -- Add_Stub_Constructs --
+ -------------------------
+
+ procedure Add_Stub_Constructs (N : Node_Id) is
+ U : constant Node_Id := Unit (N);
+ Spec : Entity_Id := Empty;
+ Exp : Node_Id := U; -- Unit that will be expanded
+
+ begin
+ pragma Assert (Distribution_Stub_Mode /= No_Stubs);
+
+ if Nkind (U) = N_Package_Declaration then
+ Spec := Defining_Entity (Specification (U));
+
+ elsif Nkind (U) = N_Package_Body then
+ Spec := Corresponding_Spec (U);
+
+ else pragma Assert (Nkind (U) = N_Package_Instantiation);
+ Exp := Instance_Spec (U);
+ Spec := Defining_Entity (Specification (Exp));
+ end if;
+
+ pragma Assert (Is_Shared_Passive (Spec)
+ or else Is_Remote_Call_Interface (Spec));
+
+ if Distribution_Stub_Mode = Generate_Caller_Stub_Body then
+
+ if Is_Shared_Passive (Spec) then
+ null;
+ elsif Nkind (U) = N_Package_Body then
+ Error_Msg_N
+ ("Specification file expected from command line", U);
+ else
+ Expand_Calling_Stubs_Bodies (Exp);
+ end if;
+
+ else
+
+ if Is_Shared_Passive (Spec) then
+ Build_Passive_Partition_Stub (Exp);
+ else
+ Expand_Receiving_Stubs_Bodies (Exp);
+ end if;
+
+ end if;
+ end Add_Stub_Constructs;
+
+ -------------------------
+ -- Full_Qualified_Name --
+ -------------------------
+
+ function Full_Qualified_Name (E : Entity_Id) return String_Id is
+ Ent : Entity_Id := E;
+ Parent_Name : String_Id := No_String;
+
+ begin
+ -- Deals properly with child units
+
+ if Nkind (Ent) = N_Defining_Program_Unit_Name then
+ Ent := Defining_Identifier (Ent);
+ end if;
+
+ -- Compute recursively the qualification. Only "Standard" has no scope.
+
+ if Present (Scope (Scope (Ent))) then
+ Parent_Name := Full_Qualified_Name (Scope (Ent));
+ end if;
+
+ -- Every entity should have a name except some expanded blocks
+ -- don't bother about those.
+
+ if Chars (Ent) = No_Name then
+ return Parent_Name;
+ end if;
+
+ -- Add a period between Name and qualification
+
+ if Parent_Name /= No_String then
+ Start_String (Parent_Name);
+ Store_String_Char (Get_Char_Code ('.'));
+
+ else
+ Start_String;
+ end if;
+
+ -- Generates the entity name in upper case
+
+ Get_Name_String (Chars (Ent));
+ Set_Casing (All_Lower_Case);
+ Store_String_Chars (Name_Buffer (1 .. Name_Len));
+ return End_String;
+ end Full_Qualified_Name;
+
+ -----------------------
+ -- Get_Subprogram_Id --
+ -----------------------
+
+ function Get_Subprogram_Id (E : Entity_Id) return Int is
+ Current_Declaration : Node_Id;
+ Result : Int := 0;
+
+ begin
+ pragma Assert
+ (Is_Remote_Call_Interface (Scope (E))
+ and then
+ (Nkind (Parent (E)) = N_Procedure_Specification
+ or else
+ Nkind (Parent (E)) = N_Function_Specification));
+
+ Current_Declaration :=
+ First (Visible_Declarations
+ (Package_Specification_Of_Scope (Scope (E))));
+
+ while Current_Declaration /= Empty loop
+ if Nkind (Current_Declaration) = N_Subprogram_Declaration
+ and then Comes_From_Source (Current_Declaration)
+ then
+ if Defining_Unit_Name
+ (Specification (Current_Declaration)) = E
+ then
+ return Result;
+ end if;
+
+ Result := Result + 1;
+ end if;
+
+ Next (Current_Declaration);
+ end loop;
+
+ -- Error if we do not find it
+
+ raise Program_Error;
+ end Get_Subprogram_Id;
+
+ ------------------------
+ -- Is_All_Remote_Call --
+ ------------------------
+
+ function Is_All_Remote_Call (N : Node_Id) return Boolean is
+ Par : Node_Id;
+
+ begin
+ if (Nkind (N) = N_Function_Call
+ or else Nkind (N) = N_Procedure_Call_Statement)
+ and then Nkind (Name (N)) in N_Has_Entity
+ and then Is_Remote_Call_Interface (Entity (Name (N)))
+ and then Has_All_Calls_Remote (Scope (Entity (Name (N))))
+ and then Comes_From_Source (N)
+ then
+ Par := Parent (Entity (Name (N)));
+
+ while Present (Par)
+ and then (Nkind (Par) /= N_Package_Specification
+ or else Is_Wrapper_Package (Defining_Entity (Par)))
+ loop
+ Par := Parent (Par);
+ end loop;
+
+ if Present (Par) then
+ return
+ not Scope_Within_Or_Same (Current_Scope, Defining_Entity (Par));
+ else
+ return False;
+ end if;
+ else
+ return False;
+ end if;
+ end Is_All_Remote_Call;
+
+ ------------------------------------
+ -- Package_Specification_Of_Scope --
+ ------------------------------------
+
+ function Package_Specification_Of_Scope (E : Entity_Id) return Node_Id is
+ N : Node_Id := Parent (E);
+ begin
+ while Nkind (N) /= N_Package_Specification loop
+ N := Parent (N);
+ end loop;
+
+ return N;
+ end Package_Specification_Of_Scope;
+
+ --------------------------
+ -- Process_Partition_ID --
+ --------------------------
+
+ procedure Process_Partition_Id (N : Node_Id) is
+ Loc : constant Source_Ptr := Sloc (N);
+ Ety : Entity_Id;
+ Nd : Node_Id;
+ Get_Pt_Id : Node_Id;
+ Get_Pt_Id_Call : Node_Id;
+ Prefix_String : String_Id;
+ Typ : constant Entity_Id := Etype (N);
+
+ begin
+ Ety := Entity (Prefix (N));
+
+ -- In case prefix is not a library unit entity, get the entity
+ -- of library unit.
+
+ while (Present (Scope (Ety))
+ and then Scope (Ety) /= Standard_Standard)
+ and not Is_Child_Unit (Ety)
+ loop
+ Ety := Scope (Ety);
+ end loop;
+
+ Nd := Enclosing_Lib_Unit_Node (N);
+
+ -- Retrieve the proper function to call.
+
+ if Is_Remote_Call_Interface (Ety) then
+ Get_Pt_Id := New_Occurrence_Of
+ (RTE (RE_Get_Active_Partition_Id), Loc);
+
+ elsif Is_Shared_Passive (Ety) then
+ Get_Pt_Id := New_Occurrence_Of
+ (RTE (RE_Get_Passive_Partition_Id), Loc);
+
+ else
+ Get_Pt_Id := New_Occurrence_Of
+ (RTE (RE_Get_Local_Partition_Id), Loc);
+ end if;
+
+ -- Get and store the String_Id corresponding to the name of the
+ -- library unit whose Partition_Id is needed
+
+ Get_Unit_Name_String (Get_Unit_Name (Unit_Declaration_Node (Ety)));
+
+ -- Remove seven last character ("(spec)" or " (body)").
+ -- (this is a bit nasty, should have interface for this ???)
+
+ Name_Len := Name_Len - 7;
+
+ Start_String;
+ Store_String_Chars (Name_Buffer (1 .. Name_Len));
+ Prefix_String := End_String;
+
+ -- Build the function call which will replace the attribute
+
+ if Is_Remote_Call_Interface (Ety)
+ or else Is_Shared_Passive (Ety)
+ then
+ Get_Pt_Id_Call :=
+ Make_Function_Call (Loc,
+ Name => Get_Pt_Id,
+ Parameter_Associations =>
+ New_List (Make_String_Literal (Loc, Prefix_String)));
+
+ else
+ Get_Pt_Id_Call := Make_Function_Call (Loc, Get_Pt_Id);
+
+ end if;
+
+ -- Replace the attribute node by a conversion of the function call
+ -- to the target type.
+
+ Rewrite (N, Convert_To (Typ, Get_Pt_Id_Call));
+ Analyze_And_Resolve (N, Typ);
+
+ end Process_Partition_Id;
+
+ ----------------------------------
+ -- Process_Remote_AST_Attribute --
+ ----------------------------------
+
+ procedure Process_Remote_AST_Attribute
+ (N : Node_Id;
+ New_Type : Entity_Id)
+ is
+ Loc : constant Source_Ptr := Sloc (N);
+ Remote_Subp : Entity_Id;
+ Tick_Access_Conv_Call : Node_Id;
+ Remote_Subp_Decl : Node_Id;
+ RAS_Decl : Node_Id;
+ RS_Pkg_Specif : Node_Id;
+ RS_Pkg_E : Entity_Id;
+ RAS_Pkg_E : Entity_Id;
+ RAS_Type : Entity_Id;
+ RAS_Name : Name_Id;
+ Async_E : Entity_Id;
+ Subp_Id : Int;
+ Attribute_Subp : Entity_Id;
+ Parameter : Node_Id;
+
+ begin
+ -- Check if we have to expand the access attribute
+
+ Remote_Subp := Entity (Prefix (N));
+
+ if not Expander_Active then
+ return;
+
+ elsif Ekind (New_Type) = E_Record_Type then
+ RAS_Type := New_Type;
+
+ else
+ -- If the remote type has not been constructed yet, create
+ -- it and its attributes now.
+
+ Attribute_Subp := TSS (New_Type, Name_uRAS_Access);
+
+ if No (Attribute_Subp) then
+ Add_RAST_Features (Parent (New_Type));
+ end if;
+
+ RAS_Type := Equivalent_Type (New_Type);
+ end if;
+
+ RAS_Name := Chars (RAS_Type);
+ RAS_Decl := Parent (RAS_Type);
+ Attribute_Subp := TSS (RAS_Type, Name_uRAS_Access);
+
+ RAS_Pkg_E := Defining_Entity (Parent (RAS_Decl));
+ Remote_Subp_Decl := Unit_Declaration_Node (Remote_Subp);
+
+ if Nkind (Remote_Subp_Decl) = N_Subprogram_Body then
+ Remote_Subp := Corresponding_Spec (Remote_Subp_Decl);
+ Remote_Subp_Decl := Unit_Declaration_Node (Remote_Subp);
+ end if;
+
+ RS_Pkg_Specif := Parent (Remote_Subp_Decl);
+ RS_Pkg_E := Defining_Entity (RS_Pkg_Specif);
+
+ Subp_Id := Get_Subprogram_Id (Remote_Subp);
+
+ if Ekind (Remote_Subp) = E_Procedure
+ and then Is_Asynchronous (Remote_Subp)
+ then
+ Async_E := Standard_True;
+ else
+ Async_E := Standard_False;
+ end if;
+
+ -- Right now, we do not call the Name_uAddress_Resolver subprogram,
+ -- which means that we end up with a Null_Address value in the ras
+ -- field: each dereference of an RAS will go through the PCS, which
+ -- is authorized but potentially not very efficient ???
+
+ Parameter := New_Occurrence_Of (RTE (RE_Null_Address), Loc);
+
+ Tick_Access_Conv_Call :=
+ Make_Function_Call (Loc,
+ Name => New_Occurrence_Of (Attribute_Subp, Loc),
+ Parameter_Associations =>
+ New_List (
+ Parameter,
+ Make_String_Literal (Loc, Full_Qualified_Name (RS_Pkg_E)),
+ Make_Integer_Literal (Loc, Subp_Id),
+ New_Occurrence_Of (Async_E, Loc)));
+
+ Rewrite (N, Tick_Access_Conv_Call);
+ Analyze_And_Resolve (N, RAS_Type);
+
+ end Process_Remote_AST_Attribute;
+
+ ------------------------------------
+ -- Process_Remote_AST_Declaration --
+ ------------------------------------
+
+ procedure Process_Remote_AST_Declaration (N : Node_Id) is
+ Loc : constant Source_Ptr := Sloc (N);
+ User_Type : constant Node_Id := Defining_Identifier (N);
+ Fat_Type : constant Entity_Id :=
+ Make_Defining_Identifier
+ (Loc, Chars (User_Type));
+ New_Type_Decl : Node_Id;
+
+ begin
+ -- We add a record type declaration for the equivalent fat pointer type
+
+ New_Type_Decl :=
+ Make_Full_Type_Declaration (Loc,
+ Defining_Identifier => Fat_Type,
+ Type_Definition =>
+ Make_Record_Definition (Loc,
+ Component_List =>
+ Make_Component_List (Loc,
+ Component_Items => New_List (
+
+ Make_Component_Declaration (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc,
+ Chars => Name_Ras),
+ Subtype_Indication =>
+ New_Occurrence_Of
+ (RTE (RE_Unsigned_64), Loc)),
+
+ Make_Component_Declaration (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc,
+ Chars => Name_Origin),
+ Subtype_Indication =>
+ New_Reference_To
+ (Standard_Integer,
+ Loc)),
+
+ Make_Component_Declaration (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc,
+ Chars => Name_Receiver),
+ Subtype_Indication =>
+ New_Reference_To
+ (RTE (RE_Unsigned_64), Loc)),
+
+ Make_Component_Declaration (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc,
+ Chars => Name_Subp_Id),
+ Subtype_Indication =>
+ New_Reference_To
+ (Standard_Natural,
+ Loc)),
+
+ Make_Component_Declaration (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc,
+ Chars => Name_Async),
+ Subtype_Indication =>
+ New_Reference_To
+ (Standard_Boolean,
+ Loc))))));
+
+ Insert_After (N, New_Type_Decl);
+ Set_Equivalent_Type (User_Type, Fat_Type);
+ Set_Corresponding_Remote_Type (Fat_Type, User_Type);
+
+ -- The reason we suppress the initialization procedure is that we know
+ -- that no initialization is required (even if Initialize_Scalars mode
+ -- is active), and there are order of elaboration problems if we do try
+ -- to generate an Init_Proc for this created record type.
+
+ Set_Suppress_Init_Proc (Fat_Type);
+
+ if Expander_Active then
+ Add_RAST_Features (Parent (User_Type));
+ end if;
+
+ end Process_Remote_AST_Declaration;
+
+ -----------------------
+ -- RAS_E_Dereference --
+ -----------------------
+
+ procedure RAS_E_Dereference (Pref : Node_Id) is
+ Loc : constant Source_Ptr := Sloc (Pref);
+ Call_Node : Node_Id;
+ New_Type : constant Entity_Id := Etype (Pref);
+ RAS : constant Entity_Id :=
+ Corresponding_Remote_Type (New_Type);
+ RAS_Decl : constant Node_Id := Parent (RAS);
+ Explicit_Deref : constant Node_Id := Parent (Pref);
+ Deref_Subp_Call : constant Node_Id := Parent (Explicit_Deref);
+ Deref_Proc : Entity_Id;
+ Params : List_Id;
+
+ begin
+ if Nkind (Deref_Subp_Call) = N_Procedure_Call_Statement then
+ Params := Parameter_Associations (Deref_Subp_Call);
+
+ if Present (Params) then
+ Prepend (Pref, Params);
+ else
+ Params := New_List (Pref);
+ end if;
+
+ elsif Nkind (Deref_Subp_Call) = N_Indexed_Component then
+
+ Params := Expressions (Deref_Subp_Call);
+
+ if Present (Params) then
+ Prepend (Pref, Params);
+ else
+ Params := New_List (Pref);
+ end if;
+
+ else
+ -- Context is not a call.
+
+ return;
+ end if;
+
+ Deref_Proc := TSS (New_Type, Name_uRAS_Dereference);
+
+ if not Expander_Active then
+ return;
+
+ elsif No (Deref_Proc) then
+ Add_RAST_Features (RAS_Decl);
+ Deref_Proc := TSS (New_Type, Name_uRAS_Dereference);
+ end if;
+
+ if Ekind (Deref_Proc) = E_Function then
+ Call_Node :=
+ Make_Function_Call (Loc,
+ Name => New_Occurrence_Of (Deref_Proc, Loc),
+ Parameter_Associations => Params);
+
+ else
+ Call_Node :=
+ Make_Procedure_Call_Statement (Loc,
+ Name => New_Occurrence_Of (Deref_Proc, Loc),
+ Parameter_Associations => Params);
+ end if;
+
+ Rewrite (Deref_Subp_Call, Call_Node);
+ Analyze (Deref_Subp_Call);
+ end RAS_E_Dereference;
+
+ ------------------------------
+ -- Remote_AST_E_Dereference --
+ ------------------------------
+
+ function Remote_AST_E_Dereference (P : Node_Id) return Boolean
+ is
+ ET : constant Entity_Id := Etype (P);
+
+ begin
+ -- Perform the changes only on original dereferences, and only if
+ -- we are generating code.
+
+ if Comes_From_Source (P)
+ and then Is_Record_Type (ET)
+ and then (Is_Remote_Call_Interface (ET)
+ or else Is_Remote_Types (ET))
+ and then Present (Corresponding_Remote_Type (ET))
+ and then (Nkind (Parent (Parent (P))) = N_Procedure_Call_Statement
+ or else Nkind (Parent (Parent (P))) = N_Indexed_Component)
+ and then Expander_Active
+ then
+ RAS_E_Dereference (P);
+ return True;
+ else
+ return False;
+ end if;
+ end Remote_AST_E_Dereference;
+
+ ------------------------------
+ -- Remote_AST_I_Dereference --
+ ------------------------------
+
+ function Remote_AST_I_Dereference (P : Node_Id) return Boolean
+ is
+ ET : constant Entity_Id := Etype (P);
+ Deref : Node_Id;
+ begin
+
+ if Comes_From_Source (P)
+ and then (Is_Remote_Call_Interface (ET)
+ or else Is_Remote_Types (ET))
+ and then Present (Corresponding_Remote_Type (ET))
+ and then Ekind (Entity (P)) /= E_Function
+ then
+ Deref :=
+ Make_Explicit_Dereference (Sloc (P),
+ Prefix => Relocate_Node (P));
+ Rewrite (P, Deref);
+ Set_Etype (P, ET);
+ RAS_E_Dereference (Prefix (P));
+ return True;
+ end if;
+
+ return False;
+ end Remote_AST_I_Dereference;
+
+ ---------------------------
+ -- Remote_AST_Null_Value --
+ ---------------------------
+
+ function Remote_AST_Null_Value
+ (N : Node_Id;
+ Typ : Entity_Id)
+ return Boolean
+ is
+ Loc : constant Source_Ptr := Sloc (N);
+ Target_Type : Entity_Id;
+
+ begin
+ if not Expander_Active then
+ return False;
+
+ elsif Ekind (Typ) = E_Access_Subprogram_Type
+ and then (Is_Remote_Call_Interface (Typ)
+ or else Is_Remote_Types (Typ))
+ and then Comes_From_Source (N)
+ and then Expander_Active
+ then
+ -- Any null that comes from source and is of the RAS type must
+ -- be expanded, except if expansion is not active (nothing
+ -- gets expanded into the equivalent record type).
+
+ Target_Type := Equivalent_Type (Typ);
+
+ elsif Ekind (Typ) = E_Record_Type
+ and then Present (Corresponding_Remote_Type (Typ))
+ then
+
+ -- This is a record type representing a RAS type, this must be
+ -- expanded.
+
+ Target_Type := Typ;
+
+ else
+ -- We do not have to handle this case
+
+ return False;
+
+ end if;
+
+ Rewrite (N,
+ Make_Aggregate (Loc,
+ Expressions => New_List (
+ Make_Integer_Literal (Loc, 0), -- Ras
+ Make_Integer_Literal (Loc, 0), -- Origin
+ Make_Integer_Literal (Loc, 0), -- Receiver
+ Make_Integer_Literal (Loc, 0), -- Subp_Id
+ New_Occurrence_Of (Standard_False, Loc)))); -- Asyn
+ Analyze_And_Resolve (N, Target_Type);
+ return True;
+ end Remote_AST_Null_Value;
+
+end Sem_Dist;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S E M _ D I S T --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.56 $
+-- --
+-- 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). --
+-- --
+------------------------------------------------------------------------------
+
+-- Semantic processing for distribution annex facilities
+
+with Types; use Types;
+
+package Sem_Dist is
+
+ procedure Add_Stub_Constructs (N : Node_Id);
+ -- Create the stubs constructs for a remote call interface package
+ -- specification or body or for a shared passive specification. For
+ -- caller stubs, expansion takes place directly in the specification and
+ -- no additional compilation unit is created.
+
+ function Is_All_Remote_Call (N : Node_Id) return Boolean;
+ -- Check whether a function or procedure call should be expanded into
+ -- a remote call, because the entity is declared in a package decl that
+ -- is not currently in scope, and the proper pragmas apply.
+
+ procedure Process_Partition_Id (N : Node_Id);
+ -- Replace attribute reference with call to runtime function. The result
+ -- is converted to the context type, because the attribute yields a
+ -- universal integer value.
+
+ procedure Process_Remote_AST_Attribute (N : Node_Id; New_Type : Entity_Id);
+ -- Given N, an access attribute reference node whose prefix is a
+ -- remote subprogram, rewrite N with a call to a conversion function
+ -- whose return type is New_Type.
+
+ procedure Process_Remote_AST_Declaration (N : Node_Id);
+ -- Given N, an access to subprogram type declaration node in RCI or
+ -- remote types unit, build a new record (fat pointer) type declaration
+ -- using the old Defining_Identifier of N and a link to the old
+ -- declaration node N whose Defining_Identifier is changed.
+ -- We also construct declarations of two subprograms in the unit
+ -- specification which handle remote access to subprogram type
+ -- (fat pointer) dereference and the unit receiver that handles
+ -- remote calls (from remote access to subprogram type values.)
+
+ function Remote_AST_E_Dereference (P : Node_Id) return Boolean;
+ -- If the prefix of an explicit dereference is a record type that
+ -- represent the fat pointer for an Remote access to subprogram, in
+ -- the context of a call, rewrite the enclosing call node into a
+ -- remote call, the first actual of which is the fat pointer. Return
+ -- true if the context is correct and the transformation took place.
+
+ function Remote_AST_I_Dereference (P : Node_Id) return Boolean;
+ -- If P is a record type that represents the fat pointer for a remote
+ -- access to subprogram, and P is the prefix of a call, insert an
+ -- explicit dereference and perform the transformation described for
+ -- the previous function.
+
+ function Remote_AST_Null_Value
+ (N : Node_Id;
+ Typ : Entity_Id)
+ return Boolean;
+ -- If N is a null value and Typ a remote access to subprogram type,
+ -- this function will check if null needs to be replaced with an
+ -- aggregate and will return True in this case. Otherwise, it will
+ -- return False.
+
+ function Get_Subprogram_Id (E : Entity_Id) return Int;
+ -- Given a subprogram defined in a RCI package, get its subprogram id
+ -- which will be used for remote calls.
+
+ function Package_Specification_Of_Scope (E : Entity_Id) return Node_Id;
+ -- Return the N_Package_Specification corresponding to a scope E
+
+end Sem_Dist;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S E M _ E L A B --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.84 $
+-- --
+-- Copyright (C) 1997-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 Atree; use Atree;
+with Checks; use Checks;
+with Debug; use Debug;
+with Einfo; use Einfo;
+with Elists; use Elists;
+with Errout; use Errout;
+with Exp_Util; use Exp_Util;
+with Expander; use Expander;
+with Fname; use Fname;
+with Lib; use Lib;
+with Lib.Load; use Lib.Load;
+with Namet; use Namet;
+with Nlists; use Nlists;
+with Nmake; use Nmake;
+with Opt; use Opt;
+with Output; use Output;
+with Restrict; use Restrict;
+with Sem; use Sem;
+with Sem_Cat; use Sem_Cat;
+with Sem_Ch7; use Sem_Ch7;
+with Sem_Ch8; use Sem_Ch8;
+with Sem_Res; use Sem_Res;
+with Sem_Util; use Sem_Util;
+with Sinfo; use Sinfo;
+with Sinput; use Sinput;
+with Snames; use Snames;
+with Stand; use Stand;
+with Table;
+with Tbuild; use Tbuild;
+with Uname; use Uname;
+
+package body Sem_Elab is
+
+ -- The following table records the recursive call chain for output
+ -- in the Output routine. Each entry records the call node and the
+ -- entity of the called routine. The number of entries in the table
+ -- (i.e. the value of Elab_Call.Last) indicates the current depth
+ -- of recursion and is used to identify the outer level.
+
+ type Elab_Call_Entry is record
+ Cloc : Source_Ptr;
+ Ent : Entity_Id;
+ end record;
+
+ package Elab_Call is new Table.Table (
+ Table_Component_Type => Elab_Call_Entry,
+ Table_Index_Type => Int,
+ Table_Low_Bound => 1,
+ Table_Initial => 50,
+ Table_Increment => 100,
+ Table_Name => "Elab_Call");
+
+ -- This table is initialized at the start of each outer level call.
+ -- It holds the entities for all subprograms that have been examined
+ -- for this particular outer level call, and is used to prevent both
+ -- infinite recursion, and useless reanalysis of bodies already seen
+
+ package Elab_Visited is new Table.Table (
+ Table_Component_Type => Entity_Id,
+ Table_Index_Type => Int,
+ Table_Low_Bound => 1,
+ Table_Initial => 200,
+ Table_Increment => 100,
+ Table_Name => "Elab_Visited");
+
+ -- This table stores calls to Check_Internal_Call that are delayed
+ -- until all generics are instantiated, and in particular that all
+ -- generic bodies have been inserted. We need to delay, because we
+ -- need to be able to look through the inserted bodies.
+
+ type Delay_Element is record
+ N : Node_Id;
+ -- The parameter N from the call to Check_Internal_Call. Note that
+ -- this node may get rewritten over the delay period by expansion
+ -- in the call case (but not in the instantiation case).
+
+ E : Entity_Id;
+ -- The parameter E from the call to Check_Internal_Call
+
+ Orig_Ent : Entity_Id;
+ -- The parameter Orig_Ent from the call to Check_Internal_Call
+
+ Curscop : Entity_Id;
+ -- The current scope of the call. This is restored when we complete
+ -- the delayed call, so that we do this in the right scope.
+
+ From_Elab_Code : Boolean;
+ -- Save indication of whether this call is from elaboration code
+
+ Outer_Scope : Entity_Id;
+ -- Save scope of outer level call
+
+ end record;
+
+ package Delay_Check is new Table.Table (
+ Table_Component_Type => Delay_Element,
+ Table_Index_Type => Int,
+ Table_Low_Bound => 1,
+ Table_Initial => 1000,
+ Table_Increment => 100,
+ Table_Name => "Delay_Check");
+
+ C_Scope : Entity_Id;
+ -- Top level scope of current scope. We need to compute this only
+ -- once at the outer level, i.e. for a call to Check_Elab_Call from
+ -- outside this unit.
+
+ Outer_Level_Sloc : Source_Ptr;
+ -- Save Sloc value for outer level call node for comparisons of source
+ -- locations. A body is too late if it appears after the *outer* level
+ -- call, not the particular call that is being analyzed.
+
+ From_Elab_Code : Boolean;
+ -- This flag shows whether the outer level call currently being examined
+ -- is or is not in elaboration code. We are only interested in calls to
+ -- routines in other units if this flag is True.
+
+ In_Task_Activation : Boolean := False;
+ -- This flag indicates whether we are performing elaboration checks on
+ -- task procedures, at the point of activation. If true, we do not trace
+ -- internal calls in these procedures, because all local bodies are known
+ -- to be elaborated.
+
+ Delaying_Elab_Checks : Boolean := True;
+ -- This is set True till the compilation is complete, including the
+ -- insertion of all instance bodies. Then when Check_Elab_Calls is
+ -- called, the delay table is used to make the delayed calls and
+ -- this flag is reset to False, so that the calls are processed
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ -- Note: Outer_Scope in all these calls represents the scope of
+ -- interest of the outer level call. If it is set to Standard_Standard,
+ -- then it means the outer level call was at elaboration level, and that
+ -- thus all calls are of interest. If it was set to some other scope,
+ -- then the original call was an inner call, and we are not interested
+ -- in calls that go outside this scope.
+
+ procedure Check_A_Call
+ (N : Node_Id;
+ E : Entity_Id;
+ Outer_Scope : Entity_Id;
+ Inter_Unit_Only : Boolean;
+ Generate_Warnings : Boolean := True);
+ -- This is the internal recursive routine that is called to check for
+ -- a possible elaboration error. The argument N is a subprogram call
+ -- or generic instantiation to be checked, and E is the entity of
+ -- the called subprogram, or instantiated generic unit. The flag
+ -- Outer_Scope is the outer level scope for the original call.
+ -- Inter_Unit_Only is set if the call is only to be checked in the
+ -- case where it is to another unit (and skipped if within a unit).
+ -- Generate_Warnings is set to True to suppress warning messages
+ -- about missing pragma Elaborate_All's. These messages are not
+ -- wanted for inner calls in the dynamic model.
+
+ procedure Check_Bad_Instantiation (N : Node_Id);
+ -- N is a node for an instantiation (if called with any other node kind,
+ -- Check_Bad_Instantiation ignores the call). This subprogram checks for
+ -- the special case of a generic instantiation of a generic spec in the
+ -- same declarative part as the instantiation where a body is present and
+ -- has not yet been seen. This is an obvious error, but needs to be checked
+ -- specially at the time of the instantiation, since it is a case where we
+ -- cannot insert the body anywhere. If this case is detected, warnings are
+ -- generated, and a raise of Program_Error is inserted. In addition any
+ -- subprograms in the generic spec are stubbed, and the Bad_Instantiation
+ -- flag is set on the instantiation node. The caller in Sem_Ch12 uses this
+ -- flag as an indication that no attempt should be made to insert an
+ -- instance body.
+
+ procedure Check_Internal_Call
+ (N : Node_Id;
+ E : Entity_Id;
+ Outer_Scope : Entity_Id;
+ Orig_Ent : Entity_Id);
+ -- N is a function call or procedure statement call node and E is
+ -- the entity of the called function, which is within the current
+ -- compilation unit (where subunits count as part of the parent).
+ -- This call checks if this call, or any call within any accessed
+ -- body could cause an ABE, and if so, outputs a warning. Orig_Ent
+ -- differs from E only in the case of renamings, and points to the
+ -- original name of the entity. This is used for error messages.
+ -- Outer_Scope is the outer level scope for the original call.
+
+ procedure Check_Internal_Call_Continue
+ (N : Node_Id;
+ E : Entity_Id;
+ Outer_Scope : Entity_Id;
+ Orig_Ent : Entity_Id);
+ -- The processing for Check_Internal_Call is divided up into two phases,
+ -- and this represents the second phase. The second phase is delayed if
+ -- Delaying_Elab_Calls is set to True. In this delayed case, the first
+ -- phase makes an entry in the Delay_Check table, which is processed
+ -- when Check_Elab_Calls is called. N, E and Orig_Ent are as for the call
+ -- to Check_Internal_Call. Outer_Scope is the outer level scope for
+ -- the original call.
+
+ function Has_Generic_Body (N : Node_Id) return Boolean;
+ -- N is a generic package instantiation node, and this routine determines
+ -- if this package spec does in fact have a generic body. If so, then
+ -- True is returned, otherwise False. Note that this is not at all the
+ -- same as checking if the unit requires a body, since it deals with
+ -- the case of optional bodies accurately (i.e. if a body is optional,
+ -- then it looks to see if a body is actually present). Note: this
+ -- function can only do a fully correct job if in generating code mode
+ -- where all bodies have to be present. If we are operating in semantics
+ -- check only mode, then in some cases of optional bodies, a result of
+ -- False may incorrectly be given. In practice this simply means that
+ -- some cases of warnings for incorrect order of elaboration will only
+ -- be given when generating code, which is not a big problem (and is
+ -- inevitable, given the optional body semantics of Ada).
+
+ procedure Insert_Elab_Check (N : Node_Id; C : Node_Id := Empty);
+ -- Given code for an elaboration check (or unconditional raise if
+ -- the check is not needed), inserts the code in the appropriate
+ -- place. N is the call or instantiation node for which the check
+ -- code is required. C is the test whose failure triggers the raise.
+
+ procedure Output_Calls (N : Node_Id);
+ -- Outputs chain of calls stored in the Elab_Call table. The caller
+ -- has already generated the main warning message, so the warnings
+ -- generated are all continuation messages. The argument is the
+ -- call node at which the messages are to be placed.
+
+ function Same_Elaboration_Scope (Scop1, Scop2 : Entity_Id) return Boolean;
+ -- Given two scopes, determine whether they are the same scope from an
+ -- elaboration point of view, i.e. packages and blocks are ignored.
+
+ procedure Set_C_Scope;
+ -- On entry C_Scope is set to some scope. On return, C_Scope is reset
+ -- to be the enclosing compilation unit of this scope.
+
+ function Spec_Entity (E : Entity_Id) return Entity_Id;
+ -- Given a compilation unit entity, if it is a spec entity, it is
+ -- returned unchanged. If it is a body entity, then the spec for
+ -- the corresponding spec is returned
+
+ procedure Supply_Bodies (N : Node_Id);
+ -- Given a node, N, that is either a subprogram declaration or a package
+ -- declaration, this procedure supplies dummy bodies for the subprogram
+ -- or for all subprograms in the package. If the given node is not one
+ -- of these two possibilities, then Supply_Bodies does nothing. The
+ -- dummy body is supplied by setting the subprogram to be Imported with
+ -- convention Stubbed.
+
+ procedure Supply_Bodies (L : List_Id);
+ -- Calls Supply_Bodies for all elements of the given list L.
+
+ function Within (E1, E2 : Entity_Id) return Boolean;
+ -- Given two scopes E1 and E2, returns True if E1 is equal to E2, or
+ -- is one of its contained scopes, False otherwise.
+
+ ------------------
+ -- Check_A_Call --
+ ------------------
+
+ procedure Check_A_Call
+ (N : Node_Id;
+ E : Entity_Id;
+ Outer_Scope : Entity_Id;
+ Inter_Unit_Only : Boolean;
+ Generate_Warnings : Boolean := True)
+ is
+ Loc : constant Source_Ptr := Sloc (N);
+ Ent : Entity_Id;
+ Decl : Node_Id;
+
+ E_Scope : Entity_Id;
+ -- Top level scope of entity for called subprogram
+
+ Body_Acts_As_Spec : Boolean;
+ -- Set to true if call is to body acting as spec (no separate spec)
+
+ Inst_Case : constant Boolean := Nkind (N) in N_Generic_Instantiation;
+ -- Indicates if we have instantiation case
+
+ Caller_Unit_Internal : Boolean;
+ Callee_Unit_Internal : Boolean;
+
+ Inst_Caller : Source_Ptr;
+ Inst_Callee : Source_Ptr;
+
+ Unit_Caller : Unit_Number_Type;
+ Unit_Callee : Unit_Number_Type;
+
+ Cunit_SW : Boolean := False;
+ -- Set to suppress warnings for case of external reference where
+ -- one of the enclosing scopes has the Suppress_Elaboration_Warnings
+ -- flag set. For the internal case, we ignore this flag.
+
+ Cunit_SC : Boolean := False;
+ -- Set to suppress dynamic elaboration checks where one of the
+ -- enclosing scopes has Suppress_Elaboration_Checks set. For
+ -- the internal case, we ignore this flag.
+
+ begin
+ -- Go to parent for derived subprogram, or to original subprogram
+ -- in the case of a renaming (Alias covers both these cases)
+
+ Ent := E;
+ loop
+ if Suppress_Elaboration_Warnings (Ent) then
+ return;
+ end if;
+
+ -- Nothing to do for imported entities,
+
+ if Is_Imported (Ent) then
+ return;
+ end if;
+
+ exit when Inst_Case or else No (Alias (Ent));
+ Ent := Alias (Ent);
+ end loop;
+
+ Decl := Unit_Declaration_Node (Ent);
+
+ if Nkind (Decl) = N_Subprogram_Body then
+ Body_Acts_As_Spec := True;
+
+ elsif Nkind (Decl) = N_Subprogram_Declaration
+ or else Nkind (Decl) = N_Subprogram_Body_Stub
+ or else Inst_Case
+ then
+ Body_Acts_As_Spec := False;
+
+ -- If we have none of an instantiation, subprogram body or
+ -- subprogram declaration, then it is not a case that we want
+ -- to check. (One case is a call to a generic formal subprogram,
+ -- where we do not want the check in the template).
+
+ else
+ return;
+ end if;
+
+ E_Scope := Ent;
+ loop
+ if Suppress_Elaboration_Warnings (E_Scope) then
+ Cunit_SW := True;
+ end if;
+
+ if Suppress_Elaboration_Checks (E_Scope) then
+ Cunit_SC := True;
+ end if;
+
+ -- Exit when we get to compilation unit, not counting subunits
+
+ exit when Is_Compilation_Unit (E_Scope)
+ and then (Is_Child_Unit (E_Scope)
+ or else Scope (E_Scope) = Standard_Standard);
+
+ -- If we did not find a compilation unit, other than standard,
+ -- then nothing to check (happens in some instantiation cases)
+
+ if E_Scope = Standard_Standard then
+ return;
+
+ -- Otherwise move up a scope looking for compilation unit
+
+ else
+ E_Scope := Scope (E_Scope);
+ end if;
+ end loop;
+
+ -- No checks needed for pure or preelaborated compilation units
+
+ if Is_Pure (E_Scope)
+ or else Is_Preelaborated (E_Scope)
+ then
+ return;
+ end if;
+
+ -- If the generic entity is within a deeper instance than we are, then
+ -- either the instantiation to which we refer itself caused an ABE, in
+ -- which case that will be handled separately. Otherwise, we know that
+ -- the body we need appears as needed at the point of the instantiation.
+ -- However, this assumption is only valid if we are in static mode.
+
+ if not Dynamic_Elaboration_Checks
+ and then Instantiation_Depth (Sloc (Ent)) >
+ Instantiation_Depth (Sloc (N))
+ then
+ return;
+ end if;
+
+ -- Do not give a warning for a package with no body
+
+ if Ekind (Ent) = E_Generic_Package
+ and then not Has_Generic_Body (N)
+ then
+ return;
+ end if;
+
+ -- Case of entity is not in current unit (i.e. with'ed unit case)
+
+ if E_Scope /= C_Scope then
+
+ -- We are only interested in such calls if the outer call was from
+ -- elaboration code, or if we are in Dynamic_Elaboration_Checks mode.
+
+ if not From_Elab_Code and then not Dynamic_Elaboration_Checks then
+ return;
+ end if;
+
+ -- Nothing to do if some scope said to ignore warnings
+
+ if Cunit_SW then
+ return;
+ end if;
+
+ -- Nothing to do for a generic instance, because in this case
+ -- the checking was at the point of instantiation of the generic
+ -- However, this shortcut is only applicable in static mode.
+
+ if Is_Generic_Instance (Ent) and not Dynamic_Elaboration_Checks then
+ return;
+ end if;
+
+ -- Nothing to do if subprogram with no separate spec
+
+ if Body_Acts_As_Spec then
+ return;
+ end if;
+
+ -- Check cases of internal units
+
+ Callee_Unit_Internal :=
+ Is_Internal_File_Name
+ (Unit_File_Name (Get_Source_Unit (E_Scope)));
+
+ -- Do not give a warning if the with'ed unit is internal
+ -- and this is the generic instantiation case (this saves a
+ -- lot of hassle dealing with the Text_IO special child units)
+
+ if Callee_Unit_Internal and Inst_Case then
+ return;
+ end if;
+
+ if C_Scope = Standard_Standard then
+ Caller_Unit_Internal := False;
+ else
+ Caller_Unit_Internal :=
+ Is_Internal_File_Name
+ (Unit_File_Name (Get_Source_Unit (C_Scope)));
+ end if;
+
+ -- Do not give a warning if the with'ed unit is internal
+ -- and the caller is not internal (since the binder always
+ -- elaborates internal units first).
+
+ if Callee_Unit_Internal and (not Caller_Unit_Internal) then
+ return;
+ end if;
+
+ -- For now, if debug flag -gnatdE is not set, do no checking for
+ -- one internal unit withing another. This fixes the problem with
+ -- the sgi build and storage errors. To be resolved later ???
+
+ if (Callee_Unit_Internal and Caller_Unit_Internal)
+ and then not Debug_Flag_EE
+ then
+ return;
+ end if;
+
+ Ent := E;
+
+ -- If the call is in an instance, and the called entity is not
+ -- defined in the same instance, then the elaboration issue
+ -- focuses around the unit containing the template, it is
+ -- this unit which requires an Elaborate_All.
+
+ -- However, if we are doing dynamic elaboration, we need to
+ -- chase the call in the usual manner.
+
+ -- We do not handle the case of calling a generic formal correctly
+ -- in the static case. See test 4703-004 to explore this gap ???
+
+ Inst_Caller := Instantiation (Get_Source_File_Index (Sloc (N)));
+ Inst_Callee := Instantiation (Get_Source_File_Index (Sloc (Ent)));
+
+ if Inst_Caller = No_Location then
+ Unit_Caller := No_Unit;
+ else
+ Unit_Caller := Get_Source_Unit (N);
+ end if;
+
+ if Inst_Callee = No_Location then
+ Unit_Callee := No_Unit;
+ else
+ Unit_Callee := Get_Source_Unit (Ent);
+ end if;
+
+ if Unit_Caller /= No_Unit
+ and then Unit_Callee /= Unit_Caller
+ and then not Dynamic_Elaboration_Checks
+ then
+ E_Scope := Spec_Entity (Cunit_Entity (Unit_Caller));
+
+ -- If we don't get a spec entity, just ignore call. Not
+ -- quite clear why this check is necessary.
+
+ if No (E_Scope) then
+ return;
+ end if;
+
+ -- Otherwise step to enclosing compilation unit
+
+ while not Is_Compilation_Unit (E_Scope) loop
+ E_Scope := Scope (E_Scope);
+ end loop;
+
+ -- For the case of not in an instance, or call within instance
+ -- We recompute E_Scope for the error message, since we
+ -- do NOT want to go to the unit which has the ultimate
+ -- declaration in the case of renaming and derivation and
+ -- we also want to go to the generic unit in the case of
+ -- an instance, and no further.
+
+ else
+ -- Loop to carefully follow renamings and derivations
+ -- one step outside the current unit, but not further.
+
+ loop
+ E_Scope := Ent;
+ while not Is_Compilation_Unit (E_Scope) loop
+ E_Scope := Scope (E_Scope);
+ end loop;
+
+ -- If E_Scope is the same as C_Scope, it means that there
+ -- definitely was a renaming or derivation, and we are
+ -- not yet out of the current unit.
+
+ exit when E_Scope /= C_Scope;
+ Ent := Alias (Ent);
+ end loop;
+ end if;
+
+ if not Suppress_Elaboration_Warnings (Ent)
+ and then not Suppress_Elaboration_Warnings (E_Scope)
+ and then Elab_Warnings
+ and then Generate_Warnings
+ then
+ Warn_On_Instance := True;
+
+ if Inst_Case then
+ Error_Msg_NE
+ ("instantiation of& may raise Program_Error?", N, Ent);
+ else
+ Error_Msg_NE
+ ("call to & may raise Program_Error?", N, Ent);
+ end if;
+
+ Error_Msg_Qual_Level := Nat'Last;
+ Error_Msg_NE
+ ("\missing pragma Elaborate_All for&?", N, E_Scope);
+ Error_Msg_Qual_Level := 0;
+ Output_Calls (N);
+ Warn_On_Instance := False;
+
+ -- Set flag to prevent further warnings for same unit
+ -- unless in All_Errors_Mode.
+
+ if not All_Errors_Mode and not Dynamic_Elaboration_Checks then
+ Set_Suppress_Elaboration_Warnings (E_Scope);
+ end if;
+ end if;
+
+ -- Check for runtime elaboration check required
+
+ if Dynamic_Elaboration_Checks then
+ if not Elaboration_Checks_Suppressed (Ent)
+ and then not Suppress_Elaboration_Checks (E_Scope)
+ and then not Cunit_SC
+ then
+ -- Runtime elaboration check required. generate check of the
+ -- elaboration Boolean for the unit containing the entity.
+
+ Insert_Elab_Check (N,
+ Make_Attribute_Reference (Loc,
+ Attribute_Name => Name_Elaborated,
+ Prefix =>
+ New_Occurrence_Of
+ (Spec_Entity (E_Scope), Loc)));
+ end if;
+
+ -- If no dynamic check required, then ask binder to guarantee
+ -- that the necessary elaborations will be done properly!
+
+ else
+ if not Suppress_Elaboration_Warnings (E)
+ and then not Suppress_Elaboration_Warnings (E_Scope)
+ and then Elab_Warnings
+ and then Generate_Warnings
+ and then not Inst_Case
+ then
+ Error_Msg_Node_2 := E_Scope;
+ Error_Msg_NE ("call to& in elaboration code " &
+ "requires pragma Elaborate_All on&?", N, E);
+ end if;
+
+ Set_Elaborate_All_Desirable (E_Scope);
+ Set_Suppress_Elaboration_Warnings (E_Scope);
+ end if;
+
+ -- Case of entity is in same unit as call or instantiation
+
+ elsif not Inter_Unit_Only then
+ Check_Internal_Call (N, Ent, Outer_Scope, E);
+ end if;
+
+ end Check_A_Call;
+
+ -----------------------------
+ -- Check_Bad_Instantiation --
+ -----------------------------
+
+ procedure Check_Bad_Instantiation (N : Node_Id) is
+ Nam : Node_Id;
+ Ent : Entity_Id;
+
+ begin
+ -- Nothing to do if we do not have an instantiation (happens in some
+ -- error cases, and also in the formal package declaration case)
+
+ if Nkind (N) not in N_Generic_Instantiation then
+ return;
+
+ -- Nothing to do if errors already detected (avoid cascaded errors)
+
+ elsif Errors_Detected /= 0 then
+ return;
+
+ -- Nothing to do if not in full analysis mode
+
+ elsif not Full_Analysis then
+ return;
+
+ -- Nothing to do if inside a generic template
+
+ elsif Inside_A_Generic then
+ return;
+
+ -- Nothing to do if a library level instantiation
+
+ elsif Nkind (Parent (N)) = N_Compilation_Unit then
+ return;
+
+ -- Nothing to do if we are compiling a proper body for semantic
+ -- purposes only. The generic body may be in another proper body.
+
+ elsif
+ Nkind (Parent (Unit_Declaration_Node (Main_Unit_Entity))) = N_Subunit
+ then
+ return;
+ end if;
+
+ Nam := Name (N);
+ Ent := Entity (Nam);
+
+ -- The case we are interested in is when the generic spec is in the
+ -- current declarative part
+
+ if not Same_Elaboration_Scope (Current_Scope, Scope (Ent))
+ or else not In_Same_Extended_Unit (Sloc (N), Sloc (Ent))
+ then
+ return;
+ end if;
+
+ -- If the generic entity is within a deeper instance than we are, then
+ -- either the instantiation to which we refer itself caused an ABE, in
+ -- which case that will be handled separately. Otherwise, we know that
+ -- the body we need appears as needed at the point of the instantiation.
+ -- If they are both at the same level but not within the same instance
+ -- then the body of the generic will be in the earlier instance.
+
+ declare
+ D1 : constant Int := Instantiation_Depth (Sloc (Ent));
+ D2 : constant Int := Instantiation_Depth (Sloc (N));
+
+ begin
+ if D1 > D2 then
+ return;
+
+ elsif D1 = D2
+ and then Is_Generic_Instance (Scope (Ent))
+ and then not In_Open_Scopes (Scope (Ent))
+ then
+ return;
+ end if;
+ end;
+
+ -- Now we can proceed, if the entity being called has a completion,
+ -- then we are definitely OK, since we have already seen the body.
+
+ if Has_Completion (Ent) then
+ return;
+ end if;
+
+ -- If there is no body, then nothing to do
+
+ if not Has_Generic_Body (N) then
+ return;
+ end if;
+
+ -- Here we definitely have a bad instantiation
+
+ Error_Msg_NE
+ ("?cannot instantiate& before body seen", N, Ent);
+
+ if Present (Instance_Spec (N)) then
+ Supply_Bodies (Instance_Spec (N));
+ end if;
+
+ Error_Msg_N
+ ("\?Program_Error will be raised at run time", N);
+ Insert_Elab_Check (N);
+ Set_ABE_Is_Certain (N);
+
+ end Check_Bad_Instantiation;
+
+ ---------------------
+ -- Check_Elab_Call --
+ ---------------------
+
+ procedure Check_Elab_Call
+ (N : Node_Id;
+ Outer_Scope : Entity_Id := Empty)
+ is
+ Nam : Node_Id;
+ Ent : Entity_Id;
+ P : Node_Id;
+
+ begin
+ -- For an entry call, check relevant restriction
+
+ if Nkind (N) = N_Entry_Call_Statement
+ and then not In_Subprogram_Or_Concurrent_Unit
+ then
+ Check_Restriction (No_Entry_Calls_In_Elaboration_Code, N);
+
+ -- Nothing to do if this is not a call (happens in some error
+ -- conditions, and in some cases where rewriting occurs).
+
+ elsif Nkind (N) /= N_Function_Call
+ and then Nkind (N) /= N_Procedure_Call_Statement
+ then
+ return;
+
+ -- Nothing to do if this is a call already rewritten for elab checking.
+
+ elsif Nkind (Parent (N)) = N_Conditional_Expression then
+ return;
+
+ -- Nothing to do if inside a generic template
+
+ elsif Inside_A_Generic
+ and then not Present (Enclosing_Generic_Body (N))
+ then
+ return;
+ end if;
+
+ -- Here we have a call at elaboration time which must be checked
+
+ if Debug_Flag_LL then
+ Write_Str (" Check_Elab_Call: ");
+
+ if No (Name (N))
+ or else not Is_Entity_Name (Name (N))
+ then
+ Write_Str ("<<not entity name>> ");
+ else
+ Write_Name (Chars (Entity (Name (N))));
+ end if;
+
+ Write_Str (" call at ");
+ Write_Location (Sloc (N));
+ Write_Eol;
+ end if;
+
+ -- Climb up the tree to make sure we are not inside a
+ -- default expression of a parameter specification or
+ -- a record component, since in both these cases, we
+ -- will be doing the actual call later, not now, and it
+ -- is at the time of the actual call (statically speaking)
+ -- that we must do our static check, not at the time of
+ -- its initial analysis).
+
+ P := Parent (N);
+ while Present (P) loop
+ if Nkind (P) = N_Parameter_Specification
+ or else
+ Nkind (P) = N_Component_Declaration
+ then
+ return;
+ else
+ P := Parent (P);
+ end if;
+ end loop;
+
+ -- Stuff that happens only at the outer level
+
+ if No (Outer_Scope) then
+ Elab_Visited.Set_Last (0);
+
+ -- Nothing to do if current scope is Standard (this is a bit
+ -- odd, but it happens in the case of generic instantiations).
+
+ C_Scope := Current_Scope;
+
+ if C_Scope = Standard_Standard then
+ return;
+ end if;
+
+ -- First case, we are in elaboration code
+
+ From_Elab_Code := not In_Subprogram_Or_Concurrent_Unit;
+
+ if From_Elab_Code then
+
+ -- Complain if call that comes from source in preelaborated
+ -- unit and we are not inside a subprogram (i.e. we are in
+ -- elab code)
+
+ if Comes_From_Source (N)
+ and then In_Preelaborated_Unit
+ then
+ Error_Msg_N
+ ("non-static call not allowed in preelaborated unit", N);
+ return;
+ end if;
+
+ -- Second case, we are inside a subprogram or concurrent unit
+ -- i.e, we are not in elaboration code.
+
+ else
+ -- In this case, the issue is whether we are inside the
+ -- declarative part of the unit in which we live, or inside
+ -- its statements. In the latter case, there is no issue of
+ -- ABE calls at this level (a call from outside to the unit
+ -- in which we live might cause an ABE, but that will be
+ -- detected when we analyze that outer level call, as it
+ -- recurses into the called unit).
+
+ -- Climb up the tree, doing this test, and also testing
+ -- for being inside a default expression, which, as
+ -- discussed above, is not checked at this stage.
+
+ declare
+ P : Node_Id;
+ L : List_Id;
+
+ begin
+ P := N;
+ loop
+ -- If we find a parentless subtree, it seems safe to
+ -- assume that we are not in a declarative part and
+ -- that no checking is required.
+
+ if No (P) then
+ return;
+ end if;
+
+ if Is_List_Member (P) then
+ L := List_Containing (P);
+ P := Parent (L);
+ else
+ L := No_List;
+ P := Parent (P);
+ end if;
+
+ exit when Nkind (P) = N_Subunit;
+
+ -- Filter out case of default expressions, where
+ -- we do not do the check at this stage.
+
+ if Nkind (P) = N_Parameter_Specification
+ or else
+ Nkind (P) = N_Component_Declaration
+ then
+ return;
+ end if;
+
+ if Nkind (P) = N_Subprogram_Body
+ or else
+ Nkind (P) = N_Protected_Body
+ or else
+ Nkind (P) = N_Task_Body
+ or else
+ Nkind (P) = N_Block_Statement
+ then
+ if L = Declarations (P) then
+ exit;
+
+ -- We are not in elaboration code, but we are doing
+ -- dynamic elaboration checks, in this case, we still
+ -- need to do the call, since the subprogram we are in
+ -- could be called from another unit, also in dynamic
+ -- elaboration check mode, at elaboration time.
+
+ elsif Dynamic_Elaboration_Checks then
+
+ -- This is a rather new check, going into version
+ -- 3.14a1 for the first time (V1.80 of this unit),
+ -- so we provide a debug flag to enable it. That
+ -- way we have an easy work around for regressions
+ -- that are caused by this new check. This debug
+ -- flag can be removed later.
+
+ if Debug_Flag_DD then
+ return;
+ end if;
+
+ -- Do the check in this case
+
+ exit;
+
+ -- Static model, call is not in elaboration code, we
+ -- never need to worry, because in the static model
+ -- the top level caller always takes care of things.
+
+ else
+ return;
+ end if;
+ end if;
+ end loop;
+ end;
+ end if;
+ end if;
+
+ -- Retrieve called entity. If this is a call to a protected subprogram,
+ -- the entity is a selected component.
+ -- The callable entity may be absent, in which case there is nothing
+ -- to do. This happens with non-analyzed calls in nested generics.
+
+ Nam := Name (N);
+
+ if No (Nam) then
+ return;
+
+ elsif Nkind (Nam) = N_Selected_Component then
+ Ent := Entity (Selector_Name (Nam));
+
+ elsif not Is_Entity_Name (Nam) then
+ return;
+
+ else
+ Ent := Entity (Nam);
+ end if;
+
+ if No (Ent) then
+ return;
+ end if;
+
+ -- Nothing to do if this is a recursive call (i.e. a call to
+ -- an entity that is already in the Elab_Call stack)
+
+ for J in 1 .. Elab_Visited.Last loop
+ if Ent = Elab_Visited.Table (J) then
+ return;
+ end if;
+ end loop;
+
+ -- See if we need to analyze this call. We analyze it if either of
+ -- the following conditions is met:
+
+ -- It is an inner level call (since in this case it was triggered
+ -- by an outer level call from elaboration code), but only if the
+ -- call is within the scope of the original outer level call.
+
+ -- It is an outer level call from elaboration code, or the called
+ -- entity is in the same elaboration scope.
+
+ -- And in these cases, we will check both inter-unit calls and
+ -- intra-unit (within a single unit) calls.
+
+ C_Scope := Current_Scope;
+
+ -- If not outer level call, then we follow it if it is within
+ -- the original scope of the outer call.
+
+ if Present (Outer_Scope)
+ and then Within (Scope (Ent), Outer_Scope)
+ then
+ Set_C_Scope;
+ Check_A_Call (N, Ent, Outer_Scope, Inter_Unit_Only => False);
+
+ elsif Elaboration_Checks_Suppressed (Current_Scope) then
+ null;
+
+ elsif From_Elab_Code then
+ Set_C_Scope;
+ Check_A_Call (N, Ent, Standard_Standard, Inter_Unit_Only => False);
+
+ elsif Same_Elaboration_Scope (C_Scope, Scope (Ent)) then
+ Set_C_Scope;
+ Check_A_Call (N, Ent, Scope (Ent), Inter_Unit_Only => False);
+
+ -- If none of those cases holds, but Dynamic_Elaboration_Checks mode
+ -- is set, then we will do the check, but only in the inter-unit case
+ -- (this is to accomodate unguarded elaboration calls from other units
+ -- in which this same mode is set). We don't want warnings in this case,
+ -- it would generate warnings having nothing to do with elaboration.
+
+ elsif Dynamic_Elaboration_Checks then
+ Set_C_Scope;
+ Check_A_Call
+ (N,
+ Ent,
+ Standard_Standard,
+ Inter_Unit_Only => True,
+ Generate_Warnings => False);
+
+ else
+ return;
+ end if;
+ end Check_Elab_Call;
+
+ ----------------------
+ -- Check_Elab_Calls --
+ ----------------------
+
+ procedure Check_Elab_Calls is
+ begin
+ -- If expansion is disabled, do not generate any checks. Also
+ -- skip checks if any subunits are missing because in either
+ -- case we lack the full information that we need, and no object
+ -- file will be created in any case.
+
+ if not Expander_Active or else Subunits_Missing then
+ return;
+ end if;
+
+ -- Skip delayed calls if we had any errors
+
+ if Errors_Detected = 0 then
+ Delaying_Elab_Checks := False;
+ Expander_Mode_Save_And_Set (True);
+
+ for J in Delay_Check.First .. Delay_Check.Last loop
+ New_Scope (Delay_Check.Table (J).Curscop);
+ From_Elab_Code := Delay_Check.Table (J).From_Elab_Code;
+
+ Check_Internal_Call_Continue (
+ N => Delay_Check.Table (J).N,
+ E => Delay_Check.Table (J).E,
+ Outer_Scope => Delay_Check.Table (J).Outer_Scope,
+ Orig_Ent => Delay_Check.Table (J).Orig_Ent);
+
+ Pop_Scope;
+ end loop;
+
+ -- Set Delaying_Elab_Checks back on for next main compilation
+
+ Expander_Mode_Restore;
+ Delaying_Elab_Checks := True;
+ end if;
+ end Check_Elab_Calls;
+
+ ------------------------------
+ -- Check_Elab_Instantiation --
+ ------------------------------
+
+ procedure Check_Elab_Instantiation
+ (N : Node_Id;
+ Outer_Scope : Entity_Id := Empty)
+ is
+ Nam : Node_Id;
+ Ent : Entity_Id;
+
+ begin
+ -- Check for and deal with bad instantiation case. There is some
+ -- duplicated code here, but we will worry about this later ???
+
+ Check_Bad_Instantiation (N);
+
+ if ABE_Is_Certain (N) then
+ return;
+ end if;
+
+ -- Nothing to do if we do not have an instantiation (happens in some
+ -- error cases, and also in the formal package declaration case)
+
+ if Nkind (N) not in N_Generic_Instantiation then
+ return;
+ end if;
+
+ -- Nothing to do if inside a generic template
+
+ if Inside_A_Generic then
+ return;
+ end if;
+
+ Nam := Name (N);
+ Ent := Entity (Nam);
+ From_Elab_Code := not In_Subprogram_Or_Concurrent_Unit;
+
+ -- See if we need to analyze this instantiation. We analyze it if
+ -- either of the following conditions is met:
+
+ -- It is an inner level instantiation (since in this case it was
+ -- triggered by an outer level call from elaboration code), but
+ -- only if the instantiation is within the scope of the original
+ -- outer level call.
+
+ -- It is an outer level instantiation from elaboration code, or the
+ -- instantiated entity is in the same elaboratoin scope.
+
+ -- And in these cases, we will check both the inter-unit case and
+ -- the intra-unit (within a single unit) case.
+
+ C_Scope := Current_Scope;
+
+ if Present (Outer_Scope)
+ and then Within (Scope (Ent), Outer_Scope)
+ then
+ Set_C_Scope;
+ Check_A_Call (N, Ent, Outer_Scope, Inter_Unit_Only => False);
+
+ elsif From_Elab_Code then
+ Set_C_Scope;
+ Check_A_Call (N, Ent, Standard_Standard, Inter_Unit_Only => False);
+
+ elsif Same_Elaboration_Scope (C_Scope, Scope (Ent)) then
+ Set_C_Scope;
+ Check_A_Call (N, Ent, Scope (Ent), Inter_Unit_Only => False);
+
+ -- If none of those cases holds, but Dynamic_Elaboration_Checks mode
+ -- is set, then we will do the check, but only in the inter-unit case
+ -- (this is to accomodate unguarded elaboration calls from other units
+ -- in which this same mode is set). We inhibit warnings in this case,
+ -- since this instantiation is not occurring in elaboration code.
+
+ elsif Dynamic_Elaboration_Checks then
+ Set_C_Scope;
+ Check_A_Call
+ (N,
+ Ent,
+ Standard_Standard,
+ Inter_Unit_Only => True,
+ Generate_Warnings => False);
+
+ else
+ return;
+ end if;
+ end Check_Elab_Instantiation;
+
+ -------------------------
+ -- Check_Internal_Call --
+ -------------------------
+
+ procedure Check_Internal_Call
+ (N : Node_Id;
+ E : Entity_Id;
+ Outer_Scope : Entity_Id;
+ Orig_Ent : Entity_Id)
+ is
+ Inst_Case : constant Boolean := Nkind (N) in N_Generic_Instantiation;
+
+ begin
+ -- If not function or procedure call or instantiation, then ignore
+ -- call (this happens in some error case and rewriting cases)
+
+ if Nkind (N) /= N_Function_Call
+ and then
+ Nkind (N) /= N_Procedure_Call_Statement
+ and then
+ not Inst_Case
+ then
+ return;
+
+ -- Nothing to do if this is a call or instantiation that has
+ -- already been found to be a sure ABE
+
+ elsif ABE_Is_Certain (N) then
+ return;
+
+ -- Nothing to do if errors already detected (avoid cascaded errors)
+
+ elsif Errors_Detected /= 0 then
+ return;
+
+ -- Nothing to do if not in full analysis mode
+
+ elsif not Full_Analysis then
+ return;
+
+ -- Nothing to do if within a default expression, since the call
+ -- is not actualy being made at this time.
+
+ elsif In_Default_Expression then
+ return;
+
+ -- Nothing to do for call to intrinsic subprogram
+
+ elsif Is_Intrinsic_Subprogram (E) then
+ return;
+
+ -- No need to trace local calls if checking task activation, because
+ -- other local bodies are elaborated already.
+
+ elsif In_Task_Activation then
+ return;
+ end if;
+
+ -- Delay this call if we are still delaying calls
+
+ if Delaying_Elab_Checks then
+ Delay_Check.Increment_Last;
+ Delay_Check.Table (Delay_Check.Last) :=
+ (N => N,
+ E => E,
+ Orig_Ent => Orig_Ent,
+ Curscop => Current_Scope,
+ Outer_Scope => Outer_Scope,
+ From_Elab_Code => From_Elab_Code);
+ return;
+
+ -- Otherwise, call phase 2 continuation right now
+
+ else
+ Check_Internal_Call_Continue (N, E, Outer_Scope, Orig_Ent);
+ end if;
+
+ end Check_Internal_Call;
+
+ ----------------------------------
+ -- Check_Internal_Call_Continue --
+ ----------------------------------
+
+ procedure Check_Internal_Call_Continue
+ (N : Node_Id;
+ E : Entity_Id;
+ Outer_Scope : Entity_Id;
+ Orig_Ent : Entity_Id)
+ is
+ Loc : constant Source_Ptr := Sloc (N);
+ Inst_Case : constant Boolean := Is_Generic_Unit (E);
+
+ Sbody : Node_Id;
+ Ebody : Entity_Id;
+
+ function Process (N : Node_Id) return Traverse_Result;
+ -- Function applied to each node as we traverse the body.
+ -- Checks for call that needs checking, and if so checks
+ -- it. Always returns OK, so entire tree is traversed.
+
+ function Process (N : Node_Id) return Traverse_Result is
+ begin
+ -- If user has specified that there are no entry calls in elaboration
+ -- code, do not trace past an accept statement, because the rendez-
+ -- vous will happen after elaboration.
+
+ if (Nkind (Original_Node (N)) = N_Accept_Statement
+ or else Nkind (Original_Node (N)) = N_Selective_Accept)
+ and then Restrictions (No_Entry_Calls_In_Elaboration_Code)
+ then
+ return Abandon;
+
+ -- If we have a subprogram call, check it
+
+ elsif Nkind (N) = N_Function_Call
+ or else Nkind (N) = N_Procedure_Call_Statement
+ then
+ Check_Elab_Call (N, Outer_Scope);
+ return OK;
+
+ -- If we have a generic instantiation, check it
+
+ elsif Nkind (N) in N_Generic_Instantiation then
+ Check_Elab_Instantiation (N, Outer_Scope);
+ return OK;
+
+ -- Skip subprogram bodies that come from source (wait for
+ -- call to analyze these). The reason for the come from
+ -- source test is to avoid catching task bodies.
+
+ -- For task bodies, we should really avoid these too, waiting
+ -- for the task activation, but that's too much trouble to
+ -- catch for now, so we go in unconditionally. This is not
+ -- so terrible, it means the error backtrace is not quite
+ -- complete, and we are too eager to scan bodies of tasks
+ -- that are unused, but this is hardly very significant!
+
+ elsif Nkind (N) = N_Subprogram_Body
+ and then Comes_From_Source (N)
+ then
+ return Skip;
+
+ else
+ return OK;
+ end if;
+ end Process;
+
+ procedure Traverse is new Atree.Traverse_Proc;
+ -- Traverse procedure using above Process function
+
+ -- Start of processing for Check_Internal_Call_Continue
+
+ begin
+ -- Save outer level call if at outer level
+
+ if Elab_Call.Last = 0 then
+ Outer_Level_Sloc := Loc;
+ end if;
+
+ Elab_Visited.Increment_Last;
+ Elab_Visited.Table (Elab_Visited.Last) := E;
+
+ -- If the call is to a function that renames a literal, no check
+ -- is needed.
+
+ if Ekind (E) = E_Enumeration_Literal then
+ return;
+ end if;
+
+ Sbody := Unit_Declaration_Node (E);
+
+ if Nkind (Sbody) /= N_Subprogram_Body
+ and then
+ Nkind (Sbody) /= N_Package_Body
+ then
+ Ebody := Corresponding_Body (Sbody);
+
+ if No (Ebody) then
+ return;
+ else
+ Sbody := Unit_Declaration_Node (Ebody);
+ end if;
+ end if;
+
+ -- If the body appears after the outer level call or
+ -- instantiation then we have an error case handled below.
+
+ if Earlier_In_Extended_Unit (Outer_Level_Sloc, Sloc (Sbody))
+ and then not In_Task_Activation
+ then
+ null;
+
+ -- If we have the instantiation case we are done, since we now
+ -- know that the body of the generic appeared earlier.
+
+ elsif Inst_Case then
+ return;
+
+ -- Otherwise we have a call, so we trace through the called
+ -- body to see if it has any problems ..
+
+ else
+ pragma Assert (Nkind (Sbody) = N_Subprogram_Body);
+
+ Elab_Call.Increment_Last;
+ Elab_Call.Table (Elab_Call.Last).Cloc := Loc;
+ Elab_Call.Table (Elab_Call.Last).Ent := E;
+
+ if Debug_Flag_LL then
+ Write_Str ("Elab_Call.Last = ");
+ Write_Int (Int (Elab_Call.Last));
+ Write_Str (" Ent = ");
+ Write_Name (Chars (E));
+ Write_Str (" at ");
+ Write_Location (Sloc (N));
+ Write_Eol;
+ end if;
+
+ -- Now traverse declarations and statements of subprogram body.
+ -- Note that we cannot simply Traverse (Sbody), since traverse
+ -- does not normally visit subprogram bodies.
+
+ declare
+ Decl : Node_Id := First (Declarations (Sbody));
+
+ begin
+ while Present (Decl) loop
+ Traverse (Decl);
+ Next (Decl);
+ end loop;
+ end;
+
+ Traverse (Handled_Statement_Sequence (Sbody));
+
+ Elab_Call.Decrement_Last;
+ return;
+ end if;
+
+ -- Here is the case of calling a subprogram where the body has
+ -- not yet been encountered, a warning message is needed.
+
+ Warn_On_Instance := True;
+
+ -- If we have nothing in the call stack, then this is at the
+ -- outer level, and the ABE is bound to occur.
+
+ if Elab_Call.Last = 0 then
+
+ if Inst_Case then
+ Error_Msg_NE
+ ("?cannot instantiate& before body seen", N, Orig_Ent);
+ else
+ Error_Msg_NE
+ ("?cannot call& before body seen", N, Orig_Ent);
+ end if;
+
+ Error_Msg_N
+ ("\?Program_Error will be raised at run time", N);
+ Insert_Elab_Check (N);
+
+ -- Call is not at outer level
+
+ else
+ -- Deal with dynamic elaboration check
+
+ if not Elaboration_Checks_Suppressed (E) then
+ Set_Elaboration_Entity_Required (E);
+
+ -- Case of no elaboration entity allocated yet
+
+ if No (Elaboration_Entity (E)) then
+
+ -- Create object declaration for elaboration entity, and put it
+ -- just in front of the spec of the subprogram or generic unit,
+ -- in the same scope as this unit.
+
+ declare
+ Loce : constant Source_Ptr := Sloc (E);
+ Ent : constant Entity_Id :=
+ Make_Defining_Identifier (Loc,
+ Chars => New_External_Name (Chars (E), 'E'));
+
+ begin
+ Set_Elaboration_Entity (E, Ent);
+ New_Scope (Scope (E));
+
+ Insert_Action (Declaration_Node (E),
+ Make_Object_Declaration (Loce,
+ Defining_Identifier => Ent,
+ Object_Definition =>
+ New_Occurrence_Of (Standard_Boolean, Loce),
+ Expression => New_Occurrence_Of (Standard_False, Loce)));
+
+ -- Set elaboration flag at the point of the body
+
+ Set_Elaboration_Flag (Sbody, E);
+
+ Pop_Scope;
+ end;
+ end if;
+
+ -- Generate check of the elaboration Boolean
+
+ Insert_Elab_Check (N,
+ New_Occurrence_Of (Elaboration_Entity (E), Loc));
+ end if;
+
+ -- Generate the warning
+
+ if not Suppress_Elaboration_Warnings (E) then
+ if Inst_Case then
+ Error_Msg_NE
+ ("instantiation of& may occur before body is seen?",
+ N, Orig_Ent);
+ else
+ Error_Msg_NE
+ ("call to& may occur before body is seen?", N, Orig_Ent);
+ end if;
+
+ Error_Msg_N
+ ("\Program_Error may be raised at run time?", N);
+
+ Output_Calls (N);
+ end if;
+ end if;
+
+ Warn_On_Instance := False;
+
+ -- Set flag to suppress further warnings on same subprogram
+ -- unless in all errors mode
+
+ if not All_Errors_Mode then
+ Set_Suppress_Elaboration_Warnings (E);
+ end if;
+ end Check_Internal_Call_Continue;
+
+ ----------------------------
+ -- Check_Task_Activation --
+ ----------------------------
+
+ procedure Check_Task_Activation (N : Node_Id) is
+ Loc : constant Source_Ptr := Sloc (N);
+ Ent : Entity_Id;
+ P : Entity_Id;
+ Task_Scope : Entity_Id;
+ Cunit_SC : Boolean := False;
+ Decl : Node_Id;
+ Elmt : Elmt_Id;
+ Inter_Procs : Elist_Id := New_Elmt_List;
+ Intra_Procs : Elist_Id := New_Elmt_List;
+ Enclosing : Entity_Id;
+
+ procedure Add_Task_Proc (Typ : Entity_Id);
+ -- Add to Task_Procs the task body procedure(s) of task types in Typ.
+ -- For record types, this procedure recurses over component types.
+
+ procedure Collect_Tasks (Decls : List_Id);
+ -- Collect the types of the tasks that are to be activated in the given
+ -- list of declarations, in order to perform elaboration checks on the
+ -- corresponding task procedures which are called implicitly here.
+
+ function Outer_Unit (E : Entity_Id) return Entity_Id;
+ -- find enclosing compilation unit of Entity, ignoring subunits, or
+ -- else enclosing subprogram. If E is not a package, there is no need
+ -- for inter-unit elaboration checks.
+
+ -------------------
+ -- Add_Task_Proc --
+ -------------------
+
+ procedure Add_Task_Proc (Typ : Entity_Id) is
+ Comp : Entity_Id;
+ Proc : Entity_Id := Empty;
+
+ begin
+ if Is_Task_Type (Typ) then
+ Proc := Get_Task_Body_Procedure (Typ);
+
+ elsif Is_Array_Type (Typ)
+ and then Has_Task (Base_Type (Typ))
+ then
+ Add_Task_Proc (Component_Type (Typ));
+
+ elsif Is_Record_Type (Typ)
+ and then Has_Task (Base_Type (Typ))
+ then
+ Comp := First_Component (Typ);
+
+ while Present (Comp) loop
+ Add_Task_Proc (Etype (Comp));
+ Comp := Next_Component (Comp);
+ end loop;
+ end if;
+
+ -- If the task type is another unit, we will perform the usual
+ -- elaboration check on its enclosing unit. If the type is in the
+ -- same unit, we can trace the task body as for an internal call,
+ -- but we only need to examine other external calls, because at
+ -- the point the task is activated, internal subprogram bodies
+ -- will have been elaborated already. We keep separate lists for
+ -- each kind of task.
+
+ if Present (Proc) then
+ if Outer_Unit (Scope (Proc)) = Enclosing then
+
+ if No (Corresponding_Body (Unit_Declaration_Node (Proc)))
+ and then
+ (not Is_Generic_Instance (Scope (Proc))
+ or else
+ Scope (Proc) = Scope (Defining_Identifier (Decl)))
+ then
+ Error_Msg_N
+ ("task will be activated before elaboration of its body?",
+ Decl);
+ Error_Msg_N
+ ("Program_Error will be raised at run-time?", Decl);
+
+ elsif
+ Present (Corresponding_Body (Unit_Declaration_Node (Proc)))
+ then
+ Append_Elmt (Proc, Intra_Procs);
+ end if;
+
+ else
+ Elmt := First_Elmt (Inter_Procs);
+
+ -- No need for multiple entries of the same type.
+
+ while Present (Elmt) loop
+ if Node (Elmt) = Proc then
+ return;
+ end if;
+
+ Next_Elmt (Elmt);
+ end loop;
+
+ Append_Elmt (Proc, Inter_Procs);
+ end if;
+ end if;
+ end Add_Task_Proc;
+
+ -------------------
+ -- Collect_Tasks --
+ -------------------
+
+ procedure Collect_Tasks (Decls : List_Id) is
+ begin
+ if Present (Decls) then
+ Decl := First (Decls);
+
+ while Present (Decl) loop
+
+ if Nkind (Decl) = N_Object_Declaration
+ and then Has_Task (Etype (Defining_Identifier (Decl)))
+ then
+ Add_Task_Proc (Etype (Defining_Identifier (Decl)));
+ end if;
+
+ Next (Decl);
+ end loop;
+ end if;
+ end Collect_Tasks;
+
+ ----------------
+ -- Outer_Unit --
+ ----------------
+
+ function Outer_Unit (E : Entity_Id) return Entity_Id is
+ Outer : Entity_Id := E;
+
+ begin
+ while Present (Outer) loop
+ if Suppress_Elaboration_Checks (Outer) then
+ Cunit_SC := True;
+ end if;
+
+ exit when Is_Child_Unit (Outer)
+ or else Scope (Outer) = Standard_Standard
+ or else Ekind (Outer) /= E_Package;
+ Outer := Scope (Outer);
+ end loop;
+
+ return Outer;
+ end Outer_Unit;
+
+ -- Start of processing for Check_Task_Activation
+
+ begin
+ Enclosing := Outer_Unit (Current_Scope);
+
+ -- Find all tasks declared in the current unit.
+
+ if Nkind (N) = N_Package_Body then
+ P := Unit_Declaration_Node (Corresponding_Spec (N));
+
+ Collect_Tasks (Declarations (N));
+ Collect_Tasks (Visible_Declarations (Specification (P)));
+ Collect_Tasks (Private_Declarations (Specification (P)));
+
+ elsif Nkind (N) = N_Package_Declaration then
+ Collect_Tasks (Visible_Declarations (Specification (N)));
+ Collect_Tasks (Private_Declarations (Specification (N)));
+
+ else
+ Collect_Tasks (Declarations (N));
+ end if;
+
+ -- We only perform detailed checks in all tasks are library level
+ -- entities. If the master is a subprogram or task, activation will
+ -- depend on the activation of the master itself.
+ -- Should dynamic checks be added in the more general case???
+
+ if Ekind (Enclosing) /= E_Package then
+ return;
+ end if;
+
+ -- For task types defined in other units, we want the unit containing
+ -- the task body to be elaborated before the current one.
+
+ Elmt := First_Elmt (Inter_Procs);
+
+ while Present (Elmt) loop
+ Ent := Node (Elmt);
+ Task_Scope := Outer_Unit (Scope (Ent));
+
+ if not Is_Compilation_Unit (Task_Scope) then
+ null;
+
+ elsif Suppress_Elaboration_Warnings (Task_Scope) then
+ null;
+
+ elsif Dynamic_Elaboration_Checks then
+ if not Elaboration_Checks_Suppressed (Ent)
+ and then not Cunit_SC
+ and then not Restrictions (No_Entry_Calls_In_Elaboration_Code)
+ then
+ -- Runtime elaboration check required. generate check of the
+ -- elaboration Boolean for the unit containing the entity.
+
+ Insert_Elab_Check (N,
+ Make_Attribute_Reference (Loc,
+ Attribute_Name => Name_Elaborated,
+ Prefix =>
+ New_Occurrence_Of
+ (Spec_Entity (Task_Scope), Loc)));
+ end if;
+
+ else
+ -- Force the binder to elaborate other unit first.
+
+ if not Suppress_Elaboration_Warnings (Ent)
+ and then Elab_Warnings
+ and then not Suppress_Elaboration_Warnings (Task_Scope)
+ then
+ Error_Msg_Node_2 := Task_Scope;
+ Error_Msg_NE ("activation of an instance of task type&" &
+ " requires pragma Elaborate_All on &?", N, Ent);
+ end if;
+
+ Set_Elaborate_All_Desirable (Task_Scope);
+ Set_Suppress_Elaboration_Warnings (Task_Scope);
+ end if;
+
+ Next_Elmt (Elmt);
+ end loop;
+
+ -- For tasks declared in the current unit, trace other calls within
+ -- the task procedure bodies, which are available.
+
+ In_Task_Activation := True;
+ Elmt := First_Elmt (Intra_Procs);
+
+ while Present (Elmt) loop
+ Ent := Node (Elmt);
+ Check_Internal_Call_Continue (N, Ent, Enclosing, Ent);
+ Next_Elmt (Elmt);
+ end loop;
+
+ In_Task_Activation := False;
+ end Check_Task_Activation;
+
+ ----------------------
+ -- Has_Generic_Body --
+ ----------------------
+
+ function Has_Generic_Body (N : Node_Id) return Boolean is
+ Ent : constant Entity_Id := Entity (Name (N));
+ Decl : constant Node_Id := Unit_Declaration_Node (Ent);
+ Scop : Entity_Id;
+
+ function Find_Body_In (E : Entity_Id; N : Node_Id) return Node_Id;
+ -- Determine if the list of nodes headed by N and linked by Next
+ -- contains a package body for the package spec entity E, and if
+ -- so return the package body. If not, then returns Empty.
+
+ function Load_Package_Body (Nam : Unit_Name_Type) return Node_Id;
+ -- This procedure is called load the unit whose name is given by Nam.
+ -- This unit is being loaded to see whether it contains an optional
+ -- generic body. The returned value is the loaded unit, which is
+ -- always a package body (only package bodies can contain other
+ -- entities in the sense in which Has_Generic_Body is interested).
+ -- We only attempt to load bodies if we are generating code. If we
+ -- are in semantics check only mode, then it would be wrong to load
+ -- bodies that are not required from a semantic point of view, so
+ -- in this case we return Empty. The result is that the caller may
+ -- incorrectly decide that a generic spec does not have a body when
+ -- in fact it does, but the only harm in this is that some warnings
+ -- on elaboration problems may be lost in semantic checks only mode,
+ -- which is not big loss. We also return Empty if we go for a body
+ -- and it is not there.
+
+ function Locate_Corresponding_Body (PE : Entity_Id) return Node_Id;
+ -- PE is the entity for a package spec. This function locates the
+ -- corresponding package body, returning Empty if none is found.
+ -- The package body returned is fully parsed but may not yet be
+ -- analyzed, so only syntactic fields should be referenced.
+
+ ------------------
+ -- Find_Body_In --
+ ------------------
+
+ function Find_Body_In (E : Entity_Id; N : Node_Id) return Node_Id is
+ Nod : Node_Id;
+
+ begin
+ Nod := N;
+ while Present (Nod) loop
+
+ -- If we found the package body we are looking for, return it
+
+ if Nkind (Nod) = N_Package_Body
+ and then Chars (Defining_Unit_Name (Nod)) = Chars (E)
+ then
+ return Nod;
+
+ -- If we found the stub for the body, go after the subunit,
+ -- loading it if necessary.
+
+ elsif Nkind (Nod) = N_Package_Body_Stub
+ and then Chars (Defining_Identifier (Nod)) = Chars (E)
+ then
+ if Present (Library_Unit (Nod)) then
+ return Unit (Library_Unit (Nod));
+
+ else
+ return Load_Package_Body (Get_Unit_Name (Nod));
+ end if;
+
+ -- If neither package body nor stub, keep looking on chain
+
+ else
+ Next (Nod);
+ end if;
+ end loop;
+
+ return Empty;
+ end Find_Body_In;
+
+ -----------------------
+ -- Load_Package_Body --
+ -----------------------
+
+ function Load_Package_Body (Nam : Unit_Name_Type) return Node_Id is
+ U : Unit_Number_Type;
+
+ begin
+ if Operating_Mode /= Generate_Code then
+ return Empty;
+ else
+ U :=
+ Load_Unit
+ (Load_Name => Nam,
+ Required => False,
+ Subunit => False,
+ Error_Node => N);
+
+ if U = No_Unit then
+ return Empty;
+ else
+ return Unit (Cunit (U));
+ end if;
+ end if;
+ end Load_Package_Body;
+
+ -------------------------------
+ -- Locate_Corresponding_Body --
+ -------------------------------
+
+ function Locate_Corresponding_Body (PE : Entity_Id) return Node_Id is
+ Spec : constant Node_Id := Declaration_Node (PE);
+ Decl : constant Node_Id := Parent (Spec);
+ Scop : constant Entity_Id := Scope (PE);
+ PBody : Node_Id;
+
+ begin
+ if Is_Library_Level_Entity (PE) then
+
+ -- If package is a library unit that requires a body, we have
+ -- no choice but to go after that body because it might contain
+ -- an optional body for the original generic package.
+
+ if Unit_Requires_Body (PE) then
+
+ -- Load the body. Note that we are a little careful here to
+ -- use Spec to get the unit number, rather than PE or Decl,
+ -- since in the case where the package is itself a library
+ -- level instantiation, Spec will properly reference the
+ -- generic template, which is what we really want.
+
+ return
+ Load_Package_Body
+ (Get_Body_Name (Unit_Name (Get_Source_Unit (Spec))));
+
+ -- But if the package is a library unit that does NOT require
+ -- a body, then no body is permitted, so we are sure that there
+ -- is no body for the original generic package.
+
+ else
+ return Empty;
+ end if;
+
+ -- Otherwise look and see if we are embedded in a further package
+
+ elsif Is_Package (Scop) then
+
+ -- If so, get the body of the enclosing package, and look in
+ -- its package body for the package body we are looking for.
+
+ PBody := Locate_Corresponding_Body (Scop);
+
+ if No (PBody) then
+ return Empty;
+ else
+ return Find_Body_In (PE, First (Declarations (PBody)));
+ end if;
+
+ -- If we are not embedded in a further package, then the body
+ -- must be in the same declarative part as we are.
+
+ else
+ return Find_Body_In (PE, Next (Decl));
+ end if;
+ end Locate_Corresponding_Body;
+
+ -- Start of processing for Has_Generic_Body
+
+ begin
+ if Present (Corresponding_Body (Decl)) then
+ return True;
+
+ elsif Unit_Requires_Body (Ent) then
+ return True;
+
+ -- Compilation units cannot have optional bodies
+
+ elsif Is_Compilation_Unit (Ent) then
+ return False;
+
+ -- Otherwise look at what scope we are in
+
+ else
+ Scop := Scope (Ent);
+
+ -- Case of entity is in other than a package spec, in this case
+ -- the body, if present, must be in the same declarative part.
+
+ if not Is_Package (Scop) then
+ declare
+ P : Node_Id;
+
+ begin
+ P := Declaration_Node (Ent);
+
+ -- Declaration node may get us a spec, so if so, go to
+ -- the parent declaration.
+
+ while not Is_List_Member (P) loop
+ P := Parent (P);
+ end loop;
+
+ return Present (Find_Body_In (Ent, Next (P)));
+ end;
+
+ -- If the entity is in a package spec, then we have to locate
+ -- the corresponding package body, and look there.
+
+ else
+ declare
+ PBody : constant Node_Id := Locate_Corresponding_Body (Scop);
+
+ begin
+ if No (PBody) then
+ return False;
+ else
+ return
+ Present
+ (Find_Body_In (Ent, (First (Declarations (PBody)))));
+ end if;
+ end;
+ end if;
+ end if;
+ end Has_Generic_Body;
+
+ -----------------------
+ -- Insert_Elab_Check --
+ -----------------------
+
+ procedure Insert_Elab_Check (N : Node_Id; C : Node_Id := Empty) is
+ Nod : Node_Id;
+ Loc : constant Source_Ptr := Sloc (N);
+
+ begin
+ -- If expansion is disabled, do not generate any checks. Also
+ -- skip checks if any subunits are missing because in either
+ -- case we lack the full information that we need, and no object
+ -- file will be created in any case.
+
+ if not Expander_Active or else Subunits_Missing then
+ return;
+ end if;
+
+ -- If we have a generic instantiation, where Instance_Spec is set,
+ -- then this field points to a generic instance spec that has
+ -- been inserted before the instantiation node itself, so that
+ -- is where we want to insert a check.
+
+ if Nkind (N) in N_Generic_Instantiation
+ and then Present (Instance_Spec (N))
+ then
+ Nod := Instance_Spec (N);
+ else
+ Nod := N;
+ end if;
+
+ -- If we are inserting at the top level, insert in Aux_Decls
+
+ if Nkind (Parent (Nod)) = N_Compilation_Unit then
+ declare
+ ADN : constant Node_Id := Aux_Decls_Node (Parent (Nod));
+ R : Node_Id;
+
+ begin
+ if No (C) then
+ R := Make_Raise_Program_Error (Loc);
+ else
+ R := Make_Raise_Program_Error (Loc, Make_Op_Not (Loc, C));
+ end if;
+
+ if No (Declarations (ADN)) then
+ Set_Declarations (ADN, New_List (R));
+ else
+ Append_To (Declarations (ADN), R);
+ end if;
+
+ Analyze (R);
+ end;
+
+ -- Otherwise just insert before the node in question. However, if
+ -- the context of the call has already been analyzed, an insertion
+ -- will not work if it depends on subsequent expansion (e.g. a call in
+ -- a branch of a short-circuit). In that case we replace the call with
+ -- a conditional expression, or with a Raise if it is unconditional.
+ -- Unfortunately this does not work if the call has a dynamic size,
+ -- because gigi regards it as a dynamic-sized temporary. If such a call
+ -- appears in a short-circuit expression, the elaboration check will be
+ -- missed (rare enough ???).
+
+ else
+ if Nkind (N) = N_Function_Call
+ and then Analyzed (Parent (N))
+ and then Size_Known_At_Compile_Time (Etype (N))
+ then
+ declare
+ Typ : constant Entity_Id := Etype (N);
+ R : constant Node_Id := Make_Raise_Program_Error (Loc);
+ Chk : constant Boolean := Do_Range_Check (N);
+
+ begin
+ Set_Etype (R, Typ);
+
+ if No (C) then
+ Rewrite (N, R);
+
+ else
+ Rewrite (N,
+ Make_Conditional_Expression (Loc,
+ Expressions => New_List (C, Relocate_Node (N), R)));
+ end if;
+
+ Analyze_And_Resolve (N, Typ);
+
+ -- If the original call requires a range check, so does the
+ -- conditional expression.
+
+ if Chk then
+ Enable_Range_Check (N);
+ else
+ Set_Do_Range_Check (N, False);
+ end if;
+ end;
+
+ else
+ if No (C) then
+ Insert_Action (Nod,
+ Make_Raise_Program_Error (Loc));
+ else
+ Insert_Action (Nod,
+ Make_Raise_Program_Error (Loc,
+ Condition =>
+ Make_Op_Not (Loc,
+ Right_Opnd => C)));
+ end if;
+ end if;
+ end if;
+ end Insert_Elab_Check;
+
+ ------------------
+ -- Output_Calls --
+ ------------------
+
+ procedure Output_Calls (N : Node_Id) is
+ Ent : Entity_Id;
+
+ function Is_Printable_Error_Name (Nm : Name_Id) return Boolean;
+ -- An internal function, used to determine if a name, Nm, is either
+ -- a non-internal name, or is an internal name that is printable
+ -- by the error message circuits (i.e. it has a single upper
+ -- case letter at the end).
+
+ function Is_Printable_Error_Name (Nm : Name_Id) return Boolean is
+ begin
+ if not Is_Internal_Name (Nm) then
+ return True;
+
+ elsif Name_Len = 1 then
+ return False;
+
+ else
+ Name_Len := Name_Len - 1;
+ return not Is_Internal_Name;
+ end if;
+ end Is_Printable_Error_Name;
+
+ -- Start of processing for Output_Calls
+
+ begin
+ for J in reverse 1 .. Elab_Call.Last loop
+ Error_Msg_Sloc := Elab_Call.Table (J).Cloc;
+
+ Ent := Elab_Call.Table (J).Ent;
+
+ if Is_Generic_Unit (Ent) then
+ Error_Msg_NE ("\?& instantiated #", N, Ent);
+
+ elsif Chars (Ent) = Name_uInit_Proc then
+ Error_Msg_N ("\?initialization procedure called #", N);
+
+ elsif Is_Printable_Error_Name (Chars (Ent)) then
+ Error_Msg_NE ("\?& called #", N, Ent);
+
+ else
+ Error_Msg_N ("\? called #", N);
+ end if;
+ end loop;
+ end Output_Calls;
+
+ ----------------------------
+ -- Same_Elaboration_Scope --
+ ----------------------------
+
+ function Same_Elaboration_Scope (Scop1, Scop2 : Entity_Id) return Boolean is
+ S1 : Entity_Id := Scop1;
+ S2 : Entity_Id := Scop2;
+
+ begin
+ while S1 /= Standard_Standard
+ and then (Ekind (S1) = E_Package
+ or else
+ Ekind (S1) = E_Block)
+ loop
+ S1 := Scope (S1);
+ end loop;
+
+ while S2 /= Standard_Standard
+ and then (Ekind (S2) = E_Package
+ or else
+ Ekind (S2) = E_Protected_Type
+ or else
+ Ekind (S2) = E_Block)
+ loop
+ S2 := Scope (S2);
+ end loop;
+
+ return S1 = S2;
+ end Same_Elaboration_Scope;
+
+ -----------------
+ -- Set_C_Scope --
+ -----------------
+
+ procedure Set_C_Scope is
+ begin
+ while not Is_Compilation_Unit (C_Scope) loop
+ C_Scope := Scope (C_Scope);
+ end loop;
+ end Set_C_Scope;
+
+ -----------------
+ -- Spec_Entity --
+ -----------------
+
+ function Spec_Entity (E : Entity_Id) return Entity_Id is
+ Decl : Node_Id;
+
+ begin
+ -- Check for case of body entity
+ -- Why is the check for E_Void needed???
+
+ if Ekind (E) = E_Void
+ or else Ekind (E) = E_Subprogram_Body
+ or else Ekind (E) = E_Package_Body
+ then
+ Decl := E;
+
+ loop
+ Decl := Parent (Decl);
+ exit when Nkind (Decl) in N_Proper_Body;
+ end loop;
+
+ return Corresponding_Spec (Decl);
+
+ else
+ return E;
+ end if;
+ end Spec_Entity;
+
+ -------------------
+ -- Supply_Bodies --
+ -------------------
+
+ procedure Supply_Bodies (N : Node_Id) is
+ begin
+ if Nkind (N) = N_Subprogram_Declaration then
+ declare
+ Ent : constant Entity_Id := Defining_Unit_Name (Specification (N));
+
+ begin
+ Set_Is_Imported (Ent);
+ Set_Convention (Ent, Convention_Stubbed);
+ end;
+
+ elsif Nkind (N) = N_Package_Declaration then
+ declare
+ Spec : constant Node_Id := Specification (N);
+
+ begin
+ New_Scope (Defining_Unit_Name (Spec));
+ Supply_Bodies (Visible_Declarations (Spec));
+ Supply_Bodies (Private_Declarations (Spec));
+ Pop_Scope;
+ end;
+ end if;
+ end Supply_Bodies;
+
+ procedure Supply_Bodies (L : List_Id) is
+ Elmt : Node_Id;
+
+ begin
+ if Present (L) then
+ Elmt := First (L);
+ while Present (Elmt) loop
+ Supply_Bodies (Elmt);
+ Next (Elmt);
+ end loop;
+ end if;
+ end Supply_Bodies;
+
+ ------------
+ -- Within --
+ ------------
+
+ function Within (E1, E2 : Entity_Id) return Boolean is
+ Scop : Entity_Id;
+
+ begin
+ Scop := E1;
+
+ loop
+ if Scop = E2 then
+ return True;
+
+ elsif Scop = Standard_Standard then
+ return False;
+
+ else
+ Scop := Scope (Scop);
+ end if;
+ end loop;
+
+ raise Program_Error;
+ end Within;
+
+end Sem_Elab;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S E M _ E L A B --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.8 $
+-- --
+-- Copyright (C) 1997-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 contains the routines used to deal with issuing warnings
+-- for cases of calls that may require warnings about possible access
+-- before elaboration.
+
+with Types; use Types;
+
+package Sem_Elab is
+
+ -----------------------------
+ -- Description of Approach --
+ -----------------------------
+
+ -- Every non-static call that is encountered by Sem_Res results in
+ -- a call to Check_Elab_Call, with N being the call node, and Outer
+ -- set to its default value of True.
+
+ -- The goal of Check_Elab_Call is to determine whether or not the
+ -- call in question can generate an access before elaboration
+ -- error (raising Program_Error) either by directly calling a
+ -- subprogram whose body has not yet been elaborated, or indirectly,
+ -- by calling a subprogram whose body has been elaborated, but which
+ -- contains a call to such a subprogram.
+
+ -- The only calls that we need to look at at the outer level are
+ -- calls that occur in elaboration code. There are two cases. The
+ -- call can be at the outer level of elaboration code, or it can
+ -- be within another unit, e.g. the elaboration code of a subprogram.
+
+ -- In the case of an elaboration call at the outer level, we must
+ -- trace all calls to outer level routines either within the current
+ -- unit or to other units that are with'ed. For calls within the
+ -- current unit, we can determine if the body has been elaborated
+ -- or not, and if it has not, then a warning is generated.
+
+ -- Note that there are two subcases. If the original call directly
+ -- calls a subprogram whose body has not been elaborated, then we
+ -- know that an ABE will take place, and we replace the call by
+ -- a raise of Program_Error. If the call is indirect, then we don't
+ -- know that the PE will be raised, since the call might be guarded
+ -- by a conditional. In this case we set Do_Elab_Check on the call
+ -- so that a dynamic check is generated, and output a warning.
+
+ -- For calls to a subprogram in a with'ed unit, we require that
+ -- a pragma Elaborate_All or pragma Elaborate be present, or that
+ -- the referenced unit have a pragma Preelaborate, pragma Pure, or
+ -- pragma Elaborate_Body. If none of these conditions is met, then
+ -- a warning is generated that a pragma Elaborate_All may be needed.
+
+ -- For the case of an elaboration call at some inner level, we are
+ -- interested in tracing only calls to subprograms at the same level,
+ -- i.e. those that can be called during elaboration. Any calls to
+ -- outer level routines cannot cause ABE's as a result of the original
+ -- call (there might be an outer level call to the subprogram from
+ -- outside that causes the ABE, but that gets analyzed separately).
+
+ -- Note that we never trace calls to inner level subprograms, since
+ -- these cannot result in ABE's unless there is an elaboration problem
+ -- at a lower level, which will be separately detected.
+
+ -- Note on pragma Elaborate. The checking here assumes that a pragma
+ -- Elaborate on a with'ed unit guarantees that subprograms within the
+ -- unit can be called without causing an ABE. This is not in fact the
+ -- case since pragma Elaborate does not guarantee the transititive
+ -- coverage guaranteed by Elaborate_All. However, we leave this issue
+ -- up to the binder, which has generates warnings if there are possible
+ -- problems in the use of pragma Elaborate.
+
+ --------------------------------------
+ -- Instantiation Elaboration Errors --
+ --------------------------------------
+
+ -- A special case arises when an instantiation appears in a context
+ -- that is known to be before the body is elaborated, e.g.
+
+ -- generic package x is ...
+ -- ...
+ -- package xx is new x;
+ -- ...
+ -- package body x is ...
+
+ -- In this situation it is certain that an elaboration error will
+ -- occur, and an unconditional raise Program_Error statement is
+ -- inserted before the instantiation, and a warning generated.
+
+ -- The problem is that in this case we have no place to put the
+ -- body of the instantiation. We can't put it in the normal place,
+ -- because it is too early, and will cause errors to occur as a
+ -- result of referencing entities before they are declared.
+
+ -- Our approach in this case is simply to avoid creating the body
+ -- of the instantiation in such a case. The instantiation spec is
+ -- modified to include dummy bodies for all subprograms, so that
+ -- the resulting code does not contain subprogram specs with no
+ -- corresponding bodies.
+
+ procedure Check_Elab_Call (N : Node_Id; Outer_Scope : Entity_Id := Empty);
+ -- Check a call for possible elaboration problems. N is either an
+ -- N_Function_Call or N_Procedure_Call_Statement node, and Outer
+ -- indicates whether this is an outer level call from Sem_Res
+ -- (Outer_Scope set to Empty), or an internal recursive call
+ -- (Outer_Scope set to entity of outermost call, see body).
+
+ procedure Check_Elab_Calls;
+ -- Not all the processing for Check_Elab_Call can be done at the time
+ -- of calls to Check_Elab_Call. This is because for internal calls, we
+ -- need to wait to complete the check until all generic bodies have been
+ -- instantiated. The Check_Elab_Calls procedure cleans up these waiting
+ -- checks. It is called once after the completion of instantiation.
+
+ procedure Check_Elab_Instantiation
+ (N : Node_Id;
+ Outer_Scope : Entity_Id := Empty);
+ -- Check an instantiation for possible elaboration problems. N is an
+ -- instantiation node (N_Package_Instantiation, N_Function_Instantiation,
+ -- or N_Procedure_Instantiation), and Outer_Scope indicates if this is
+ -- an outer level call from Sem_Ch12 (Outer_Scope set to Empty), or an
+ -- internal recursive call (Outer_Scope set to scope of outermost call,
+ -- see body for further details). The returned value is relevant only
+ -- for an outer level call, and is set to False if an elaboration error
+ -- is bound to occur on the instantiation, and True otherwise. This is
+ -- used by the caller to signal that the body of the instance should
+ -- not be generated (see detailed description in body).
+
+ procedure Check_Task_Activation (N : Node_Id);
+ -- at the point at which tasks are activated in a package body, check
+ -- that the bodies of the tasks are elaborated.
+
+end Sem_Elab;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S E M _ E L I M --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.13 $
+-- --
+-- Copyright (C) 1997-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 Atree; use Atree;
+with Einfo; use Einfo;
+with Errout; use Errout;
+with Namet; use Namet;
+with Nlists; use Nlists;
+with Sinfo; use Sinfo;
+with Snames; use Snames;
+with Stand; use Stand;
+with Stringt; use Stringt;
+
+with GNAT.HTable; use GNAT.HTable;
+package body Sem_Elim is
+
+ No_Elimination : Boolean;
+ -- Set True if no Eliminate pragmas active
+
+ ---------------------
+ -- Data Structures --
+ ---------------------
+
+ -- A single pragma Eliminate is represented by the following record
+
+ type Elim_Data;
+ type Access_Elim_Data is access Elim_Data;
+
+ type Names is array (Nat range <>) of Name_Id;
+ -- Type used to represent set of names. Used for names in Unit_Name
+ -- and also the set of names in Argument_Types.
+
+ type Access_Names is access Names;
+
+ type Elim_Data is record
+
+ Unit_Name : Access_Names;
+ -- Unit name, broken down into a set of names (e.g. A.B.C is
+ -- represented as Name_Id values for A, B, C in sequence).
+
+ Entity_Name : Name_Id;
+ -- Entity name if Entity parameter if present. If no Entity parameter
+ -- was supplied, then Entity_Node is set to Empty, and the Entity_Name
+ -- field contains the last identifier name in the Unit_Name.
+
+ Entity_Scope : Access_Names;
+ -- Static scope of the entity within the compilation unit represented by
+ -- Unit_Name.
+
+ Entity_Node : Node_Id;
+ -- Save node of entity argument, for posting error messages. Set
+ -- to Empty if there is no entity argument.
+
+ Parameter_Types : Access_Names;
+ -- Set to set of names given for parameter types. If no parameter
+ -- types argument is present, this argument is set to null.
+
+ Result_Type : Name_Id;
+ -- Result type name if Result_Types parameter present, No_Name if not
+
+ Hash_Link : Access_Elim_Data;
+ -- Link for hash table use
+
+ Homonym : Access_Elim_Data;
+ -- Pointer to next entry with same key
+
+ end record;
+
+ ----------------
+ -- Hash_Table --
+ ----------------
+
+ -- Setup hash table using the Entity_Name field as the hash key
+
+ subtype Element is Elim_Data;
+ subtype Elmt_Ptr is Access_Elim_Data;
+
+ subtype Key is Name_Id;
+
+ type Header_Num is range 0 .. 1023;
+
+ Null_Ptr : constant Elmt_Ptr := null;
+
+ ----------------------
+ -- Hash_Subprograms --
+ ----------------------
+
+ package Hash_Subprograms is
+
+ function Equal (F1, F2 : Key) return Boolean;
+ pragma Inline (Equal);
+
+ function Get_Key (E : Elmt_Ptr) return Key;
+ pragma Inline (Get_Key);
+
+ function Hash (F : Key) return Header_Num;
+ pragma Inline (Hash);
+
+ function Next (E : Elmt_Ptr) return Elmt_Ptr;
+ pragma Inline (Next);
+
+ procedure Set_Next (E : Elmt_Ptr; Next : Elmt_Ptr);
+ pragma Inline (Set_Next);
+
+ end Hash_Subprograms;
+
+ package body Hash_Subprograms is
+
+ -----------
+ -- Equal --
+ -----------
+
+ function Equal (F1, F2 : Key) return Boolean is
+ begin
+ return F1 = F2;
+ end Equal;
+
+ -------------
+ -- Get_Key --
+ -------------
+
+ function Get_Key (E : Elmt_Ptr) return Key is
+ begin
+ return E.Entity_Name;
+ end Get_Key;
+
+ ----------
+ -- Hash --
+ ----------
+
+ function Hash (F : Key) return Header_Num is
+ begin
+ return Header_Num (Int (F) mod 1024);
+ end Hash;
+
+ ----------
+ -- Next --
+ ----------
+
+ function Next (E : Elmt_Ptr) return Elmt_Ptr is
+ begin
+ return E.Hash_Link;
+ end Next;
+
+ --------------
+ -- Set_Next --
+ --------------
+
+ procedure Set_Next (E : Elmt_Ptr; Next : Elmt_Ptr) is
+ begin
+ E.Hash_Link := Next;
+ end Set_Next;
+ end Hash_Subprograms;
+
+ package Elim_Hash_Table is new Static_HTable (
+ Header_Num => Header_Num,
+ Element => Element,
+ Elmt_Ptr => Elmt_Ptr,
+ Null_Ptr => Null_Ptr,
+ Set_Next => Hash_Subprograms.Set_Next,
+ Next => Hash_Subprograms.Next,
+ Key => Key,
+ Get_Key => Hash_Subprograms.Get_Key,
+ Hash => Hash_Subprograms.Hash,
+ Equal => Hash_Subprograms.Equal);
+
+ ----------------------
+ -- Check_Eliminated --
+ ----------------------
+
+ procedure Check_Eliminated (E : Entity_Id) is
+ Elmt : Access_Elim_Data;
+ Scop : Entity_Id;
+ Form : Entity_Id;
+
+ begin
+ if No_Elimination then
+ return;
+
+ -- Elimination of objects and types is not implemented yet.
+
+ elsif Ekind (E) not in Subprogram_Kind then
+ return;
+ end if;
+
+ Elmt := Elim_Hash_Table.Get (Chars (E));
+
+ -- Loop through homonyms for this key
+
+ while Elmt /= null loop
+
+ -- First we check that the name of the entity matches
+
+ if Elmt.Entity_Name /= Chars (E) then
+ goto Continue;
+ end if;
+
+ -- Then we need to see if the static scope matches within the
+ -- compilation unit.
+
+ Scop := Scope (E);
+ if Elmt.Entity_Scope /= null then
+ for J in reverse Elmt.Entity_Scope'Range loop
+ if Elmt.Entity_Scope (J) /= Chars (Scop) then
+ goto Continue;
+ end if;
+
+ Scop := Scope (Scop);
+
+ if not Is_Compilation_Unit (Scop) and then J = 1 then
+ goto Continue;
+ end if;
+ end loop;
+ end if;
+
+ -- Now see if compilation unit matches
+
+ for J in reverse Elmt.Unit_Name'Range loop
+ if Elmt.Unit_Name (J) /= Chars (Scop) then
+ goto Continue;
+ end if;
+
+ Scop := Scope (Scop);
+
+ if Scop /= Standard_Standard and then J = 1 then
+ goto Continue;
+ end if;
+ end loop;
+
+ if Scop /= Standard_Standard then
+ goto Continue;
+ end if;
+
+ -- Check for case of given entity is a library level subprogram
+ -- and we have the single parameter Eliminate case, a match!
+
+ if Is_Compilation_Unit (E)
+ and then Is_Subprogram (E)
+ and then No (Elmt.Entity_Node)
+ then
+ Set_Is_Eliminated (E);
+ return;
+
+ -- Check for case of type or object with two parameter case
+
+ elsif (Is_Type (E) or else Is_Object (E))
+ and then Elmt.Result_Type = No_Name
+ and then Elmt.Parameter_Types = null
+ then
+ Set_Is_Eliminated (E);
+ return;
+
+ -- Check for case of subprogram
+
+ elsif Ekind (E) = E_Function
+ or else Ekind (E) = E_Procedure
+ then
+ -- Two parameter case always matches
+
+ if Elmt.Result_Type = No_Name
+ and then Elmt.Parameter_Types = null
+ then
+ Set_Is_Eliminated (E);
+ return;
+
+ -- Here we have a profile, so see if it matches
+
+ else
+ if Ekind (E) = E_Function then
+ if Chars (Etype (E)) /= Elmt.Result_Type then
+ goto Continue;
+ end if;
+ end if;
+
+ Form := First_Formal (E);
+
+ if No (Form) and then Elmt.Parameter_Types = null then
+ Set_Is_Eliminated (E);
+ return;
+
+ elsif Elmt.Parameter_Types = null then
+ goto Continue;
+
+ else
+ for J in Elmt.Parameter_Types'Range loop
+ if No (Form)
+ or else Chars (Etype (Form)) /= Elmt.Parameter_Types (J)
+ then
+ goto Continue;
+ else
+ Next_Formal (Form);
+ end if;
+ end loop;
+
+ if Present (Form) then
+ goto Continue;
+ else
+ Set_Is_Eliminated (E);
+ return;
+ end if;
+ end if;
+ end if;
+ end if;
+
+ <<Continue>> Elmt := Elmt.Homonym;
+ end loop;
+
+ return;
+ end Check_Eliminated;
+
+ ----------------
+ -- Initialize --
+ ----------------
+
+ procedure Initialize is
+ begin
+ Elim_Hash_Table.Reset;
+ No_Elimination := True;
+ end Initialize;
+
+ ------------------------------
+ -- Process_Eliminate_Pragma --
+ ------------------------------
+
+ procedure Process_Eliminate_Pragma
+ (Arg_Unit_Name : Node_Id;
+ Arg_Entity : Node_Id;
+ Arg_Parameter_Types : Node_Id;
+ Arg_Result_Type : Node_Id)
+ is
+ Argx_Unit_Name : Node_Id;
+ Argx_Entity : Node_Id;
+ Argx_Parameter_Types : Node_Id;
+ Argx_Result_Type : Node_Id;
+
+ Data : constant Access_Elim_Data := new Elim_Data;
+ -- Build result data here
+
+ Elmt : Access_Elim_Data;
+
+ Num_Names : Nat := 0;
+ -- Number of names in unit name
+
+ Lit : Node_Id;
+
+ function OK_Selected_Component (N : Node_Id) return Boolean;
+ -- Test if N is a selected component with all identifiers, or a
+ -- selected component whose selector is an operator symbol. As a
+ -- side effect if result is True, sets Num_Names to the number
+ -- of names present (identifiers and operator if any).
+
+ ---------------------------
+ -- OK_Selected_Component --
+ ---------------------------
+
+ function OK_Selected_Component (N : Node_Id) return Boolean is
+ begin
+ if Nkind (N) = N_Identifier
+ or else Nkind (N) = N_Operator_Symbol
+ then
+ Num_Names := Num_Names + 1;
+ return True;
+
+ elsif Nkind (N) = N_Selected_Component then
+ return OK_Selected_Component (Prefix (N))
+ and then OK_Selected_Component (Selector_Name (N));
+
+ else
+ return False;
+ end if;
+ end OK_Selected_Component;
+
+ -- Start of processing for Process_Eliminate_Pragma
+
+ begin
+ Error_Msg_Name_1 := Name_Eliminate;
+
+ -- Process Unit_Name argument
+
+ Argx_Unit_Name := Expression (Arg_Unit_Name);
+
+ if Nkind (Argx_Unit_Name) = N_Identifier then
+ Data.Unit_Name := new Names'(1 => Chars (Argx_Unit_Name));
+ Num_Names := 1;
+
+ elsif OK_Selected_Component (Argx_Unit_Name) then
+ Data.Unit_Name := new Names (1 .. Num_Names);
+
+ for J in reverse 2 .. Num_Names loop
+ Data.Unit_Name (J) := Chars (Selector_Name (Argx_Unit_Name));
+ Argx_Unit_Name := Prefix (Argx_Unit_Name);
+ end loop;
+
+ Data.Unit_Name (1) := Chars (Argx_Unit_Name);
+
+ else
+ Error_Msg_N
+ ("wrong form for Unit_Name parameter of pragma%",
+ Argx_Unit_Name);
+ return;
+ end if;
+
+ -- Process Entity argument
+
+ if Present (Arg_Entity) then
+ Argx_Entity := Expression (Arg_Entity);
+ Num_Names := 0;
+
+ if Nkind (Argx_Entity) = N_Identifier
+ or else Nkind (Argx_Entity) = N_Operator_Symbol
+ then
+ Data.Entity_Name := Chars (Argx_Entity);
+ Data.Entity_Node := Argx_Entity;
+ Data.Entity_Scope := null;
+
+ elsif OK_Selected_Component (Argx_Entity) then
+ Data.Entity_Scope := new Names (1 .. Num_Names - 1);
+ Data.Entity_Name := Chars (Selector_Name (Argx_Entity));
+ Data.Entity_Node := Argx_Entity;
+
+ Argx_Entity := Prefix (Argx_Entity);
+ for J in reverse 2 .. Num_Names - 1 loop
+ Data.Entity_Scope (J) := Chars (Selector_Name (Argx_Entity));
+ Argx_Entity := Prefix (Argx_Entity);
+ end loop;
+
+ Data.Entity_Scope (1) := Chars (Argx_Entity);
+
+ elsif Nkind (Argx_Entity) = N_String_Literal then
+ String_To_Name_Buffer (Strval (Argx_Entity));
+ Data.Entity_Name := Name_Find;
+ Data.Entity_Node := Argx_Entity;
+
+ else
+ Error_Msg_N
+ ("wrong form for Entity_Argument parameter of pragma%",
+ Argx_Unit_Name);
+ return;
+ end if;
+ else
+ Data.Entity_Node := Empty;
+ Data.Entity_Name := Data.Unit_Name (Num_Names);
+ end if;
+
+ -- Process Parameter_Types argument
+
+ if Present (Arg_Parameter_Types) then
+ Argx_Parameter_Types := Expression (Arg_Parameter_Types);
+
+ -- Case of one name, which looks like a parenthesized literal
+ -- rather than an aggregate.
+
+ if Nkind (Argx_Parameter_Types) = N_String_Literal
+ and then Paren_Count (Argx_Parameter_Types) = 1
+ then
+ String_To_Name_Buffer (Strval (Argx_Parameter_Types));
+ Data.Parameter_Types := new Names'(1 => Name_Find);
+
+ -- Otherwise must be an aggregate
+
+ elsif Nkind (Argx_Parameter_Types) /= N_Aggregate
+ or else Present (Component_Associations (Argx_Parameter_Types))
+ or else No (Expressions (Argx_Parameter_Types))
+ then
+ Error_Msg_N
+ ("Parameter_Types for pragma% must be list of string literals",
+ Argx_Parameter_Types);
+ return;
+
+ -- Here for aggregate case
+
+ else
+ Data.Parameter_Types :=
+ new Names
+ (1 .. List_Length (Expressions (Argx_Parameter_Types)));
+
+ Lit := First (Expressions (Argx_Parameter_Types));
+ for J in Data.Parameter_Types'Range loop
+ if Nkind (Lit) /= N_String_Literal then
+ Error_Msg_N
+ ("parameter types for pragma% must be string literals",
+ Lit);
+ return;
+ end if;
+
+ String_To_Name_Buffer (Strval (Lit));
+ Data.Parameter_Types (J) := Name_Find;
+ Next (Lit);
+ end loop;
+ end if;
+ end if;
+
+ -- Process Result_Types argument
+
+ if Present (Arg_Result_Type) then
+ Argx_Result_Type := Expression (Arg_Result_Type);
+
+ if Nkind (Argx_Result_Type) /= N_String_Literal then
+ Error_Msg_N
+ ("Result_Type argument for pragma% must be string literal",
+ Argx_Result_Type);
+ return;
+ end if;
+
+ String_To_Name_Buffer (Strval (Argx_Result_Type));
+ Data.Result_Type := Name_Find;
+
+ else
+ Data.Result_Type := No_Name;
+ end if;
+
+ -- Now link this new entry into the hash table
+
+ Elmt := Elim_Hash_Table.Get (Hash_Subprograms.Get_Key (Data));
+
+ -- If we already have an entry with this same key, then link
+ -- it into the chain of entries for this key.
+
+ if Elmt /= null then
+ Data.Homonym := Elmt.Homonym;
+ Elmt.Homonym := Data;
+
+ -- Otherwise create a new entry
+
+ else
+ Elim_Hash_Table.Set (Data);
+ end if;
+
+ No_Elimination := False;
+ end Process_Eliminate_Pragma;
+
+end Sem_Elim;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S E M _ E L I M --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.1 $ --
+-- --
+-- Copyright (C) 1997 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 contains the routines used to process the Eliminate pragma
+
+with Types; use Types;
+
+package Sem_Elim is
+
+ procedure Initialize;
+ -- Initialize for new main souce program
+
+ procedure Process_Eliminate_Pragma
+ (Arg_Unit_Name : Node_Id;
+ Arg_Entity : Node_Id;
+ Arg_Parameter_Types : Node_Id;
+ Arg_Result_Type : Node_Id);
+ -- Process eliminate pragma. The number of arguments has been checked,
+ -- as well as possible optional identifiers, but no other checks have
+ -- been made. This subprogram completes the checking, and then if the
+ -- pragma is well formed, makes appropriate entries in the internal
+ -- tables used to keep track of Eliminate pragmas. The four arguments
+ -- are the possible pragma arguments (set to Empty if not present).
+
+ procedure Check_Eliminated (E : Entity_Id);
+ -- Checks if entity E is eliminated, and if so sets the Is_Eliminated
+ -- flag on the given entity.
+
+end Sem_Elim;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S E M _ E V A L --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.291 $
+-- --
+-- 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). --
+-- --
+------------------------------------------------------------------------------
+
+with Atree; use Atree;
+with Checks; use Checks;
+with Debug; use Debug;
+with Einfo; use Einfo;
+with Elists; use Elists;
+with Errout; use Errout;
+with Eval_Fat; use Eval_Fat;
+with Nmake; use Nmake;
+with Nlists; use Nlists;
+with Opt; use Opt;
+with Sem; use Sem;
+with Sem_Cat; use Sem_Cat;
+with Sem_Ch8; use Sem_Ch8;
+with Sem_Res; use Sem_Res;
+with Sem_Util; use Sem_Util;
+with Sem_Type; use Sem_Type;
+with Sem_Warn; use Sem_Warn;
+with Sinfo; use Sinfo;
+with Snames; use Snames;
+with Stand; use Stand;
+with Stringt; use Stringt;
+
+package body Sem_Eval is
+
+ -----------------------------------------
+ -- Handling of Compile Time Evaluation --
+ -----------------------------------------
+
+ -- The compile time evaluation of expressions is distributed over several
+ -- Eval_xxx procedures. These procedures are called immediatedly after
+ -- a subexpression is resolved and is therefore accomplished in a bottom
+ -- up fashion. The flags are synthesized using the following approach.
+
+ -- Is_Static_Expression is determined by following the detailed rules
+ -- in RM 4.9(4-14). This involves testing the Is_Static_Expression
+ -- flag of the operands in many cases.
+
+ -- Raises_Constraint_Error is set if any of the operands have the flag
+ -- set or if an attempt to compute the value of the current expression
+ -- results in detection of a runtime constraint error.
+
+ -- As described in the spec, the requirement is that Is_Static_Expression
+ -- be accurately set, and in addition for nodes for which this flag is set,
+ -- Raises_Constraint_Error must also be set. Furthermore a node which has
+ -- Is_Static_Expression set, and Raises_Constraint_Error clear, then the
+ -- requirement is that the expression value must be precomputed, and the
+ -- node is either a literal, or the name of a constant entity whose value
+ -- is a static expression.
+
+ -- The general approach is as follows. First compute Is_Static_Expression.
+ -- If the node is not static, then the flag is left off in the node and
+ -- we are all done. Otherwise for a static node, we test if any of the
+ -- operands will raise constraint error, and if so, propagate the flag
+ -- Raises_Constraint_Error to the result node and we are done (since the
+ -- error was already posted at a lower level).
+
+ -- For the case of a static node whose operands do not raise constraint
+ -- error, we attempt to evaluate the node. If this evaluation succeeds,
+ -- then the node is replaced by the result of this computation. If the
+ -- evaluation raises constraint error, then we rewrite the node with
+ -- Apply_Compile_Time_Constraint_Error to raise the exception and also
+ -- to post appropriate error messages.
+
+ ----------------
+ -- Local Data --
+ ----------------
+
+ type Bits is array (Nat range <>) of Boolean;
+ -- Used to convert unsigned (modular) values for folding logical ops
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ function OK_Bits (N : Node_Id; Bits : Uint) return Boolean;
+ -- Bits represents the number of bits in an integer value to be computed
+ -- (but the value has not been computed yet). If this value in Bits is
+ -- reasonable, a result of True is returned, with the implication that
+ -- the caller should go ahead and complete the calculation. If the value
+ -- in Bits is unreasonably large, then an error is posted on node N, and
+ -- False is returned (and the caller skips the proposed calculation).
+
+ function From_Bits (B : Bits; T : Entity_Id) return Uint;
+ -- Converts a bit string of length B'Length to a Uint value to be used
+ -- for a target of type T, which is a modular type. This procedure
+ -- includes the necessary reduction by the modulus in the case of a
+ -- non-binary modulus (for a binary modulus, the bit string is the
+ -- right length any way so all is well).
+
+ function Get_String_Val (N : Node_Id) return Node_Id;
+ -- Given a tree node for a folded string or character value, returns
+ -- the corresponding string literal or character literal (one of the
+ -- two must be available, or the operand would not have been marked
+ -- as foldable in the earlier analysis of the operation).
+
+ procedure Out_Of_Range (N : Node_Id);
+ -- This procedure is called if it is determined that node N, which
+ -- appears in a non-static context, is a compile time known value
+ -- which is outside its range, i.e. the range of Etype. This is used
+ -- in contexts where this is an illegality if N is static, and should
+ -- generate a warning otherwise.
+
+ procedure Rewrite_In_Raise_CE (N : Node_Id; Exp : Node_Id);
+ -- N and Exp are nodes representing an expression, Exp is known
+ -- to raise CE. N is rewritten in term of Exp in the optimal way.
+
+ function String_Type_Len (Stype : Entity_Id) return Uint;
+ -- Given a string type, determines the length of the index type, or,
+ -- if this index type is non-static, the length of the base type of
+ -- this index type. Note that if the string type is itself static,
+ -- then the index type is static, so the second case applies only
+ -- if the string type passed is non-static.
+
+ function Test (Cond : Boolean) return Uint;
+ pragma Inline (Test);
+ -- This function simply returns the appropriate Boolean'Pos value
+ -- corresponding to the value of Cond as a universal integer. It is
+ -- used for producing the result of the static evaluation of the
+ -- logical operators
+
+ procedure Test_Expression_Is_Foldable
+ (N : Node_Id;
+ Op1 : Node_Id;
+ Stat : out Boolean;
+ Fold : out Boolean);
+ -- Tests to see if expression N whose single operand is Op1 is foldable,
+ -- i.e. the operand value is known at compile time. If the operation is
+ -- foldable, then Fold is True on return, and Stat indicates whether
+ -- the result is static (i.e. both operands were static). Note that it
+ -- is quite possible for Fold to be True, and Stat to be False, since
+ -- there are cases in which we know the value of an operand even though
+ -- it is not technically static (e.g. the static lower bound of a range
+ -- whose upper bound is non-static).
+ --
+ -- If Stat is set False on return, then Expression_Is_Foldable makes a
+ -- call to Check_Non_Static_Context on the operand. If Fold is False on
+ -- return, then all processing is complete, and the caller should
+ -- return, since there is nothing else to do.
+
+ procedure Test_Expression_Is_Foldable
+ (N : Node_Id;
+ Op1 : Node_Id;
+ Op2 : Node_Id;
+ Stat : out Boolean;
+ Fold : out Boolean);
+ -- Same processing, except applies to an expression N with two operands
+ -- Op1 and Op2.
+
+ procedure To_Bits (U : Uint; B : out Bits);
+ -- Converts a Uint value to a bit string of length B'Length
+
+ ------------------------------
+ -- Check_Non_Static_Context --
+ ------------------------------
+
+ procedure Check_Non_Static_Context (N : Node_Id) is
+ T : Entity_Id := Etype (N);
+ Checks_On : constant Boolean :=
+ not Index_Checks_Suppressed (T)
+ and not Range_Checks_Suppressed (T);
+
+ begin
+ -- We need the check only for static expressions not raising CE
+ -- We can also ignore cases in which the type is Any_Type
+
+ if not Is_OK_Static_Expression (N)
+ or else Etype (N) = Any_Type
+ then
+ return;
+
+ -- Skip this check for non-scalar expressions
+
+ elsif not Is_Scalar_Type (T) then
+ return;
+ end if;
+
+ -- Here we have the case of outer level static expression of
+ -- scalar type, where the processing of this procedure is needed.
+
+ -- For real types, this is where we convert the value to a machine
+ -- number (see RM 4.9(38)). Also see ACVC test C490001. We should
+ -- only need to do this if the parent is a constant declaration,
+ -- since in other cases, gigi should do the necessary conversion
+ -- correctly, but experimentation shows that this is not the case
+ -- on all machines, in particular if we do not convert all literals
+ -- to machine values in non-static contexts, then ACVC test C490001
+ -- fails on Sparc/Solaris and SGI/Irix.
+
+ if Nkind (N) = N_Real_Literal
+ and then not Is_Machine_Number (N)
+ and then not Is_Generic_Type (Etype (N))
+ and then Etype (N) /= Universal_Real
+ and then not Debug_Flag_S
+ and then (not Debug_Flag_T
+ or else
+ (Nkind (Parent (N)) = N_Object_Declaration
+ and then Constant_Present (Parent (N))))
+ then
+ -- Check that value is in bounds before converting to machine
+ -- number, so as not to lose case where value overflows in the
+ -- least significant bit or less. See B490001.
+
+ if Is_Out_Of_Range (N, Base_Type (T)) then
+ Out_Of_Range (N);
+ return;
+ end if;
+
+ -- Note: we have to copy the node, to avoid problems with conformance
+ -- of very similar numbers (see ACVC tests B4A010C and B63103A).
+
+ Rewrite (N, New_Copy (N));
+
+ if not Is_Floating_Point_Type (T) then
+ Set_Realval
+ (N, Corresponding_Integer_Value (N) * Small_Value (T));
+
+ elsif not UR_Is_Zero (Realval (N)) then
+ declare
+ RT : constant Entity_Id := Base_Type (T);
+ X : constant Ureal := Machine (RT, Realval (N), Round);
+
+ begin
+ -- Warn if result of static rounding actually differs from
+ -- runtime evaluation, which uses round to even.
+
+ if Warn_On_Biased_Rounding and Rounding_Was_Biased then
+ Error_Msg_N ("static expression does not round to even"
+ & " ('R'M 4.9(38))?", N);
+ end if;
+
+ Set_Realval (N, X);
+ end;
+ end if;
+
+ Set_Is_Machine_Number (N);
+ end if;
+
+ -- Check for out of range universal integer. This is a non-static
+ -- context, so the integer value must be in range of the runtime
+ -- representation of universal integers.
+
+ -- We do this only within an expression, because that is the only
+ -- case in which non-static universal integer values can occur, and
+ -- furthermore, Check_Non_Static_Context is currently (incorrectly???)
+ -- called in contexts like the expression of a number declaration where
+ -- we certainly want to allow out of range values.
+
+ if Etype (N) = Universal_Integer
+ and then Nkind (N) = N_Integer_Literal
+ and then Nkind (Parent (N)) in N_Subexpr
+ and then
+ (Intval (N) < Expr_Value (Type_Low_Bound (Universal_Integer))
+ or else
+ Intval (N) > Expr_Value (Type_High_Bound (Universal_Integer)))
+ then
+ Apply_Compile_Time_Constraint_Error
+ (N, "non-static universal integer value out of range?");
+
+ -- Check out of range of base type
+
+ elsif Is_Out_Of_Range (N, Base_Type (T)) then
+ Out_Of_Range (N);
+
+ -- Give warning if outside subtype (where one or both of the
+ -- bounds of the subtype is static). This warning is omitted
+ -- if the expression appears in a range that could be null
+ -- (warnings are handled elsewhere for this case).
+
+ elsif T /= Base_Type (T)
+ and then Nkind (Parent (N)) /= N_Range
+ then
+ if Is_In_Range (N, T) then
+ null;
+
+ elsif Is_Out_Of_Range (N, T) then
+ Apply_Compile_Time_Constraint_Error
+ (N, "value not in range of}?");
+
+ elsif Checks_On then
+ Enable_Range_Check (N);
+
+ else
+ Set_Do_Range_Check (N, False);
+ end if;
+ end if;
+ end Check_Non_Static_Context;
+
+ ---------------------------------
+ -- Check_String_Literal_Length --
+ ---------------------------------
+
+ procedure Check_String_Literal_Length (N : Node_Id; Ttype : Entity_Id) is
+ begin
+ if not Raises_Constraint_Error (N)
+ and then Is_Constrained (Ttype)
+ then
+ if
+ UI_From_Int (String_Length (Strval (N))) /= String_Type_Len (Ttype)
+ then
+ Apply_Compile_Time_Constraint_Error
+ (N, "string length wrong for}?",
+ Ent => Ttype,
+ Typ => Ttype);
+ end if;
+ end if;
+ end Check_String_Literal_Length;
+
+ --------------------------
+ -- Compile_Time_Compare --
+ --------------------------
+
+ function Compile_Time_Compare (L, R : Node_Id) return Compare_Result is
+ Ltyp : constant Entity_Id := Etype (L);
+ Rtyp : constant Entity_Id := Etype (R);
+
+ procedure Compare_Decompose
+ (N : Node_Id;
+ R : out Node_Id;
+ V : out Uint);
+ -- This procedure decomposes the node N into an expression node
+ -- and a signed offset, so that the value of N is equal to the
+ -- value of R plus the value V (which may be negative). If no
+ -- such decomposition is possible, then on return R is a copy
+ -- of N, and V is set to zero.
+
+ function Compare_Fixup (N : Node_Id) return Node_Id;
+ -- This function deals with replacing 'Last and 'First references
+ -- with their corresponding type bounds, which we then can compare.
+ -- The argument is the original node, the result is the identity,
+ -- unless we have a 'Last/'First reference in which case the value
+ -- returned is the appropriate type bound.
+
+ function Is_Same_Value (L, R : Node_Id) return Boolean;
+ -- Returns True iff L and R represent expressions that definitely
+ -- have identical (but not necessarily compile time known) values
+ -- Indeed the caller is expected to have already dealt with the
+ -- cases of compile time known values, so these are not tested here.
+
+ -----------------------
+ -- Compare_Decompose --
+ -----------------------
+
+ procedure Compare_Decompose
+ (N : Node_Id;
+ R : out Node_Id;
+ V : out Uint)
+ is
+ begin
+ if Nkind (N) = N_Op_Add
+ and then Nkind (Right_Opnd (N)) = N_Integer_Literal
+ then
+ R := Left_Opnd (N);
+ V := Intval (Right_Opnd (N));
+ return;
+
+ elsif Nkind (N) = N_Op_Subtract
+ and then Nkind (Right_Opnd (N)) = N_Integer_Literal
+ then
+ R := Left_Opnd (N);
+ V := UI_Negate (Intval (Right_Opnd (N)));
+ return;
+
+ elsif Nkind (N) = N_Attribute_Reference then
+
+ if Attribute_Name (N) = Name_Succ then
+ R := First (Expressions (N));
+ V := Uint_1;
+ return;
+
+ elsif Attribute_Name (N) = Name_Pred then
+ R := First (Expressions (N));
+ V := Uint_Minus_1;
+ return;
+ end if;
+ end if;
+
+ R := N;
+ V := Uint_0;
+ end Compare_Decompose;
+
+ -------------------
+ -- Compare_Fixup --
+ -------------------
+
+ function Compare_Fixup (N : Node_Id) return Node_Id is
+ Indx : Node_Id;
+ Xtyp : Entity_Id;
+ Subs : Nat;
+
+ begin
+ if Nkind (N) = N_Attribute_Reference
+ and then (Attribute_Name (N) = Name_First
+ or else
+ Attribute_Name (N) = Name_Last)
+ then
+ Xtyp := Etype (Prefix (N));
+
+ -- If we have no type, then just abandon the attempt to do
+ -- a fixup, this is probably the result of some other error.
+
+ if No (Xtyp) then
+ return N;
+ end if;
+
+ -- Dereference an access type
+
+ if Is_Access_Type (Xtyp) then
+ Xtyp := Designated_Type (Xtyp);
+ end if;
+
+ -- If we don't have an array type at this stage, something
+ -- is peculiar, e.g. another error, and we abandon the attempt
+ -- at a fixup.
+
+ if not Is_Array_Type (Xtyp) then
+ return N;
+ end if;
+
+ -- Ignore unconstrained array, since bounds are not meaningful
+
+ if not Is_Constrained (Xtyp) then
+ return N;
+ end if;
+
+ -- Find correct index type
+
+ Indx := First_Index (Xtyp);
+
+ if Present (Expressions (N)) then
+ Subs := UI_To_Int (Expr_Value (First (Expressions (N))));
+
+ for J in 2 .. Subs loop
+ Indx := Next_Index (Indx);
+ end loop;
+ end if;
+
+ Xtyp := Etype (Indx);
+
+ if Attribute_Name (N) = Name_First then
+ return Type_Low_Bound (Xtyp);
+
+ else -- Attribute_Name (N) = Name_Last
+ return Type_High_Bound (Xtyp);
+ end if;
+ end if;
+
+ return N;
+ end Compare_Fixup;
+
+ -------------------
+ -- Is_Same_Value --
+ -------------------
+
+ function Is_Same_Value (L, R : Node_Id) return Boolean is
+ Lf : constant Node_Id := Compare_Fixup (L);
+ Rf : constant Node_Id := Compare_Fixup (R);
+
+ begin
+ -- Values are the same if they are the same identifier and the
+ -- identifier refers to a constant object (E_Constant)
+
+ if Nkind (Lf) = N_Identifier and then Nkind (Rf) = N_Identifier
+ and then Entity (Lf) = Entity (Rf)
+ and then (Ekind (Entity (Lf)) = E_Constant or else
+ Ekind (Entity (Lf)) = E_In_Parameter or else
+ Ekind (Entity (Lf)) = E_Loop_Parameter)
+ then
+ return True;
+
+ -- Or if they are compile time known and identical
+
+ elsif Compile_Time_Known_Value (Lf)
+ and then
+ Compile_Time_Known_Value (Rf)
+ and then Expr_Value (Lf) = Expr_Value (Rf)
+ then
+ return True;
+
+ -- Or if they are both 'First or 'Last values applying to the
+ -- same entity (first and last don't change even if value does)
+
+ elsif Nkind (Lf) = N_Attribute_Reference
+ and then
+ Nkind (Rf) = N_Attribute_Reference
+ and then Attribute_Name (Lf) = Attribute_Name (Rf)
+ and then (Attribute_Name (Lf) = Name_First
+ or else
+ Attribute_Name (Lf) = Name_Last)
+ and then Is_Entity_Name (Prefix (Lf))
+ and then Is_Entity_Name (Prefix (Rf))
+ and then Entity (Prefix (Lf)) = Entity (Prefix (Rf))
+ then
+ return True;
+
+ -- All other cases, we can't tell
+
+ else
+ return False;
+ end if;
+ end Is_Same_Value;
+
+ -- Start of processing for Compile_Time_Compare
+
+ begin
+ if L = R then
+ return EQ;
+
+ -- If expressions have no types, then do not attempt to determine
+ -- if they are the same, since something funny is going on. One
+ -- case in which this happens is during generic template analysis,
+ -- when bounds are not fully analyzed.
+
+ elsif No (Ltyp) or else No (Rtyp) then
+ return Unknown;
+
+ -- We only attempt compile time analysis for scalar values
+
+ elsif not Is_Scalar_Type (Ltyp)
+ or else Is_Packed_Array_Type (Ltyp)
+ then
+ return Unknown;
+
+ -- Case where comparison involves two compile time known values
+
+ elsif Compile_Time_Known_Value (L)
+ and then Compile_Time_Known_Value (R)
+ then
+ -- For the floating-point case, we have to be a little careful, since
+ -- at compile time we are dealing with universal exact values, but at
+ -- runtime, these will be in non-exact target form. That's why the
+ -- returned results are LE and GE below instead of LT and GT.
+
+ if Is_Floating_Point_Type (Ltyp)
+ or else
+ Is_Floating_Point_Type (Rtyp)
+ then
+ declare
+ Lo : constant Ureal := Expr_Value_R (L);
+ Hi : constant Ureal := Expr_Value_R (R);
+
+ begin
+ if Lo < Hi then
+ return LE;
+ elsif Lo = Hi then
+ return EQ;
+ else
+ return GE;
+ end if;
+ end;
+
+ -- For the integer case we know exactly (note that this includes the
+ -- fixed-point case, where we know the run time integer values now)
+
+ else
+ declare
+ Lo : constant Uint := Expr_Value (L);
+ Hi : constant Uint := Expr_Value (R);
+
+ begin
+ if Lo < Hi then
+ return LT;
+ elsif Lo = Hi then
+ return EQ;
+ else
+ return GT;
+ end if;
+ end;
+ end if;
+
+ -- Cases where at least one operand is not known at compile time
+
+ else
+ -- Here is where we check for comparisons against maximum bounds of
+ -- types, where we know that no value can be outside the bounds of
+ -- the subtype. Note that this routine is allowed to assume that all
+ -- expressions are within their subtype bounds. Callers wishing to
+ -- deal with possibly invalid values must in any case take special
+ -- steps (e.g. conversions to larger types) to avoid this kind of
+ -- optimization, which is always considered to be valid. We do not
+ -- attempt this optimization with generic types, since the type
+ -- bounds may not be meaningful in this case.
+
+ if Is_Discrete_Type (Ltyp)
+ and then not Is_Generic_Type (Ltyp)
+ and then not Is_Generic_Type (Rtyp)
+ then
+ if Is_Same_Value (R, Type_High_Bound (Ltyp)) then
+ return LE;
+
+ elsif Is_Same_Value (R, Type_Low_Bound (Ltyp)) then
+ return GE;
+
+ elsif Is_Same_Value (L, Type_High_Bound (Rtyp)) then
+ return GE;
+
+ elsif Is_Same_Value (L, Type_Low_Bound (Ltyp)) then
+ return LE;
+ end if;
+ end if;
+
+ -- Next attempt is to decompose the expressions to extract
+ -- a constant offset resulting from the use of any of the forms:
+
+ -- expr + literal
+ -- expr - literal
+ -- typ'Succ (expr)
+ -- typ'Pred (expr)
+
+ -- Then we see if the two expressions are the same value, and if so
+ -- the result is obtained by comparing the offsets.
+
+ declare
+ Lnode : Node_Id;
+ Loffs : Uint;
+ Rnode : Node_Id;
+ Roffs : Uint;
+
+ begin
+ Compare_Decompose (L, Lnode, Loffs);
+ Compare_Decompose (R, Rnode, Roffs);
+
+ if Is_Same_Value (Lnode, Rnode) then
+ if Loffs = Roffs then
+ return EQ;
+
+ elsif Loffs < Roffs then
+ return LT;
+
+ else
+ return GT;
+ end if;
+
+ -- If the expressions are different, we cannot say at compile
+ -- time how they compare, so we return the Unknown indication.
+
+ else
+ return Unknown;
+ end if;
+ end;
+ end if;
+ end Compile_Time_Compare;
+
+ ------------------------------
+ -- Compile_Time_Known_Value --
+ ------------------------------
+
+ function Compile_Time_Known_Value (Op : Node_Id) return Boolean is
+ K : constant Node_Kind := Nkind (Op);
+
+ begin
+ -- Never known at compile time if bad type or raises constraint error
+ -- or empty (latter case occurs only as a result of a previous error)
+
+ if No (Op)
+ or else Op = Error
+ or else Etype (Op) = Any_Type
+ or else Raises_Constraint_Error (Op)
+ then
+ return False;
+ end if;
+
+ -- If we have an entity name, then see if it is the name of a constant
+ -- and if so, test the corresponding constant value, or the name of
+ -- an enumeration literal, which is always a constant.
+
+ if Present (Etype (Op)) and then Is_Entity_Name (Op) then
+ declare
+ E : constant Entity_Id := Entity (Op);
+ V : Node_Id;
+
+ begin
+ -- Never known at compile time if it is a packed array value.
+ -- We might want to try to evaluate these at compile time one
+ -- day, but we do not make that attempt now.
+
+ if Is_Packed_Array_Type (Etype (Op)) then
+ return False;
+ end if;
+
+ if Ekind (E) = E_Enumeration_Literal then
+ return True;
+
+ elsif Ekind (E) /= E_Constant then
+ return False;
+
+ else
+ V := Constant_Value (E);
+ return Present (V) and then Compile_Time_Known_Value (V);
+ end if;
+ end;
+
+ -- We have a value, see if it is compile time known
+
+ else
+ -- Literals and NULL are known at compile time
+
+ if K = N_Integer_Literal
+ or else
+ K = N_Character_Literal
+ or else
+ K = N_Real_Literal
+ or else
+ K = N_String_Literal
+ or else
+ K = N_Null
+ then
+ return True;
+
+ -- Any reference to Null_Parameter is known at compile time. No
+ -- other attribute references (that have not already been folded)
+ -- are known at compile time.
+
+ elsif K = N_Attribute_Reference then
+ return Attribute_Name (Op) = Name_Null_Parameter;
+
+ -- All other types of values are not known at compile time
+
+ else
+ return False;
+ end if;
+
+ end if;
+ end Compile_Time_Known_Value;
+
+ --------------------------------------
+ -- Compile_Time_Known_Value_Or_Aggr --
+ --------------------------------------
+
+ function Compile_Time_Known_Value_Or_Aggr (Op : Node_Id) return Boolean is
+ begin
+ -- If we have an entity name, then see if it is the name of a constant
+ -- and if so, test the corresponding constant value, or the name of
+ -- an enumeration literal, which is always a constant.
+
+ if Is_Entity_Name (Op) then
+ declare
+ E : constant Entity_Id := Entity (Op);
+ V : Node_Id;
+
+ begin
+ if Ekind (E) = E_Enumeration_Literal then
+ return True;
+
+ elsif Ekind (E) /= E_Constant then
+ return False;
+
+ else
+ V := Constant_Value (E);
+ return Present (V)
+ and then Compile_Time_Known_Value_Or_Aggr (V);
+ end if;
+ end;
+
+ -- We have a value, see if it is compile time known
+
+ else
+ if Compile_Time_Known_Value (Op) then
+ return True;
+
+ elsif Nkind (Op) = N_Aggregate then
+
+ if Present (Expressions (Op)) then
+ declare
+ Expr : Node_Id;
+
+ begin
+ Expr := First (Expressions (Op));
+ while Present (Expr) loop
+ if not Compile_Time_Known_Value_Or_Aggr (Expr) then
+ return False;
+ end if;
+
+ Next (Expr);
+ end loop;
+ end;
+ end if;
+
+ if Present (Component_Associations (Op)) then
+ declare
+ Cass : Node_Id;
+
+ begin
+ Cass := First (Component_Associations (Op));
+ while Present (Cass) loop
+ if not
+ Compile_Time_Known_Value_Or_Aggr (Expression (Cass))
+ then
+ return False;
+ end if;
+
+ Next (Cass);
+ end loop;
+ end;
+ end if;
+
+ return True;
+
+ -- All other types of values are not known at compile time
+
+ else
+ return False;
+ end if;
+
+ end if;
+ end Compile_Time_Known_Value_Or_Aggr;
+
+ -----------------
+ -- Eval_Actual --
+ -----------------
+
+ -- This is only called for actuals of functions that are not predefined
+ -- operators (which have already been rewritten as operators at this
+ -- stage), so the call can never be folded, and all that needs doing for
+ -- the actual is to do the check for a non-static context.
+
+ procedure Eval_Actual (N : Node_Id) is
+ begin
+ Check_Non_Static_Context (N);
+ end Eval_Actual;
+
+ --------------------
+ -- Eval_Allocator --
+ --------------------
+
+ -- Allocators are never static, so all we have to do is to do the
+ -- check for a non-static context if an expression is present.
+
+ procedure Eval_Allocator (N : Node_Id) is
+ Expr : constant Node_Id := Expression (N);
+
+ begin
+ if Nkind (Expr) = N_Qualified_Expression then
+ Check_Non_Static_Context (Expression (Expr));
+ end if;
+ end Eval_Allocator;
+
+ ------------------------
+ -- Eval_Arithmetic_Op --
+ ------------------------
+
+ -- Arithmetic operations are static functions, so the result is static
+ -- if both operands are static (RM 4.9(7), 4.9(20)).
+
+ procedure Eval_Arithmetic_Op (N : Node_Id) is
+ Left : constant Node_Id := Left_Opnd (N);
+ Right : constant Node_Id := Right_Opnd (N);
+ Ltype : constant Entity_Id := Etype (Left);
+ Rtype : constant Entity_Id := Etype (Right);
+ Stat : Boolean;
+ Fold : Boolean;
+
+ begin
+ -- If not foldable we are done
+
+ Test_Expression_Is_Foldable (N, Left, Right, Stat, Fold);
+
+ if not Fold then
+ return;
+ end if;
+
+ -- Fold for cases where both operands are of integer type
+
+ if Is_Integer_Type (Ltype) and then Is_Integer_Type (Rtype) then
+ declare
+ Left_Int : constant Uint := Expr_Value (Left);
+ Right_Int : constant Uint := Expr_Value (Right);
+ Result : Uint;
+
+ begin
+ case Nkind (N) is
+
+ when N_Op_Add =>
+ Result := Left_Int + Right_Int;
+
+ when N_Op_Subtract =>
+ Result := Left_Int - Right_Int;
+
+ when N_Op_Multiply =>
+ if OK_Bits
+ (N, UI_From_Int
+ (Num_Bits (Left_Int) + Num_Bits (Right_Int)))
+ then
+ Result := Left_Int * Right_Int;
+ else
+ Result := Left_Int;
+ end if;
+
+ when N_Op_Divide =>
+
+ -- The exception Constraint_Error is raised by integer
+ -- division, rem and mod if the right operand is zero.
+
+ if Right_Int = 0 then
+ Apply_Compile_Time_Constraint_Error
+ (N, "division by zero");
+ return;
+ else
+ Result := Left_Int / Right_Int;
+ end if;
+
+ when N_Op_Mod =>
+
+ -- The exception Constraint_Error is raised by integer
+ -- division, rem and mod if the right operand is zero.
+
+ if Right_Int = 0 then
+ Apply_Compile_Time_Constraint_Error
+ (N, "mod with zero divisor");
+ return;
+ else
+ Result := Left_Int mod Right_Int;
+ end if;
+
+ when N_Op_Rem =>
+
+ -- The exception Constraint_Error is raised by integer
+ -- division, rem and mod if the right operand is zero.
+
+ if Right_Int = 0 then
+ Apply_Compile_Time_Constraint_Error
+ (N, "rem with zero divisor");
+ return;
+ else
+ Result := Left_Int rem Right_Int;
+ end if;
+
+ when others =>
+ raise Program_Error;
+ end case;
+
+ -- Adjust the result by the modulus if the type is a modular type
+
+ if Is_Modular_Integer_Type (Ltype) then
+ Result := Result mod Modulus (Ltype);
+ end if;
+
+ Fold_Uint (N, Result);
+ end;
+
+ -- Cases where at least one operand is a real. We handle the cases
+ -- of both reals, or mixed/real integer cases (the latter happen
+ -- only for divide and multiply, and the result is always real).
+
+ elsif Is_Real_Type (Ltype) or else Is_Real_Type (Rtype) then
+ declare
+ Left_Real : Ureal;
+ Right_Real : Ureal;
+ Result : Ureal;
+
+ begin
+ if Is_Real_Type (Ltype) then
+ Left_Real := Expr_Value_R (Left);
+ else
+ Left_Real := UR_From_Uint (Expr_Value (Left));
+ end if;
+
+ if Is_Real_Type (Rtype) then
+ Right_Real := Expr_Value_R (Right);
+ else
+ Right_Real := UR_From_Uint (Expr_Value (Right));
+ end if;
+
+ if Nkind (N) = N_Op_Add then
+ Result := Left_Real + Right_Real;
+
+ elsif Nkind (N) = N_Op_Subtract then
+ Result := Left_Real - Right_Real;
+
+ elsif Nkind (N) = N_Op_Multiply then
+ Result := Left_Real * Right_Real;
+
+ else pragma Assert (Nkind (N) = N_Op_Divide);
+ if UR_Is_Zero (Right_Real) then
+ Apply_Compile_Time_Constraint_Error
+ (N, "division by zero");
+ return;
+ end if;
+
+ Result := Left_Real / Right_Real;
+ end if;
+
+ Fold_Ureal (N, Result);
+ end;
+ end if;
+
+ Set_Is_Static_Expression (N, Stat);
+
+ end Eval_Arithmetic_Op;
+
+ ----------------------------
+ -- Eval_Character_Literal --
+ ----------------------------
+
+ -- Nothing to be done!
+
+ procedure Eval_Character_Literal (N : Node_Id) is
+ begin
+ null;
+ end Eval_Character_Literal;
+
+ ------------------------
+ -- Eval_Concatenation --
+ ------------------------
+
+ -- Concatenation is a static function, so the result is static if
+ -- both operands are static (RM 4.9(7), 4.9(21)).
+
+ procedure Eval_Concatenation (N : Node_Id) is
+ Left : constant Node_Id := Left_Opnd (N);
+ Right : constant Node_Id := Right_Opnd (N);
+ Stat : Boolean;
+ Fold : Boolean;
+ C_Typ : constant Entity_Id := Root_Type (Component_Type (Etype (N)));
+
+ begin
+ -- Concatenation is never static in Ada 83, so if Ada 83
+ -- check operand non-static context
+
+ if Ada_83
+ and then Comes_From_Source (N)
+ then
+ Check_Non_Static_Context (Left);
+ Check_Non_Static_Context (Right);
+ return;
+ end if;
+
+ -- If not foldable we are done. In principle concatenation that yields
+ -- any string type is static (i.e. an array type of character types).
+ -- However, character types can include enumeration literals, and
+ -- concatenation in that case cannot be described by a literal, so we
+ -- only consider the operation static if the result is an array of
+ -- (a descendant of) a predefined character type.
+
+ Test_Expression_Is_Foldable (N, Left, Right, Stat, Fold);
+
+ if (C_Typ = Standard_Character
+ or else C_Typ = Standard_Wide_Character)
+ and then Fold
+ then
+ null;
+ else
+ Set_Is_Static_Expression (N, False);
+ return;
+ end if;
+
+ -- Compile time string concatenation.
+
+ -- ??? Note that operands that are aggregates can be marked as
+ -- static, so we should attempt at a later stage to fold
+ -- concatenations with such aggregates.
+
+ declare
+ Left_Str : constant Node_Id := Get_String_Val (Left);
+ Right_Str : constant Node_Id := Get_String_Val (Right);
+
+ begin
+ -- Establish new string literal, and store left operand. We make
+ -- sure to use the special Start_String that takes an operand if
+ -- the left operand is a string literal. Since this is optimized
+ -- in the case where that is the most recently created string
+ -- literal, we ensure efficient time/space behavior for the
+ -- case of a concatenation of a series of string literals.
+
+ if Nkind (Left_Str) = N_String_Literal then
+ Start_String (Strval (Left_Str));
+ else
+ Start_String;
+ Store_String_Char (Char_Literal_Value (Left_Str));
+ end if;
+
+ -- Now append the characters of the right operand
+
+ if Nkind (Right_Str) = N_String_Literal then
+ declare
+ S : constant String_Id := Strval (Right_Str);
+
+ begin
+ for J in 1 .. String_Length (S) loop
+ Store_String_Char (Get_String_Char (S, J));
+ end loop;
+ end;
+ else
+ Store_String_Char (Char_Literal_Value (Right_Str));
+ end if;
+
+ Set_Is_Static_Expression (N, Stat);
+
+ if Stat then
+ Fold_Str (N, End_String);
+ end if;
+ end;
+ end Eval_Concatenation;
+
+ ---------------------------------
+ -- Eval_Conditional_Expression --
+ ---------------------------------
+
+ -- This GNAT internal construct can never be statically folded, so the
+ -- only required processing is to do the check for non-static context
+ -- for the two expression operands.
+
+ procedure Eval_Conditional_Expression (N : Node_Id) is
+ Condition : constant Node_Id := First (Expressions (N));
+ Then_Expr : constant Node_Id := Next (Condition);
+ Else_Expr : constant Node_Id := Next (Then_Expr);
+
+ begin
+ Check_Non_Static_Context (Then_Expr);
+ Check_Non_Static_Context (Else_Expr);
+ end Eval_Conditional_Expression;
+
+ ----------------------
+ -- Eval_Entity_Name --
+ ----------------------
+
+ -- This procedure is used for identifiers and expanded names other than
+ -- named numbers (see Eval_Named_Integer, Eval_Named_Real. These are
+ -- static if they denote a static constant (RM 4.9(6)) or if the name
+ -- denotes an enumeration literal (RM 4.9(22)).
+
+ procedure Eval_Entity_Name (N : Node_Id) is
+ Def_Id : constant Entity_Id := Entity (N);
+ Val : Node_Id;
+
+ begin
+ -- Enumeration literals are always considered to be constants
+ -- and cannot raise constraint error (RM 4.9(22)).
+
+ if Ekind (Def_Id) = E_Enumeration_Literal then
+ Set_Is_Static_Expression (N);
+ return;
+
+ -- A name is static if it denotes a static constant (RM 4.9(5)), and
+ -- we also copy Raise_Constraint_Error. Notice that even if non-static,
+ -- it does not violate 10.2.1(8) here, since this is not a variable.
+
+ elsif Ekind (Def_Id) = E_Constant then
+
+ -- Deferred constants must always be treated as nonstatic
+ -- outside the scope of their full view.
+
+ if Present (Full_View (Def_Id))
+ and then not In_Open_Scopes (Scope (Def_Id))
+ then
+ Val := Empty;
+ else
+ Val := Constant_Value (Def_Id);
+ end if;
+
+ if Present (Val) then
+ Set_Is_Static_Expression
+ (N, Is_Static_Expression (Val)
+ and then Is_Static_Subtype (Etype (Def_Id)));
+ Set_Raises_Constraint_Error (N, Raises_Constraint_Error (Val));
+
+ if not Is_Static_Expression (N)
+ and then not Is_Generic_Type (Etype (N))
+ then
+ Validate_Static_Object_Name (N);
+ end if;
+
+ return;
+ end if;
+ end if;
+
+ -- Fall through if the name is not static.
+
+ Validate_Static_Object_Name (N);
+ end Eval_Entity_Name;
+
+ ----------------------------
+ -- Eval_Indexed_Component --
+ ----------------------------
+
+ -- Indexed components are never static, so the only required processing
+ -- is to perform the check for non-static context on the index values.
+
+ procedure Eval_Indexed_Component (N : Node_Id) is
+ Expr : Node_Id;
+
+ begin
+ Expr := First (Expressions (N));
+ while Present (Expr) loop
+ Check_Non_Static_Context (Expr);
+ Next (Expr);
+ end loop;
+
+ end Eval_Indexed_Component;
+
+ --------------------------
+ -- Eval_Integer_Literal --
+ --------------------------
+
+ -- Numeric literals are static (RM 4.9(1)), and have already been marked
+ -- as static by the analyzer. The reason we did it that early is to allow
+ -- the possibility of turning off the Is_Static_Expression flag after
+ -- analysis, but before resolution, when integer literals are generated
+ -- in the expander that do not correspond to static expressions.
+
+ procedure Eval_Integer_Literal (N : Node_Id) is
+ T : constant Entity_Id := Etype (N);
+
+ begin
+ -- If the literal appears in a non-expression context, then it is
+ -- certainly appearing in a non-static context, so check it. This
+ -- is actually a redundant check, since Check_Non_Static_Context
+ -- would check it, but it seems worth while avoiding the call.
+
+ if Nkind (Parent (N)) not in N_Subexpr then
+ Check_Non_Static_Context (N);
+ end if;
+
+ -- Modular integer literals must be in their base range
+
+ if Is_Modular_Integer_Type (T)
+ and then Is_Out_Of_Range (N, Base_Type (T))
+ then
+ Out_Of_Range (N);
+ end if;
+ end Eval_Integer_Literal;
+
+ ---------------------
+ -- Eval_Logical_Op --
+ ---------------------
+
+ -- Logical operations are static functions, so the result is potentially
+ -- static if both operands are potentially static (RM 4.9(7), 4.9(20)).
+
+ procedure Eval_Logical_Op (N : Node_Id) is
+ Left : constant Node_Id := Left_Opnd (N);
+ Right : constant Node_Id := Right_Opnd (N);
+ Stat : Boolean;
+ Fold : Boolean;
+
+ begin
+ -- If not foldable we are done
+
+ Test_Expression_Is_Foldable (N, Left, Right, Stat, Fold);
+
+ if not Fold then
+ return;
+ end if;
+
+ -- Compile time evaluation of logical operation
+
+ declare
+ Left_Int : constant Uint := Expr_Value (Left);
+ Right_Int : constant Uint := Expr_Value (Right);
+
+ begin
+ if Is_Modular_Integer_Type (Etype (N)) then
+ declare
+ Left_Bits : Bits (0 .. UI_To_Int (Esize (Etype (N))) - 1);
+ Right_Bits : Bits (0 .. UI_To_Int (Esize (Etype (N))) - 1);
+
+ begin
+ To_Bits (Left_Int, Left_Bits);
+ To_Bits (Right_Int, Right_Bits);
+
+ -- Note: should really be able to use array ops instead of
+ -- these loops, but they weren't working at the time ???
+
+ if Nkind (N) = N_Op_And then
+ for J in Left_Bits'Range loop
+ Left_Bits (J) := Left_Bits (J) and Right_Bits (J);
+ end loop;
+
+ elsif Nkind (N) = N_Op_Or then
+ for J in Left_Bits'Range loop
+ Left_Bits (J) := Left_Bits (J) or Right_Bits (J);
+ end loop;
+
+ else
+ pragma Assert (Nkind (N) = N_Op_Xor);
+
+ for J in Left_Bits'Range loop
+ Left_Bits (J) := Left_Bits (J) xor Right_Bits (J);
+ end loop;
+ end if;
+
+ Fold_Uint (N, From_Bits (Left_Bits, Etype (N)));
+ end;
+
+ else
+ pragma Assert (Is_Boolean_Type (Etype (N)));
+
+ if Nkind (N) = N_Op_And then
+ Fold_Uint (N,
+ Test (Is_True (Left_Int) and then Is_True (Right_Int)));
+
+ elsif Nkind (N) = N_Op_Or then
+ Fold_Uint (N,
+ Test (Is_True (Left_Int) or else Is_True (Right_Int)));
+
+ else
+ pragma Assert (Nkind (N) = N_Op_Xor);
+ Fold_Uint (N,
+ Test (Is_True (Left_Int) xor Is_True (Right_Int)));
+ end if;
+ end if;
+
+ Set_Is_Static_Expression (N, Stat);
+ end;
+ end Eval_Logical_Op;
+
+ ------------------------
+ -- Eval_Membership_Op --
+ ------------------------
+
+ -- A membership test is potentially static if the expression is static,
+ -- and the range is a potentially static range, or is a subtype mark
+ -- denoting a static subtype (RM 4.9(12)).
+
+ procedure Eval_Membership_Op (N : Node_Id) is
+ Left : constant Node_Id := Left_Opnd (N);
+ Right : constant Node_Id := Right_Opnd (N);
+ Def_Id : Entity_Id;
+ Lo : Node_Id;
+ Hi : Node_Id;
+ Result : Boolean;
+ Stat : Boolean;
+ Fold : Boolean;
+
+ begin
+ -- Ignore if error in either operand, except to make sure that
+ -- Any_Type is properly propagated to avoid junk cascaded errors.
+
+ if Etype (Left) = Any_Type
+ or else Etype (Right) = Any_Type
+ then
+ Set_Etype (N, Any_Type);
+ return;
+ end if;
+
+ -- Case of right operand is a subtype name
+
+ if Is_Entity_Name (Right) then
+ Def_Id := Entity (Right);
+
+ if (Is_Scalar_Type (Def_Id) or else Is_String_Type (Def_Id))
+ and then Is_OK_Static_Subtype (Def_Id)
+ then
+ Test_Expression_Is_Foldable (N, Left, Stat, Fold);
+
+ if not Fold or else not Stat then
+ return;
+ end if;
+ else
+ Check_Non_Static_Context (Left);
+ return;
+ end if;
+
+ -- For string membership tests we will check the length
+ -- further below.
+
+ if not Is_String_Type (Def_Id) then
+ Lo := Type_Low_Bound (Def_Id);
+ Hi := Type_High_Bound (Def_Id);
+
+ else
+ Lo := Empty;
+ Hi := Empty;
+ end if;
+
+ -- Case of right operand is a range
+
+ else
+ if Is_Static_Range (Right) then
+ Test_Expression_Is_Foldable (N, Left, Stat, Fold);
+
+ if not Fold or else not Stat then
+ return;
+
+ -- If one bound of range raises CE, then don't try to fold
+
+ elsif not Is_OK_Static_Range (Right) then
+ Check_Non_Static_Context (Left);
+ return;
+ end if;
+
+ else
+ Check_Non_Static_Context (Left);
+ return;
+ end if;
+
+ -- Here we know range is an OK static range
+
+ Lo := Low_Bound (Right);
+ Hi := High_Bound (Right);
+ end if;
+
+ -- For strings we check that the length of the string expression is
+ -- compatible with the string subtype if the subtype is constrained,
+ -- or if unconstrained then the test is always true.
+
+ if Is_String_Type (Etype (Right)) then
+ if not Is_Constrained (Etype (Right)) then
+ Result := True;
+
+ else
+ declare
+ Typlen : constant Uint := String_Type_Len (Etype (Right));
+ Strlen : constant Uint :=
+ UI_From_Int (String_Length (Strval (Get_String_Val (Left))));
+ begin
+ Result := (Typlen = Strlen);
+ end;
+ end if;
+
+ -- Fold the membership test. We know we have a static range and Lo
+ -- and Hi are set to the expressions for the end points of this range.
+
+ elsif Is_Real_Type (Etype (Right)) then
+ declare
+ Leftval : constant Ureal := Expr_Value_R (Left);
+
+ begin
+ Result := Expr_Value_R (Lo) <= Leftval
+ and then Leftval <= Expr_Value_R (Hi);
+ end;
+
+ else
+ declare
+ Leftval : constant Uint := Expr_Value (Left);
+
+ begin
+ Result := Expr_Value (Lo) <= Leftval
+ and then Leftval <= Expr_Value (Hi);
+ end;
+ end if;
+
+ if Nkind (N) = N_Not_In then
+ Result := not Result;
+ end if;
+
+ Fold_Uint (N, Test (Result));
+ Warn_On_Known_Condition (N);
+
+ end Eval_Membership_Op;
+
+ ------------------------
+ -- Eval_Named_Integer --
+ ------------------------
+
+ procedure Eval_Named_Integer (N : Node_Id) is
+ begin
+ Fold_Uint (N,
+ Expr_Value (Expression (Declaration_Node (Entity (N)))));
+ end Eval_Named_Integer;
+
+ ---------------------
+ -- Eval_Named_Real --
+ ---------------------
+
+ procedure Eval_Named_Real (N : Node_Id) is
+ begin
+ Fold_Ureal (N,
+ Expr_Value_R (Expression (Declaration_Node (Entity (N)))));
+ end Eval_Named_Real;
+
+ -------------------
+ -- Eval_Op_Expon --
+ -------------------
+
+ -- Exponentiation is a static functions, so the result is potentially
+ -- static if both operands are potentially static (RM 4.9(7), 4.9(20)).
+
+ procedure Eval_Op_Expon (N : Node_Id) is
+ Left : constant Node_Id := Left_Opnd (N);
+ Right : constant Node_Id := Right_Opnd (N);
+ Stat : Boolean;
+ Fold : Boolean;
+
+ begin
+ -- If not foldable we are done
+
+ Test_Expression_Is_Foldable (N, Left, Right, Stat, Fold);
+
+ if not Fold then
+ return;
+ end if;
+
+ -- Fold exponentiation operation
+
+ declare
+ Right_Int : constant Uint := Expr_Value (Right);
+
+ begin
+ -- Integer case
+
+ if Is_Integer_Type (Etype (Left)) then
+ declare
+ Left_Int : constant Uint := Expr_Value (Left);
+ Result : Uint;
+
+ begin
+ -- Exponentiation of an integer raises the exception
+ -- Constraint_Error for a negative exponent (RM 4.5.6)
+
+ if Right_Int < 0 then
+ Apply_Compile_Time_Constraint_Error
+ (N, "integer exponent negative");
+ return;
+
+ else
+ if OK_Bits (N, Num_Bits (Left_Int) * Right_Int) then
+ Result := Left_Int ** Right_Int;
+ else
+ Result := Left_Int;
+ end if;
+
+ if Is_Modular_Integer_Type (Etype (N)) then
+ Result := Result mod Modulus (Etype (N));
+ end if;
+
+ Fold_Uint (N, Result);
+ end if;
+ end;
+
+ -- Real case
+
+ else
+ declare
+ Left_Real : constant Ureal := Expr_Value_R (Left);
+
+ begin
+ -- Cannot have a zero base with a negative exponent
+
+ if UR_Is_Zero (Left_Real) then
+
+ if Right_Int < 0 then
+ Apply_Compile_Time_Constraint_Error
+ (N, "zero ** negative integer");
+ return;
+ else
+ Fold_Ureal (N, Ureal_0);
+ end if;
+
+ else
+ Fold_Ureal (N, Left_Real ** Right_Int);
+ end if;
+ end;
+ end if;
+
+ Set_Is_Static_Expression (N, Stat);
+ end;
+ end Eval_Op_Expon;
+
+ -----------------
+ -- Eval_Op_Not --
+ -----------------
+
+ -- The not operation is a static functions, so the result is potentially
+ -- static if the operand is potentially static (RM 4.9(7), 4.9(20)).
+
+ procedure Eval_Op_Not (N : Node_Id) is
+ Right : constant Node_Id := Right_Opnd (N);
+ Stat : Boolean;
+ Fold : Boolean;
+
+ begin
+ -- If not foldable we are done
+
+ Test_Expression_Is_Foldable (N, Right, Stat, Fold);
+
+ if not Fold then
+ return;
+ end if;
+
+ -- Fold not operation
+
+ declare
+ Rint : constant Uint := Expr_Value (Right);
+ Typ : constant Entity_Id := Etype (N);
+
+ begin
+ -- Negation is equivalent to subtracting from the modulus minus
+ -- one. For a binary modulus this is equivalent to the ones-
+ -- component of the original value. For non-binary modulus this
+ -- is an arbitrary but consistent definition.
+
+ if Is_Modular_Integer_Type (Typ) then
+ Fold_Uint (N, Modulus (Typ) - 1 - Rint);
+
+ else
+ pragma Assert (Is_Boolean_Type (Typ));
+ Fold_Uint (N, Test (not Is_True (Rint)));
+ end if;
+
+ Set_Is_Static_Expression (N, Stat);
+ end;
+ end Eval_Op_Not;
+
+ -------------------------------
+ -- Eval_Qualified_Expression --
+ -------------------------------
+
+ -- A qualified expression is potentially static if its subtype mark denotes
+ -- a static subtype and its expression is potentially static (RM 4.9 (11)).
+
+ procedure Eval_Qualified_Expression (N : Node_Id) is
+ Operand : constant Node_Id := Expression (N);
+ Target_Type : constant Entity_Id := Entity (Subtype_Mark (N));
+
+ Stat : Boolean;
+ Fold : Boolean;
+
+ begin
+ -- Can only fold if target is string or scalar and subtype is static
+ -- Also, do not fold if our parent is an allocator (this is because
+ -- the qualified expression is really part of the syntactic structure
+ -- of an allocator, and we do not want to end up with something that
+ -- corresponds to "new 1" where the 1 is the result of folding a
+ -- qualified expression).
+
+ if not Is_Static_Subtype (Target_Type)
+ or else Nkind (Parent (N)) = N_Allocator
+ then
+ Check_Non_Static_Context (Operand);
+ return;
+ end if;
+
+ -- If not foldable we are done
+
+ Test_Expression_Is_Foldable (N, Operand, Stat, Fold);
+
+ if not Fold then
+ return;
+
+ -- Don't try fold if target type has constraint error bounds
+
+ elsif not Is_OK_Static_Subtype (Target_Type) then
+ Set_Raises_Constraint_Error (N);
+ return;
+ end if;
+
+ -- Fold the result of qualification
+
+ if Is_Discrete_Type (Target_Type) then
+ Fold_Uint (N, Expr_Value (Operand));
+ Set_Is_Static_Expression (N, Stat);
+
+ elsif Is_Real_Type (Target_Type) then
+ Fold_Ureal (N, Expr_Value_R (Operand));
+ Set_Is_Static_Expression (N, Stat);
+
+ else
+ Fold_Str (N, Strval (Get_String_Val (Operand)));
+
+ if not Stat then
+ Set_Is_Static_Expression (N, False);
+ else
+ Check_String_Literal_Length (N, Target_Type);
+ end if;
+
+ return;
+ end if;
+
+ if Is_Out_Of_Range (N, Etype (N)) then
+ Out_Of_Range (N);
+ end if;
+
+ end Eval_Qualified_Expression;
+
+ -----------------------
+ -- Eval_Real_Literal --
+ -----------------------
+
+ -- Numeric literals are static (RM 4.9(1)), and have already been marked
+ -- as static by the analyzer. The reason we did it that early is to allow
+ -- the possibility of turning off the Is_Static_Expression flag after
+ -- analysis, but before resolution, when integer literals are generated
+ -- in the expander that do not correspond to static expressions.
+
+ procedure Eval_Real_Literal (N : Node_Id) is
+ begin
+ -- If the literal appears in a non-expression context, then it is
+ -- certainly appearing in a non-static context, so check it.
+
+ if Nkind (Parent (N)) not in N_Subexpr then
+ Check_Non_Static_Context (N);
+ end if;
+
+ end Eval_Real_Literal;
+
+ ------------------------
+ -- Eval_Relational_Op --
+ ------------------------
+
+ -- Relational operations are static functions, so the result is static
+ -- if both operands are static (RM 4.9(7), 4.9(20)).
+
+ procedure Eval_Relational_Op (N : Node_Id) is
+ Left : constant Node_Id := Left_Opnd (N);
+ Right : constant Node_Id := Right_Opnd (N);
+ Typ : constant Entity_Id := Etype (Left);
+ Result : Boolean;
+ Stat : Boolean;
+ Fold : Boolean;
+
+ begin
+ -- One special case to deal with first. If we can tell that
+ -- the result will be false because the lengths of one or
+ -- more index subtypes are compile time known and different,
+ -- then we can replace the entire result by False. We only
+ -- do this for one dimensional arrays, because the case of
+ -- multi-dimensional arrays is rare and too much trouble!
+
+ if Is_Array_Type (Typ)
+ and then Number_Dimensions (Typ) = 1
+ and then (Nkind (N) = N_Op_Eq
+ or else Nkind (N) = N_Op_Ne)
+ then
+ if Raises_Constraint_Error (Left)
+ or else Raises_Constraint_Error (Right)
+ then
+ return;
+ end if;
+
+ declare
+ procedure Get_Static_Length (Op : Node_Id; Len : out Uint);
+ -- If Op is an expression for a constrained array with a
+ -- known at compile time length, then Len is set to this
+ -- (non-negative length). Otherwise Len is set to minus 1.
+
+ procedure Get_Static_Length (Op : Node_Id; Len : out Uint) is
+ T : Entity_Id;
+
+ begin
+ if Nkind (Op) = N_String_Literal then
+ Len := UI_From_Int (String_Length (Strval (Op)));
+
+ elsif not Is_Constrained (Etype (Op)) then
+ Len := Uint_Minus_1;
+
+ else
+ T := Etype (First_Index (Etype (Op)));
+
+ if Is_Discrete_Type (T)
+ and then
+ Compile_Time_Known_Value (Type_Low_Bound (T))
+ and then
+ Compile_Time_Known_Value (Type_High_Bound (T))
+ then
+ Len := UI_Max (Uint_0,
+ Expr_Value (Type_High_Bound (T)) -
+ Expr_Value (Type_Low_Bound (T)) + 1);
+ else
+ Len := Uint_Minus_1;
+ end if;
+ end if;
+ end Get_Static_Length;
+
+ Len_L : Uint;
+ Len_R : Uint;
+
+ begin
+ Get_Static_Length (Left, Len_L);
+ Get_Static_Length (Right, Len_R);
+
+ if Len_L /= Uint_Minus_1
+ and then Len_R /= Uint_Minus_1
+ and then Len_L /= Len_R
+ then
+ Fold_Uint (N, Test (Nkind (N) = N_Op_Ne));
+ Set_Is_Static_Expression (N, False);
+ Warn_On_Known_Condition (N);
+ return;
+ end if;
+ end;
+ end if;
+
+ -- Can only fold if type is scalar (don't fold string ops)
+
+ if not Is_Scalar_Type (Typ) then
+ Check_Non_Static_Context (Left);
+ Check_Non_Static_Context (Right);
+ return;
+ end if;
+
+ -- If not foldable we are done
+
+ Test_Expression_Is_Foldable (N, Left, Right, Stat, Fold);
+
+ if not Fold then
+ return;
+ end if;
+
+ -- Integer and Enumeration (discrete) type cases
+
+ if Is_Discrete_Type (Typ) then
+ declare
+ Left_Int : constant Uint := Expr_Value (Left);
+ Right_Int : constant Uint := Expr_Value (Right);
+
+ begin
+ case Nkind (N) is
+ when N_Op_Eq => Result := Left_Int = Right_Int;
+ when N_Op_Ne => Result := Left_Int /= Right_Int;
+ when N_Op_Lt => Result := Left_Int < Right_Int;
+ when N_Op_Le => Result := Left_Int <= Right_Int;
+ when N_Op_Gt => Result := Left_Int > Right_Int;
+ when N_Op_Ge => Result := Left_Int >= Right_Int;
+
+ when others =>
+ raise Program_Error;
+ end case;
+
+ Fold_Uint (N, Test (Result));
+ end;
+
+ -- Real type case
+
+ else
+ pragma Assert (Is_Real_Type (Typ));
+
+ declare
+ Left_Real : constant Ureal := Expr_Value_R (Left);
+ Right_Real : constant Ureal := Expr_Value_R (Right);
+
+ begin
+ case Nkind (N) is
+ when N_Op_Eq => Result := (Left_Real = Right_Real);
+ when N_Op_Ne => Result := (Left_Real /= Right_Real);
+ when N_Op_Lt => Result := (Left_Real < Right_Real);
+ when N_Op_Le => Result := (Left_Real <= Right_Real);
+ when N_Op_Gt => Result := (Left_Real > Right_Real);
+ when N_Op_Ge => Result := (Left_Real >= Right_Real);
+
+ when others =>
+ raise Program_Error;
+ end case;
+
+ Fold_Uint (N, Test (Result));
+ end;
+ end if;
+
+ Set_Is_Static_Expression (N, Stat);
+ Warn_On_Known_Condition (N);
+ end Eval_Relational_Op;
+
+ ----------------
+ -- Eval_Shift --
+ ----------------
+
+ -- Shift operations are intrinsic operations that can never be static,
+ -- so the only processing required is to perform the required check for
+ -- a non static context for the two operands.
+
+ -- Actually we could do some compile time evaluation here some time ???
+
+ procedure Eval_Shift (N : Node_Id) is
+ begin
+ Check_Non_Static_Context (Left_Opnd (N));
+ Check_Non_Static_Context (Right_Opnd (N));
+ end Eval_Shift;
+
+ ------------------------
+ -- Eval_Short_Circuit --
+ ------------------------
+
+ -- A short circuit operation is potentially static if both operands
+ -- are potentially static (RM 4.9 (13))
+
+ procedure Eval_Short_Circuit (N : Node_Id) is
+ Kind : constant Node_Kind := Nkind (N);
+ Left : constant Node_Id := Left_Opnd (N);
+ Right : constant Node_Id := Right_Opnd (N);
+ Left_Int : Uint;
+ Rstat : constant Boolean :=
+ Is_Static_Expression (Left)
+ and then Is_Static_Expression (Right);
+
+ begin
+ -- Short circuit operations are never static in Ada 83
+
+ if Ada_83
+ and then Comes_From_Source (N)
+ then
+ Check_Non_Static_Context (Left);
+ Check_Non_Static_Context (Right);
+ return;
+ end if;
+
+ -- Now look at the operands, we can't quite use the normal call to
+ -- Test_Expression_Is_Foldable here because short circuit operations
+ -- are a special case, they can still be foldable, even if the right
+ -- operand raises constraint error.
+
+ -- If either operand is Any_Type, just propagate to result and
+ -- do not try to fold, this prevents cascaded errors.
+
+ if Etype (Left) = Any_Type or else Etype (Right) = Any_Type then
+ Set_Etype (N, Any_Type);
+ return;
+
+ -- If left operand raises constraint error, then replace node N with
+ -- the raise constraint error node, and we are obviously not foldable.
+ -- Is_Static_Expression is set from the two operands in the normal way,
+ -- and we check the right operand if it is in a non-static context.
+
+ elsif Raises_Constraint_Error (Left) then
+ if not Rstat then
+ Check_Non_Static_Context (Right);
+ end if;
+
+ Rewrite_In_Raise_CE (N, Left);
+ Set_Is_Static_Expression (N, Rstat);
+ return;
+
+ -- If the result is not static, then we won't in any case fold
+
+ elsif not Rstat then
+ Check_Non_Static_Context (Left);
+ Check_Non_Static_Context (Right);
+ return;
+ end if;
+
+ -- Here the result is static, note that, unlike the normal processing
+ -- in Test_Expression_Is_Foldable, we did *not* check above to see if
+ -- the right operand raises constraint error, that's because it is not
+ -- significant if the left operand is decisive.
+
+ Set_Is_Static_Expression (N);
+
+ -- It does not matter if the right operand raises constraint error if
+ -- it will not be evaluated. So deal specially with the cases where
+ -- the right operand is not evaluated. Note that we will fold these
+ -- cases even if the right operand is non-static, which is fine, but
+ -- of course in these cases the result is not potentially static.
+
+ Left_Int := Expr_Value (Left);
+
+ if (Kind = N_And_Then and then Is_False (Left_Int))
+ or else (Kind = N_Or_Else and Is_True (Left_Int))
+ then
+ Fold_Uint (N, Left_Int);
+ return;
+ end if;
+
+ -- If first operand not decisive, then it does matter if the right
+ -- operand raises constraint error, since it will be evaluated, so
+ -- we simply replace the node with the right operand. Note that this
+ -- properly propagates Is_Static_Expression and Raises_Constraint_Error
+ -- (both are set to True in Right).
+
+ if Raises_Constraint_Error (Right) then
+ Rewrite_In_Raise_CE (N, Right);
+ Check_Non_Static_Context (Left);
+ return;
+ end if;
+
+ -- Otherwise the result depends on the right operand
+
+ Fold_Uint (N, Expr_Value (Right));
+ return;
+
+ end Eval_Short_Circuit;
+
+ ----------------
+ -- Eval_Slice --
+ ----------------
+
+ -- Slices can never be static, so the only processing required is to
+ -- check for non-static context if an explicit range is given.
+
+ procedure Eval_Slice (N : Node_Id) is
+ Drange : constant Node_Id := Discrete_Range (N);
+
+ begin
+ if Nkind (Drange) = N_Range then
+ Check_Non_Static_Context (Low_Bound (Drange));
+ Check_Non_Static_Context (High_Bound (Drange));
+ end if;
+ end Eval_Slice;
+
+ -------------------------
+ -- Eval_String_Literal --
+ -------------------------
+
+ procedure Eval_String_Literal (N : Node_Id) is
+ T : constant Entity_Id := Etype (N);
+ B : constant Entity_Id := Base_Type (T);
+ I : Entity_Id;
+
+ begin
+ -- Nothing to do if error type (handles cases like default expressions
+ -- or generics where we have not yet fully resolved the type)
+
+ if B = Any_Type or else B = Any_String then
+ return;
+
+ -- String literals are static if the subtype is static (RM 4.9(2)), so
+ -- reset the static expression flag (it was set unconditionally in
+ -- Analyze_String_Literal) if the subtype is non-static. We tell if
+ -- the subtype is static by looking at the lower bound.
+
+ elsif not Is_OK_Static_Expression (String_Literal_Low_Bound (T)) then
+ Set_Is_Static_Expression (N, False);
+
+ elsif Nkind (Original_Node (N)) = N_Type_Conversion then
+ Set_Is_Static_Expression (N, False);
+
+ -- Test for illegal Ada 95 cases. A string literal is illegal in
+ -- Ada 95 if its bounds are outside the index base type and this
+ -- index type is static. This can hapen in only two ways. Either
+ -- the string literal is too long, or it is null, and the lower
+ -- bound is type'First. In either case it is the upper bound that
+ -- is out of range of the index type.
+
+ elsif Ada_95 then
+ if Root_Type (B) = Standard_String
+ or else Root_Type (B) = Standard_Wide_String
+ then
+ I := Standard_Positive;
+ else
+ I := Etype (First_Index (B));
+ end if;
+
+ if String_Literal_Length (T) > String_Type_Len (B) then
+ Apply_Compile_Time_Constraint_Error
+ (N, "string literal too long for}",
+ Ent => B,
+ Typ => First_Subtype (B));
+
+ elsif String_Literal_Length (T) = 0
+ and then not Is_Generic_Type (I)
+ and then Expr_Value (String_Literal_Low_Bound (T)) =
+ Expr_Value (Type_Low_Bound (Base_Type (I)))
+ then
+ Apply_Compile_Time_Constraint_Error
+ (N, "null string literal not allowed for}",
+ Ent => B,
+ Typ => First_Subtype (B));
+ end if;
+ end if;
+
+ end Eval_String_Literal;
+
+ --------------------------
+ -- Eval_Type_Conversion --
+ --------------------------
+
+ -- A type conversion is potentially static if its subtype mark is for a
+ -- static scalar subtype, and its operand expression is potentially static
+ -- (RM 4.9 (10))
+
+ procedure Eval_Type_Conversion (N : Node_Id) is
+ Operand : constant Node_Id := Expression (N);
+ Source_Type : constant Entity_Id := Etype (Operand);
+ Target_Type : constant Entity_Id := Etype (N);
+
+ Stat : Boolean;
+ Fold : Boolean;
+
+ function To_Be_Treated_As_Integer (T : Entity_Id) return Boolean;
+ -- Returns true if type T is an integer type, or if it is a
+ -- fixed-point type to be treated as an integer (i.e. the flag
+ -- Conversion_OK is set on the conversion node).
+
+ function To_Be_Treated_As_Real (T : Entity_Id) return Boolean;
+ -- Returns true if type T is a floating-point type, or if it is a
+ -- fixed-point type that is not to be treated as an integer (i.e. the
+ -- flag Conversion_OK is not set on the conversion node).
+
+ function To_Be_Treated_As_Integer (T : Entity_Id) return Boolean is
+ begin
+ return
+ Is_Integer_Type (T)
+ or else (Is_Fixed_Point_Type (T) and then Conversion_OK (N));
+ end To_Be_Treated_As_Integer;
+
+ function To_Be_Treated_As_Real (T : Entity_Id) return Boolean is
+ begin
+ return
+ Is_Floating_Point_Type (T)
+ or else (Is_Fixed_Point_Type (T) and then not Conversion_OK (N));
+ end To_Be_Treated_As_Real;
+
+ -- Start of processing for Eval_Type_Conversion
+
+ begin
+ -- Cannot fold if target type is non-static or if semantic error.
+
+ if not Is_Static_Subtype (Target_Type) then
+ Check_Non_Static_Context (Operand);
+ return;
+
+ elsif Error_Posted (N) then
+ return;
+ end if;
+
+ -- If not foldable we are done
+
+ Test_Expression_Is_Foldable (N, Operand, Stat, Fold);
+
+ if not Fold then
+ return;
+
+ -- Don't try fold if target type has constraint error bounds
+
+ elsif not Is_OK_Static_Subtype (Target_Type) then
+ Set_Raises_Constraint_Error (N);
+ return;
+ end if;
+
+ -- Remaining processing depends on operand types. Note that in the
+ -- following type test, fixed-point counts as real unless the flag
+ -- Conversion_OK is set, in which case it counts as integer.
+
+ -- Fold conversion, case of string type. The result is not static.
+
+ if Is_String_Type (Target_Type) then
+ Fold_Str (N, Strval (Get_String_Val (Operand)));
+ Set_Is_Static_Expression (N, False);
+
+ return;
+
+ -- Fold conversion, case of integer target type
+
+ elsif To_Be_Treated_As_Integer (Target_Type) then
+ declare
+ Result : Uint;
+
+ begin
+ -- Integer to integer conversion
+
+ if To_Be_Treated_As_Integer (Source_Type) then
+ Result := Expr_Value (Operand);
+
+ -- Real to integer conversion
+
+ else
+ Result := UR_To_Uint (Expr_Value_R (Operand));
+ end if;
+
+ -- If fixed-point type (Conversion_OK must be set), then the
+ -- result is logically an integer, but we must replace the
+ -- conversion with the corresponding real literal, since the
+ -- type from a semantic point of view is still fixed-point.
+
+ if Is_Fixed_Point_Type (Target_Type) then
+ Fold_Ureal
+ (N, UR_From_Uint (Result) * Small_Value (Target_Type));
+
+ -- Otherwise result is integer literal
+
+ else
+ Fold_Uint (N, Result);
+ end if;
+ end;
+
+ -- Fold conversion, case of real target type
+
+ elsif To_Be_Treated_As_Real (Target_Type) then
+ declare
+ Result : Ureal;
+
+ begin
+ if To_Be_Treated_As_Real (Source_Type) then
+ Result := Expr_Value_R (Operand);
+ else
+ Result := UR_From_Uint (Expr_Value (Operand));
+ end if;
+
+ Fold_Ureal (N, Result);
+ end;
+
+ -- Enumeration types
+
+ else
+ Fold_Uint (N, Expr_Value (Operand));
+ end if;
+
+ Set_Is_Static_Expression (N, Stat);
+
+ if Is_Out_Of_Range (N, Etype (N)) then
+ Out_Of_Range (N);
+ end if;
+
+ end Eval_Type_Conversion;
+
+ -------------------
+ -- Eval_Unary_Op --
+ -------------------
+
+ -- Predefined unary operators are static functions (RM 4.9(20)) and thus
+ -- are potentially static if the operand is potentially static (RM 4.9(7))
+
+ procedure Eval_Unary_Op (N : Node_Id) is
+ Right : constant Node_Id := Right_Opnd (N);
+ Stat : Boolean;
+ Fold : Boolean;
+
+ begin
+ -- If not foldable we are done
+
+ Test_Expression_Is_Foldable (N, Right, Stat, Fold);
+
+ if not Fold then
+ return;
+ end if;
+
+ -- Fold for integer case
+
+ if Is_Integer_Type (Etype (N)) then
+ declare
+ Rint : constant Uint := Expr_Value (Right);
+ Result : Uint;
+
+ begin
+ -- In the case of modular unary plus and abs there is no need
+ -- to adjust the result of the operation since if the original
+ -- operand was in bounds the result will be in the bounds of the
+ -- modular type. However, in the case of modular unary minus the
+ -- result may go out of the bounds of the modular type and needs
+ -- adjustment.
+
+ if Nkind (N) = N_Op_Plus then
+ Result := Rint;
+
+ elsif Nkind (N) = N_Op_Minus then
+ if Is_Modular_Integer_Type (Etype (N)) then
+ Result := (-Rint) mod Modulus (Etype (N));
+ else
+ Result := (-Rint);
+ end if;
+
+ else
+ pragma Assert (Nkind (N) = N_Op_Abs);
+ Result := abs Rint;
+ end if;
+
+ Fold_Uint (N, Result);
+ end;
+
+ -- Fold for real case
+
+ elsif Is_Real_Type (Etype (N)) then
+ declare
+ Rreal : constant Ureal := Expr_Value_R (Right);
+ Result : Ureal;
+
+ begin
+ if Nkind (N) = N_Op_Plus then
+ Result := Rreal;
+
+ elsif Nkind (N) = N_Op_Minus then
+ Result := UR_Negate (Rreal);
+
+ else
+ pragma Assert (Nkind (N) = N_Op_Abs);
+ Result := abs Rreal;
+ end if;
+
+ Fold_Ureal (N, Result);
+ end;
+ end if;
+
+ Set_Is_Static_Expression (N, Stat);
+
+ end Eval_Unary_Op;
+
+ -------------------------------
+ -- Eval_Unchecked_Conversion --
+ -------------------------------
+
+ -- Unchecked conversions can never be static, so the only required
+ -- processing is to check for a non-static context for the operand.
+
+ procedure Eval_Unchecked_Conversion (N : Node_Id) is
+ begin
+ Check_Non_Static_Context (Expression (N));
+ end Eval_Unchecked_Conversion;
+
+ --------------------
+ -- Expr_Rep_Value --
+ --------------------
+
+ function Expr_Rep_Value (N : Node_Id) return Uint is
+ Kind : constant Node_Kind := Nkind (N);
+ Ent : Entity_Id;
+
+ begin
+ if Is_Entity_Name (N) then
+ Ent := Entity (N);
+
+ -- An enumeration literal that was either in the source or
+ -- created as a result of static evaluation.
+
+ if Ekind (Ent) = E_Enumeration_Literal then
+ return Enumeration_Rep (Ent);
+
+ -- A user defined static constant
+
+ else
+ pragma Assert (Ekind (Ent) = E_Constant);
+ return Expr_Rep_Value (Constant_Value (Ent));
+ end if;
+
+ -- An integer literal that was either in the source or created
+ -- as a result of static evaluation.
+
+ elsif Kind = N_Integer_Literal then
+ return Intval (N);
+
+ -- A real literal for a fixed-point type. This must be the fixed-point
+ -- case, either the literal is of a fixed-point type, or it is a bound
+ -- of a fixed-point type, with type universal real. In either case we
+ -- obtain the desired value from Corresponding_Integer_Value.
+
+ elsif Kind = N_Real_Literal then
+
+ -- Apply the assertion to the Underlying_Type of the literal for
+ -- the benefit of calls to this function in the JGNAT back end,
+ -- where literal types can reflect private views.
+
+ pragma Assert (Is_Fixed_Point_Type (Underlying_Type (Etype (N))));
+ return Corresponding_Integer_Value (N);
+
+ else
+ pragma Assert (Kind = N_Character_Literal);
+ Ent := Entity (N);
+
+ -- Since Character literals of type Standard.Character don't
+ -- have any defining character literals built for them, they
+ -- do not have their Entity set, so just use their Char
+ -- code. Otherwise for user-defined character literals use
+ -- their Pos value as usual which is the same as the Rep value.
+
+ if No (Ent) then
+ return UI_From_Int (Int (Char_Literal_Value (N)));
+ else
+ return Enumeration_Rep (Ent);
+ end if;
+ end if;
+ end Expr_Rep_Value;
+
+ ----------------
+ -- Expr_Value --
+ ----------------
+
+ function Expr_Value (N : Node_Id) return Uint is
+ Kind : constant Node_Kind := Nkind (N);
+ Ent : Entity_Id;
+
+ begin
+ if Is_Entity_Name (N) then
+ Ent := Entity (N);
+
+ -- An enumeration literal that was either in the source or
+ -- created as a result of static evaluation.
+
+ if Ekind (Ent) = E_Enumeration_Literal then
+ return Enumeration_Pos (Ent);
+
+ -- A user defined static constant
+
+ else
+ pragma Assert (Ekind (Ent) = E_Constant);
+ return Expr_Value (Constant_Value (Ent));
+ end if;
+
+ -- An integer literal that was either in the source or created
+ -- as a result of static evaluation.
+
+ elsif Kind = N_Integer_Literal then
+ return Intval (N);
+
+ -- A real literal for a fixed-point type. This must be the fixed-point
+ -- case, either the literal is of a fixed-point type, or it is a bound
+ -- of a fixed-point type, with type universal real. In either case we
+ -- obtain the desired value from Corresponding_Integer_Value.
+
+ elsif Kind = N_Real_Literal then
+
+ -- Apply the assertion to the Underlying_Type of the literal for
+ -- the benefit of calls to this function in the JGNAT back end,
+ -- where literal types can reflect private views.
+
+ pragma Assert (Is_Fixed_Point_Type (Underlying_Type (Etype (N))));
+ return Corresponding_Integer_Value (N);
+
+ -- Peculiar VMS case, if we have xxx'Null_Parameter, return zero
+
+ elsif Kind = N_Attribute_Reference
+ and then Attribute_Name (N) = Name_Null_Parameter
+ then
+ return Uint_0;
+
+ -- Otherwise must be character literal
+
+ else
+ pragma Assert (Kind = N_Character_Literal);
+ Ent := Entity (N);
+
+ -- Since Character literals of type Standard.Character don't
+ -- have any defining character literals built for them, they
+ -- do not have their Entity set, so just use their Char
+ -- code. Otherwise for user-defined character literals use
+ -- their Pos value as usual.
+
+ if No (Ent) then
+ return UI_From_Int (Int (Char_Literal_Value (N)));
+ else
+ return Enumeration_Pos (Ent);
+ end if;
+ end if;
+
+ end Expr_Value;
+
+ ------------------
+ -- Expr_Value_E --
+ ------------------
+
+ function Expr_Value_E (N : Node_Id) return Entity_Id is
+ Ent : constant Entity_Id := Entity (N);
+
+ begin
+ if Ekind (Ent) = E_Enumeration_Literal then
+ return Ent;
+ else
+ pragma Assert (Ekind (Ent) = E_Constant);
+ return Expr_Value_E (Constant_Value (Ent));
+ end if;
+ end Expr_Value_E;
+
+ ------------------
+ -- Expr_Value_R --
+ ------------------
+
+ function Expr_Value_R (N : Node_Id) return Ureal is
+ Kind : constant Node_Kind := Nkind (N);
+ Ent : Entity_Id;
+ Expr : Node_Id;
+
+ begin
+ if Kind = N_Real_Literal then
+ return Realval (N);
+
+ elsif Kind = N_Identifier or else Kind = N_Expanded_Name then
+ Ent := Entity (N);
+ pragma Assert (Ekind (Ent) = E_Constant);
+ return Expr_Value_R (Constant_Value (Ent));
+
+ elsif Kind = N_Integer_Literal then
+ return UR_From_Uint (Expr_Value (N));
+
+ -- Strange case of VAX literals, which are at this stage transformed
+ -- into Vax_Type!x_To_y(IEEE_Literal). See Expand_N_Real_Literal in
+ -- Exp_Vfpt for further details.
+
+ elsif Vax_Float (Etype (N))
+ and then Nkind (N) = N_Unchecked_Type_Conversion
+ then
+ Expr := Expression (N);
+
+ if Nkind (Expr) = N_Function_Call
+ and then Present (Parameter_Associations (Expr))
+ then
+ Expr := First (Parameter_Associations (Expr));
+
+ if Nkind (Expr) = N_Real_Literal then
+ return Realval (Expr);
+ end if;
+ end if;
+
+ -- Peculiar VMS case, if we have xxx'Null_Parameter, return 0.0
+
+ elsif Kind = N_Attribute_Reference
+ and then Attribute_Name (N) = Name_Null_Parameter
+ then
+ return Ureal_0;
+ end if;
+
+ -- If we fall through, we have a node that cannot be interepreted
+ -- as a compile time constant. That is definitely an error.
+
+ raise Program_Error;
+ end Expr_Value_R;
+
+ ------------------
+ -- Expr_Value_S --
+ ------------------
+
+ function Expr_Value_S (N : Node_Id) return Node_Id is
+ begin
+ if Nkind (N) = N_String_Literal then
+ return N;
+ else
+ pragma Assert (Ekind (Entity (N)) = E_Constant);
+ return Expr_Value_S (Constant_Value (Entity (N)));
+ end if;
+ end Expr_Value_S;
+
+ --------------
+ -- Fold_Str --
+ --------------
+
+ procedure Fold_Str (N : Node_Id; Val : String_Id) is
+ Loc : constant Source_Ptr := Sloc (N);
+ Typ : constant Entity_Id := Etype (N);
+
+ begin
+ Rewrite (N, Make_String_Literal (Loc, Strval => Val));
+ Analyze_And_Resolve (N, Typ);
+ end Fold_Str;
+
+ ---------------
+ -- Fold_Uint --
+ ---------------
+
+ procedure Fold_Uint (N : Node_Id; Val : Uint) is
+ Loc : constant Source_Ptr := Sloc (N);
+ Typ : constant Entity_Id := Etype (N);
+
+ begin
+ -- For a result of type integer, subsitute an N_Integer_Literal node
+ -- for the result of the compile time evaluation of the expression.
+
+ if Is_Integer_Type (Etype (N)) then
+ Rewrite (N, Make_Integer_Literal (Loc, Val));
+
+ -- Otherwise we have an enumeration type, and we substitute either
+ -- an N_Identifier or N_Character_Literal to represent the enumeration
+ -- literal corresponding to the given value, which must always be in
+ -- range, because appropriate tests have already been made for this.
+
+ else pragma Assert (Is_Enumeration_Type (Etype (N)));
+ Rewrite (N, Get_Enum_Lit_From_Pos (Etype (N), Val, Loc));
+ end if;
+
+ -- We now have the literal with the right value, both the actual type
+ -- and the expected type of this literal are taken from the expression
+ -- that was evaluated.
+
+ Analyze (N);
+ Set_Etype (N, Typ);
+ Resolve (N, Typ);
+ end Fold_Uint;
+
+ ----------------
+ -- Fold_Ureal --
+ ----------------
+
+ procedure Fold_Ureal (N : Node_Id; Val : Ureal) is
+ Loc : constant Source_Ptr := Sloc (N);
+ Typ : constant Entity_Id := Etype (N);
+
+ begin
+ Rewrite (N, Make_Real_Literal (Loc, Realval => Val));
+ Analyze (N);
+
+ -- Both the actual and expected type comes from the original expression
+
+ Set_Etype (N, Typ);
+ Resolve (N, Typ);
+ end Fold_Ureal;
+
+ ---------------
+ -- From_Bits --
+ ---------------
+
+ function From_Bits (B : Bits; T : Entity_Id) return Uint is
+ V : Uint := Uint_0;
+
+ begin
+ for J in 0 .. B'Last loop
+ if B (J) then
+ V := V + 2 ** J;
+ end if;
+ end loop;
+
+ if Non_Binary_Modulus (T) then
+ V := V mod Modulus (T);
+ end if;
+
+ return V;
+ end From_Bits;
+
+ --------------------
+ -- Get_String_Val --
+ --------------------
+
+ function Get_String_Val (N : Node_Id) return Node_Id is
+ begin
+ if Nkind (N) = N_String_Literal then
+ return N;
+
+ elsif Nkind (N) = N_Character_Literal then
+ return N;
+
+ else
+ pragma Assert (Is_Entity_Name (N));
+ return Get_String_Val (Constant_Value (Entity (N)));
+ end if;
+ end Get_String_Val;
+
+ --------------------
+ -- In_Subrange_Of --
+ --------------------
+
+ function In_Subrange_Of
+ (T1 : Entity_Id;
+ T2 : Entity_Id;
+ Fixed_Int : Boolean := False)
+ return Boolean
+ is
+ L1 : Node_Id;
+ H1 : Node_Id;
+
+ L2 : Node_Id;
+ H2 : Node_Id;
+
+ begin
+ if T1 = T2 or else Is_Subtype_Of (T1, T2) then
+ return True;
+
+ -- Never in range if both types are not scalar. Don't know if this can
+ -- actually happen, but just in case.
+
+ elsif not Is_Scalar_Type (T1) or else not Is_Scalar_Type (T1) then
+ return False;
+
+ else
+ L1 := Type_Low_Bound (T1);
+ H1 := Type_High_Bound (T1);
+
+ L2 := Type_Low_Bound (T2);
+ H2 := Type_High_Bound (T2);
+
+ -- Check bounds to see if comparison possible at compile time
+
+ if Compile_Time_Compare (L1, L2) in Compare_GE
+ and then
+ Compile_Time_Compare (H1, H2) in Compare_LE
+ then
+ return True;
+ end if;
+
+ -- If bounds not comparable at compile time, then the bounds of T2
+ -- must be compile time known or we cannot answer the query.
+
+ if not Compile_Time_Known_Value (L2)
+ or else not Compile_Time_Known_Value (H2)
+ then
+ return False;
+ end if;
+
+ -- If the bounds of T1 are know at compile time then use these
+ -- ones, otherwise use the bounds of the base type (which are of
+ -- course always static).
+
+ if not Compile_Time_Known_Value (L1) then
+ L1 := Type_Low_Bound (Base_Type (T1));
+ end if;
+
+ if not Compile_Time_Known_Value (H1) then
+ H1 := Type_High_Bound (Base_Type (T1));
+ end if;
+
+ -- Fixed point types should be considered as such only if
+ -- flag Fixed_Int is set to False.
+
+ if Is_Floating_Point_Type (T1) or else Is_Floating_Point_Type (T2)
+ or else (Is_Fixed_Point_Type (T1) and then not Fixed_Int)
+ or else (Is_Fixed_Point_Type (T2) and then not Fixed_Int)
+ then
+ return
+ Expr_Value_R (L2) <= Expr_Value_R (L1)
+ and then
+ Expr_Value_R (H2) >= Expr_Value_R (H1);
+
+ else
+ return
+ Expr_Value (L2) <= Expr_Value (L1)
+ and then
+ Expr_Value (H2) >= Expr_Value (H1);
+
+ end if;
+ end if;
+
+ -- If any exception occurs, it means that we have some bug in the compiler
+ -- possibly triggered by a previous error, or by some unforseen peculiar
+ -- occurrence. However, this is only an optimization attempt, so there is
+ -- really no point in crashing the compiler. Instead we just decide, too
+ -- bad, we can't figure out the answer in this case after all.
+
+ exception
+ when others =>
+
+ -- Debug flag K disables this behavior (useful for debugging)
+
+ if Debug_Flag_K then
+ raise;
+ else
+ return False;
+ end if;
+ end In_Subrange_Of;
+
+ -----------------
+ -- Is_In_Range --
+ -----------------
+
+ function Is_In_Range
+ (N : Node_Id;
+ Typ : Entity_Id;
+ Fixed_Int : Boolean := False;
+ Int_Real : Boolean := False)
+ return Boolean
+ is
+ Val : Uint;
+ Valr : Ureal;
+
+ begin
+ -- Universal types have no range limits, so always in range.
+
+ if Typ = Universal_Integer or else Typ = Universal_Real then
+ return True;
+
+ -- Never in range if not scalar type. Don't know if this can
+ -- actually happen, but our spec allows it, so we must check!
+
+ elsif not Is_Scalar_Type (Typ) then
+ return False;
+
+ -- Never in range unless we have a compile time known value.
+
+ elsif not Compile_Time_Known_Value (N) then
+ return False;
+
+ else
+ declare
+ Lo : constant Node_Id := Type_Low_Bound (Typ);
+ Hi : constant Node_Id := Type_High_Bound (Typ);
+ LB_Known : constant Boolean := Compile_Time_Known_Value (Lo);
+ UB_Known : constant Boolean := Compile_Time_Known_Value (Hi);
+
+ begin
+ -- Fixed point types should be considered as such only in
+ -- flag Fixed_Int is set to False.
+
+ if Is_Floating_Point_Type (Typ)
+ or else (Is_Fixed_Point_Type (Typ) and then not Fixed_Int)
+ or else Int_Real
+ then
+ Valr := Expr_Value_R (N);
+
+ if LB_Known and then Valr >= Expr_Value_R (Lo)
+ and then UB_Known and then Valr <= Expr_Value_R (Hi)
+ then
+ return True;
+ else
+ return False;
+ end if;
+
+ else
+ Val := Expr_Value (N);
+
+ if LB_Known and then Val >= Expr_Value (Lo)
+ and then UB_Known and then Val <= Expr_Value (Hi)
+ then
+ return True;
+ else
+ return False;
+ end if;
+ end if;
+ end;
+ end if;
+ end Is_In_Range;
+
+ -------------------
+ -- Is_Null_Range --
+ -------------------
+
+ function Is_Null_Range (Lo : Node_Id; Hi : Node_Id) return Boolean is
+ Typ : constant Entity_Id := Etype (Lo);
+
+ begin
+ if not Compile_Time_Known_Value (Lo)
+ or else not Compile_Time_Known_Value (Hi)
+ then
+ return False;
+ end if;
+
+ if Is_Discrete_Type (Typ) then
+ return Expr_Value (Lo) > Expr_Value (Hi);
+
+ else
+ pragma Assert (Is_Real_Type (Typ));
+ return Expr_Value_R (Lo) > Expr_Value_R (Hi);
+ end if;
+ end Is_Null_Range;
+
+ -----------------------------
+ -- Is_OK_Static_Expression --
+ -----------------------------
+
+ function Is_OK_Static_Expression (N : Node_Id) return Boolean is
+ begin
+ return Is_Static_Expression (N)
+ and then not Raises_Constraint_Error (N);
+ end Is_OK_Static_Expression;
+
+ ------------------------
+ -- Is_OK_Static_Range --
+ ------------------------
+
+ -- A static range is a range whose bounds are static expressions, or a
+ -- Range_Attribute_Reference equivalent to such a range (RM 4.9(26)).
+ -- We have already converted range attribute references, so we get the
+ -- "or" part of this rule without needing a special test.
+
+ function Is_OK_Static_Range (N : Node_Id) return Boolean is
+ begin
+ return Is_OK_Static_Expression (Low_Bound (N))
+ and then Is_OK_Static_Expression (High_Bound (N));
+ end Is_OK_Static_Range;
+
+ --------------------------
+ -- Is_OK_Static_Subtype --
+ --------------------------
+
+ -- Determines if Typ is a static subtype as defined in (RM 4.9(26))
+ -- where neither bound raises constraint error when evaluated.
+
+ function Is_OK_Static_Subtype (Typ : Entity_Id) return Boolean is
+ Base_T : constant Entity_Id := Base_Type (Typ);
+ Anc_Subt : Entity_Id;
+
+ begin
+ -- First a quick check on the non static subtype flag. As described
+ -- in further detail in Einfo, this flag is not decisive in all cases,
+ -- but if it is set, then the subtype is definitely non-static.
+
+ if Is_Non_Static_Subtype (Typ) then
+ return False;
+ end if;
+
+ Anc_Subt := Ancestor_Subtype (Typ);
+
+ if Anc_Subt = Empty then
+ Anc_Subt := Base_T;
+ end if;
+
+ if Is_Generic_Type (Root_Type (Base_T))
+ or else Is_Generic_Actual_Type (Base_T)
+ then
+ return False;
+
+ -- String types
+
+ elsif Is_String_Type (Typ) then
+ return
+ Ekind (Typ) = E_String_Literal_Subtype
+ or else
+ (Is_OK_Static_Subtype (Component_Type (Typ))
+ and then Is_OK_Static_Subtype (Etype (First_Index (Typ))));
+
+ -- Scalar types
+
+ elsif Is_Scalar_Type (Typ) then
+ if Base_T = Typ then
+ return True;
+
+ else
+ -- Scalar_Range (Typ) might be an N_Subtype_Indication, so
+ -- use Get_Type_Low,High_Bound.
+
+ return Is_OK_Static_Subtype (Anc_Subt)
+ and then Is_OK_Static_Expression (Type_Low_Bound (Typ))
+ and then Is_OK_Static_Expression (Type_High_Bound (Typ));
+ end if;
+
+ -- Types other than string and scalar types are never static
+
+ else
+ return False;
+ end if;
+ end Is_OK_Static_Subtype;
+
+ ---------------------
+ -- Is_Out_Of_Range --
+ ---------------------
+
+ function Is_Out_Of_Range
+ (N : Node_Id;
+ Typ : Entity_Id;
+ Fixed_Int : Boolean := False;
+ Int_Real : Boolean := False)
+ return Boolean
+ is
+ Val : Uint;
+ Valr : Ureal;
+
+ begin
+ -- Universal types have no range limits, so always in range.
+
+ if Typ = Universal_Integer or else Typ = Universal_Real then
+ return False;
+
+ -- Never out of range if not scalar type. Don't know if this can
+ -- actually happen, but our spec allows it, so we must check!
+
+ elsif not Is_Scalar_Type (Typ) then
+ return False;
+
+ -- Never out of range if this is a generic type, since the bounds
+ -- of generic types are junk. Note that if we only checked for
+ -- static expressions (instead of compile time known values) below,
+ -- we would not need this check, because values of a generic type
+ -- can never be static, but they can be known at compile time.
+
+ elsif Is_Generic_Type (Typ) then
+ return False;
+
+ -- Never out of range unless we have a compile time known value.
+
+ elsif not Compile_Time_Known_Value (N) then
+ return False;
+
+ else
+ declare
+ Lo : constant Node_Id := Type_Low_Bound (Typ);
+ Hi : constant Node_Id := Type_High_Bound (Typ);
+ LB_Known : constant Boolean := Compile_Time_Known_Value (Lo);
+ UB_Known : constant Boolean := Compile_Time_Known_Value (Hi);
+
+ begin
+ -- Real types (note that fixed-point types are not treated
+ -- as being of a real type if the flag Fixed_Int is set,
+ -- since in that case they are regarded as integer types).
+
+ if Is_Floating_Point_Type (Typ)
+ or else (Is_Fixed_Point_Type (Typ) and then not Fixed_Int)
+ or else Int_Real
+ then
+ Valr := Expr_Value_R (N);
+
+ if LB_Known and then Valr < Expr_Value_R (Lo) then
+ return True;
+
+ elsif UB_Known and then Expr_Value_R (Hi) < Valr then
+ return True;
+
+ else
+ return False;
+ end if;
+
+ else
+ Val := Expr_Value (N);
+
+ if LB_Known and then Val < Expr_Value (Lo) then
+ return True;
+
+ elsif UB_Known and then Expr_Value (Hi) < Val then
+ return True;
+
+ else
+ return False;
+ end if;
+ end if;
+ end;
+ end if;
+ end Is_Out_Of_Range;
+
+ ---------------------
+ -- Is_Static_Range --
+ ---------------------
+
+ -- A static range is a range whose bounds are static expressions, or a
+ -- Range_Attribute_Reference equivalent to such a range (RM 4.9(26)).
+ -- We have already converted range attribute references, so we get the
+ -- "or" part of this rule without needing a special test.
+
+ function Is_Static_Range (N : Node_Id) return Boolean is
+ begin
+ return Is_Static_Expression (Low_Bound (N))
+ and then Is_Static_Expression (High_Bound (N));
+ end Is_Static_Range;
+
+ -----------------------
+ -- Is_Static_Subtype --
+ -----------------------
+
+ -- Determines if Typ is a static subtype as defined in (RM 4.9(26)).
+
+ function Is_Static_Subtype (Typ : Entity_Id) return Boolean is
+ Base_T : constant Entity_Id := Base_Type (Typ);
+ Anc_Subt : Entity_Id;
+
+ begin
+ -- First a quick check on the non static subtype flag. As described
+ -- in further detail in Einfo, this flag is not decisive in all cases,
+ -- but if it is set, then the subtype is definitely non-static.
+
+ if Is_Non_Static_Subtype (Typ) then
+ return False;
+ end if;
+
+ Anc_Subt := Ancestor_Subtype (Typ);
+
+ if Anc_Subt = Empty then
+ Anc_Subt := Base_T;
+ end if;
+
+ if Is_Generic_Type (Root_Type (Base_T))
+ or else Is_Generic_Actual_Type (Base_T)
+ then
+ return False;
+
+ -- String types
+
+ elsif Is_String_Type (Typ) then
+ return
+ Ekind (Typ) = E_String_Literal_Subtype
+ or else
+ (Is_Static_Subtype (Component_Type (Typ))
+ and then Is_Static_Subtype (Etype (First_Index (Typ))));
+
+ -- Scalar types
+
+ elsif Is_Scalar_Type (Typ) then
+ if Base_T = Typ then
+ return True;
+
+ else
+ return Is_Static_Subtype (Anc_Subt)
+ and then Is_Static_Expression (Type_Low_Bound (Typ))
+ and then Is_Static_Expression (Type_High_Bound (Typ));
+ end if;
+
+ -- Types other than string and scalar types are never static
+
+ else
+ return False;
+ end if;
+ end Is_Static_Subtype;
+
+ --------------------
+ -- Not_Null_Range --
+ --------------------
+
+ function Not_Null_Range (Lo : Node_Id; Hi : Node_Id) return Boolean is
+ Typ : constant Entity_Id := Etype (Lo);
+
+ begin
+ if not Compile_Time_Known_Value (Lo)
+ or else not Compile_Time_Known_Value (Hi)
+ then
+ return False;
+ end if;
+
+ if Is_Discrete_Type (Typ) then
+ return Expr_Value (Lo) <= Expr_Value (Hi);
+
+ else
+ pragma Assert (Is_Real_Type (Typ));
+
+ return Expr_Value_R (Lo) <= Expr_Value_R (Hi);
+ end if;
+ end Not_Null_Range;
+
+ -------------
+ -- OK_Bits --
+ -------------
+
+ function OK_Bits (N : Node_Id; Bits : Uint) return Boolean is
+ begin
+ -- We allow a maximum of 500,000 bits which seems a reasonable limit
+
+ if Bits < 500_000 then
+ return True;
+
+ else
+ Error_Msg_N ("static value too large, capacity exceeded", N);
+ return False;
+ end if;
+ end OK_Bits;
+
+ ------------------
+ -- Out_Of_Range --
+ ------------------
+
+ procedure Out_Of_Range (N : Node_Id) is
+ begin
+ -- If we have the static expression case, then this is an illegality
+ -- in Ada 95 mode, except that in an instance, we never generate an
+ -- error (if the error is legitimate, it was already diagnosed in
+ -- the template). The expression to compute the length of a packed
+ -- array is attached to the array type itself, and deserves a separate
+ -- message.
+
+ if Is_Static_Expression (N)
+ and then not In_Instance
+ and then Ada_95
+ then
+
+ if Nkind (Parent (N)) = N_Defining_Identifier
+ and then Is_Array_Type (Parent (N))
+ and then Present (Packed_Array_Type (Parent (N)))
+ and then Present (First_Rep_Item (Parent (N)))
+ then
+ Error_Msg_N
+ ("length of packed array must not exceed Integer''Last",
+ First_Rep_Item (Parent (N)));
+ Rewrite (N, Make_Integer_Literal (Sloc (N), Uint_1));
+
+ else
+ Apply_Compile_Time_Constraint_Error
+ (N, "value not in range of}");
+ end if;
+
+ -- Here we generate a warning for the Ada 83 case, or when we are
+ -- in an instance, or when we have a non-static expression case.
+
+ else
+ Warn_On_Instance := True;
+ Apply_Compile_Time_Constraint_Error
+ (N, "value not in range of}?");
+ Warn_On_Instance := False;
+ end if;
+ end Out_Of_Range;
+
+ -------------------------
+ -- Rewrite_In_Raise_CE --
+ -------------------------
+
+ procedure Rewrite_In_Raise_CE (N : Node_Id; Exp : Node_Id) is
+ Typ : constant Entity_Id := Etype (N);
+
+ begin
+ -- If we want to raise CE in the condition of a raise_CE node
+ -- we may as well get rid of the condition
+
+ if Present (Parent (N))
+ and then Nkind (Parent (N)) = N_Raise_Constraint_Error
+ then
+ Set_Condition (Parent (N), Empty);
+
+ -- If the expression raising CE is a N_Raise_CE node, we can use
+ -- that one. We just preserve the type of the context
+
+ elsif Nkind (Exp) = N_Raise_Constraint_Error then
+ Rewrite (N, Exp);
+ Set_Etype (N, Typ);
+
+ -- We have to build an explicit raise_ce node
+
+ else
+ Rewrite (N, Make_Raise_Constraint_Error (Sloc (Exp)));
+ Set_Raises_Constraint_Error (N);
+ Set_Etype (N, Typ);
+ end if;
+ end Rewrite_In_Raise_CE;
+
+ ---------------------
+ -- String_Type_Len --
+ ---------------------
+
+ function String_Type_Len (Stype : Entity_Id) return Uint is
+ NT : constant Entity_Id := Etype (First_Index (Stype));
+ T : Entity_Id;
+
+ begin
+ if Is_OK_Static_Subtype (NT) then
+ T := NT;
+ else
+ T := Base_Type (NT);
+ end if;
+
+ return Expr_Value (Type_High_Bound (T)) -
+ Expr_Value (Type_Low_Bound (T)) + 1;
+ end String_Type_Len;
+
+ ------------------------------------
+ -- Subtypes_Statically_Compatible --
+ ------------------------------------
+
+ function Subtypes_Statically_Compatible
+ (T1 : Entity_Id;
+ T2 : Entity_Id)
+ return Boolean
+ is
+ begin
+ if Is_Scalar_Type (T1) then
+
+ -- Definitely compatible if we match
+
+ if Subtypes_Statically_Match (T1, T2) then
+ return True;
+
+ -- If either subtype is nonstatic then they're not compatible
+
+ elsif not Is_Static_Subtype (T1)
+ or else not Is_Static_Subtype (T2)
+ then
+ return False;
+
+ -- If either type has constraint error bounds, then consider that
+ -- they match to avoid junk cascaded errors here.
+
+ elsif not Is_OK_Static_Subtype (T1)
+ or else not Is_OK_Static_Subtype (T2)
+ then
+ return True;
+
+ -- Base types must match, but we don't check that (should
+ -- we???) but we do at least check that both types are
+ -- real, or both types are not real.
+
+ elsif (Is_Real_Type (T1) /= Is_Real_Type (T2)) then
+ return False;
+
+ -- Here we check the bounds
+
+ else
+ declare
+ LB1 : constant Node_Id := Type_Low_Bound (T1);
+ HB1 : constant Node_Id := Type_High_Bound (T1);
+ LB2 : constant Node_Id := Type_Low_Bound (T2);
+ HB2 : constant Node_Id := Type_High_Bound (T2);
+
+ begin
+ if Is_Real_Type (T1) then
+ return
+ (Expr_Value_R (LB1) > Expr_Value_R (HB1))
+ or else
+ (Expr_Value_R (LB2) <= Expr_Value_R (LB1)
+ and then
+ Expr_Value_R (HB1) <= Expr_Value_R (HB2));
+
+ else
+ return
+ (Expr_Value (LB1) > Expr_Value (HB1))
+ or else
+ (Expr_Value (LB2) <= Expr_Value (LB1)
+ and then
+ Expr_Value (HB1) <= Expr_Value (HB2));
+ end if;
+ end;
+ end if;
+
+ elsif Is_Access_Type (T1) then
+ return not Is_Constrained (T2)
+ or else Subtypes_Statically_Match
+ (Designated_Type (T1), Designated_Type (T2));
+
+ else
+ return (Is_Composite_Type (T1) and then not Is_Constrained (T2))
+ or else Subtypes_Statically_Match (T1, T2);
+ end if;
+ end Subtypes_Statically_Compatible;
+
+ -------------------------------
+ -- Subtypes_Statically_Match --
+ -------------------------------
+
+ -- Subtypes statically match if they have statically matching constraints
+ -- (RM 4.9.1(2)). Constraints statically match if there are none, or if
+ -- they are the same identical constraint, or if they are static and the
+ -- values match (RM 4.9.1(1)).
+
+ function Subtypes_Statically_Match (T1, T2 : Entity_Id) return Boolean is
+ begin
+ -- A type always statically matches itself
+
+ if T1 = T2 then
+ return True;
+
+ -- Scalar types
+
+ elsif Is_Scalar_Type (T1) then
+
+ -- Base types must be the same
+
+ if Base_Type (T1) /= Base_Type (T2) then
+ return False;
+ end if;
+
+ -- A constrained numeric subtype never matches an unconstrained
+ -- subtype, i.e. both types must be constrained or unconstrained.
+
+ -- To understand the requirement for this test, see RM 4.9.1(1).
+ -- As is made clear in RM 3.5.4(11), type Integer, for example
+ -- is a constrained subtype with constraint bounds matching the
+ -- bounds of its corresponding uncontrained base type. In this
+ -- situation, Integer and Integer'Base do not statically match,
+ -- even though they have the same bounds.
+
+ -- We only apply this test to types in Standard and types that
+ -- appear in user programs. That way, we do not have to be
+ -- too careful about setting Is_Constrained right for itypes.
+
+ if Is_Numeric_Type (T1)
+ and then (Is_Constrained (T1) /= Is_Constrained (T2))
+ and then (Scope (T1) = Standard_Standard
+ or else Comes_From_Source (T1))
+ and then (Scope (T2) = Standard_Standard
+ or else Comes_From_Source (T2))
+ then
+ return False;
+ end if;
+
+ -- If there was an error in either range, then just assume
+ -- the types statically match to avoid further junk errors
+
+ if Error_Posted (Scalar_Range (T1))
+ or else
+ Error_Posted (Scalar_Range (T2))
+ then
+ return True;
+ end if;
+
+ -- Otherwise both types have bound that can be compared
+
+ declare
+ LB1 : constant Node_Id := Type_Low_Bound (T1);
+ HB1 : constant Node_Id := Type_High_Bound (T1);
+ LB2 : constant Node_Id := Type_Low_Bound (T2);
+ HB2 : constant Node_Id := Type_High_Bound (T2);
+
+ begin
+ -- If the bounds are the same tree node, then match
+
+ if LB1 = LB2 and then HB1 = HB2 then
+ return True;
+
+ -- Otherwise bounds must be static and identical value
+
+ else
+ if not Is_Static_Subtype (T1)
+ or else not Is_Static_Subtype (T2)
+ then
+ return False;
+
+ -- If either type has constraint error bounds, then say
+ -- that they match to avoid junk cascaded errors here.
+
+ elsif not Is_OK_Static_Subtype (T1)
+ or else not Is_OK_Static_Subtype (T2)
+ then
+ return True;
+
+ elsif Is_Real_Type (T1) then
+ return
+ (Expr_Value_R (LB1) = Expr_Value_R (LB2))
+ and then
+ (Expr_Value_R (HB1) = Expr_Value_R (HB2));
+
+ else
+ return
+ Expr_Value (LB1) = Expr_Value (LB2)
+ and then
+ Expr_Value (HB1) = Expr_Value (HB2);
+ end if;
+ end if;
+ end;
+
+ -- Type with discriminants
+
+ elsif Has_Discriminants (T1) or else Has_Discriminants (T2) then
+ if Has_Discriminants (T1) /= Has_Discriminants (T2) then
+ return False;
+ end if;
+
+ declare
+ DL1 : constant Elist_Id := Discriminant_Constraint (T1);
+ DL2 : constant Elist_Id := Discriminant_Constraint (T2);
+
+ DA1 : Elmt_Id := First_Elmt (DL1);
+ DA2 : Elmt_Id := First_Elmt (DL2);
+
+ begin
+ if DL1 = DL2 then
+ return True;
+
+ elsif Is_Constrained (T1) /= Is_Constrained (T2) then
+ return False;
+ end if;
+
+ while Present (DA1) loop
+ declare
+ Expr1 : constant Node_Id := Node (DA1);
+ Expr2 : constant Node_Id := Node (DA2);
+
+ begin
+ if not Is_Static_Expression (Expr1)
+ or else not Is_Static_Expression (Expr2)
+ then
+ return False;
+
+ -- If either expression raised a constraint error,
+ -- consider the expressions as matching, since this
+ -- helps to prevent cascading errors.
+
+ elsif Raises_Constraint_Error (Expr1)
+ or else Raises_Constraint_Error (Expr2)
+ then
+ null;
+
+ elsif Expr_Value (Expr1) /= Expr_Value (Expr2) then
+ return False;
+ end if;
+ end;
+
+ Next_Elmt (DA1);
+ Next_Elmt (DA2);
+ end loop;
+ end;
+
+ return True;
+
+ -- A definite type does not match an indefinite or classwide type.
+
+ elsif
+ Has_Unknown_Discriminants (T1) /= Has_Unknown_Discriminants (T2)
+ then
+ return False;
+
+ -- Array type
+
+ elsif Is_Array_Type (T1) then
+
+ -- If either subtype is unconstrained then both must be,
+ -- and if both are unconstrained then no further checking
+ -- is needed.
+
+ if not Is_Constrained (T1) or else not Is_Constrained (T2) then
+ return not (Is_Constrained (T1) or else Is_Constrained (T2));
+ end if;
+
+ -- Both subtypes are constrained, so check that the index
+ -- subtypes statically match.
+
+ declare
+ Index1 : Node_Id := First_Index (T1);
+ Index2 : Node_Id := First_Index (T2);
+
+ begin
+ while Present (Index1) loop
+ if not
+ Subtypes_Statically_Match (Etype (Index1), Etype (Index2))
+ then
+ return False;
+ end if;
+
+ Next_Index (Index1);
+ Next_Index (Index2);
+ end loop;
+
+ return True;
+ end;
+
+ elsif Is_Access_Type (T1) then
+ return Subtypes_Statically_Match
+ (Designated_Type (T1),
+ Designated_Type (T2));
+
+ -- All other types definitely match
+
+ else
+ return True;
+ end if;
+ end Subtypes_Statically_Match;
+
+ ----------
+ -- Test --
+ ----------
+
+ function Test (Cond : Boolean) return Uint is
+ begin
+ if Cond then
+ return Uint_1;
+ else
+ return Uint_0;
+ end if;
+ end Test;
+
+ ---------------------------------
+ -- Test_Expression_Is_Foldable --
+ ---------------------------------
+
+ -- One operand case
+
+ procedure Test_Expression_Is_Foldable
+ (N : Node_Id;
+ Op1 : Node_Id;
+ Stat : out Boolean;
+ Fold : out Boolean)
+ is
+ begin
+ Stat := False;
+
+ -- If operand is Any_Type, just propagate to result and do not
+ -- try to fold, this prevents cascaded errors.
+
+ if Etype (Op1) = Any_Type then
+ Set_Etype (N, Any_Type);
+ Fold := False;
+ return;
+
+ -- If operand raises constraint error, then replace node N with the
+ -- raise constraint error node, and we are obviously not foldable.
+ -- Note that this replacement inherits the Is_Static_Expression flag
+ -- from the operand.
+
+ elsif Raises_Constraint_Error (Op1) then
+ Rewrite_In_Raise_CE (N, Op1);
+ Fold := False;
+ return;
+
+ -- If the operand is not static, then the result is not static, and
+ -- all we have to do is to check the operand since it is now known
+ -- to appear in a non-static context.
+
+ elsif not Is_Static_Expression (Op1) then
+ Check_Non_Static_Context (Op1);
+ Fold := Compile_Time_Known_Value (Op1);
+ return;
+
+ -- An expression of a formal modular type is not foldable because
+ -- the modulus is unknown.
+
+ elsif Is_Modular_Integer_Type (Etype (Op1))
+ and then Is_Generic_Type (Etype (Op1))
+ then
+ Check_Non_Static_Context (Op1);
+ Fold := False;
+ return;
+
+ -- Here we have the case of an operand whose type is OK, which is
+ -- static, and which does not raise constraint error, we can fold.
+
+ else
+ Set_Is_Static_Expression (N);
+ Fold := True;
+ Stat := True;
+ end if;
+ end Test_Expression_Is_Foldable;
+
+ -- Two operand case
+
+ procedure Test_Expression_Is_Foldable
+ (N : Node_Id;
+ Op1 : Node_Id;
+ Op2 : Node_Id;
+ Stat : out Boolean;
+ Fold : out Boolean)
+ is
+ Rstat : constant Boolean := Is_Static_Expression (Op1)
+ and then Is_Static_Expression (Op2);
+
+ begin
+ Stat := False;
+
+ -- If either operand is Any_Type, just propagate to result and
+ -- do not try to fold, this prevents cascaded errors.
+
+ if Etype (Op1) = Any_Type or else Etype (Op2) = Any_Type then
+ Set_Etype (N, Any_Type);
+ Fold := False;
+ return;
+
+ -- If left operand raises constraint error, then replace node N with
+ -- the raise constraint error node, and we are obviously not foldable.
+ -- Is_Static_Expression is set from the two operands in the normal way,
+ -- and we check the right operand if it is in a non-static context.
+
+ elsif Raises_Constraint_Error (Op1) then
+ if not Rstat then
+ Check_Non_Static_Context (Op2);
+ end if;
+
+ Rewrite_In_Raise_CE (N, Op1);
+ Set_Is_Static_Expression (N, Rstat);
+ Fold := False;
+ return;
+
+ -- Similar processing for the case of the right operand. Note that
+ -- we don't use this routine for the short-circuit case, so we do
+ -- not have to worry about that special case here.
+
+ elsif Raises_Constraint_Error (Op2) then
+ if not Rstat then
+ Check_Non_Static_Context (Op1);
+ end if;
+
+ Rewrite_In_Raise_CE (N, Op2);
+ Set_Is_Static_Expression (N, Rstat);
+ Fold := False;
+ return;
+
+ -- Exclude expressions of a generic modular type, as above.
+
+ elsif Is_Modular_Integer_Type (Etype (Op1))
+ and then Is_Generic_Type (Etype (Op1))
+ then
+ Check_Non_Static_Context (Op1);
+ Fold := False;
+ return;
+
+ -- If result is not static, then check non-static contexts on operands
+ -- since one of them may be static and the other one may not be static
+
+ elsif not Rstat then
+ Check_Non_Static_Context (Op1);
+ Check_Non_Static_Context (Op2);
+ Fold := Compile_Time_Known_Value (Op1)
+ and then Compile_Time_Known_Value (Op2);
+ return;
+
+ -- Else result is static and foldable. Both operands are static,
+ -- and neither raises constraint error, so we can definitely fold.
+
+ else
+ Set_Is_Static_Expression (N);
+ Fold := True;
+ Stat := True;
+ return;
+ end if;
+ end Test_Expression_Is_Foldable;
+
+ --------------
+ -- To_Bits --
+ --------------
+
+ procedure To_Bits (U : Uint; B : out Bits) is
+ begin
+ for J in 0 .. B'Last loop
+ B (J) := (U / (2 ** J)) mod 2 /= 0;
+ end loop;
+ end To_Bits;
+
+end Sem_Eval;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S E M _ E V A L --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.53 $
+-- --
+-- 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 contains various subprograms involved in compile time
+-- evaluation of expressions and checks for staticness of expressions
+-- and types. It also contains the circuitry for checking for violations
+-- of pure and preelaborated conditions (this naturally goes here, since
+-- these rules involve consideration of staticness).
+
+-- Note: the static evaluation for attributes is found in Sem_Attr even
+-- though logically it belongs here. We have done this so that it is easier
+-- to add new attributes to GNAT.
+
+with Types; use Types;
+with Uintp; use Uintp;
+with Urealp; use Urealp;
+
+package Sem_Eval is
+
+ ------------------------------------
+ -- Handling of Static Expressions --
+ ------------------------------------
+
+ -- This package contains a set of routine that process individual
+ -- subexpression nodes with the objective of folding (precomputing)
+ -- the value of static expressions that are known at compile time and
+ -- properly computing the setting of two flags that appear in every
+ -- subexpression node:
+
+ -- Is_Static_Expression
+
+ -- This flag is set on any expression that is static according
+ -- to the rules in (RM 4.9(3-32)).
+
+ -- Raises_Constraint_Error
+
+ -- This flag indicatest that it is known at compile time that the
+ -- evaluation of an expression raises constraint error. If the
+ -- expression is static, and this flag is off, then it is also known
+ -- at compile time that the expression does not raise constraint error
+ -- (i.e. the flag is accurate for static expressions, and conservative
+ -- for non-static expressions.
+
+ -- If a static expression does not raise constraint error, then the
+ -- Raises_Constraint_Error flag is off, and the expression must be
+ -- computed at compile time, which means that it has the form of either
+ -- a literal, or a constant that is itself (recursively) either a literal
+ -- or a constant.
+
+ -- The above rules must be followed exactly in order for legality
+ -- checks to be accurate. For subexpressions that are not static
+ -- according to the RM definition, they are sometimes folded anyway,
+ -- but of course in this case Is_Static_Expression is not set.
+
+ -------------------------------
+ -- Compile-Time Known Values --
+ -------------------------------
+
+ -- For most legality checking purposes the flag Is_Static_Expression
+ -- defined in Sinfo should be used. This package also provides
+ -- a routine called Is_OK_Static_Expression which in addition of
+ -- checking that an expression is static in the RM 4.9 sense, it
+ -- checks that the expression does not raise constraint error. In
+ -- fact for certain legality checks not only do we need to ascertain
+ -- that the expression is static, but we must also ensure that it
+ -- does not raise constraint error.
+ --
+ -- Neither of Is_Static_Expression and Is_OK_Static_Expression should
+ -- be used for compile time evaluation purposes. In fact certain
+ -- expression whose value is known at compile time are not static
+ -- in the RM 4.9 sense. A typical example is:
+ --
+ -- C : constant Integer := Record_Type'Size;
+ --
+ -- The expression 'C' is not static in the technical RM sense, but for
+ -- many simple record types, the size is in fact known at compile time.
+ -- When we are trying to perform compile time constant folding (for
+ -- instance for expressions such as 'C + 1', Is_Static_Expression or
+ -- Is_OK_Static_Expression are not the right functions to test to see
+ -- if folding is possible. Instead, we use Compile_Time_Know_Value.
+ -- All static expressions that do not raise constraint error (i.e.
+ -- those for which Is_OK_Static_Expression is true) are known at
+ -- compile time, but as shown by the above example, there are cases
+ -- of non-static expressions which are known at compile time.
+
+ -----------------
+ -- Subprograms --
+ -----------------
+
+ procedure Check_Non_Static_Context (N : Node_Id);
+ -- Deals with the special check required for a static expression that
+ -- appears in a non-static context, i.e. is not part of a larger static
+ -- expression (see RM 4.9(35)), i.e. the value of the expression must be
+ -- within the base range of the base type of its expected type. A check
+ -- is also made for expressions that are inside the base range, but
+ -- outside the range of the expected subtype (this is a warning message
+ -- rather than an illegality).
+ --
+ -- Note: most cases of non-static context checks are handled within
+ -- Sem_Eval itself, including all cases of expressions at the outer
+ -- level (i.e. those that are not a subexpression). Currently the only
+ -- outside customer for this procedure is Sem_Attr (because Eval_Attribute
+ -- is there). There is also one special case arising from ranges (see body
+ -- of Resolve_Range).
+
+ procedure Check_String_Literal_Length (N : Node_Id; Ttype : Entity_Id);
+ -- N is either a string literal, or a constraint error node. In the latter
+ -- case, the situation is already dealt with, and the call has no effect.
+ -- In the former case, if the target type, Ttyp is constrained, then a
+ -- check is made to see if the string literal is of appropriate length.
+
+ type Compare_Result is (LT, LE, EQ, GT, GE, NE, Unknown);
+ subtype Compare_GE is Compare_Result range EQ .. GE;
+ subtype Compare_LE is Compare_Result range LT .. EQ;
+ function Compile_Time_Compare (L, R : Node_Id) return Compare_Result;
+ -- Given two expression nodes, finds out whether it can be determined
+ -- at compile time how the runtime values will compare. An Unknown
+ -- result means that the result of a comparison cannot be determined at
+ -- compile time, otherwise the returned result indicates the known result
+ -- of the comparison, given as tightly as possible (i.e. EQ or LT is a
+ -- preferred returned value to LE).
+
+ function Is_OK_Static_Expression (N : Node_Id) return Boolean;
+ -- An OK static expression is one that is static in the RM definition
+ -- sense and which does not raise constraint error. For most legality
+ -- checking purposes you should use Is_Static_Expression. For those
+ -- legality checks where the expression N should not raise constaint
+ -- error use this routine. This routine is *not* to be used in contexts
+ -- where the test is for compile time evaluation purposes. Use routine
+ -- Compile_Time_Known_Value instead (see section on "Compile-Time Known
+ -- Values" above).
+
+ function Is_Static_Range (N : Node_Id) return Boolean;
+ -- Determine if range is static, as defined in RM 4.9(26). The only
+ -- allowed argument is an N_Range node (but note that the semantic
+ -- analysis of equivalent range attribute references already turned
+ -- them into the equivalent range).
+
+ function Is_OK_Static_Range (N : Node_Id) return Boolean;
+ -- Like Is_Static_Range, but also makes sure that the bounds of the
+ -- range are compile-time evaluable (i.e. do not raise constraint error).
+ -- A result of true means that the bounds are compile time evaluable.
+ -- A result of false means they are not (either because the range is
+ -- not static, or because one or the other bound raises CE).
+
+ function Is_Static_Subtype (Typ : Entity_Id) return Boolean;
+ -- Determines whether a subtype fits the definition of an Ada static
+ -- subtype as given in (RM 4.9(26)).
+
+ function Is_OK_Static_Subtype (Typ : Entity_Id) return Boolean;
+ -- Like Is_Static_Subtype but also makes sure that the bounds of the
+ -- subtype are compile-time evaluable (i.e. do not raise constraint
+ -- error). A result of true means that the bounds are compile time
+ -- evaluable. A result of false means they are not (either because the
+ -- range is not static, or because one or the other bound raises CE).
+
+ function Subtypes_Statically_Compatible
+ (T1 : Entity_Id;
+ T2 : Entity_Id)
+ return Boolean;
+ -- Returns true if the subtypes are unconstrained or the constraint on
+ -- on T1 is statically compatible with T2 (as defined by 4.9.1(4)).
+ -- Otherwise returns false.
+
+ function Subtypes_Statically_Match (T1, T2 : Entity_Id) return Boolean;
+ -- Determine whether two types T1, T2, which have the same base type,
+ -- are statically matching subtypes (RM 4.9.1(1-2)).
+
+ function Compile_Time_Known_Value (Op : Node_Id) return Boolean;
+ -- Returns true if Op is an expression not raising constraint error
+ -- whose value is known at compile time. This is true if Op is a static
+ -- expression, but can also be true for expressions which are
+ -- technically non-static but which are in fact known at compile time,
+ -- such as the static lower bound of a non-static range or the value
+ -- of a constant object whose initial value is static. Note that this
+ -- routine is defended against unanalyzed expressions. Such expressions
+ -- will not cause a blowup, they may cause pessimistic (i.e. False)
+ -- results to be returned.
+
+ function Compile_Time_Known_Value_Or_Aggr (Op : Node_Id) return Boolean;
+ -- Similar to Compile_Time_Known_Value, but also returns True if the
+ -- value is a compile time known aggregate, i.e. an aggregate all of
+ -- whose constituent expressions are either compile time known values
+ -- or compile time known aggregates.
+
+ function Expr_Value (N : Node_Id) return Uint;
+ -- Returns the folded value of the expression N. This function is called
+ -- in instances where it has already been determined that the expression
+ -- is static or its value is known at compile time (ie the call to
+ -- Compile_Time_Known_Value (N) returns True). This version is used for
+ -- integer values, and enumeration or character literals. In the latter
+ -- two cases, the value returned is the Pos value in the relevant
+ -- enumeration type. It can also be used for fixed-point values, in
+ -- which case it returns the corresponding integer value. It cannot be
+ -- used for floating-point values.
+
+ function Expr_Value_E (N : Node_Id) return Entity_Id;
+ -- Returns the folded value of the expression. This function is called
+ -- in instances where it has already been determined that the expression
+ -- is static or its value known at compile time. This version is used
+ -- for enumeration types and returns the corresponding enumeration
+ -- literal.
+
+ function Expr_Value_R (N : Node_Id) return Ureal;
+ -- Returns the folded value of the expression. This function is called
+ -- in instances where it has already been determined that the expression
+ -- is static or its value known at compile time. This version is used
+ -- for real values (including both the floating-point and fixed-point
+ -- cases). In the case of a fixed-point type, the real value is returned
+ -- (cf above version returning Uint).
+
+ function Expr_Value_S (N : Node_Id) return Node_Id;
+ -- Returns the folded value of the expression. This function is called
+ -- in instances where it has already been determined that the expression
+ -- is static or its value is known at compile time. This version is used
+ -- for string types and returns the corresponding N_String_Literal node.
+
+ function Expr_Rep_Value (N : Node_Id) return Uint;
+ -- This is identical to Expr_Value, except in the case of enumeration
+ -- literals of types for which an enumeration representation clause has
+ -- been given, in which case it returns the representation value rather
+ -- than the pos value. This is the value that is needed for generating
+ -- code sequences, while the Expr_Value value is appropriate for compile
+ -- time constraint errors or getting the logical value. Note that this
+ -- function does NOT concern itself with biased values, if the caller
+ -- needs a properly biased value, the subtraction of the bias must be
+ -- handled explicitly.
+
+ procedure Eval_Actual (N : Node_Id);
+ procedure Eval_Allocator (N : Node_Id);
+ procedure Eval_Arithmetic_Op (N : Node_Id);
+ procedure Eval_Character_Literal (N : Node_Id);
+ procedure Eval_Concatenation (N : Node_Id);
+ procedure Eval_Conditional_Expression (N : Node_Id);
+ procedure Eval_Entity_Name (N : Node_Id);
+ procedure Eval_Indexed_Component (N : Node_Id);
+ procedure Eval_Integer_Literal (N : Node_Id);
+ procedure Eval_Logical_Op (N : Node_Id);
+ procedure Eval_Membership_Op (N : Node_Id);
+ procedure Eval_Named_Integer (N : Node_Id);
+ procedure Eval_Named_Real (N : Node_Id);
+ procedure Eval_Op_Expon (N : Node_Id);
+ procedure Eval_Op_Not (N : Node_Id);
+ procedure Eval_Real_Literal (N : Node_Id);
+ procedure Eval_Relational_Op (N : Node_Id);
+ procedure Eval_Shift (N : Node_Id);
+ procedure Eval_Short_Circuit (N : Node_Id);
+ procedure Eval_Slice (N : Node_Id);
+ procedure Eval_String_Literal (N : Node_Id);
+ procedure Eval_Qualified_Expression (N : Node_Id);
+ procedure Eval_Type_Conversion (N : Node_Id);
+ procedure Eval_Unary_Op (N : Node_Id);
+ procedure Eval_Unchecked_Conversion (N : Node_Id);
+
+ procedure Fold_Str (N : Node_Id; Val : String_Id);
+ -- Rewrite N with a new N_String_Literal node as the result of the
+ -- compile time evaluation of the node N. Val is the resulting string
+ -- value from the folding operation. The Is_Static_Expression flag is
+ -- set in the result node. The result is fully analyzed and resolved.
+
+ procedure Fold_Uint (N : Node_Id; Val : Uint);
+ -- Rewrite N with a (N_Integer_Literal, N_Identifier, N_Character_Literal)
+ -- node as the result of the compile time evaluation of the node N. Val
+ -- is the result in the integer case and is the position of the literal
+ -- in the literals list for the enumeration case. Is_Static_Expression
+ -- is set True in the result node. The result is fully analyzed/resolved.
+
+ procedure Fold_Ureal (N : Node_Id; Val : Ureal);
+ -- Rewrite N with a new N_Real_Literal node as the result of the compile
+ -- time evaluation of the node N. Val is the resulting real value from
+ -- the folding operation. The Is_Static_Expression flag is set in the
+ -- result node. The result is fully analyzed and result.
+
+ function Is_In_Range
+ (N : Node_Id;
+ Typ : Entity_Id;
+ Fixed_Int : Boolean := False;
+ Int_Real : Boolean := False)
+ return Boolean;
+ -- Returns True if it can be guaranteed at compile time that expression
+ -- N is known to be in range of the subtype Typ. If the values of N or
+ -- of either bouds of Type are unknown at compile time, False will
+ -- always be returned. A result of False does not mean that the
+ -- expression is out of range, merely that it cannot be determined at
+ -- compile time that it is in range. If Typ is a floating point type or
+ -- Int_Real is set, any integer value is treated as though it was a real
+ -- value (i.e. the underlying real value is used). In this case we use
+ -- the corresponding real value, both for the bounds of Typ, and for the
+ -- value of the expression N. If Typ is a fixed type or a discrete type
+ -- and Int_Real is False but flag Fixed_Int is True then any fixed-point
+ -- value is treated as though it was a discrete value (i.e. the
+ -- underlying integer value is used). In this case we use the
+ -- corresponding integer value, both for the bounds of Typ, and for the
+ -- value of the expression N. If Typ is a discret type and Fixed_Int as
+ -- well as Int_Real are false, intere values are used throughout.
+
+ function Is_Out_Of_Range
+ (N : Node_Id;
+ Typ : Entity_Id;
+ Fixed_Int : Boolean := False;
+ Int_Real : Boolean := False)
+ return Boolean;
+ -- Returns True if it can be guaranteed at compile time that expression
+ -- N is known to be out of range of the subtype Typ. True is returned
+ -- if Typ is a scalar type, at least one of whose bounds is known at
+ -- compile time, and N is a compile time known expression which can be
+ -- determined to be outside a compile_time known bound of Typ. A result
+ -- of False does not mean that the expression is in range, merely that
+ -- it cannot be determined at compile time that it is out of range. Flags
+ -- Int_Real and Fixed_Int are used like in routine Is_In_Range above.
+
+ function In_Subrange_Of
+ (T1 : Entity_Id;
+ T2 : Entity_Id;
+ Fixed_Int : Boolean := False)
+ return Boolean;
+ -- Returns True if it can be guaranteed at compile time that the range
+ -- of values for scalar type T1 are always in the range of scalar type
+ -- T2. A result of False does not mean that T1 is not in T2's subrange,
+ -- only that it cannot be determined at compile time. Flag Fixed_Int is
+ -- used is like in routine Is_In_Range_Above.
+
+ function Is_Null_Range (Lo : Node_Id; Hi : Node_Id) return Boolean;
+ -- Returns True if it can guarantee that Lo .. Hi is a null range.
+ -- If it cannot (because the value of Lo or Hi is not known at compile
+ -- time) then it returns False.
+
+ function Not_Null_Range (Lo : Node_Id; Hi : Node_Id) return Boolean;
+ -- Returns True if it can guarantee that Lo .. Hi is not a null range.
+ -- If it cannot (because the value of Lo or Hi is not known at compile
+ -- time) then it returns False.
+
+private
+ -- The Eval routines are all marked inline, since they are called once
+
+ pragma Inline (Eval_Actual);
+ pragma Inline (Eval_Allocator);
+ pragma Inline (Eval_Character_Literal);
+ pragma Inline (Eval_Conditional_Expression);
+ pragma Inline (Eval_Indexed_Component);
+ pragma Inline (Eval_Integer_Literal);
+ pragma Inline (Eval_Named_Integer);
+ pragma Inline (Eval_Named_Real);
+ pragma Inline (Eval_Real_Literal);
+ pragma Inline (Eval_Shift);
+ pragma Inline (Eval_Slice);
+ pragma Inline (Eval_String_Literal);
+ pragma Inline (Eval_Unchecked_Conversion);
+
+ pragma Inline (Is_OK_Static_Expression);
+
+end Sem_Eval;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S E M _ I N T R --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.25 $
+-- --
+-- 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). --
+-- --
+------------------------------------------------------------------------------
+
+-- Processing for intrinsic subprogram declarations
+
+with Atree; use Atree;
+with Einfo; use Einfo;
+with Errout; use Errout;
+with Fname; use Fname;
+with Lib; use Lib;
+with Namet; use Namet;
+with Sem_Eval; use Sem_Eval;
+with Sem_Util; use Sem_Util;
+with Sinfo; use Sinfo;
+with Snames; use Snames;
+with Stand; use Stand;
+with Stringt; use Stringt;
+with Targparm; use Targparm;
+with Uintp; use Uintp;
+
+package body Sem_Intr is
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ procedure Check_Exception_Function (E : Entity_Id; N : Node_Id);
+ -- Check use of intrinsic Exception_Message, Exception_Info or
+ -- Exception_Name, as used in the DEC compatible Current_Exceptions
+ -- package. In each case we must have a parameterless function that
+ -- returns type String.
+
+ procedure Check_Intrinsic_Operator (E : Entity_Id; N : Node_Id);
+ -- Check that operator is one of the binary arithmetic operators, and
+ -- that the types involved have the same size.
+
+ procedure Check_Shift (E : Entity_Id; N : Node_Id);
+ -- Check intrinsic shift subprogram, the two arguments are the same
+ -- as for Check_Intrinsic_Subprogram (i.e. the entity of the subprogram
+ -- declaration, and the node for the pragma argument, used for messages)
+
+ procedure Errint (Msg : String; S : Node_Id; N : Node_Id);
+ -- Post error message for bad intrinsic, the message itself is posted
+ -- on the appropriate spec node and another message is placed on the
+ -- pragma itself, referring to the spec. S is the node in the spec on
+ -- which the message is to be placed, and N is the pragma argument node.
+
+ ------------------------------
+ -- Check_Exception_Function --
+ ------------------------------
+
+ procedure Check_Exception_Function (E : Entity_Id; N : Node_Id) is
+ begin
+ if Ekind (E) /= E_Function
+ and then Ekind (E) /= E_Generic_Function
+ then
+ Errint
+ ("intrinsic exception subprogram must be a function", E, N);
+
+ elsif Present (First_Formal (E)) then
+ Errint
+ ("intrinsic exception subprogram may not have parameters",
+ E, First_Formal (E));
+ return;
+
+ elsif Etype (E) /= Standard_String then
+ Errint
+ ("return type of exception subprogram must be String", E, N);
+ return;
+ end if;
+ end Check_Exception_Function;
+
+ --------------------------
+ -- Check_Intrinsic_Call --
+ --------------------------
+
+ procedure Check_Intrinsic_Call (N : Node_Id) is
+ Nam : constant Entity_Id := Entity (Name (N));
+ Cnam : constant Name_Id := Chars (Nam);
+ Arg1 : constant Node_Id := First_Actual (N);
+
+ begin
+ -- For Import_xxx calls, argument must be static string
+
+ if Cnam = Name_Import_Address
+ or else
+ Cnam = Name_Import_Largest_Value
+ or else
+ Cnam = Name_Import_Value
+ then
+ if Etype (Arg1) = Any_Type
+ or else Raises_Constraint_Error (Arg1)
+ then
+ null;
+
+ elsif not Is_Static_Expression (Arg1) then
+ Error_Msg_NE
+ ("call to & requires static string argument", N, Nam);
+
+ elsif String_Length (Strval (Expr_Value_S (Arg1))) = 0 then
+ Error_Msg_NE
+ ("call to & does not permit null string", N, Nam);
+
+ elsif OpenVMS_On_Target
+ and then String_Length (Strval (Expr_Value_S (Arg1))) > 31
+ then
+ Error_Msg_NE
+ ("argument in call to & must be 31 characters or less", N, Nam);
+ end if;
+
+ -- For now, no other special checks are required
+
+ else
+ return;
+ end if;
+ end Check_Intrinsic_Call;
+
+ ------------------------------
+ -- Check_Intrinsic_Operator --
+ ------------------------------
+
+ procedure Check_Intrinsic_Operator (E : Entity_Id; N : Node_Id) is
+ Nam : Name_Id := Chars (E);
+ T1 : Entity_Id;
+ T2 : Entity_Id;
+ Ret : constant Entity_Id := Etype (E);
+
+ begin
+ if Nam = Name_Op_Add
+ or else Nam = Name_Op_Subtract
+ or else Nam = Name_Op_Multiply
+ or else Nam = Name_Op_Divide
+ then
+ T1 := Etype (First_Formal (E));
+
+ if No (Next_Formal (First_Formal (E))) then
+
+ -- previous error in declaration.
+ return;
+
+ else
+ T2 := Etype (Next_Formal (First_Formal (E)));
+ end if;
+
+ if Root_Type (T1) /= Root_Type (T2)
+ or else Root_Type (T1) /= Root_Type (Ret)
+ then
+ Errint (
+ "types of intrinsic operator must have the same size", E, N);
+
+ elsif not Is_Numeric_Type (T1) then
+ Errint (
+ " intrinsic operator can only apply to numeric types", E, N);
+ end if;
+
+ else
+ Errint ("incorrect context for ""Intrinsic"" convention", E, N);
+ end if;
+ end Check_Intrinsic_Operator;
+
+ --------------------------------
+ -- Check_Intrinsic_Subprogram --
+ --------------------------------
+
+ procedure Check_Intrinsic_Subprogram (E : Entity_Id; N : Node_Id) is
+ Spec : constant Node_Id := Specification (Unit_Declaration_Node (E));
+ Nam : Name_Id;
+
+ begin
+ if Present (Spec)
+ and then Present (Generic_Parent (Spec))
+ then
+ Nam := Chars (Generic_Parent (Spec));
+ else
+ Nam := Chars (E);
+ end if;
+
+ -- Check name is valid intrinsic name
+
+ Get_Name_String (Nam);
+
+ if Name_Buffer (1) /= 'O'
+ and then Nam /= Name_Asm
+ and then Nam not in First_Intrinsic_Name .. Last_Intrinsic_Name
+ then
+ Errint ("unrecognized intrinsic subprogram", E, N);
+
+ -- We always allow intrinsic specifications in language defined units
+ -- and in expanded code. We assume that the GNAT implemetors know what
+ -- they are doing, and do not write or generate junk use of intrinsic!
+
+ elsif not Comes_From_Source (E)
+ or else not Comes_From_Source (N)
+ or else Is_Predefined_File_Name
+ (Unit_File_Name (Get_Source_Unit (N)))
+ then
+ null;
+
+ -- Shift cases. We allow user specification of intrinsic shift
+ -- operators for any numeric types.
+
+ elsif
+ Nam = Name_Rotate_Left
+ or else
+ Nam = Name_Rotate_Right
+ or else
+ Nam = Name_Shift_Left
+ or else
+ Nam = Name_Shift_Right
+ or else
+ Nam = Name_Shift_Right_Arithmetic
+ then
+ Check_Shift (E, N);
+
+ elsif
+ Nam = Name_Exception_Information
+ or else
+ Nam = Name_Exception_Message
+ or else
+ Nam = Name_Exception_Name
+ then
+ Check_Exception_Function (E, N);
+
+ elsif Nkind (E) = N_Defining_Operator_Symbol then
+ Check_Intrinsic_Operator (E, N);
+
+ elsif Nam = Name_File
+ or else Nam = Name_Line
+ or else Nam = Name_Source_Location
+ or else Nam = Name_Enclosing_Entity
+ then
+ null;
+
+ -- For now, no other intrinsic subprograms are recognized in user code
+
+ else
+ Errint ("incorrect context for ""Intrinsic"" convention", E, N);
+ end if;
+ end Check_Intrinsic_Subprogram;
+
+ -----------------
+ -- Check_Shift --
+ -----------------
+
+ procedure Check_Shift (E : Entity_Id; N : Node_Id) is
+ Arg1 : Node_Id;
+ Arg2 : Node_Id;
+ Size : Nat;
+ Typ1 : Entity_Id;
+ Typ2 : Entity_Id;
+ Ptyp1 : Node_Id;
+ Ptyp2 : Node_Id;
+
+ begin
+ if Ekind (E) /= E_Function
+ and then Ekind (E) /= E_Generic_Function
+ then
+ Errint ("intrinsic shift subprogram must be a function", E, N);
+ return;
+ end if;
+
+ Arg1 := First_Formal (E);
+
+ if Present (Arg1) then
+ Arg2 := Next_Formal (Arg1);
+ else
+ Arg2 := Empty;
+ end if;
+
+ if Arg1 = Empty or else Arg2 = Empty then
+ Errint ("intrinsic shift function must have two arguments", E, N);
+ return;
+ end if;
+
+ Typ1 := Etype (Arg1);
+ Typ2 := Etype (Arg2);
+
+ Ptyp1 := Parameter_Type (Parent (Arg1));
+ Ptyp2 := Parameter_Type (Parent (Arg2));
+
+ if not Is_Integer_Type (Typ1) then
+ Errint ("first argument to shift must be integer type", Ptyp1, N);
+ return;
+ end if;
+
+ if Typ2 /= Standard_Natural then
+ Errint ("second argument to shift must be type Natural", Ptyp2, N);
+ return;
+ end if;
+
+ Size := UI_To_Int (Esize (Typ1));
+
+ if Size /= 8
+ and then Size /= 16
+ and then Size /= 32
+ and then Size /= 64
+ then
+ Errint
+ ("first argument for shift must have size 8, 16, 32 or 64",
+ Ptyp1, N);
+ return;
+
+ elsif Is_Modular_Integer_Type (Typ1)
+ and then Non_Binary_Modulus (Typ1)
+ then
+ Errint
+ ("shifts not allowed for non-binary modular types",
+ Ptyp1, N);
+
+ elsif Etype (Arg1) /= Etype (E) then
+ Errint
+ ("first argument of shift must match return type", Ptyp1, N);
+ return;
+ end if;
+ end Check_Shift;
+
+ ------------
+ -- Errint --
+ ------------
+
+ procedure Errint (Msg : String; S : Node_Id; N : Node_Id) is
+ begin
+ Error_Msg_N (Msg, S);
+ Error_Msg_N ("incorrect intrinsic subprogram, see spec", N);
+ end Errint;
+
+end Sem_Intr;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S E M _ I N T R --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.4 $ --
+-- --
+-- Copyright (C) 1992,1993,1994 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). --
+-- --
+------------------------------------------------------------------------------
+
+-- Processing for intrinsic subprogram declarations
+
+with Types; use Types;
+
+package Sem_Intr is
+
+ procedure Check_Intrinsic_Call (N : Node_Id);
+ -- Perform legality check for intrinsic call N (which is either function
+ -- call or a procedure call node). All the normal semantic checks have
+ -- been performed already. Check_Intrinsic_Call applies any additional
+ -- checks required by the fact that an intrinsic subprogram is involved.
+
+ procedure Check_Intrinsic_Subprogram (E : Entity_Id; N : Node_Id);
+ -- Special processing for pragma Import or pragma Interface when the
+ -- convention is Intrinsic. E is the Entity_Id of the spec of the
+ -- subprogram, and N is the second (subprogram) argument of the pragma.
+ -- Check_Intrinsic_Subprogram checks that the referenced subprogram is
+ -- known as an intrinsic and has an appropriate profile. If so the flag
+ -- Is_Intrinsic_Subprogram is set, otherwise an error message is posted.
+
+end Sem_Intr;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S E M _ M A P S --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.3 $ --
+-- --
+-- Copyright (C) 1996-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). --
+-- --
+------------------------------------------------------------------------------
+
+with Atree; use Atree;
+with Einfo; use Einfo;
+with Namet; use Namet;
+with Output; use Output;
+with Sinfo; use Sinfo;
+with Uintp; use Uintp;
+
+package body Sem_Maps is
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ function Find_Assoc (M : Map; E : Entity_Id) return Assoc_Index;
+ -- Standard hash table search. M is the map to be searched, E is the
+ -- entity to be searched for, and Assoc_Index is the resulting
+ -- association, or is set to No_Assoc if there is no association.
+
+ function Find_Header_Size (N : Int) return Header_Index;
+ -- Find largest power of two smaller than the number of entries in
+ -- the table. This load factor of 2 may be adjusted later if needed.
+
+ procedure Write_Map (E : Entity_Id);
+ pragma Warnings (Off, Write_Map);
+ -- For debugging purposes.
+
+ ---------------------
+ -- Add_Association --
+ ---------------------
+
+ procedure Add_Association
+ (M : in out Map;
+ O_Id : Entity_Id;
+ N_Id : Entity_Id;
+ Kind : Scope_Kind := S_Local)
+ is
+ Info : constant Map_Info := Maps_Table.Table (M);
+ Offh : constant Header_Index := Info.Header_Offset;
+ Offs : constant Header_Index := Info.Header_Num;
+ J : constant Header_Index := Header_Index (O_Id) mod Offs;
+ K : constant Assoc_Index := Info.Assoc_Next;
+
+ begin
+ Associations_Table.Table (K) := (O_Id, N_Id, Kind, No_Assoc);
+ Maps_Table.Table (M).Assoc_Next := K + 1;
+
+ if Headers_Table.Table (Offh + J) /= No_Assoc then
+
+ -- Place new association at head of chain.
+
+ Associations_Table.Table (K).Next := Headers_Table.Table (Offh + J);
+ end if;
+
+ Headers_Table.Table (Offh + J) := K;
+ end Add_Association;
+
+ ------------------------
+ -- Build_Instance_Map --
+ ------------------------
+
+ function Build_Instance_Map (M : Map) return Map is
+ Info : constant Map_Info := Maps_Table.Table (M);
+ Res : constant Map := New_Map (Int (Info.Assoc_Num));
+ Offh1 : constant Header_Index := Info.Header_Offset;
+ Offa1 : constant Assoc_Index := Info.Assoc_Offset;
+ Offh2 : constant Header_Index := Maps_Table.Table (Res).Header_Offset;
+ Offa2 : constant Assoc_Index := Maps_Table.Table (Res).Assoc_Offset;
+ A : Assoc;
+ A_Index : Assoc_Index;
+
+ begin
+ for J in 0 .. Info.Header_Num - 1 loop
+ A_Index := Headers_Table.Table (Offh1 + J);
+
+ if A_Index /= No_Assoc then
+ Headers_Table.Table (Offh2 + J) := A_Index + (Offa2 - Offa1);
+ end if;
+ end loop;
+
+ for J in 0 .. Info.Assoc_Num - 1 loop
+ A := Associations_Table.Table (Offa1 + J);
+
+ -- For local entities that come from source, create the
+ -- corresponding local entities in the instance. Entities that
+ -- do not come from source are etypes, and new ones will be
+ -- generated when analyzing the instance.
+
+ if No (A.New_Id)
+ and then A.Kind = S_Local
+ and then Comes_From_Source (A.Old_Id)
+ then
+ A.New_Id := New_Copy (A.Old_Id);
+ A.New_Id := New_Entity (Nkind (A.Old_Id), Sloc (A.Old_Id));
+ Set_Chars (A.New_Id, Chars (A.Old_Id));
+ end if;
+
+ if A.Next /= No_Assoc then
+ A.Next := A.Next + (Offa2 - Offa1);
+ end if;
+
+ Associations_Table.Table (Offa2 + J) := A;
+ end loop;
+
+ Maps_Table.Table (Res).Assoc_Next := Associations_Table.Last;
+ return Res;
+ end Build_Instance_Map;
+
+ -------------
+ -- Compose --
+ -------------
+
+ function Compose (Orig_Map : Map; New_Map : Map) return Map is
+ Res : constant Map := Copy (Orig_Map);
+ Off : constant Assoc_Index := Maps_Table.Table (Res).Assoc_Offset;
+ A : Assoc;
+ K : Assoc_Index;
+
+ begin
+ -- Iterate over the contents of Orig_Map, looking for entities
+ -- that are further mapped under New_Map.
+
+ for J in 0 .. Maps_Table.Table (Res).Assoc_Num - 1 loop
+ A := Associations_Table.Table (Off + J);
+ K := Find_Assoc (New_Map, A.New_Id);
+
+ if K /= No_Assoc then
+ Associations_Table.Table (Off + J).New_Id
+ := Associations_Table.Table (K).New_Id;
+ end if;
+ end loop;
+
+ return Res;
+ end Compose;
+
+ ----------
+ -- Copy --
+ ----------
+
+ function Copy (M : Map) return Map is
+ Info : constant Map_Info := Maps_Table.Table (M);
+ Res : constant Map := New_Map (Int (Info.Assoc_Num));
+ Offh1 : constant Header_Index := Info.Header_Offset;
+ Offa1 : constant Assoc_Index := Info.Assoc_Offset;
+ Offh2 : constant Header_Index := Maps_Table.Table (Res).Header_Offset;
+ Offa2 : constant Assoc_Index := Maps_Table.Table (Res).Assoc_Offset;
+ A : Assoc;
+ A_Index : Assoc_Index;
+
+ begin
+ for J in 0 .. Info.Header_Num - 1 loop
+ A_Index := Headers_Table.Table (Offh1 + J) + (Offa2 - Offa1);
+
+ if A_Index /= No_Assoc then
+ Headers_Table.Table (Offh2 + J) := A_Index + (Offa2 - Offa1);
+ end if;
+ end loop;
+
+ for J in 0 .. Info.Assoc_Num - 1 loop
+ A := Associations_Table.Table (Offa1 + J);
+ A.Next := A.Next + (Offa2 - Offa1);
+ Associations_Table.Table (Offa2 + J) := A;
+ end loop;
+
+ Maps_Table.Table (Res).Assoc_Next := Associations_Table.Last;
+ return Res;
+ end Copy;
+
+ ----------------
+ -- Find_Assoc --
+ ----------------
+
+ function Find_Assoc (M : Map; E : Entity_Id) return Assoc_Index is
+ Offh : constant Header_Index := Maps_Table.Table (M).Header_Offset;
+ Offs : constant Header_Index := Maps_Table.Table (M).Header_Num;
+ J : constant Header_Index := Header_Index (E) mod Offs;
+ A : Assoc;
+ A_Index : Assoc_Index;
+
+ begin
+ A_Index := Headers_Table.Table (Offh + J);
+
+ if A_Index = No_Assoc then
+ return A_Index;
+
+ else
+ A := Associations_Table.Table (A_Index);
+
+ while Present (A.Old_Id) loop
+
+ if A.Old_Id = E then
+ return A_Index;
+
+ elsif A.Next = No_Assoc then
+ return No_Assoc;
+
+ else
+ A_Index := A.Next;
+ A := Associations_Table.Table (A.Next);
+ end if;
+ end loop;
+
+ return No_Assoc;
+ end if;
+ end Find_Assoc;
+
+ ----------------------
+ -- Find_Header_Size --
+ ----------------------
+
+ function Find_Header_Size (N : Int) return Header_Index is
+ Siz : Header_Index;
+
+ begin
+ Siz := 2;
+ while 2 * Siz < Header_Index (N) loop
+ Siz := 2 * Siz;
+ end loop;
+
+ return Siz;
+ end Find_Header_Size;
+
+ ------------
+ -- Lookup --
+ ------------
+
+ function Lookup (M : Map; E : Entity_Id) return Entity_Id is
+ Offh : constant Header_Index := Maps_Table.Table (M).Header_Offset;
+ Offs : constant Header_Index := Maps_Table.Table (M).Header_Num;
+ J : constant Header_Index := Header_Index (E) mod Offs;
+ A : Assoc;
+
+ begin
+ if Headers_Table.Table (Offh + J) = No_Assoc then
+ return Empty;
+
+ else
+ A := Associations_Table.Table (Headers_Table.Table (Offh + J));
+
+ while Present (A.Old_Id) loop
+
+ if A.Old_Id = E then
+ return A.New_Id;
+
+ elsif A.Next = No_Assoc then
+ return Empty;
+
+ else
+ A := Associations_Table.Table (A.Next);
+ end if;
+ end loop;
+
+ return Empty;
+ end if;
+ end Lookup;
+
+ -------------
+ -- New_Map --
+ -------------
+
+ function New_Map (Num_Assoc : Int) return Map is
+ Header_Size : Header_Index := Find_Header_Size (Num_Assoc);
+ Res : Map_Info;
+
+ begin
+ -- Allocate the tables for the new map at the current end of the
+ -- global tables.
+
+ Associations_Table.Increment_Last;
+ Headers_Table.Increment_Last;
+ Maps_Table.Increment_Last;
+
+ Res.Header_Offset := Headers_Table.Last;
+ Res.Header_Num := Header_Size;
+ Res.Assoc_Offset := Associations_Table.Last;
+ Res.Assoc_Next := Associations_Table.Last;
+ Res.Assoc_Num := Assoc_Index (Num_Assoc);
+
+ Headers_Table.Set_Last (Headers_Table.Last + Header_Size);
+ Associations_Table.Set_Last
+ (Associations_Table.Last + Assoc_Index (Num_Assoc));
+ Maps_Table.Table (Maps_Table.Last) := Res;
+
+ for J in 1 .. Header_Size loop
+ Headers_Table.Table (Headers_Table.Last - J) := No_Assoc;
+ end loop;
+
+ return Maps_Table.Last;
+ end New_Map;
+
+ ------------------------
+ -- Update_Association --
+ ------------------------
+
+ procedure Update_Association
+ (M : in out Map;
+ O_Id : Entity_Id;
+ N_Id : Entity_Id;
+ Kind : Scope_Kind := S_Local)
+ is
+ J : constant Assoc_Index := Find_Assoc (M, O_Id);
+
+ begin
+ Associations_Table.Table (J).New_Id := N_Id;
+ Associations_Table.Table (J).Kind := Kind;
+ end Update_Association;
+
+ ---------------
+ -- Write_Map --
+ ---------------
+
+ procedure Write_Map (E : Entity_Id) is
+ M : constant Map := Map (UI_To_Int (Renaming_Map (E)));
+ Info : constant Map_Info := Maps_Table.Table (M);
+ Offh : constant Header_Index := Info.Header_Offset;
+ Offa : constant Assoc_Index := Info.Assoc_Offset;
+ A : Assoc;
+
+ begin
+ Write_Str ("Size : ");
+ Write_Int (Int (Info.Assoc_Num));
+ Write_Eol;
+
+ Write_Str ("Headers");
+ Write_Eol;
+
+ for J in 0 .. Info.Header_Num - 1 loop
+ Write_Int (Int (Offh + J));
+ Write_Str (" : ");
+ Write_Int (Int (Headers_Table.Table (Offh + J)));
+ Write_Eol;
+ end loop;
+
+ for J in 0 .. Info.Assoc_Num - 1 loop
+ A := Associations_Table.Table (Offa + J);
+ Write_Int (Int (Offa + J));
+ Write_Str (" : ");
+ Write_Name (Chars (A.Old_Id));
+ Write_Str (" ");
+ Write_Int (Int (A.Old_Id));
+ Write_Str (" ==> ");
+ Write_Int (Int (A.New_Id));
+ Write_Str (" next = ");
+ Write_Int (Int (A.Next));
+ Write_Eol;
+ end loop;
+ end Write_Map;
+
+end Sem_Maps;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S E M _ M A P S --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.4 $
+-- --
+-- Copyright (C) 1996-1999 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 contains the operations on the renaming maps used for
+-- generic analysis and instantiation. Renaming maps are created when
+-- a generic unit is analyzed, in order to capture all references to
+-- global variables within the unit. The renaming map of a generic unit
+-- copied prior to each instantiation, and then updated by mapping the
+-- formals into the actuals and the local entities into entities local to
+-- the instance. When the generic tree is copied to produce the instance,
+-- all references are updated by means of the renaming map.
+
+-- Map composition of renaming maps takes place for nested instantiations,
+-- for generic child units, and for formal packages.
+
+-- For additional details, see the documentation in sem_ch12.
+
+with Table;
+with Types; use Types;
+
+package Sem_Maps is
+
+ type Map is new Int;
+
+ type Assoc is private;
+
+ type Scope_Kind is (S_Global, S_Formal, S_Local);
+
+ function New_Map (Num_Assoc : Int) return Map;
+ -- Build empty map with the given number of associations, and a
+ -- headers table of the appropriate size.
+
+ function Compose (Orig_Map : Map; New_Map : Map) return Map;
+ -- Update the associations in Orig_Map, so that if Orig_Map (e1) = e2
+ -- and New_Map (e2) = e3, then the image of e1 under the result is e3.
+
+ function Copy (M : Map) return Map;
+ -- Full copy of contents and headers.
+
+ function Lookup (M : Map; E : Entity_Id) return Entity_Id;
+ -- Retrieve image of E under M, Empty if undefined.
+
+ procedure Add_Association
+ (M : in out Map;
+ O_Id : Entity_Id;
+ N_Id : Entity_Id;
+ Kind : Scope_Kind := S_Local);
+ -- Update M in place. On entry M (O_Id) must not be defined.
+
+ procedure Update_Association
+ (M : in out Map;
+ O_Id : Entity_Id;
+ N_Id : Entity_Id;
+ Kind : Scope_Kind := S_Local);
+ -- Update the entry in M for O_Id.
+
+ function Build_Instance_Map (M : Map) return Map;
+ -- Copy renaming map of generic, and create new entities for all the
+ -- local entities within.
+
+private
+
+ -- New maps are created when a generic is analyzed, and for each of
+ -- its instantiations. Maps are also updated for nested generics, for
+ -- child units, and for formal packages. As a result we need to allocate
+ -- maps dynamically.
+
+ -- When analyzing a generic, we do not know how many references are
+ -- in it. We build an initial map after generic analysis, using a static
+ -- structure that relies on the compiler's extensible table mechanism.
+ -- After constructing this initial map, all subsequent uses and updates
+ -- of this map do not modify its domain, so that dynamically allocated
+ -- maps have a fixed size and never need to be reallocated. Furthermore,
+ -- the headers of the hash table of a dynamically allocated map can be
+ -- chosen according to the total number of entries in the map, to
+ -- accomodate efficiently generic units of different sizes (Unchecked_
+ -- Conversion vs. Generic_Elementary_Functions, for example). So in
+ -- fact both components of a map have fixed size, and can be allocated
+ -- using the standard table mechanism. A Maps_Table holds records that
+ -- contain indices into the global Headers table and the Associations
+ -- table, and a Map is an index into the Maps_Table.
+ --
+ -- Maps_Table Headers_Table Associations_Table
+ --
+ -- |_____| |___________ |
+ -- |_____| | | | |
+ -- ------>|Map |------------------------------>|Associations|
+ -- |Info |------------->| |=========>| for one |
+ -- |_____| | |====| | unit |
+ -- | | | | |====>| |
+ -- |_____| |____________|
+ -- | | | |
+ type Header_Index is new Int;
+ type Assoc_Index is new Int;
+ No_Assoc : constant Assoc_Index := -1;
+
+ type Map_Info is record
+ Header_Offset : Header_Index;
+ Header_Num : Header_Index;
+ Assoc_Offset : Assoc_Index;
+ Assoc_Num : Assoc_Index;
+ Assoc_Next : Assoc_Index;
+ end record;
+
+ type Assoc is record
+ Old_Id : Entity_Id := Empty;
+ New_Id : Entity_Id := Empty;
+ Kind : Scope_Kind := S_Local;
+ Next : Assoc_Index := No_Assoc;
+ end record;
+
+ -- All maps are accessed through the following table. The map attribute
+ -- of a generic unit or an instance is an index into this table.
+
+ package Maps_Table is new Table.Table (
+ Table_Component_Type => Map_Info,
+ Table_Index_Type => Map,
+ Table_Low_Bound => 0,
+ Table_Initial => 100,
+ Table_Increment => 10,
+ Table_Name => "Maps_Table");
+
+ -- All headers for hash tables are allocated in one global table. Each
+ -- map stores the offset into this table at which its own headers start.
+
+ package Headers_Table is new Table.Table (
+ Table_Component_Type => Assoc_Index,
+ Table_Index_Type => Header_Index,
+ Table_Low_Bound => 0,
+ Table_Initial => 1000,
+ Table_Increment => 10,
+ Table_Name => "Headers_Table");
+
+ -- All associations are allocated in one global table. Each map stores
+ -- the offset into this table at which its own associations start.
+
+ package Associations_Table is new Table.Table (
+ Table_Component_Type => Assoc,
+ Table_Index_Type => Assoc_Index,
+ Table_Low_Bound => 1,
+ Table_Initial => 1000,
+ Table_Increment => 10,
+ Table_Name => "Associations_Table");
+
+end Sem_Maps;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S E M _ M E C H --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.16 $
+-- --
+-- Copyright (C) 1996-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 Atree; use Atree;
+with Einfo; use Einfo;
+with Errout; use Errout;
+with Targparm; use Targparm;
+with Nlists; use Nlists;
+with Sem; use Sem;
+with Sem_Util; use Sem_Util;
+with Sinfo; use Sinfo;
+with Snames; use Snames;
+with Stand; use Stand;
+
+package body Sem_Mech is
+
+ -------------------------
+ -- Set_Mechanism_Value --
+ -------------------------
+
+ procedure Set_Mechanism_Value (Ent : Entity_Id; Mech_Name : Node_Id) is
+ Class : Node_Id;
+ Param : Node_Id;
+
+ procedure Bad_Class;
+ -- Signal bad descriptor class name
+
+ procedure Bad_Mechanism;
+ -- Signal bad mechanism name
+
+ procedure Bad_Class is
+ begin
+ Error_Msg_N ("unrecognized descriptor class name", Class);
+ end Bad_Class;
+
+ procedure Bad_Mechanism is
+ begin
+ Error_Msg_N ("unrecognized mechanism name", Mech_Name);
+ end Bad_Mechanism;
+
+ -- Start of processing for Set_Mechanism_Value
+
+ begin
+ if Mechanism (Ent) /= Default_Mechanism then
+ Error_Msg_NE
+ ("mechanism for & has already been set", Mech_Name, Ent);
+ end if;
+
+ -- MECHANISM_NAME ::= value | reference | descriptor
+
+ if Nkind (Mech_Name) = N_Identifier then
+ if Chars (Mech_Name) = Name_Value then
+ Set_Mechanism_With_Checks (Ent, By_Copy, Mech_Name);
+ return;
+
+ elsif Chars (Mech_Name) = Name_Reference then
+ Set_Mechanism_With_Checks (Ent, By_Reference, Mech_Name);
+ return;
+
+ elsif Chars (Mech_Name) = Name_Descriptor then
+ Check_VMS (Mech_Name);
+ Set_Mechanism_With_Checks (Ent, By_Descriptor, Mech_Name);
+ return;
+
+ elsif Chars (Mech_Name) = Name_Copy then
+ Error_Msg_N
+ ("bad mechanism name, Value assumed", Mech_Name);
+ Set_Mechanism (Ent, By_Copy);
+
+ else
+ Bad_Mechanism;
+ return;
+ end if;
+
+ -- MECHANISM_NAME ::= descriptor (CLASS_NAME)
+ -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
+
+ -- Note: this form is parsed as an indexed component
+
+ elsif Nkind (Mech_Name) = N_Indexed_Component then
+ Class := First (Expressions (Mech_Name));
+
+ if Nkind (Prefix (Mech_Name)) /= N_Identifier
+ or else Chars (Prefix (Mech_Name)) /= Name_Descriptor
+ or else Present (Next (Class))
+ then
+ Bad_Mechanism;
+ return;
+ end if;
+
+ -- MECHANISM_NAME ::= descriptor (Class => CLASS_NAME)
+ -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
+
+ -- Note: this form is parsed as a function call
+
+ elsif Nkind (Mech_Name) = N_Function_Call then
+
+ Param := First (Parameter_Associations (Mech_Name));
+
+ if Nkind (Name (Mech_Name)) /= N_Identifier
+ or else Chars (Name (Mech_Name)) /= Name_Descriptor
+ or else Present (Next (Param))
+ or else No (Selector_Name (Param))
+ or else Chars (Selector_Name (Param)) /= Name_Class
+ then
+ Bad_Mechanism;
+ return;
+ else
+ Class := Explicit_Actual_Parameter (Param);
+ end if;
+
+ else
+ Bad_Mechanism;
+ return;
+ end if;
+
+ -- Fall through here with Class set to descriptor class name
+
+ Check_VMS (Mech_Name);
+
+ if Nkind (Class) /= N_Identifier then
+ Bad_Class;
+ return;
+
+ elsif Chars (Class) = Name_UBS then
+ Set_Mechanism_With_Checks (Ent, By_Descriptor_UBS, Mech_Name);
+
+ elsif Chars (Class) = Name_UBSB then
+ Set_Mechanism_With_Checks (Ent, By_Descriptor_UBSB, Mech_Name);
+
+ elsif Chars (Class) = Name_UBA then
+ Set_Mechanism_With_Checks (Ent, By_Descriptor_UBA, Mech_Name);
+
+ elsif Chars (Class) = Name_S then
+ Set_Mechanism_With_Checks (Ent, By_Descriptor_S, Mech_Name);
+
+ elsif Chars (Class) = Name_SB then
+ Set_Mechanism_With_Checks (Ent, By_Descriptor_SB, Mech_Name);
+
+ elsif Chars (Class) = Name_A then
+ Set_Mechanism_With_Checks (Ent, By_Descriptor_A, Mech_Name);
+
+ elsif Chars (Class) = Name_NCA then
+ Set_Mechanism_With_Checks (Ent, By_Descriptor_NCA, Mech_Name);
+
+ else
+ Bad_Class;
+ return;
+ end if;
+
+ end Set_Mechanism_Value;
+
+ -------------------------------
+ -- Set_Mechanism_With_Checks --
+ -------------------------------
+
+ procedure Set_Mechanism_With_Checks
+ (Ent : Entity_Id;
+ Mech : Mechanism_Type;
+ Enod : Node_Id)
+ is
+ begin
+ -- Right now we only do some checks for functions returning arguments
+ -- by desctiptor. Probably mode checks need to be added here ???
+
+ if Mech in Descriptor_Codes and then not Is_Formal (Ent) then
+ if Is_Record_Type (Etype (Ent)) then
+ Error_Msg_N ("?records cannot be returned by Descriptor", Enod);
+ return;
+ end if;
+ end if;
+
+ -- If we fall through, all checks have passed
+
+ Set_Mechanism (Ent, Mech);
+ end Set_Mechanism_With_Checks;
+
+ --------------------
+ -- Set_Mechanisms --
+ --------------------
+
+ procedure Set_Mechanisms (E : Entity_Id) is
+ Formal : Entity_Id;
+ Typ : Entity_Id;
+
+ begin
+ -- Skip this processing if inside a generic template. Not only is
+ -- it uneccessary (since neither extra formals nor mechanisms are
+ -- relevant for the template itself), but at least at the moment,
+ -- procedures get frozen early inside a template so attempting to
+ -- look at the formal types does not work too well if they are
+ -- private types that have not been frozen yet.
+
+ if Inside_A_Generic then
+ return;
+ end if;
+
+ -- Loop through formals
+
+ Formal := First_Formal (E);
+ while Present (Formal) loop
+
+ if Mechanism (Formal) = Default_Mechanism then
+ Typ := Underlying_Type (Etype (Formal));
+
+ -- If there is no underlying type, then skip this processing and
+ -- leave the convention set to Default_Mechanism. It seems odd
+ -- that there should ever be such cases but there are (see
+ -- comments for filed regression tests 1418-001 and 1912-009) ???
+
+ if No (Typ) then
+ goto Skip_Formal;
+ end if;
+
+ case Convention (E) is
+
+ ---------
+ -- Ada --
+ ---------
+
+ -- Note: all RM defined conventions are treated the same
+ -- from the point of view of parameter passing mechanims
+
+ when Convention_Ada |
+ Convention_Intrinsic |
+ Convention_Entry |
+ Convention_Protected |
+ Convention_Stubbed =>
+
+ -- By reference types are passed by reference (RM 6.2(4))
+
+ if Is_By_Reference_Type (Typ) then
+ Set_Mechanism (Formal, By_Reference);
+
+ -- By copy types are passed by copy (RM 6.2(3))
+
+ elsif Is_By_Copy_Type (Typ) then
+ Set_Mechanism (Formal, By_Copy);
+
+ -- All other types we leave the Default_Mechanism set, so
+ -- that the backend can choose the appropriate method.
+
+ else
+ null;
+ end if;
+
+ -------
+ -- C --
+ -------
+
+ -- Note: Assembler, C++, Java, Stdcall also use C conventions
+
+ when Convention_Assembler |
+ Convention_C |
+ Convention_CPP |
+ Convention_Java |
+ Convention_Stdcall =>
+
+ -- The following values are passed by copy
+
+ -- IN Scalar parameters (RM B.3(66))
+ -- IN parameters of access types (RM B.3(67))
+ -- Access parameters (RM B.3(68))
+ -- Access to subprogram types (RM B.3(71))
+
+ -- Note: in the case of access parameters, it is the
+ -- pointer that is passed by value. In GNAT access
+ -- parameters are treated as IN parameters of an
+ -- anonymous access type, so this falls out free.
+
+ -- The bottom line is that all IN elementary types
+ -- are passed by copy in GNAT.
+
+ if Is_Elementary_Type (Typ) then
+ if Ekind (Formal) = E_In_Parameter then
+ Set_Mechanism (Formal, By_Copy);
+
+ -- OUT and IN OUT parameters of elementary types are
+ -- passed by reference (RM B.3(68)). Note that we are
+ -- not following the advice to pass the address of a
+ -- copy to preserve by copy semantics.
+
+ else
+ Set_Mechanism (Formal, By_Reference);
+ end if;
+
+ -- Records are normally passed by reference (RM B.3(69)).
+ -- However, this can be overridden by the use of the
+ -- C_Pass_By_Copy pragma or C_Pass_By_Copy convention.
+
+ elsif Is_Record_Type (Typ) then
+
+ -- If the record is not convention C, then we always
+ -- pass by reference, C_Pass_By_Copy does not apply.
+
+ if Convention (Typ) /= Convention_C then
+ Set_Mechanism (Formal, By_Reference);
+
+ -- If convention C_Pass_By_Copy was specified for
+ -- the record type, then we pass by copy.
+
+ elsif C_Pass_By_Copy (Typ) then
+ Set_Mechanism (Formal, By_Copy);
+
+ -- Otherwise, for a C convention record, we set the
+ -- convention in accordance with a possible use of
+ -- the C_Pass_By_Copy pragma. Note that the value of
+ -- Default_C_Record_Mechanism in the absence of such
+ -- a pragma is By_Reference.
+
+ else
+ Set_Mechanism (Formal, Default_C_Record_Mechanism);
+ end if;
+
+ -- Array types are passed by reference (B.3 (71))
+
+ elsif Is_Array_Type (Typ) then
+ Set_Mechanism (Formal, By_Reference);
+
+ -- For all other types, use Default_Mechanism mechanism
+
+ else
+ null;
+ end if;
+
+ -----------
+ -- COBOL --
+ -----------
+
+ when Convention_COBOL =>
+
+ -- Access parameters (which in GNAT look like IN parameters
+ -- of an access type) are passed by copy (RM B.4(96)) as
+ -- are all other IN parameters of scalar type (RM B.4(97)).
+
+ -- For now we pass these parameters by reference as well.
+ -- The RM specifies the intent BY_CONTENT, but gigi does
+ -- not currently transform By_Copy properly. If we pass by
+ -- reference, it will be imperative to introduce copies ???
+
+ if Is_Elementary_Type (Typ)
+ and then Ekind (Formal) = E_In_Parameter
+ then
+ Set_Mechanism (Formal, By_Reference);
+
+ -- All other parameters (i.e. all non-scalar types, and
+ -- all OUT or IN OUT parameters) are passed by reference.
+ -- Note that at the moment we are not bothering to make
+ -- copies of scalar types as recommended in the RM.
+
+ else
+ Set_Mechanism (Formal, By_Reference);
+ end if;
+
+ -------------
+ -- Fortran --
+ -------------
+
+ when Convention_Fortran =>
+
+ -- In OpenVMS, pass a character of array of character
+ -- value using Descriptor(S). Should this also test
+ -- Debug_Flag_M ???
+
+ if OpenVMS_On_Target
+ and then (Root_Type (Typ) = Standard_Character
+ or else
+ (Is_Array_Type (Typ)
+ and then
+ Root_Type (Component_Type (Typ)) =
+ Standard_Character))
+ then
+ Set_Mechanism (Formal, By_Descriptor_S);
+
+ -- Access types are passed by default (presumably this
+ -- will mean they are passed by copy)
+
+ elsif Is_Access_Type (Typ) then
+ null;
+
+ -- For now, we pass all other parameters by reference.
+ -- It is not clear that this is right in the long run,
+ -- but it seems to correspond to what gnu f77 wants.
+
+
+ else
+ Set_Mechanism (Formal, By_Reference);
+ end if;
+
+ end case;
+ end if;
+
+ <<Skip_Formal>> -- remove this when problem above is fixed ???
+
+ Next_Formal (Formal);
+ end loop;
+
+ -- Now deal with return type, we always leave the default mechanism
+ -- set except for the case of returning a By_Reference type for an
+ -- Ada convention, where we force return by reference
+
+ if Ekind (E) = E_Function
+ and then Mechanism (E) = Default_Mechanism
+ and then not Has_Foreign_Convention (E)
+ and then Is_By_Reference_Type (Etype (E))
+ then
+ Set_Mechanism (E, By_Reference);
+ end if;
+
+ end Set_Mechanisms;
+
+end Sem_Mech;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S E M _ M E C H --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.6 $ --
+-- --
+-- Copyright (C) 1996-1997 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 contains the routine used to establish calling mechanisms
+-- The reason we separate this off into its own package is that it is
+-- entirely possible that it may need some target specific specialization.
+
+with Types; use Types;
+
+package Sem_Mech is
+
+ -------------------------------------------------
+ -- Definitions for Parameter Mechanism Control --
+ -------------------------------------------------
+
+ -- For parameters passed to subprograms, and for function return values,
+ -- as passing mechanism is defined. The entity attribute Mechanism returns
+ -- an indication of the mechanism, and Set_Mechanism can be used to set
+ -- the mechanism. At the program level, there are three ways to explicitly
+ -- set the mechanism:
+
+ -- An Import_xxx or Export_xxx pragma (where xxx is Function, Procedure,
+ -- or Valued_Procedure) can explicitly set the mechanism for either a
+ -- parameter or a function return value. A mechanism explicitly set by
+ -- such a pragma overrides the effect of C_Pass_By_Copy described below.
+
+ -- If convention C_Pass_By_Copy is set for a record, and the record type
+ -- is used as the formal type of a subprogram with a foreign convention,
+ -- then the mechanism is set to By_Copy.
+
+ -- If a pragma C_Pass_By_Copy applies, and a record type has Convention
+ -- C, and the record type is used as the formal type of a subprogram
+ -- with a foreign convention, then the mechanism is set to use By_Copy
+ -- if the size of the record is sufficiently small (as determined by
+ -- the value of the parameter to pragma C_Pass_By_Copy).
+
+ -- The subtype Mechanism_Type (declared in Types) is used to describe
+ -- the mechanism to be used. The following special values of this type
+ -- specify the mechanism, as follows.
+
+ Default_Mechanism : constant Mechanism_Type := 0;
+ -- The default setting indicates that the backend will choose the proper
+ -- default mechanism. This depends on the convention of the subprogram
+ -- involved, and is generally target dependent. In the compiler, the
+ -- backend chooses the mechanism in this case in accordance with any
+ -- requirements imposed by the ABI. Note that Default is never used for
+ -- record types on foreign convention subprograms, since By_Reference
+ -- is forced for such types unless one of the above described approaches
+ -- is used to explicitly force By_Copy.
+
+ By_Copy : constant Mechanism_Type := -1;
+ -- Passing by copy is forced. The exact meaning of By_Copy (e.g. whether
+ -- at a low level the value is passed in registers, or the value is copied
+ -- and a pointer is passed), is determined by the backend in accordance
+ -- with requirements imposed by the ABI. Note that in the extended import
+ -- and export pragma mechanisms, this is called Value, rather than Copy.
+
+ By_Reference : constant Mechanism_Type := -2;
+ -- Passing by reference is forced. This is always equivalent to passing
+ -- a simple pointer in the case of subprograms with a foreign convention.
+ -- For unconstrained arrays passed to foreign convention subprograms, the
+ -- address of the first element of the array is passed. For convention
+ -- Ada, the result is logically to pass a reference, but the precise
+ -- mechanism (e.g. to pass bounds of unconstrained types and other needed
+ -- special information) is determined by the backend in accordance with
+ -- requirements imposed by the ABI as interpreted for Ada.
+
+ By_Descriptor : constant Mechanism_Type := -3;
+ By_Descriptor_UBS : constant Mechanism_Type := -4;
+ By_Descriptor_UBSB : constant Mechanism_Type := -5;
+ By_Descriptor_UBA : constant Mechanism_Type := -6;
+ By_Descriptor_S : constant Mechanism_Type := -7;
+ By_Descriptor_SB : constant Mechanism_Type := -8;
+ By_Descriptor_A : constant Mechanism_Type := -9;
+ By_Descriptor_NCA : constant Mechanism_Type := -10;
+ -- These values are used only in OpenVMS ports of GNAT. Pass by descriptor
+ -- is forced, as described in the OpenVMS ABI. The suffix indicates the
+ -- descriptor type:
+ --
+ -- UBS unaligned bit string
+ -- UBSB aligned bit string with arbitrary bounds
+ -- UBA unaligned bit array
+ -- S string, also a scalar or access type parameter
+ -- SB string with arbitrary bounds
+ -- A contiguous array
+ -- NCA non-contiguous array
+ --
+ -- Note: the form with no suffix is used if the Import/Export pragma
+ -- uses the simple form of the mechanism name where no descriptor
+ -- type is supplied. In this case the back end assigns a descriptor
+ -- type based on the Ada type in accordance with the OpenVMS ABI.
+
+ subtype Descriptor_Codes is Mechanism_Type
+ range By_Descriptor_NCA .. By_Descriptor;
+ -- Subtype including all descriptor mechanisms
+
+ -- All the above special values are non-positive. Positive values for
+ -- Mechanism_Type values have a special meaning. They are used only in
+ -- the case of records, as a result of the use of the C_Pass_By_Copy
+ -- pragma, and the meaning is that if the size of the record is known
+ -- at compile time and does not exceed the mechanism type value, then
+ -- By_Copy passing is forced, otherwise By_Reference is forced.
+
+ ----------------------
+ -- Global Variables --
+ ----------------------
+
+ Default_C_Record_Mechanism : Mechanism_Type := By_Reference;
+ -- This value is the default mechanism used for C convention records
+ -- in foreign-convention subprograms if no mechanism is otherwise
+ -- specified. This value is modified appropriately by the occurrence
+ -- of a C_Pass_By_Copy configuration pragma.
+
+ -----------------
+ -- Subprograms --
+ -----------------
+
+ procedure Set_Mechanisms (E : Entity_Id);
+ -- E is a subprogram or subprogram type that has been frozen, so the
+ -- convention of the subprogram and all its formal types and result
+ -- type in the case of a function are established. The function of
+ -- this call is to set mechanism values for formals and for the
+ -- function return if they have not already been explicitly set by
+ -- a use of an extended Import or Export pragma. The idea is to set
+ -- mechanism values whereever the semantics is dictated by either
+ -- requirements or implementation advice in the RM, and to leave
+ -- the mechanism set to Default if there is no requirement, so that
+ -- the back-end is free to choose the most efficient method.
+
+ procedure Set_Mechanism_Value (Ent : Entity_Id; Mech_Name : Node_Id);
+ -- Mech is a parameter passing mechanism (see Import_Function syntax
+ -- for MECHANISM_NAME). This routine checks that the mechanism argument
+ -- has the right form, and if not issues an error message. If the
+ -- argument has the right form then the Mechanism field of Ent is
+ -- set appropriately. It also performs some error checks. Note that
+ -- the mechanism name has not been analyzed (and cannot indeed be
+ -- analyzed, since it is semantic nonsense), so we get it in the
+ -- exact form created by the parser.
+
+ procedure Set_Mechanism_With_Checks
+ (Ent : Entity_Id;
+ Mech : Mechanism_Type;
+ Enod : Node_Id);
+ -- Sets the mechanism of Ent to the given Mech value, after first checking
+ -- that the request makes sense. If it does not make sense, a warning is
+ -- posted on node Enod, and the Mechanism of Ent is unchanged.
+
+end Sem_Mech;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S E M _ P R A G --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.558 $
+-- --
+-- 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 unit contains the semantic processing for all pragmas, both language
+-- and implementation defined. For most pragmas, the parser only does the
+-- most basic job of checking the syntax, so Sem_Prag also contains the code
+-- to complete the syntax checks. Certain pragmas are handled partially or
+-- completely by the parser (see Par.Prag for further details).
+
+with Atree; use Atree;
+with Casing; use Casing;
+with Csets; use Csets;
+with Debug; use Debug;
+with Einfo; use Einfo;
+with Elists; use Elists;
+with Errout; use Errout;
+with Expander; use Expander;
+with Exp_Dist; use Exp_Dist;
+with Fname; use Fname;
+with Hostparm; use Hostparm;
+with Lib; use Lib;
+with Namet; use Namet;
+with Nlists; use Nlists;
+with Nmake; use Nmake;
+with Opt; use Opt;
+with Output; use Output;
+with Restrict; use Restrict;
+with Rtsfind; use Rtsfind;
+with Sem; use Sem;
+with Sem_Ch8; use Sem_Ch8;
+with Sem_Ch13; use Sem_Ch13;
+with Sem_Disp; use Sem_Disp;
+with Sem_Elim; use Sem_Elim;
+with Sem_Eval; use Sem_Eval;
+with Sem_Intr; use Sem_Intr;
+with Sem_Mech; use Sem_Mech;
+with Sem_Res; use Sem_Res;
+with Sem_Type; use Sem_Type;
+with Sem_Util; use Sem_Util;
+with Sem_VFpt; use Sem_VFpt;
+with Stand; use Stand;
+with Sinfo; use Sinfo;
+with Sinfo.CN; use Sinfo.CN;
+with Sinput; use Sinput;
+with Snames; use Snames;
+with Stringt; use Stringt;
+with Stylesw; use Stylesw;
+with Targparm; use Targparm;
+with Tbuild; use Tbuild;
+with Ttypes;
+with Uintp; use Uintp;
+with Urealp; use Urealp;
+with Validsw; use Validsw;
+
+package body Sem_Prag is
+
+ ----------------------------------------------
+ -- Common Handling of Import-Export Pragmas --
+ ----------------------------------------------
+
+ -- In the following section, a number of Import_xxx and Export_xxx
+ -- pragmas are defined by GNAT. These are compatible with the DEC
+ -- pragmas of the same name, and all have the following common
+ -- form and processing:
+
+ -- pragma Export_xxx
+ -- [Internal =>] LOCAL_NAME,
+ -- [, [External =>] EXTERNAL_SYMBOL]
+ -- [, other optional parameters ]);
+
+ -- pragma Import_xxx
+ -- [Internal =>] LOCAL_NAME,
+ -- [, [External =>] EXTERNAL_SYMBOL]
+ -- [, other optional parameters ]);
+
+ -- EXTERNAL_SYMBOL ::=
+ -- IDENTIFIER
+ -- | static_string_EXPRESSION
+
+ -- The internal LOCAL_NAME designates the entity that is imported or
+ -- exported, and must refer to an entity in the current declarative
+ -- part (as required by the rules for LOCAL_NAME).
+
+ -- The external linker name is designated by the External parameter
+ -- if given, or the Internal parameter if not (if there is no External
+ -- parameter, the External parameter is a copy of the Internal name).
+
+ -- If the External parameter is given as a string, then this string
+ -- is treated as an external name (exactly as though it had been given
+ -- as an External_Name parameter for a normal Import pragma).
+
+ -- If the External parameter is given as an identifier (or there is no
+ -- External parameter, so that the Internal identifier is used), then
+ -- the external name is the characters of the identifier, translated
+ -- to all upper case letters for OpenVMS versions of GNAT, and to all
+ -- lower case letters for all other versions
+
+ -- Note: the external name specified or implied by any of these special
+ -- Import_xxx or Export_xxx pragmas override an external or link name
+ -- specified in a previous Import or Export pragma.
+
+ -- Note: these and all other DEC-compatible GNAT pragmas allow full
+ -- use of named notation, following the standard rules for subprogram
+ -- calls, i.e. parameters can be given in any order if named notation
+ -- is used, and positional and named notation can be mixed, subject to
+ -- the rule that all positional parameters must appear first.
+
+ -- Note: All these pragmas are implemented exactly following the DEC
+ -- design and implementation and are intended to be fully compatible
+ -- with the use of these pragmas in the DEC Ada compiler.
+
+ -------------------------------------
+ -- Local Subprograms and Variables --
+ -------------------------------------
+
+ function Adjust_External_Name_Case (N : Node_Id) return Node_Id;
+ -- This routine is used for possible casing adjustment of an explicit
+ -- external name supplied as a string literal (the node N), according
+ -- to the casing requirement of Opt.External_Name_Casing. If this is
+ -- set to As_Is, then the string literal is returned unchanged, but if
+ -- it is set to Uppercase or Lowercase, then a new string literal with
+ -- appropriate casing is constructed.
+
+ function Is_Generic_Subprogram (Id : Entity_Id) return Boolean;
+ -- Return True if Id is a generic procedure or a function
+
+ function Get_Base_Subprogram (Def_Id : Entity_Id) return Entity_Id;
+ -- If Def_Id refers to a renamed subprogram, then the base subprogram
+ -- (the original one, following the renaming chain) is returned.
+ -- Otherwise the entity is returned unchanged. Should be in Einfo???
+
+ procedure Set_Unit_Name (N : Node_Id; With_Item : Node_Id);
+ -- Place semantic information on the argument of an Elaborate or
+ -- Elaborate_All pragma. Entity name for unit and its parents is
+ -- taken from item in previous with_clause that mentions the unit.
+
+ Locking_Policy_Sloc : Source_Ptr := No_Location;
+ Queuing_Policy_Sloc : Source_Ptr := No_Location;
+ Task_Dispatching_Policy_Sloc : Source_Ptr := No_Location;
+ -- These global variables remember the location of a previous locking,
+ -- queuing or task dispatching policy pragma, so that appropriate error
+ -- messages can be generated for inconsistent pragmas. Note that it is
+ -- fine that these are global locations, because the check for consistency
+ -- is over the entire program.
+
+ -------------------------------
+ -- Adjust_External_Name_Case --
+ -------------------------------
+
+ function Adjust_External_Name_Case (N : Node_Id) return Node_Id is
+ CC : Char_Code;
+
+ begin
+ -- Adjust case of literal if required
+
+ if Opt.External_Name_Exp_Casing = As_Is then
+ return N;
+
+ else
+ -- Copy existing string
+
+ Start_String;
+
+ -- Set proper casing
+
+ for J in 1 .. String_Length (Strval (N)) loop
+ CC := Get_String_Char (Strval (N), J);
+
+ if Opt.External_Name_Exp_Casing = Uppercase
+ and then CC >= Get_Char_Code ('a')
+ and then CC <= Get_Char_Code ('z')
+ then
+ Store_String_Char (CC - 32);
+
+ elsif Opt.External_Name_Exp_Casing = Lowercase
+ and then CC >= Get_Char_Code ('A')
+ and then CC <= Get_Char_Code ('Z')
+ then
+ Store_String_Char (CC + 32);
+
+ else
+ Store_String_Char (CC);
+ end if;
+ end loop;
+
+ return
+ Make_String_Literal (Sloc (N),
+ Strval => End_String);
+ end if;
+ end Adjust_External_Name_Case;
+
+ --------------------
+ -- Analyze_Pragma --
+ --------------------
+
+ procedure Analyze_Pragma (N : Node_Id) is
+ Loc : constant Source_Ptr := Sloc (N);
+ Prag_Id : Pragma_Id;
+
+ Pragma_Exit : exception;
+ -- This exception is used to exit pragma processing completely. It
+ -- is used when an error is detected, and in other situations where
+ -- it is known that no further processing is required.
+
+ Arg_Count : Nat;
+ -- Number of pragma argument associations
+
+ Arg1 : Node_Id;
+ Arg2 : Node_Id;
+ Arg3 : Node_Id;
+ Arg4 : Node_Id;
+ -- First four pragma arguments (pragma argument association nodes,
+ -- or Empty if the corresponding argument does not exist).
+
+ procedure Check_Ada_83_Warning;
+ -- Issues a warning message for the current pragma if operating in Ada
+ -- 83 mode (used for language pragmas that are not a standard part of
+ -- Ada 83). This procedure does not raise Error_Pragma. Also notes use
+ -- of 95 pragma.
+
+ procedure Check_Arg_Count (Required : Nat);
+ -- Check argument count for pragma is equal to given parameter.
+ -- If not, then issue an error message and raise Pragma_Exit.
+
+ -- Note: all routines whose name is Check_Arg_Is_xxx take an
+ -- argument Arg which can either be a pragma argument association,
+ -- in which case the check is applied to the expression of the
+ -- association or an expression directly.
+
+ procedure Check_Arg_Is_Identifier (Arg : Node_Id);
+ -- Check the specified argument Arg to make sure that it is an
+ -- identifier. If not give error and raise Pragma_Exit.
+
+ procedure Check_Arg_Is_Integer_Literal (Arg : Node_Id);
+ -- Check the specified argument Arg to make sure that it is an
+ -- integer literal. If not give error and raise Pragma_Exit.
+
+ procedure Check_Arg_Is_Library_Level_Local_Name (Arg : Node_Id);
+ -- Check the specified argument Arg to make sure that it has the
+ -- proper syntactic form for a local name and meets the semantic
+ -- requirements for a local name. The local name is analyzed as
+ -- part of the processing for this call. In addition, the local
+ -- name is required to represent an entity at the library level.
+
+ procedure Check_Arg_Is_Local_Name (Arg : Node_Id);
+ -- Check the specified argument Arg to make sure that it has the
+ -- proper syntactic form for a local name and meets the semantic
+ -- requirements for a local name. The local name is analyzed as
+ -- part of the processing for this call.
+
+ procedure Check_Arg_Is_Locking_Policy (Arg : Node_Id);
+ -- Check the specified argument Arg to make sure that it is a valid
+ -- locking policy name. If not give error and raise Pragma_Exit.
+
+ procedure Check_Arg_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id);
+ procedure Check_Arg_Is_One_Of (Arg : Node_Id; N1, N2, N3 : Name_Id);
+ -- Check the specified argument Arg to make sure that it is an
+ -- identifier whose name matches either N1 or N2 (or N3 if present).
+ -- If not then give error and raise Pragma_Exit.
+
+ procedure Check_Arg_Is_Queuing_Policy (Arg : Node_Id);
+ -- Check the specified argument Arg to make sure that it is a valid
+ -- queuing policy name. If not give error and raise Pragma_Exit.
+
+ procedure Check_Arg_Is_Static_Expression
+ (Arg : Node_Id;
+ Typ : Entity_Id);
+ -- Check the specified argument Arg to make sure that it is a static
+ -- expression of the given type (i.e. it will be analyzed and resolved
+ -- using this type, which can be any valid argument to Resolve, e.g.
+ -- Any_Integer is OK). If not, given error and raise Pragma_Exit.
+
+ procedure Check_Arg_Is_String_Literal (Arg : Node_Id);
+ -- Check the specified argument Arg to make sure that it is a
+ -- string literal. If not give error and raise Pragma_Exit
+
+ procedure Check_Arg_Is_Task_Dispatching_Policy (Arg : Node_Id);
+ -- Check the specified argument Arg to make sure that it is a valid
+ -- valid task dispatching policy name. If not give error and raise
+ -- Pragma_Exit.
+
+ procedure Check_At_Least_N_Arguments (N : Nat);
+ -- Check there are at least N arguments present
+
+ procedure Check_At_Most_N_Arguments (N : Nat);
+ -- Check there are no more than N arguments present
+
+ procedure Check_First_Subtype (Arg : Node_Id);
+ -- Checks that Arg, whose expression is an entity name referencing
+ -- a subtype, does not reference a type that is not a first subtype.
+
+ procedure Check_In_Main_Program;
+ -- Common checks for pragmas that appear within a main program
+ -- (Priority, Main_Storage, Time_Slice).
+
+ procedure Check_Interrupt_Or_Attach_Handler;
+ -- Common processing for first argument of pragma Interrupt_Handler
+ -- or pragma Attach_Handler.
+
+ procedure Check_Is_In_Decl_Part_Or_Package_Spec;
+ -- Check that pragma appears in a declarative part, or in a package
+ -- specification, i.e. that it does not occur in a statement sequence
+ -- in a body.
+
+ procedure Check_No_Identifier (Arg : Node_Id);
+ -- Checks that the given argument does not have an identifier. If
+ -- an identifier is present, then an error message is issued, and
+ -- Pragma_Exit is raised.
+
+ procedure Check_No_Identifiers;
+ -- Checks that none of the arguments to the pragma has an identifier.
+ -- If any argument has an identifier, then an error message is issued,
+ -- and Pragma_Exit is raised.
+
+ procedure Check_Non_Overloaded_Function (Arg : Node_Id);
+ -- Check that the given argument is the name of a local function of
+ -- one argument that is not overloaded in the current local scope.
+
+ procedure Check_Optional_Identifier (Arg : Node_Id; Id : Name_Id);
+ -- Checks if the given argument has an identifier, and if so, requires
+ -- it to match the given identifier name. If there is a non-matching
+ -- identifier, then an error message is given and Error_Pragmas raised.
+
+ procedure Check_Optional_Identifier (Arg : Node_Id; Id : String);
+ -- Checks if the given argument has an identifier, and if so, requires
+ -- it to match the given identifier name. If there is a non-matching
+ -- identifier, then an error message is given and Error_Pragmas raised.
+ -- In this version of the procedure, the identifier name is given as
+ -- a string with lower case letters.
+
+ procedure Check_Static_Constraint (Constr : Node_Id);
+ -- Constr is a constraint from an N_Subtype_Indication node from a
+ -- component constraint in an Unchecked_Union type. This routine checks
+ -- that the constraint is static as required by the restrictions for
+ -- Unchecked_Union.
+
+ procedure Check_Valid_Configuration_Pragma;
+ -- Legality checks for placement of a configuration pragma
+
+ procedure Check_Valid_Library_Unit_Pragma;
+ -- Legality checks for library unit pragmas. A special case arises for
+ -- pragmas in generic instances that come from copies of the original
+ -- library unit pragmas in the generic templates. In the case of other
+ -- than library level instantiations these can appear in contexts which
+ -- would normally be invalid (they only apply to the original template
+ -- and to library level instantiations), and they are simply ignored,
+ -- which is implemented by rewriting them as null statements.
+
+ procedure Error_Pragma (Msg : String);
+ pragma No_Return (Error_Pragma);
+ -- Outputs error message for current pragma. The message contains an %
+ -- that will be replaced with the pragma name, and the flag is placed
+ -- on the pragma itself. Pragma_Exit is then raised.
+
+ procedure Error_Pragma_Arg (Msg : String; Arg : Node_Id);
+ pragma No_Return (Error_Pragma_Arg);
+ -- Outputs error message for current pragma. The message may contain
+ -- a % that will be replaced with the pragma name. The parameter Arg
+ -- may either be a pragma argument association, in which case the flag
+ -- is placed on the expression of this association, or an expression,
+ -- in which case the flag is placed directly on the expression. The
+ -- message is placed using Error_Msg_N, so the message may also contain
+ -- an & insertion character which will reference the given Arg value.
+ -- After placing the message, Pragma_Exit is raised.
+
+ procedure Error_Pragma_Arg (Msg1, Msg2 : String; Arg : Node_Id);
+ pragma No_Return (Error_Pragma_Arg);
+ -- Similar to above form of Error_Pragma_Arg except that two messages
+ -- are provided, the second is a continuation comment starting with \.
+
+ procedure Error_Pragma_Arg_Ident (Msg : String; Arg : Node_Id);
+ pragma No_Return (Error_Pragma_Arg_Ident);
+ -- Outputs error message for current pragma. The message may contain
+ -- a % that will be replaced with the pragma name. The parameter Arg
+ -- must be a pragma argument association with a non-empty identifier
+ -- (i.e. its Chars field must be set), and the error message is placed
+ -- on the identifier. The message is placed using Error_Msg_N so
+ -- the message may also contain an & insertion character which will
+ -- reference the identifier. After placing the message, Pragma_Exit
+ -- is raised.
+
+ function Find_Lib_Unit_Name return Entity_Id;
+ -- Used for a library unit pragma to find the entity to which the
+ -- library unit pragma applies, returns the entity found.
+
+ procedure Find_Program_Unit_Name (Id : Node_Id);
+ -- If the pragma is a compilation unit pragma, the id must denote the
+ -- compilation unit in the same compilation, and the pragma must appear
+ -- in the list of preceding or trailing pragmas. If it is a program
+ -- unit pragma that is not a compilation unit pragma, then the
+ -- identifier must be visible.
+
+ type Name_List is array (Natural range <>) of Name_Id;
+ type Args_List is array (Natural range <>) of Node_Id;
+ procedure Gather_Associations
+ (Names : Name_List;
+ Args : out Args_List);
+ -- This procedure is used to gather the arguments for a pragma that
+ -- permits arbitrary ordering of parameters using the normal rules
+ -- for named and positional parameters. The Names argument is a list
+ -- of Name_Id values that corresponds to the allowed pragma argument
+ -- association identifiers in order. The result returned in Args is
+ -- a list of corresponding expressions that are the pragma arguments.
+ -- Note that this is a list of expressions, not of pragma argument
+ -- associations (Gather_Associations has completely checked all the
+ -- optional identifiers when it returns). An entry in Args is Empty
+ -- on return if the corresponding argument is not present.
+
+ function Get_Pragma_Arg (Arg : Node_Id) return Node_Id;
+ -- All the routines that check pragma arguments take either a pragma
+ -- argument association (in which case the expression of the argument
+ -- association is checked), or the expression directly. The function
+ -- Get_Pragma_Arg is a utility used to deal with these two cases. If
+ -- Arg is a pragma argument association node, then its expression is
+ -- returned, otherwise Arg is returned unchanged.
+
+ procedure GNAT_Pragma;
+ -- Called for all GNAT defined pragmas to note the use of the feature,
+ -- and also check the relevant restriction (No_Implementation_Pragmas).
+
+ function Is_Before_First_Decl
+ (Pragma_Node : Node_Id;
+ Decls : List_Id)
+ return Boolean;
+ -- Return True if Pragma_Node is before the first declarative item in
+ -- Decls where Decls is the list of declarative items.
+
+ function Is_Configuration_Pragma return Boolean;
+ -- Deterermines if the placement of the current pragma is appropriate
+ -- for a configuration pragma (precedes the current compilation unit)
+
+ procedure Pragma_Misplaced;
+ -- Issue fatal error message for misplaced pragma
+
+ procedure Process_Atomic_Shared_Volatile;
+ -- Common processing for pragmas Atomic, Shared, Volatile. Note that
+ -- Shared is an obsolete Ada 83 pragma, treated as being identical
+ -- in effect to pragma Atomic.
+
+ procedure Process_Convention (C : out Convention_Id; E : out Entity_Id);
+ -- Common procesing for Convention, Interface, Import and Export.
+ -- Checks first two arguments of pragma, and sets the appropriate
+ -- convention value in the specified entity or entities. On return
+ -- C is the convention, E is the referenced entity.
+
+ procedure Process_Extended_Import_Export_Exception_Pragma
+ (Arg_Internal : Node_Id;
+ Arg_External : Node_Id;
+ Arg_Form : Node_Id;
+ Arg_Code : Node_Id);
+ -- Common processing for the pragmas Import/Export_Exception.
+ -- The three arguments correspond to the three named parameters of
+ -- the pragma. An argument is empty if the corresponding parameter
+ -- is not present in the pragma.
+
+ procedure Process_Extended_Import_Export_Object_Pragma
+ (Arg_Internal : Node_Id;
+ Arg_External : Node_Id;
+ Arg_Size : Node_Id);
+ -- Common processing for the pragmass Import/Export_Object.
+ -- The three arguments correspond to the three named parameters
+ -- of the pragmas. An argument is empty if the corresponding
+ -- parameter is not present in the pragma.
+
+ procedure Process_Extended_Import_Export_Internal_Arg
+ (Arg_Internal : Node_Id := Empty);
+ -- Common processing for all extended Import and Export pragmas. The
+ -- argument is the pragma parameter for the Internal argument. If
+ -- Arg_Internal is empty or inappropriate, an error message is posted.
+ -- Otherwise, on normal return, the Entity_Field of Arg_Internal is
+ -- set to identify the referenced entity.
+
+ procedure Process_Extended_Import_Export_Subprogram_Pragma
+ (Arg_Internal : Node_Id;
+ Arg_External : Node_Id;
+ Arg_Parameter_Types : Node_Id;
+ Arg_Result_Type : Node_Id := Empty;
+ Arg_Mechanism : Node_Id;
+ Arg_Result_Mechanism : Node_Id := Empty;
+ Arg_First_Optional_Parameter : Node_Id := Empty);
+ -- Common processing for all extended Import and Export pragmas
+ -- applying to subprograms. The caller omits any arguments that do
+ -- bnot apply to the pragma in question (for example, Arg_Result_Type
+ -- can be non-Empty only in the Import_Function and Export_Function
+ -- cases). The argument names correspond to the allowed pragma
+ -- association identifiers.
+
+ procedure Process_Generic_List;
+ -- Common processing for Share_Generic and Inline_Generic
+
+ procedure Process_Import_Or_Interface;
+ -- Common processing for Import of Interface
+
+ procedure Process_Inline (Active : Boolean);
+ -- Common processing for Inline and Inline_Always. The parameter
+ -- indicates if the inline pragma is active, i.e. if it should
+ -- actually cause inlining to occur.
+
+ procedure Process_Interface_Name
+ (Subprogram_Def : Entity_Id;
+ Ext_Arg : Node_Id;
+ Link_Arg : Node_Id);
+ -- Given the last two arguments of pragma Import, pragma Export, or
+ -- pragma Interface_Name, performs validity checks and sets the
+ -- Interface_Name field of the given subprogram entity to the
+ -- appropriate external or link name, depending on the arguments
+ -- given. Ext_Arg is always present, but Link_Arg may be missing.
+ -- Note that Ext_Arg may represent the Link_Name if Link_Arg is
+ -- missing, and appropriate named notation is used for Ext_Arg.
+ -- If neither Ext_Arg nor Link_Arg is present, the interface name
+ -- is set to the default from the subprogram name.
+
+ procedure Process_Interrupt_Or_Attach_Handler;
+ -- Attach the pragmas to the rep item chain.
+
+ procedure Process_Suppress_Unsuppress (Suppress_Case : Boolean);
+ -- Common processing for Suppress and Unsuppress. The boolean parameter
+ -- Suppress_Case is True for the Suppress case, and False for the
+ -- Unsuppress case.
+
+ procedure Set_Exported (E : Entity_Id; Arg : Node_Id);
+ -- This procedure sets the Is_Exported flag for the given entity,
+ -- checking that the entity was not previously imported. Arg is
+ -- the argument that specified the entity.
+
+ procedure Set_Extended_Import_Export_External_Name
+ (Internal_Ent : Entity_Id;
+ Arg_External : Node_Id);
+ -- Common processing for all extended import export pragmas. The first
+ -- argument, Internal_Ent, is the internal entity, which has already
+ -- been checked for validity by the caller. Arg_External is from the
+ -- Import or Export pragma, and may be null if no External parameter
+ -- was present. If Arg_External is present and is a non-null string
+ -- (a null string is treated as the default), then the Interface_Name
+ -- field of Internal_Ent is set appropriately.
+
+ procedure Set_Imported (E : Entity_Id);
+ -- This procedure sets the Is_Imported flag for the given entity,
+ -- checking that it is not previously exported or imported.
+
+ procedure Set_Mechanism_Value (Ent : Entity_Id; Mech_Name : Node_Id);
+ -- Mech is a parameter passing mechanism (see Import_Function syntax
+ -- for MECHANISM_NAME). This routine checks that the mechanism argument
+ -- has the right form, and if not issues an error message. If the
+ -- argument has the right form then the Mechanism field of Ent is
+ -- set appropriately.
+
+ --------------------------
+ -- Check_Ada_83_Warning --
+ --------------------------
+
+ procedure Check_Ada_83_Warning is
+ begin
+ GNAT_Pragma;
+
+ if Ada_83 and then Comes_From_Source (N) then
+ Error_Msg_N ("(Ada 83) pragma& is non-standard?", N);
+ end if;
+ end Check_Ada_83_Warning;
+
+ ---------------------
+ -- Check_Arg_Count --
+ ---------------------
+
+ procedure Check_Arg_Count (Required : Nat) is
+ begin
+ if Arg_Count /= Required then
+ Error_Pragma ("wrong number of arguments for pragma%");
+ end if;
+ end Check_Arg_Count;
+
+ -----------------------------
+ -- Check_Arg_Is_Identifier --
+ -----------------------------
+
+ procedure Check_Arg_Is_Identifier (Arg : Node_Id) is
+ Argx : constant Node_Id := Get_Pragma_Arg (Arg);
+
+ begin
+ if Nkind (Argx) /= N_Identifier then
+ Error_Pragma_Arg
+ ("argument for pragma% must be identifier", Argx);
+ end if;
+ end Check_Arg_Is_Identifier;
+
+ ----------------------------------
+ -- Check_Arg_Is_Integer_Literal --
+ ----------------------------------
+
+ procedure Check_Arg_Is_Integer_Literal (Arg : Node_Id) is
+ Argx : constant Node_Id := Get_Pragma_Arg (Arg);
+
+ begin
+ if Nkind (Argx) /= N_Integer_Literal then
+ Error_Pragma_Arg
+ ("argument for pragma% must be integer literal", Argx);
+ end if;
+ end Check_Arg_Is_Integer_Literal;
+
+ -------------------------------------------
+ -- Check_Arg_Is_Library_Level_Local_Name --
+ -------------------------------------------
+
+ -- LOCAL_NAME ::=
+ -- DIRECT_NAME
+ -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR
+ -- | library_unit_NAME
+
+ procedure Check_Arg_Is_Library_Level_Local_Name (Arg : Node_Id) is
+ begin
+ Check_Arg_Is_Local_Name (Arg);
+
+ if not Is_Library_Level_Entity (Entity (Expression (Arg)))
+ and then Comes_From_Source (N)
+ then
+ Error_Pragma_Arg
+ ("argument for pragma% must be library level entity", Arg);
+ end if;
+ end Check_Arg_Is_Library_Level_Local_Name;
+
+ -----------------------------
+ -- Check_Arg_Is_Local_Name --
+ -----------------------------
+
+ -- LOCAL_NAME ::=
+ -- DIRECT_NAME
+ -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR
+ -- | library_unit_NAME
+
+ procedure Check_Arg_Is_Local_Name (Arg : Node_Id) is
+ Argx : constant Node_Id := Get_Pragma_Arg (Arg);
+
+ begin
+ Analyze (Argx);
+
+ if Nkind (Argx) not in N_Direct_Name
+ and then (Nkind (Argx) /= N_Attribute_Reference
+ or else Present (Expressions (Argx))
+ or else Nkind (Prefix (Argx)) /= N_Identifier)
+ and then (not Is_Entity_Name (Argx)
+ or else not Is_Compilation_Unit (Entity (Argx)))
+ then
+ Error_Pragma_Arg ("argument for pragma% must be local name", Argx);
+ end if;
+
+ if Is_Entity_Name (Argx)
+ and then Scope (Entity (Argx)) /= Current_Scope
+ then
+ Error_Pragma_Arg
+ ("pragma% argument must be in same declarative part", Arg);
+ end if;
+ end Check_Arg_Is_Local_Name;
+
+ ---------------------------------
+ -- Check_Arg_Is_Locking_Policy --
+ ---------------------------------
+
+ procedure Check_Arg_Is_Locking_Policy (Arg : Node_Id) is
+ Argx : constant Node_Id := Get_Pragma_Arg (Arg);
+
+ begin
+ Check_Arg_Is_Identifier (Argx);
+
+ if not Is_Locking_Policy_Name (Chars (Argx)) then
+ Error_Pragma_Arg
+ ("& is not a valid locking policy name", Argx);
+ end if;
+ end Check_Arg_Is_Locking_Policy;
+
+ -------------------------
+ -- Check_Arg_Is_One_Of --
+ -------------------------
+
+ procedure Check_Arg_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id) is
+ Argx : constant Node_Id := Get_Pragma_Arg (Arg);
+
+ begin
+ Check_Arg_Is_Identifier (Argx);
+
+ if Chars (Argx) /= N1 and then Chars (Argx) /= N2 then
+ Error_Msg_Name_2 := N1;
+ Error_Msg_Name_3 := N2;
+ Error_Pragma_Arg ("argument for pragma% must be% or%", Argx);
+ end if;
+ end Check_Arg_Is_One_Of;
+
+ procedure Check_Arg_Is_One_Of
+ (Arg : Node_Id;
+ N1, N2, N3 : Name_Id)
+ is
+ Argx : constant Node_Id := Get_Pragma_Arg (Arg);
+
+ begin
+ Check_Arg_Is_Identifier (Argx);
+
+ if Chars (Argx) /= N1
+ and then Chars (Argx) /= N2
+ and then Chars (Argx) /= N3
+ then
+ Error_Pragma_Arg ("invalid argument for pragma%", Argx);
+ end if;
+ end Check_Arg_Is_One_Of;
+
+ ---------------------------------
+ -- Check_Arg_Is_Queuing_Policy --
+ ---------------------------------
+
+ procedure Check_Arg_Is_Queuing_Policy (Arg : Node_Id) is
+ Argx : constant Node_Id := Get_Pragma_Arg (Arg);
+
+ begin
+ Check_Arg_Is_Identifier (Argx);
+
+ if not Is_Queuing_Policy_Name (Chars (Argx)) then
+ Error_Pragma_Arg
+ ("& is not a valid queuing policy name", Argx);
+ end if;
+ end Check_Arg_Is_Queuing_Policy;
+
+ ------------------------------------
+ -- Check_Arg_Is_Static_Expression --
+ ------------------------------------
+
+ procedure Check_Arg_Is_Static_Expression
+ (Arg : Node_Id;
+ Typ : Entity_Id)
+ is
+ Argx : constant Node_Id := Get_Pragma_Arg (Arg);
+
+ begin
+ Analyze_And_Resolve (Argx, Typ);
+
+ if Is_OK_Static_Expression (Argx) then
+ return;
+
+ elsif Etype (Argx) = Any_Type then
+ raise Pragma_Exit;
+
+ -- An interesting special case, if we have a string literal and
+ -- we are in Ada 83 mode, then we allow it even though it will
+ -- not be flagged as static. This allows the use of Ada 95
+ -- pragmas like Import in Ada 83 mode. They will of course be
+ -- flagged with warnings as usual, but will not cause errors.
+
+ elsif Ada_83 and then Nkind (Argx) = N_String_Literal then
+ return;
+
+ -- Static expression that raises Constraint_Error. This has
+ -- already been flagged, so just exit from pragma processing.
+
+ elsif Is_Static_Expression (Argx) then
+ raise Pragma_Exit;
+
+ -- Finally, we have a real error
+
+ else
+ Error_Pragma_Arg
+ ("argument for pragma% must be a static expression", Argx);
+ end if;
+
+ end Check_Arg_Is_Static_Expression;
+
+ ---------------------------------
+ -- Check_Arg_Is_String_Literal --
+ ---------------------------------
+
+ procedure Check_Arg_Is_String_Literal (Arg : Node_Id) is
+ Argx : constant Node_Id := Get_Pragma_Arg (Arg);
+
+ begin
+ if Nkind (Argx) /= N_String_Literal then
+ Error_Pragma_Arg
+ ("argument for pragma% must be string literal", Argx);
+ end if;
+
+ end Check_Arg_Is_String_Literal;
+
+ ------------------------------------------
+ -- Check_Arg_Is_Task_Dispatching_Policy --
+ ------------------------------------------
+
+ procedure Check_Arg_Is_Task_Dispatching_Policy (Arg : Node_Id) is
+ Argx : constant Node_Id := Get_Pragma_Arg (Arg);
+
+ begin
+ Check_Arg_Is_Identifier (Argx);
+
+ if not Is_Task_Dispatching_Policy_Name (Chars (Argx)) then
+ Error_Pragma_Arg
+ ("& is not a valid task dispatching policy name", Argx);
+ end if;
+ end Check_Arg_Is_Task_Dispatching_Policy;
+
+ --------------------------------
+ -- Check_At_Least_N_Arguments --
+ --------------------------------
+
+ procedure Check_At_Least_N_Arguments (N : Nat) is
+ begin
+ if Arg_Count < N then
+ Error_Pragma ("too few arguments for pragma%");
+ end if;
+ end Check_At_Least_N_Arguments;
+
+ -------------------------------
+ -- Check_At_Most_N_Arguments --
+ -------------------------------
+
+ procedure Check_At_Most_N_Arguments (N : Nat) is
+ Arg : Node_Id;
+
+ begin
+ if Arg_Count > N then
+ Arg := Arg1;
+
+ for J in 1 .. N loop
+ Next (Arg);
+ Error_Pragma_Arg ("too many arguments for pragma%", Arg);
+ end loop;
+ end if;
+ end Check_At_Most_N_Arguments;
+
+ -------------------------
+ -- Check_First_Subtype --
+ -------------------------
+
+ procedure Check_First_Subtype (Arg : Node_Id) is
+ Argx : constant Node_Id := Get_Pragma_Arg (Arg);
+
+ begin
+ if not Is_First_Subtype (Entity (Argx)) then
+ Error_Pragma_Arg
+ ("pragma% cannot apply to subtype", Argx);
+ end if;
+ end Check_First_Subtype;
+
+ ---------------------------
+ -- Check_In_Main_Program --
+ ---------------------------
+
+ procedure Check_In_Main_Program is
+ P : constant Node_Id := Parent (N);
+
+ begin
+ -- Must be at in subprogram body
+
+ if Nkind (P) /= N_Subprogram_Body then
+ Error_Pragma ("% pragma allowed only in subprogram");
+
+ -- Otherwise warn if obviously not main program
+
+ elsif Present (Parameter_Specifications (Specification (P)))
+ or else not Is_Library_Level_Entity (Defining_Entity (P))
+ then
+ Error_Msg_Name_1 := Chars (N);
+ Error_Msg_N
+ ("?pragma% is only effective in main program", N);
+ end if;
+ end Check_In_Main_Program;
+
+ ---------------------------------------
+ -- Check_Interrupt_Or_Attach_Handler --
+ ---------------------------------------
+
+ procedure Check_Interrupt_Or_Attach_Handler is
+ Arg1_X : constant Node_Id := Expression (Arg1);
+
+ begin
+ Analyze (Arg1_X);
+
+ if not Is_Entity_Name (Arg1_X) then
+ Error_Pragma_Arg
+ ("argument of pragma% must be entity name", Arg1);
+
+ elsif Prag_Id = Pragma_Interrupt_Handler then
+ Check_Restriction (No_Dynamic_Interrupts, N);
+ end if;
+
+ declare
+ Prot_Proc : Entity_Id := Empty;
+ Prot_Type : Entity_Id;
+ Found : Boolean := False;
+
+ begin
+ if not Is_Overloaded (Arg1_X) then
+ Prot_Proc := Entity (Arg1_X);
+
+ else
+ declare
+ It : Interp;
+ Index : Interp_Index;
+
+ begin
+ Get_First_Interp (Arg1_X, Index, It);
+ while Present (It.Nam) loop
+ Prot_Proc := It.Nam;
+
+ if Ekind (Prot_Proc) = E_Procedure
+ and then No (First_Formal (Prot_Proc))
+ then
+ if not Found then
+ Found := True;
+ Set_Entity (Arg1_X, Prot_Proc);
+ Set_Is_Overloaded (Arg1_X, False);
+ else
+ Error_Pragma_Arg
+ ("ambiguous handler name for pragma% ", Arg1);
+ end if;
+ end if;
+
+ Get_Next_Interp (Index, It);
+ end loop;
+
+ if not Found then
+ Error_Pragma_Arg
+ ("argument of pragma% must be parameterless procedure",
+ Arg1);
+ else
+ Prot_Proc := Entity (Arg1_X);
+ end if;
+ end;
+ end if;
+
+ Prot_Type := Scope (Prot_Proc);
+
+ if Ekind (Prot_Proc) /= E_Procedure
+ or else Ekind (Prot_Type) /= E_Protected_Type
+ then
+ Error_Pragma_Arg
+ ("argument of pragma% must be protected procedure",
+ Arg1);
+ end if;
+
+ if not Is_Library_Level_Entity (Prot_Type) then
+ Error_Pragma_Arg
+ ("pragma% requires library level entity", Arg1);
+ end if;
+
+ if Present (First_Formal (Prot_Proc)) then
+ Error_Pragma_Arg
+ ("argument of pragma% must be parameterless procedure",
+ Arg1);
+ end if;
+
+ if Parent (N) /=
+ Protected_Definition (Parent (Prot_Type))
+ then
+ Error_Pragma ("pragma% must be in protected definition");
+ end if;
+
+ end;
+ end Check_Interrupt_Or_Attach_Handler;
+
+ -------------------------------------------
+ -- Check_Is_In_Decl_Part_Or_Package_Spec --
+ -------------------------------------------
+
+ procedure Check_Is_In_Decl_Part_Or_Package_Spec is
+ P : Node_Id;
+
+ begin
+ P := Parent (N);
+ loop
+ if No (P) then
+ exit;
+
+ elsif Nkind (P) = N_Handled_Sequence_Of_Statements then
+ exit;
+
+ elsif Nkind (P) = N_Package_Specification then
+ return;
+
+ elsif Nkind (P) = N_Block_Statement then
+ return;
+
+ -- Note: the following tests seem a little peculiar, because
+ -- they test for bodies, but if we were in the statement part
+ -- of the body, we would already have hit the handled statement
+ -- sequence, so the only way we get here is by being in the
+ -- declarative part of the body.
+
+ elsif Nkind (P) = N_Subprogram_Body
+ or else Nkind (P) = N_Package_Body
+ or else Nkind (P) = N_Task_Body
+ or else Nkind (P) = N_Entry_Body
+ then
+ return;
+ end if;
+
+ P := Parent (P);
+ end loop;
+
+ Error_Pragma ("pragma% is not in declarative part or package spec");
+
+ end Check_Is_In_Decl_Part_Or_Package_Spec;
+
+ -------------------------
+ -- Check_No_Identifier --
+ -------------------------
+
+ procedure Check_No_Identifier (Arg : Node_Id) is
+ begin
+ if Chars (Arg) /= No_Name then
+ Error_Pragma_Arg_Ident
+ ("pragma% does not permit identifier& here", Arg);
+ end if;
+ end Check_No_Identifier;
+
+ --------------------------
+ -- Check_No_Identifiers --
+ --------------------------
+
+ procedure Check_No_Identifiers is
+ Arg_Node : Node_Id;
+
+ begin
+ if Arg_Count > 0 then
+ Arg_Node := Arg1;
+
+ while Present (Arg_Node) loop
+ Check_No_Identifier (Arg_Node);
+ Next (Arg_Node);
+ end loop;
+ end if;
+ end Check_No_Identifiers;
+
+ -----------------------------------
+ -- Check_Non_Overloaded_Function --
+ -----------------------------------
+
+ procedure Check_Non_Overloaded_Function (Arg : Node_Id) is
+ Ent : Entity_Id;
+
+ begin
+ Check_Arg_Is_Local_Name (Arg);
+ Ent := Entity (Expression (Arg));
+
+ if Present (Homonym (Ent))
+ and then Scope (Homonym (Ent)) = Current_Scope
+ then
+ Error_Pragma_Arg
+ ("argument for pragma% may not be overloaded", Arg);
+ end if;
+
+ if Ekind (Ent) /= E_Function
+ or else No (First_Formal (Ent))
+ or else Present (Next_Formal (First_Formal (Ent)))
+ then
+ Error_Pragma_Arg
+ ("argument for pragma% must be function of one argument", Arg);
+ end if;
+ end Check_Non_Overloaded_Function;
+
+ -------------------------------
+ -- Check_Optional_Identifier --
+ -------------------------------
+
+ procedure Check_Optional_Identifier (Arg : Node_Id; Id : Name_Id) is
+ begin
+ if Present (Arg) and then Chars (Arg) /= No_Name then
+ if Chars (Arg) /= Id then
+ Error_Msg_Name_1 := Chars (N);
+ Error_Msg_Name_2 := Id;
+ Error_Msg_N ("pragma% argument expects identifier%", Arg);
+ raise Pragma_Exit;
+ end if;
+ end if;
+ end Check_Optional_Identifier;
+
+ procedure Check_Optional_Identifier (Arg : Node_Id; Id : String) is
+ begin
+ Name_Buffer (1 .. Id'Length) := Id;
+ Name_Len := Id'Length;
+ Check_Optional_Identifier (Arg, Name_Find);
+ end Check_Optional_Identifier;
+
+ -----------------------------
+ -- Check_Static_Constraint --
+ -----------------------------
+
+ -- Note: for convenience in writing this procedure, in addition to
+ -- the officially (i.e. by spec) allowed argument which is always
+ -- a constraint, it also allows ranges and discriminant associations.
+
+ procedure Check_Static_Constraint (Constr : Node_Id) is
+
+ --------------------
+ -- Require_Static --
+ --------------------
+
+ procedure Require_Static (E : Node_Id);
+ -- Require given expression to be static expression
+
+ procedure Require_Static (E : Node_Id) is
+ begin
+ if not Is_OK_Static_Expression (E) then
+ Error_Msg_N
+ ("non-static constraint not allowed in Unchecked_Union", E);
+ raise Pragma_Exit;
+ end if;
+ end Require_Static;
+
+ -- Start of processing for Check_Static_Constraint
+
+ begin
+ case Nkind (Constr) is
+ when N_Discriminant_Association =>
+ Require_Static (Expression (Constr));
+
+ when N_Range =>
+ Require_Static (Low_Bound (Constr));
+ Require_Static (High_Bound (Constr));
+
+ when N_Attribute_Reference =>
+ Require_Static (Type_Low_Bound (Etype (Prefix (Constr))));
+ Require_Static (Type_High_Bound (Etype (Prefix (Constr))));
+
+ when N_Range_Constraint =>
+ Check_Static_Constraint (Range_Expression (Constr));
+
+ when N_Index_Or_Discriminant_Constraint =>
+ declare
+ IDC : Entity_Id := First (Constraints (Constr));
+
+ begin
+ while Present (IDC) loop
+ Check_Static_Constraint (IDC);
+ Next (IDC);
+ end loop;
+ end;
+
+ when others =>
+ null;
+ end case;
+ end Check_Static_Constraint;
+
+ --------------------------------------
+ -- Check_Valid_Configuration_Pragma --
+ --------------------------------------
+
+ -- A configuration pragma must appear in the context clause of
+ -- a compilation unit, at the start of the list (i.e. only other
+ -- pragmas may precede it).
+
+ procedure Check_Valid_Configuration_Pragma is
+ begin
+ if not Is_Configuration_Pragma then
+ Error_Pragma ("incorrect placement for configuration pragma%");
+ end if;
+ end Check_Valid_Configuration_Pragma;
+
+ -------------------------------------
+ -- Check_Valid_Library_Unit_Pragma --
+ -------------------------------------
+
+ procedure Check_Valid_Library_Unit_Pragma is
+ Plist : List_Id;
+ Parent_Node : Node_Id;
+ Unit_Name : Entity_Id;
+ Valid : Boolean := True;
+ Unit_Kind : Node_Kind;
+ Unit_Node : Node_Id;
+ Sindex : Source_File_Index;
+
+ begin
+ if not Is_List_Member (N) then
+ Pragma_Misplaced;
+ Valid := False;
+
+ else
+ Plist := List_Containing (N);
+ Parent_Node := Parent (Plist);
+
+ if Parent_Node = Empty then
+ Pragma_Misplaced;
+
+ -- Case of pragma appearing after a compilation unit. In this
+ -- case it must have an argument with the corresponding name
+ -- and must be part of the following pragmas of its parent.
+
+ elsif Nkind (Parent_Node) = N_Compilation_Unit_Aux then
+ if Plist /= Pragmas_After (Parent_Node) then
+ Pragma_Misplaced;
+
+ elsif Arg_Count = 0 then
+ Error_Pragma
+ ("argument required if outside compilation unit");
+
+ else
+ Check_No_Identifiers;
+ Check_Arg_Count (1);
+ Unit_Node := Unit (Parent (Parent_Node));
+ Unit_Kind := Nkind (Unit_Node);
+
+ Analyze (Expression (Arg1));
+
+ if Unit_Kind = N_Generic_Subprogram_Declaration
+ or else Unit_Kind = N_Subprogram_Declaration
+ then
+ Unit_Name := Defining_Entity (Unit_Node);
+
+ elsif Unit_Kind = N_Function_Instantiation
+ or else Unit_Kind = N_Package_Instantiation
+ or else Unit_Kind = N_Procedure_Instantiation
+ then
+ Unit_Name := Defining_Entity (Unit_Node);
+
+ else
+ Unit_Name := Cunit_Entity (Current_Sem_Unit);
+ end if;
+
+ if Chars (Unit_Name) /=
+ Chars (Entity (Expression (Arg1)))
+ then
+ Error_Pragma_Arg
+ ("pragma% argument is not current unit name", Arg1);
+ end if;
+
+ if Ekind (Unit_Name) = E_Package
+ and then Present (Renamed_Entity (Unit_Name))
+ then
+ Error_Pragma ("pragma% not allowed for renamed package");
+ end if;
+ end if;
+
+ -- Pragma appears other than after a compilation unit
+
+ else
+ -- Here we check for the generic instantiation case and also
+ -- for the case of processing a generic formal package. We
+ -- detect these cases by noting that the Sloc on the node
+ -- does not belong to the current compilation unit.
+
+ Sindex := Source_Index (Current_Sem_Unit);
+
+ if Loc not in Source_First (Sindex) .. Source_Last (Sindex) then
+ Rewrite (N, Make_Null_Statement (Loc));
+ return;
+
+ -- If before first declaration, the pragma applies to the
+ -- enclosing unit, and the name if present must be this name.
+
+ elsif Is_Before_First_Decl (N, Plist) then
+ Unit_Node := Unit_Declaration_Node (Current_Scope);
+ Unit_Kind := Nkind (Unit_Node);
+
+ if Nkind (Parent (Unit_Node)) /= N_Compilation_Unit then
+ Pragma_Misplaced;
+
+ elsif Unit_Kind = N_Subprogram_Body
+ and then not Acts_As_Spec (Unit_Node)
+ then
+ Pragma_Misplaced;
+
+ elsif Nkind (Parent_Node) = N_Package_Body then
+ Pragma_Misplaced;
+
+ elsif Nkind (Parent_Node) = N_Package_Specification
+ and then Plist = Private_Declarations (Parent_Node)
+ then
+ Pragma_Misplaced;
+
+ elsif (Nkind (Parent_Node) = N_Generic_Package_Declaration
+ or else Nkind (Parent_Node)
+ = N_Generic_Subprogram_Declaration)
+ and then Plist = Generic_Formal_Declarations (Parent_Node)
+ then
+ Pragma_Misplaced;
+
+ elsif Arg_Count > 0 then
+ Analyze (Expression (Arg1));
+
+ if Entity (Expression (Arg1)) /= Current_Scope then
+ Error_Pragma_Arg
+ ("name in pragma% must be enclosing unit", Arg1);
+ end if;
+
+ -- It is legal to have no argument in this context
+
+ else
+ return;
+ end if;
+
+ -- Error if not before first declaration. This is because a
+ -- library unit pragma argument must be the name of a library
+ -- unit (RM 10.1.5(7)), but the only names permitted in this
+ -- context are (RM 10.1.5(6)) names of subprogram declarations,
+ -- generic subprogram declarations or generic instantiations.
+
+ else
+ Error_Pragma
+ ("pragma% misplaced, must be before first declaration");
+ end if;
+ end if;
+ end if;
+
+ end Check_Valid_Library_Unit_Pragma;
+
+ ------------------
+ -- Error_Pragma --
+ ------------------
+
+ procedure Error_Pragma (Msg : String) is
+ begin
+ Error_Msg_Name_1 := Chars (N);
+ Error_Msg_N (Msg, N);
+ raise Pragma_Exit;
+ end Error_Pragma;
+
+ ----------------------
+ -- Error_Pragma_Arg --
+ ----------------------
+
+ procedure Error_Pragma_Arg (Msg : String; Arg : Node_Id) is
+ begin
+ Error_Msg_Name_1 := Chars (N);
+ Error_Msg_N (Msg, Get_Pragma_Arg (Arg));
+ raise Pragma_Exit;
+ end Error_Pragma_Arg;
+
+ procedure Error_Pragma_Arg (Msg1, Msg2 : String; Arg : Node_Id) is
+ begin
+ Error_Msg_Name_1 := Chars (N);
+ Error_Msg_N (Msg1, Get_Pragma_Arg (Arg));
+ Error_Pragma_Arg (Msg2, Arg);
+ end Error_Pragma_Arg;
+
+ ----------------------------
+ -- Error_Pragma_Arg_Ident --
+ ----------------------------
+
+ procedure Error_Pragma_Arg_Ident (Msg : String; Arg : Node_Id) is
+ begin
+ Error_Msg_Name_1 := Chars (N);
+ Error_Msg_N (Msg, Arg);
+ raise Pragma_Exit;
+ end Error_Pragma_Arg_Ident;
+
+ ------------------------
+ -- Find_Lib_Unit_Name --
+ ------------------------
+
+ function Find_Lib_Unit_Name return Entity_Id is
+ begin
+ -- Return inner compilation unit entity, for case of nested
+ -- categorization pragmas. This happens in generic unit.
+
+ if Nkind (Parent (N)) = N_Package_Specification
+ and then Defining_Entity (Parent (N)) /= Current_Scope
+ then
+ return Defining_Entity (Parent (N));
+
+ else
+ return Current_Scope;
+ end if;
+ end Find_Lib_Unit_Name;
+
+ ----------------------------
+ -- Find_Program_Unit_Name --
+ ----------------------------
+
+ procedure Find_Program_Unit_Name (Id : Node_Id) is
+ Unit_Name : Entity_Id;
+ Unit_Kind : Node_Kind;
+ P : constant Node_Id := Parent (N);
+
+ begin
+ if Nkind (P) = N_Compilation_Unit then
+ Unit_Kind := Nkind (Unit (P));
+
+ if Unit_Kind = N_Subprogram_Declaration
+ or else Unit_Kind = N_Package_Declaration
+ or else Unit_Kind in N_Generic_Declaration
+ then
+ Unit_Name := Defining_Entity (Unit (P));
+
+ if Chars (Id) = Chars (Unit_Name) then
+ Set_Entity (Id, Unit_Name);
+ Set_Etype (Id, Etype (Unit_Name));
+ else
+ Set_Etype (Id, Any_Type);
+ Error_Pragma
+ ("cannot find program unit referenced by pragma%");
+ end if;
+
+ else
+ Set_Etype (Id, Any_Type);
+ Error_Pragma ("pragma% inapplicable to this unit");
+ end if;
+
+ else
+ Analyze (Id);
+ end if;
+
+ end Find_Program_Unit_Name;
+
+ -------------------------
+ -- Gather_Associations --
+ -------------------------
+
+ procedure Gather_Associations
+ (Names : Name_List;
+ Args : out Args_List)
+ is
+ Arg : Node_Id;
+
+ begin
+ -- Initialize all parameters to Empty
+
+ for J in Args'Range loop
+ Args (J) := Empty;
+ end loop;
+
+ -- That's all we have to do if there are no argument associations
+
+ if No (Pragma_Argument_Associations (N)) then
+ return;
+ end if;
+
+ -- Otherwise first deal with any positional parameters present
+
+ Arg := First (Pragma_Argument_Associations (N));
+
+ for Index in Args'Range loop
+ exit when No (Arg) or else Chars (Arg) /= No_Name;
+ Args (Index) := Expression (Arg);
+ Next (Arg);
+ end loop;
+
+ -- Positional parameters all processed, if any left, then we
+ -- have too many positional parameters.
+
+ if Present (Arg) and then Chars (Arg) = No_Name then
+ Error_Pragma_Arg
+ ("too many positional associations for pragma%", Arg);
+ end if;
+
+ -- Process named parameters if any are present
+
+ while Present (Arg) loop
+ if Chars (Arg) = No_Name then
+ Error_Pragma_Arg
+ ("positional association cannot follow named association",
+ Arg);
+
+ else
+ for Index in Names'Range loop
+ if Names (Index) = Chars (Arg) then
+ if Present (Args (Index)) then
+ Error_Pragma_Arg
+ ("duplicate argument association for pragma%", Arg);
+ else
+ Args (Index) := Expression (Arg);
+ exit;
+ end if;
+ end if;
+
+ if Index = Names'Last then
+ Error_Pragma_Arg_Ident
+ ("pragma% does not allow & argument", Arg);
+ end if;
+ end loop;
+ end if;
+
+ Next (Arg);
+ end loop;
+ end Gather_Associations;
+
+ --------------------
+ -- Get_Pragma_Arg --
+ --------------------
+
+ function Get_Pragma_Arg (Arg : Node_Id) return Node_Id is
+ begin
+ if Nkind (Arg) = N_Pragma_Argument_Association then
+ return Expression (Arg);
+ else
+ return Arg;
+ end if;
+ end Get_Pragma_Arg;
+
+ -----------------
+ -- GNAT_Pragma --
+ -----------------
+
+ procedure GNAT_Pragma is
+ begin
+ Check_Restriction (No_Implementation_Pragmas, N);
+ end GNAT_Pragma;
+
+ --------------------------
+ -- Is_Before_First_Decl --
+ --------------------------
+
+ function Is_Before_First_Decl
+ (Pragma_Node : Node_Id;
+ Decls : List_Id)
+ return Boolean
+ is
+ Item : Node_Id := First (Decls);
+
+ begin
+ -- Only other pragmas can come before this pragma
+
+ loop
+ if No (Item) or else Nkind (Item) /= N_Pragma then
+ return False;
+
+ elsif Item = Pragma_Node then
+ return True;
+ end if;
+
+ Next (Item);
+ end loop;
+
+ end Is_Before_First_Decl;
+
+ -----------------------------
+ -- Is_Configuration_Pragma --
+ -----------------------------
+
+ -- A configuration pragma must appear in the context clause of
+ -- a compilation unit, at the start of the list (i.e. only other
+ -- pragmas may precede it).
+
+ function Is_Configuration_Pragma return Boolean is
+ Lis : constant List_Id := List_Containing (N);
+ Par : constant Node_Id := Parent (N);
+ Prg : Node_Id;
+
+ begin
+ -- If no parent, then we are in the configuration pragma file,
+ -- so the placement is definitely appropriate.
+
+ if No (Par) then
+ return True;
+
+ -- Otherwise we must be in the context clause of a compilation unit
+ -- and the only thing allowed before us in the context list is more
+ -- configuration pragmas.
+
+ elsif Nkind (Par) = N_Compilation_Unit
+ and then Context_Items (Par) = Lis
+ then
+ Prg := First (Lis);
+
+ loop
+ if Prg = N then
+ return True;
+ elsif Nkind (Prg) /= N_Pragma then
+ return False;
+ end if;
+
+ Next (Prg);
+ end loop;
+
+ else
+ return False;
+ end if;
+
+ end Is_Configuration_Pragma;
+
+ ----------------------
+ -- Pragma_Misplaced --
+ ----------------------
+
+ procedure Pragma_Misplaced is
+ begin
+ Error_Pragma ("incorrect placement of pragma%");
+ end Pragma_Misplaced;
+
+ ------------------------------------
+ -- Process Atomic_Shared_Volatile --
+ ------------------------------------
+
+ procedure Process_Atomic_Shared_Volatile is
+ E_Id : Node_Id;
+ E : Entity_Id;
+ D : Node_Id;
+ K : Node_Kind;
+
+ begin
+ GNAT_Pragma;
+ Check_Ada_83_Warning;
+ Check_No_Identifiers;
+ Check_Arg_Count (1);
+ Check_Arg_Is_Local_Name (Arg1);
+ E_Id := Expression (Arg1);
+
+ if Etype (E_Id) = Any_Type then
+ return;
+ end if;
+
+ E := Entity (E_Id);
+ D := Declaration_Node (E);
+ K := Nkind (D);
+
+ if Is_Type (E) then
+ if Rep_Item_Too_Early (E, N)
+ or else
+ Rep_Item_Too_Late (E, N)
+ then
+ return;
+ else
+ Check_First_Subtype (Arg1);
+ end if;
+
+ if Prag_Id /= Pragma_Volatile then
+ Set_Is_Atomic (E);
+ Set_Is_Atomic (Underlying_Type (E));
+ end if;
+
+ Set_Is_Volatile (E);
+ Set_Is_Volatile (Underlying_Type (E));
+
+ elsif K = N_Object_Declaration
+ or else (K = N_Component_Declaration
+ and then Original_Record_Component (E) = E)
+ then
+ if Rep_Item_Too_Late (E, N) then
+ return;
+ end if;
+
+ if Prag_Id /= Pragma_Volatile then
+ Set_Is_Atomic (E);
+ end if;
+
+ Set_Is_Volatile (E);
+
+ else
+ Error_Pragma_Arg
+ ("inappropriate entity for pragma%", Arg1);
+ end if;
+ end Process_Atomic_Shared_Volatile;
+
+ ------------------------
+ -- Process_Convention --
+ ------------------------
+
+ procedure Process_Convention
+ (C : out Convention_Id;
+ E : out Entity_Id)
+ is
+ Id : Node_Id;
+ E1 : Entity_Id;
+ Comp_Unit : Unit_Number_Type;
+ Cname : Name_Id;
+
+ procedure Set_Convention_From_Pragma (E : Entity_Id);
+ -- Set convention in entity E, and also flag that the entity has a
+ -- convention pragma. If entity is for a private or incomplete type,
+ -- also set convention and flag on underlying type. This procedure
+ -- also deals with the special case of C_Pass_By_Copy convention.
+
+ --------------------------------
+ -- Set_Convention_From_Pragma --
+ --------------------------------
+
+ procedure Set_Convention_From_Pragma (E : Entity_Id) is
+ begin
+ Set_Convention (E, C);
+ Set_Has_Convention_Pragma (E);
+
+ if Is_Incomplete_Or_Private_Type (E) then
+ Set_Convention (Underlying_Type (E), C);
+ Set_Has_Convention_Pragma (Underlying_Type (E), True);
+ end if;
+
+ -- A class-wide type should inherit the convention of
+ -- the specific root type (although this isn't specified
+ -- clearly by the RM).
+
+ if Is_Type (E) and then Present (Class_Wide_Type (E)) then
+ Set_Convention (Class_Wide_Type (E), C);
+ end if;
+
+ -- If the entity is a record type, then check for special case
+ -- of C_Pass_By_Copy, which is treated the same as C except that
+ -- the special record flag is set. This convention is also only
+ -- permitted on record types (see AI95-00131).
+
+ if Cname = Name_C_Pass_By_Copy then
+ if Is_Record_Type (E) then
+ Set_C_Pass_By_Copy (Base_Type (E));
+ elsif Is_Incomplete_Or_Private_Type (E)
+ and then Is_Record_Type (Underlying_Type (E))
+ then
+ Set_C_Pass_By_Copy (Base_Type (Underlying_Type (E)));
+ else
+ Error_Pragma_Arg
+ ("C_Pass_By_Copy convention allowed only for record type",
+ Arg2);
+ end if;
+ end if;
+
+ -- If the entity is a derived boolean type, check for the
+ -- special case of convention C, C++, or Fortran, where we
+ -- consider any nonzero value to represent true.
+
+ if Is_Discrete_Type (E)
+ and then Root_Type (Etype (E)) = Standard_Boolean
+ and then
+ (C = Convention_C
+ or else
+ C = Convention_CPP
+ or else
+ C = Convention_Fortran)
+ then
+ Set_Nonzero_Is_True (Base_Type (E));
+ end if;
+ end Set_Convention_From_Pragma;
+
+ -- Start of processing for Process_Convention
+
+ begin
+ Check_At_Least_N_Arguments (2);
+ Check_Arg_Is_Identifier (Arg1);
+ Check_Optional_Identifier (Arg1, Name_Convention);
+ Cname := Chars (Expression (Arg1));
+
+ -- C_Pass_By_Copy is treated as a synonym for convention C
+ -- (this is tested again below to set the critical flag)
+
+ if Cname = Name_C_Pass_By_Copy then
+ C := Convention_C;
+
+ -- Otherwise we must have something in the standard convention list
+
+ elsif Is_Convention_Name (Cname) then
+ C := Get_Convention_Id (Chars (Expression (Arg1)));
+
+ -- In DEC VMS, it seems that there is an undocumented feature
+ -- that any unrecognized convention is treated as the default,
+ -- which for us is convention C. It does not seem so terrible
+ -- to do this unconditionally, silently in the VMS case, and
+ -- with a warning in the non-VMS case.
+
+ else
+ if not OpenVMS_On_Target then
+ Error_Msg_N
+ ("?unrecognized convention name, C assumed",
+ Expression (Arg1));
+ end if;
+
+ C := Convention_C;
+ end if;
+
+ Check_Arg_Is_Local_Name (Arg2);
+ Check_Optional_Identifier (Arg2, Name_Entity);
+
+ Id := Expression (Arg2);
+ Analyze (Id);
+
+ if not Is_Entity_Name (Id) then
+ Error_Pragma_Arg ("entity name required", Arg2);
+ end if;
+
+ E := Entity (Id);
+
+ -- Go to renamed subprogram if present, since convention applies
+ -- to the actual renamed entity, not to the renaming entity.
+
+ if Is_Subprogram (E)
+ and then Present (Alias (E))
+ and then Nkind (Parent (Declaration_Node (E))) =
+ N_Subprogram_Renaming_Declaration
+ then
+ E := Alias (E);
+ end if;
+
+ -- Check that we not applying this to a specless body
+
+ if Is_Subprogram (E)
+ and then Nkind (Parent (Declaration_Node (E))) = N_Subprogram_Body
+ then
+ Error_Pragma
+ ("pragma% requires separate spec and must come before body");
+ end if;
+
+ -- Check that we are not applying this to a named constant
+
+ if Ekind (E) = E_Named_Integer
+ or else
+ Ekind (E) = E_Named_Real
+ then
+ Error_Msg_Name_1 := Chars (N);
+ Error_Msg_N
+ ("cannot apply pragma% to named constant!",
+ Get_Pragma_Arg (Arg2));
+ Error_Pragma_Arg
+ ("\supply appropriate type for&!", Arg2);
+ end if;
+
+ if Etype (E) = Any_Type
+ or else Rep_Item_Too_Early (E, N)
+ then
+ raise Pragma_Exit;
+ else
+ E := Underlying_Type (E);
+ end if;
+
+ if Rep_Item_Too_Late (E, N) then
+ raise Pragma_Exit;
+ end if;
+
+ if Has_Convention_Pragma (E) then
+ Error_Pragma_Arg
+ ("at most one Convention/Export/Import pragma is allowed", Arg2);
+
+ elsif Convention (E) = Convention_Protected
+ or else Ekind (Scope (E)) = E_Protected_Type
+ then
+ Error_Pragma_Arg
+ ("a protected operation cannot be given a different convention",
+ Arg2);
+ end if;
+
+ -- For Intrinsic, a subprogram is required
+
+ if C = Convention_Intrinsic
+ and then not Is_Subprogram (E)
+ and then not Is_Generic_Subprogram (E)
+ then
+ Error_Pragma_Arg
+ ("second argument of pragma% must be a subprogram", Arg2);
+ end if;
+
+ -- For Stdcall, a subprogram, variable or subprogram type is required
+
+ if C = Convention_Stdcall
+ and then not Is_Subprogram (E)
+ and then not Is_Generic_Subprogram (E)
+ and then Ekind (E) /= E_Variable
+ and then not
+ (Is_Access_Type (E)
+ and then Ekind (Designated_Type (E)) = E_Subprogram_Type)
+ then
+ Error_Pragma_Arg
+ ("second argument of pragma% must be subprogram (type)",
+ Arg2);
+ end if;
+
+ if not Is_Subprogram (E)
+ and then not Is_Generic_Subprogram (E)
+ then
+ Set_Convention_From_Pragma (E);
+
+ if Is_Type (E) then
+
+ Check_First_Subtype (Arg2);
+ Set_Convention_From_Pragma (Base_Type (E));
+
+ -- For subprograms, we must set the convention on the
+ -- internally generated directly designated type as well.
+
+ if Ekind (E) = E_Access_Subprogram_Type then
+ Set_Convention_From_Pragma (Directly_Designated_Type (E));
+ end if;
+ end if;
+
+ -- For the subprogram case, set proper convention for all homonyms
+ -- in same compilation unit.
+ -- Is the test of compilation unit really necessary ???
+ -- What about subprogram renamings here???
+
+ else
+ Comp_Unit := Get_Source_Unit (E);
+ Set_Convention_From_Pragma (E);
+
+ E1 := E;
+ loop
+ E1 := Homonym (E1);
+ exit when No (E1) or else Scope (E1) /= Current_Scope;
+
+ -- Note: below we are missing a check for Rep_Item_Too_Late.
+ -- That is deliberate, we cannot chain the rep item on more
+ -- than one Rep_Item chain, to be fixed later ???
+
+ if Comp_Unit = Get_Source_Unit (E1) then
+ Set_Convention_From_Pragma (E1);
+ end if;
+ end loop;
+ end if;
+
+ end Process_Convention;
+
+ -----------------------------------------------------
+ -- Process_Extended_Import_Export_Exception_Pragma --
+ -----------------------------------------------------
+
+ procedure Process_Extended_Import_Export_Exception_Pragma
+ (Arg_Internal : Node_Id;
+ Arg_External : Node_Id;
+ Arg_Form : Node_Id;
+ Arg_Code : Node_Id)
+ is
+ Def_Id : Entity_Id;
+ Code_Val : Uint;
+
+ begin
+ Process_Extended_Import_Export_Internal_Arg (Arg_Internal);
+ Def_Id := Entity (Arg_Internal);
+
+ if Ekind (Def_Id) /= E_Exception then
+ Error_Pragma_Arg
+ ("pragma% must refer to declared exception", Arg_Internal);
+ end if;
+
+ Set_Extended_Import_Export_External_Name (Def_Id, Arg_External);
+
+ if Present (Arg_Form) then
+ Check_Arg_Is_One_Of (Arg_Form, Name_Ada, Name_VMS);
+ end if;
+
+ if Present (Arg_Form)
+ and then Chars (Arg_Form) = Name_Ada
+ then
+ null;
+ else
+ Set_Is_VMS_Exception (Def_Id);
+ Set_Exception_Code (Def_Id, No_Uint);
+ end if;
+
+ if Present (Arg_Code) then
+ if not Is_VMS_Exception (Def_Id) then
+ Error_Pragma_Arg
+ ("Code option for pragma% not allowed for Ada case",
+ Arg_Code);
+ end if;
+
+ Check_Arg_Is_Static_Expression (Arg_Code, Any_Integer);
+ Code_Val := Expr_Value (Arg_Code);
+
+ if not UI_Is_In_Int_Range (Code_Val) then
+ Error_Pragma_Arg
+ ("Code option for pragma% must be in 32-bit range",
+ Arg_Code);
+
+ else
+ Set_Exception_Code (Def_Id, Code_Val);
+ end if;
+ end if;
+
+ end Process_Extended_Import_Export_Exception_Pragma;
+
+ -------------------------------------------------
+ -- Process_Extended_Import_Export_Internal_Arg --
+ -------------------------------------------------
+
+ procedure Process_Extended_Import_Export_Internal_Arg
+ (Arg_Internal : Node_Id := Empty)
+ is
+ begin
+ GNAT_Pragma;
+
+ if No (Arg_Internal) then
+ Error_Pragma ("Internal parameter required for pragma%");
+ end if;
+
+ if Nkind (Arg_Internal) = N_Identifier then
+ null;
+
+ elsif Nkind (Arg_Internal) = N_Operator_Symbol
+ and then (Prag_Id = Pragma_Import_Function
+ or else
+ Prag_Id = Pragma_Export_Function)
+ then
+ null;
+
+ else
+ Error_Pragma_Arg
+ ("wrong form for Internal parameter for pragma%", Arg_Internal);
+ end if;
+
+ Check_Arg_Is_Local_Name (Arg_Internal);
+
+ end Process_Extended_Import_Export_Internal_Arg;
+
+ --------------------------------------------------
+ -- Process_Extended_Import_Export_Object_Pragma --
+ --------------------------------------------------
+
+ procedure Process_Extended_Import_Export_Object_Pragma
+ (Arg_Internal : Node_Id;
+ Arg_External : Node_Id;
+ Arg_Size : Node_Id)
+ is
+ Def_Id : Entity_Id;
+
+ begin
+ Process_Extended_Import_Export_Internal_Arg (Arg_Internal);
+ Def_Id := Entity (Arg_Internal);
+
+ if Ekind (Def_Id) /= E_Constant
+ and then Ekind (Def_Id) /= E_Variable
+ then
+ Error_Pragma_Arg
+ ("pragma% must designate an object", Arg_Internal);
+ end if;
+
+ if Is_Psected (Def_Id) then
+ Error_Pragma_Arg
+ ("previous Psect_Object applies, pragma % not permitted",
+ Arg_Internal);
+ end if;
+
+ if Rep_Item_Too_Late (Def_Id, N) then
+ raise Pragma_Exit;
+ end if;
+
+ Set_Extended_Import_Export_External_Name (Def_Id, Arg_External);
+
+ if Present (Arg_Size)
+ and then Nkind (Arg_Size) /= N_Identifier
+ and then Nkind (Arg_Size) /= N_String_Literal
+ then
+ Error_Pragma_Arg
+ ("pragma% Size argument must be identifier or string literal",
+ Arg_Size);
+ end if;
+
+ -- Export_Object case
+
+ if Prag_Id = Pragma_Export_Object then
+
+ if not Is_Library_Level_Entity (Def_Id) then
+ Error_Pragma_Arg
+ ("argument for pragma% must be library level entity",
+ Arg_Internal);
+ end if;
+
+ if Ekind (Current_Scope) = E_Generic_Package then
+ Error_Pragma ("pragma& cannot appear in a generic unit");
+ end if;
+
+ if not Size_Known_At_Compile_Time (Etype (Def_Id)) then
+ Error_Pragma_Arg
+ ("exported object must have compile time known size",
+ Arg_Internal);
+ end if;
+
+ if Is_Exported (Def_Id) then
+ Error_Msg_N
+ ("?duplicate Export_Object pragma", N);
+ else
+ Set_Exported (Def_Id, Arg_Internal);
+ end if;
+
+ -- Import_Object case
+
+ else
+ if Is_Concurrent_Type (Etype (Def_Id)) then
+ Error_Pragma_Arg
+ ("cannot use pragma% for task/protected object",
+ Arg_Internal);
+ end if;
+
+ if Ekind (Def_Id) = E_Constant then
+ Error_Pragma_Arg
+ ("cannot import a constant", Arg_Internal);
+ end if;
+
+ if Has_Discriminants (Etype (Def_Id)) then
+ Error_Msg_N
+ ("imported value must be initialized?", Arg_Internal);
+ end if;
+
+ if Is_Access_Type (Etype (Def_Id)) then
+ Error_Pragma_Arg
+ ("cannot import object of an access type?", Arg_Internal);
+ end if;
+
+ if Is_Imported (Def_Id) then
+ Error_Msg_N
+ ("?duplicate Import_Object pragma", N);
+ else
+ Set_Imported (Def_Id);
+ end if;
+ end if;
+
+ end Process_Extended_Import_Export_Object_Pragma;
+
+ ------------------------------------------------------
+ -- Process_Extended_Import_Export_Subprogram_Pragma --
+ ------------------------------------------------------
+
+ procedure Process_Extended_Import_Export_Subprogram_Pragma
+ (Arg_Internal : Node_Id;
+ Arg_External : Node_Id;
+ Arg_Parameter_Types : Node_Id;
+ Arg_Result_Type : Node_Id := Empty;
+ Arg_Mechanism : Node_Id;
+ Arg_Result_Mechanism : Node_Id := Empty;
+ Arg_First_Optional_Parameter : Node_Id := Empty)
+ is
+ Ent : Entity_Id;
+ Def_Id : Entity_Id;
+ Hom_Id : Entity_Id;
+ Formal : Entity_Id;
+ Ambiguous : Boolean;
+ Match : Boolean;
+ Dval : Node_Id;
+
+ function Same_Base_Type (Ptype, Formal : Entity_Id) return Boolean;
+ -- Determines if Ptype references the type of Formal. Note that
+ -- only the base types need to match according to the spec.
+
+ function Same_Base_Type (Ptype, Formal : Entity_Id) return Boolean is
+ begin
+ Find_Type (Ptype);
+
+ if not Is_Entity_Name (Ptype)
+ or else Entity (Ptype) = Any_Type
+ then
+ raise Pragma_Exit;
+ end if;
+
+ return Base_Type (Entity (Ptype)) = Base_Type (Etype (Formal));
+ end Same_Base_Type;
+
+ -- Start of processing for
+ -- Process_Extended_Import_Export_Subprogram_Pragma
+
+ begin
+ Process_Extended_Import_Export_Internal_Arg (Arg_Internal);
+ Hom_Id := Entity (Arg_Internal);
+ Ent := Empty;
+ Ambiguous := False;
+
+ -- Loop through homonyms (overloadings) of Hom_Id
+
+ while Present (Hom_Id) loop
+ Def_Id := Get_Base_Subprogram (Hom_Id);
+
+ -- We need a subprogram in the current scope
+
+ if not Is_Subprogram (Def_Id)
+ or else Scope (Def_Id) /= Current_Scope
+ then
+ null;
+
+ else
+ Match := True;
+
+ -- Pragma cannot apply to subprogram body
+
+ if Is_Subprogram (Def_Id)
+ and then
+ Nkind (Parent
+ (Declaration_Node (Def_Id))) = N_Subprogram_Body
+ then
+ Error_Pragma
+ ("pragma% requires separate spec"
+ & " and must come before body");
+ end if;
+
+ -- Test result type if given, note that the result type
+ -- parameter can only be present for the function cases.
+
+ if Present (Arg_Result_Type)
+ and then not Same_Base_Type (Arg_Result_Type, Def_Id)
+ then
+ Match := False;
+
+ -- Test parameter types if given. Note that this parameter
+ -- has not been analyzed (and must not be, since it is
+ -- semantic nonsense), so we get it as the parser left it.
+
+ elsif Present (Arg_Parameter_Types) then
+ Check_Matching_Types : declare
+ Formal : Entity_Id;
+ Ptype : Node_Id;
+
+ begin
+ Formal := First_Formal (Def_Id);
+
+ if Nkind (Arg_Parameter_Types) = N_Null then
+ if Present (Formal) then
+ Match := False;
+ end if;
+
+ -- A list of one type, e.g. (List) is parsed as
+ -- a parenthesized expression.
+
+ elsif Nkind (Arg_Parameter_Types) /= N_Aggregate
+ and then Paren_Count (Arg_Parameter_Types) = 1
+ then
+ if No (Formal)
+ or else Present (Next_Formal (Formal))
+ then
+ Match := False;
+ else
+ Match :=
+ Same_Base_Type (Arg_Parameter_Types, Formal);
+ end if;
+
+ -- A list of more than one type is parsed as a aggregate
+
+ elsif Nkind (Arg_Parameter_Types) = N_Aggregate
+ and then Paren_Count (Arg_Parameter_Types) = 0
+ then
+ Ptype := First (Expressions (Arg_Parameter_Types));
+
+ while Present (Ptype) or else Present (Formal) loop
+ if No (Ptype)
+ or else No (Formal)
+ or else not Same_Base_Type (Ptype, Formal)
+ then
+ Match := False;
+ exit;
+ else
+ Next_Formal (Formal);
+ Next (Ptype);
+ end if;
+ end loop;
+
+ -- Anything else is of the wrong form
+
+ else
+ Error_Pragma_Arg
+ ("wrong form for Parameter_Types parameter",
+ Arg_Parameter_Types);
+ end if;
+ end Check_Matching_Types;
+ end if;
+
+ -- Match is now False if the entry we found did not match
+ -- either a supplied Parameter_Types or Result_Types argument
+
+ if Match then
+ if No (Ent) then
+ Ent := Def_Id;
+
+ -- Ambiguous case, the flag Ambiguous shows if we already
+ -- detected this and output the initial messages.
+
+ else
+ if not Ambiguous then
+ Ambiguous := True;
+ Error_Msg_Name_1 := Chars (N);
+ Error_Msg_N
+ ("pragma% does not uniquely identify subprogram!",
+ N);
+ Error_Msg_Sloc := Sloc (Ent);
+ Error_Msg_N ("matching subprogram #!", N);
+ Ent := Empty;
+ end if;
+
+ Error_Msg_Sloc := Sloc (Def_Id);
+ Error_Msg_N ("matching subprogram #!", N);
+ end if;
+ end if;
+ end if;
+
+ Hom_Id := Homonym (Hom_Id);
+ end loop;
+
+ -- See if we found an entry
+
+ if No (Ent) then
+ if not Ambiguous then
+ if Is_Generic_Subprogram (Entity (Arg_Internal)) then
+ Error_Pragma
+ ("pragma% cannot be given for generic subprogram");
+
+ else
+ Error_Pragma
+ ("pragma% does not identify local subprogram");
+ end if;
+ end if;
+
+ return;
+ end if;
+
+ -- Import pragmas must be be for imported entities
+
+ if (Prag_Id = Pragma_Import_Function
+ or else
+ Prag_Id = Pragma_Import_Procedure
+ or else
+ Prag_Id = Pragma_Import_Valued_Procedure)
+ then
+ if not Is_Imported (Ent) then
+ Error_Pragma
+ ("pragma Import or Interface must precede pragma%");
+ end if;
+
+ -- For the Export cases, the pragma Export is sufficient to set
+ -- the entity as exported, if it is not exported already. We
+ -- leave the default Ada convention in this case.
+
+ else
+ Set_Exported (Ent, Arg_Internal);
+ end if;
+
+ -- Special processing for Valued_Procedure cases
+
+ if Prag_Id = Pragma_Import_Valued_Procedure
+ or else
+ Prag_Id = Pragma_Export_Valued_Procedure
+ then
+ Formal := First_Formal (Ent);
+
+ if No (Formal) then
+ Error_Pragma
+ ("at least one parameter required for pragma%");
+
+ elsif Ekind (Formal) /= E_Out_Parameter then
+ Error_Pragma
+ ("first parameter must have mode out for pragma%");
+
+ else
+ Set_Is_Valued_Procedure (Ent);
+ end if;
+ end if;
+
+ Set_Extended_Import_Export_External_Name (Ent, Arg_External);
+
+ -- Process Result_Mechanism argument if present. We have already
+ -- checked that this is only allowed for the function case.
+
+ if Present (Arg_Result_Mechanism) then
+ Set_Mechanism_Value (Ent, Arg_Result_Mechanism);
+ end if;
+
+ -- Process Mechanism parameter if present. Note that this parameter
+ -- is not analyzed, and must not be analyzed since it is semantic
+ -- nonsense, so we get it in exactly as the parser left it.
+
+ if Present (Arg_Mechanism) then
+
+ declare
+ Formal : Entity_Id;
+ Massoc : Node_Id;
+ Mname : Node_Id;
+ Choice : Node_Id;
+
+ begin
+ -- A single mechanism association without a formal parameter
+ -- name is parsed as a parenthesized expression. All other
+ -- cases are parsed as aggregates, so we rewrite the single
+ -- parameter case as an aggregate for consistency.
+
+ if Nkind (Arg_Mechanism) /= N_Aggregate
+ and then Paren_Count (Arg_Mechanism) = 1
+ then
+ Rewrite (Arg_Mechanism,
+ Make_Aggregate (Sloc (Arg_Mechanism),
+ Expressions => New_List (
+ Relocate_Node (Arg_Mechanism))));
+ end if;
+
+ -- Case of only mechanism name given, applies to all formals
+
+ if Nkind (Arg_Mechanism) /= N_Aggregate then
+ Formal := First_Formal (Ent);
+ while Present (Formal) loop
+ Set_Mechanism_Value (Formal, Arg_Mechanism);
+ Next_Formal (Formal);
+ end loop;
+
+ -- Case of list of mechanism associations given
+
+ else
+ if Null_Record_Present (Arg_Mechanism) then
+ Error_Pragma_Arg
+ ("inappropriate form for Mechanism parameter",
+ Arg_Mechanism);
+ end if;
+
+ -- Deal with positional ones first
+
+ Formal := First_Formal (Ent);
+ if Present (Expressions (Arg_Mechanism)) then
+ Mname := First (Expressions (Arg_Mechanism));
+
+ while Present (Mname) loop
+ if No (Formal) then
+ Error_Pragma_Arg
+ ("too many mechanism associations", Mname);
+ end if;
+
+ Set_Mechanism_Value (Formal, Mname);
+ Next_Formal (Formal);
+ Next (Mname);
+ end loop;
+ end if;
+
+ -- Deal with named entries
+
+ if Present (Component_Associations (Arg_Mechanism)) then
+ Massoc := First (Component_Associations (Arg_Mechanism));
+
+ while Present (Massoc) loop
+ Choice := First (Choices (Massoc));
+
+ if Nkind (Choice) /= N_Identifier
+ or else Present (Next (Choice))
+ then
+ Error_Pragma_Arg
+ ("incorrect form for mechanism association",
+ Massoc);
+ end if;
+
+ Formal := First_Formal (Ent);
+ loop
+ if No (Formal) then
+ Error_Pragma_Arg
+ ("parameter name & not present", Choice);
+ end if;
+
+ if Chars (Choice) = Chars (Formal) then
+ Set_Mechanism_Value
+ (Formal, Expression (Massoc));
+ exit;
+ end if;
+
+ Next_Formal (Formal);
+ end loop;
+
+ Next (Massoc);
+ end loop;
+ end if;
+ end if;
+ end;
+ end if;
+
+ -- Process First_Optional_Parameter argument if present. We have
+ -- already checked that this is only allowed for the Import case.
+
+ if Present (Arg_First_Optional_Parameter) then
+ if Nkind (Arg_First_Optional_Parameter) /= N_Identifier then
+ Error_Pragma_Arg
+ ("first optional parameter must be formal parameter name",
+ Arg_First_Optional_Parameter);
+ end if;
+
+ Formal := First_Formal (Ent);
+ loop
+ if No (Formal) then
+ Error_Pragma_Arg
+ ("specified formal parameter& not found",
+ Arg_First_Optional_Parameter);
+ end if;
+
+ exit when Chars (Formal) =
+ Chars (Arg_First_Optional_Parameter);
+
+ Next_Formal (Formal);
+ end loop;
+
+ Set_First_Optional_Parameter (Ent, Formal);
+
+ -- Check specified and all remaining formals have right form
+
+ while Present (Formal) loop
+ if Ekind (Formal) /= E_In_Parameter then
+ Error_Msg_NE
+ ("optional formal& is not of mode in!",
+ Arg_First_Optional_Parameter, Formal);
+
+ else
+ Dval := Default_Value (Formal);
+
+ if not Present (Dval) then
+ Error_Msg_NE
+ ("optional formal& does not have default value!",
+ Arg_First_Optional_Parameter, Formal);
+
+ elsif Compile_Time_Known_Value_Or_Aggr (Dval) then
+ null;
+
+ else
+ Error_Msg_NE
+ ("default value for optional formal& is non-static!",
+ Arg_First_Optional_Parameter, Formal);
+ end if;
+ end if;
+
+ Set_Is_Optional_Parameter (Formal);
+ Next_Formal (Formal);
+ end loop;
+ end if;
+
+ end Process_Extended_Import_Export_Subprogram_Pragma;
+
+ --------------------------
+ -- Process_Generic_List --
+ --------------------------
+
+ procedure Process_Generic_List is
+ Arg : Node_Id;
+ Exp : Node_Id;
+
+ begin
+ GNAT_Pragma;
+ Check_No_Identifiers;
+ Check_At_Least_N_Arguments (1);
+
+ Arg := Arg1;
+ while Present (Arg) loop
+ Exp := Expression (Arg);
+ Analyze (Exp);
+
+ if not Is_Entity_Name (Exp)
+ or else
+ (not Is_Generic_Instance (Entity (Exp))
+ and then
+ not Is_Generic_Unit (Entity (Exp)))
+ then
+ Error_Pragma_Arg
+ ("pragma% argument must be name of generic unit/instance",
+ Arg);
+ end if;
+
+ Next (Arg);
+ end loop;
+ end Process_Generic_List;
+
+ ---------------------------------
+ -- Process_Import_Or_Interface --
+ ---------------------------------
+
+ procedure Process_Import_Or_Interface is
+ C : Convention_Id;
+ Def_Id : Entity_Id;
+ Hom_Id : Entity_Id;
+
+ begin
+ Process_Convention (C, Def_Id);
+ Kill_Size_Check_Code (Def_Id);
+ Note_Possible_Modification (Expression (Arg2));
+
+ if Ekind (Def_Id) = E_Variable
+ or else
+ Ekind (Def_Id) = E_Constant
+ then
+ -- User initialization is not allowed for imported object, but
+ -- the object declaration may contain a default initialization,
+ -- that will be discarded.
+
+ if Present (Expression (Parent (Def_Id)))
+ and then Comes_From_Source (Expression (Parent (Def_Id)))
+ then
+ Error_Msg_Sloc := Sloc (Def_Id);
+ Error_Pragma_Arg
+ ("no initialization allowed for declaration of& #",
+ "\imported entities cannot be initialized ('R'M' 'B.1(24))",
+ Arg2);
+
+ else
+ Set_Imported (Def_Id);
+ Set_Is_Public (Def_Id);
+ Process_Interface_Name (Def_Id, Arg3, Arg4);
+ end if;
+
+ elsif Is_Subprogram (Def_Id)
+ or else Is_Generic_Subprogram (Def_Id)
+ then
+ -- If the name is overloaded, pragma applies to all of the
+ -- denoted entities in the same declarative part.
+
+ Hom_Id := Def_Id;
+
+ while Present (Hom_Id) loop
+ Def_Id := Get_Base_Subprogram (Hom_Id);
+
+ -- Ignore inherited subprograms because the pragma will
+ -- apply to the parent operation, which is the one called.
+
+ if Is_Overloadable (Def_Id)
+ and then Present (Alias (Def_Id))
+ then
+ null;
+
+ -- Verify that the homonym is in the same declarative
+ -- part (not just the same scope).
+
+ elsif Parent (Unit_Declaration_Node (Def_Id)) /= Parent (N)
+ and then Nkind (Parent (N)) /= N_Compilation_Unit_Aux
+ then
+ exit;
+
+ else
+ Set_Imported (Def_Id);
+
+ -- If Import intrinsic, set intrinsic flag
+ -- and verify that it is known as such.
+
+ if C = Convention_Intrinsic then
+ Set_Is_Intrinsic_Subprogram (Def_Id);
+ Check_Intrinsic_Subprogram
+ (Def_Id, Expression (Arg2));
+ end if;
+
+ -- All interfaced procedures need an external
+ -- symbol created for them since they are
+ -- always referenced from another object file.
+
+ Set_Is_Public (Def_Id);
+ Set_Has_Completion (Def_Id);
+ Process_Interface_Name (Def_Id, Arg3, Arg4);
+ end if;
+
+ if Is_Compilation_Unit (Hom_Id) then
+
+ -- Its possible homonyms are not affected by the pragma.
+ -- Such homonyms might be present in the context of other
+ -- units being compiled.
+
+ exit;
+
+ else
+ Hom_Id := Homonym (Hom_Id);
+ end if;
+ end loop;
+
+ -- When the convention is Java, we also allow Import to be given
+ -- for packages, exceptions, and record components.
+
+ elsif C = Convention_Java
+ and then (Ekind (Def_Id) = E_Package
+ or else Ekind (Def_Id) = E_Exception
+ or else Nkind (Parent (Def_Id)) = N_Component_Declaration)
+ then
+ Set_Imported (Def_Id);
+ Set_Is_Public (Def_Id);
+ Process_Interface_Name (Def_Id, Arg3, Arg4);
+
+ else
+ Error_Pragma_Arg
+ ("second argument of pragma% must be object or subprogram",
+ Arg2);
+ end if;
+
+ -- If this pragma applies to a compilation unit, then the unit,
+ -- which is a subprogram, does not require (or allow) a body.
+ -- We also do not need to elaborate imported procedures.
+
+ if Nkind (Parent (N)) = N_Compilation_Unit_Aux then
+ declare
+ Cunit : constant Node_Id := Parent (Parent (N));
+
+ begin
+ Set_Body_Required (Cunit, False);
+ end;
+ end if;
+
+ end Process_Import_Or_Interface;
+
+ --------------------
+ -- Process_Inline --
+ --------------------
+
+ procedure Process_Inline (Active : Boolean) is
+ Assoc : Node_Id;
+ Decl : Node_Id;
+ Subp_Id : Node_Id;
+ Subp : Entity_Id;
+ Applies : Boolean;
+
+ procedure Make_Inline (Subp : Entity_Id);
+ -- Subp is the defining unit name of the subprogram
+ -- declaration. Set the flag, as well as the flag in the
+ -- corresponding body, if there is one present.
+
+ procedure Set_Inline_Flags (Subp : Entity_Id);
+ -- Sets Is_Inlined and Has_Pragma_Inline flags for Subp
+
+ -----------------
+ -- Make_Inline --
+ -----------------
+
+ procedure Make_Inline (Subp : Entity_Id) is
+ Kind : Entity_Kind := Ekind (Subp);
+ Inner_Subp : Entity_Id := Subp;
+
+ begin
+ if Etype (Subp) = Any_Type then
+ return;
+
+ -- Here we have a candidate for inlining, but we must exclude
+ -- derived operations. Otherwise we will end up trying to
+ -- inline a phantom declaration, and the result would be to
+ -- drag in a body which has no direct inlining associated with
+ -- it. That would not only be inefficient but would also result
+ -- in the backend doing cross-unit inlining in cases where it
+ -- was definitely inappropriate to do so.
+
+ -- However, a simple Comes_From_Source test is insufficient,
+ -- since we do want to allow inlining of generic instances,
+ -- which also do not come from source. Predefined operators do
+ -- not come from source but are not inlineable either.
+
+ elsif not Comes_From_Source (Subp)
+ and then not Is_Generic_Instance (Subp)
+ and then Scope (Subp) /= Standard_Standard
+ then
+ Applies := True;
+ return;
+
+ -- The referenced entity must either be the enclosing entity,
+ -- or an entity declared within the current open scope.
+
+ elsif Present (Scope (Subp))
+ and then Scope (Subp) /= Current_Scope
+ and then Subp /= Current_Scope
+ then
+ Error_Pragma_Arg
+ ("argument of% must be entity in current scope", Assoc);
+ return;
+ end if;
+
+ -- Processing for procedure, operator or function.
+ -- If subprogram is aliased (as for an instance) indicate
+ -- that the renamed entity is inlined.
+
+ if Kind = E_Procedure
+ or else Kind = E_Function
+ or else Kind = E_Operator
+ then
+ while Present (Alias (Inner_Subp)) loop
+ Inner_Subp := Alias (Inner_Subp);
+ end loop;
+
+ Set_Inline_Flags (Inner_Subp);
+
+ Decl := Parent (Parent (Inner_Subp));
+
+ if Nkind (Decl) = N_Subprogram_Declaration
+ and then Present (Corresponding_Body (Decl))
+ then
+ Set_Inline_Flags (Corresponding_Body (Decl));
+ end if;
+
+ Applies := True;
+
+ -- For a generic subprogram set flag as well, for use at
+ -- the point of instantiation, to determine whether the
+ -- body should be generated.
+
+ elsif Kind = E_Generic_Procedure
+ or else Kind = E_Generic_Function
+ then
+ Set_Inline_Flags (Subp);
+ Applies := True;
+
+ -- Literals are by definition inlined.
+
+ elsif Kind = E_Enumeration_Literal then
+ null;
+
+ -- Anything else is an error
+
+ else
+ Error_Pragma_Arg
+ ("expect subprogram name for pragma%", Assoc);
+ end if;
+ end Make_Inline;
+
+ ----------------------
+ -- Set_Inline_Flags --
+ ----------------------
+
+ procedure Set_Inline_Flags (Subp : Entity_Id) is
+ begin
+ if Active then
+ Set_Is_Inlined (Subp, True);
+ end if;
+
+ if not Has_Pragma_Inline (Subp) then
+ Set_Has_Pragma_Inline (Subp);
+ Set_Next_Rep_Item (N, First_Rep_Item (Subp));
+ Set_First_Rep_Item (Subp, N);
+ end if;
+ end Set_Inline_Flags;
+
+ -- Start of processing for Process_Inline
+
+ begin
+ Check_No_Identifiers;
+ Check_At_Least_N_Arguments (1);
+
+ if Active then
+ Inline_Processing_Required := True;
+ end if;
+
+ Assoc := Arg1;
+ while Present (Assoc) loop
+ Subp_Id := Expression (Assoc);
+ Analyze (Subp_Id);
+ Applies := False;
+
+ if Is_Entity_Name (Subp_Id) then
+ Subp := Entity (Subp_Id);
+
+ if Subp = Any_Id then
+ Applies := True;
+
+ else
+ Make_Inline (Subp);
+
+ while Present (Homonym (Subp))
+ and then Scope (Homonym (Subp)) = Current_Scope
+ loop
+ Make_Inline (Homonym (Subp));
+ Subp := Homonym (Subp);
+ end loop;
+ end if;
+ end if;
+
+ if not Applies then
+ Error_Pragma_Arg
+ ("inappropriate argument for pragma%", Assoc);
+ end if;
+
+ Next (Assoc);
+ end loop;
+
+ end Process_Inline;
+
+ ----------------------------
+ -- Process_Interface_Name --
+ ----------------------------
+
+ procedure Process_Interface_Name
+ (Subprogram_Def : Entity_Id;
+ Ext_Arg : Node_Id;
+ Link_Arg : Node_Id)
+ is
+ Ext_Nam : Node_Id;
+ Link_Nam : Node_Id;
+ String_Val : String_Id;
+
+ procedure Check_Form_Of_Interface_Name (SN : Node_Id);
+ -- SN is a string literal node for an interface name. This routine
+ -- performs some minimal checks that the name is reasonable. In
+ -- particular that no spaces or other obviously incorrect characters
+ -- appear. This is only a warning, since any characters are allowed.
+
+ procedure Check_Form_Of_Interface_Name (SN : Node_Id) is
+ S : constant String_Id := Strval (Expr_Value_S (SN));
+ SL : constant Nat := String_Length (S);
+ C : Char_Code;
+
+ begin
+ if SL = 0 then
+ Error_Msg_N ("interface name cannot be null string", SN);
+ end if;
+
+ for J in 1 .. SL loop
+ C := Get_String_Char (S, J);
+
+ if not In_Character_Range (C)
+ or else Get_Character (C) = ' '
+ or else Get_Character (C) = ','
+ then
+ Error_Msg_N
+ ("?interface name contains illegal character", SN);
+ end if;
+ end loop;
+ end Check_Form_Of_Interface_Name;
+
+ -- Start of processing for Process_Interface_Name
+
+ begin
+ if No (Link_Arg) then
+ if No (Ext_Arg) then
+ return;
+
+ elsif Chars (Ext_Arg) = Name_Link_Name then
+ Ext_Nam := Empty;
+ Link_Nam := Expression (Ext_Arg);
+
+ else
+ Check_Optional_Identifier (Ext_Arg, Name_External_Name);
+ Ext_Nam := Expression (Ext_Arg);
+ Link_Nam := Empty;
+ end if;
+
+ else
+ Check_Optional_Identifier (Ext_Arg, Name_External_Name);
+ Check_Optional_Identifier (Link_Arg, Name_Link_Name);
+ Ext_Nam := Expression (Ext_Arg);
+ Link_Nam := Expression (Link_Arg);
+ end if;
+
+ -- Check expressions for external name and link name are static
+
+ if Present (Ext_Nam) then
+ Check_Arg_Is_Static_Expression (Ext_Nam, Standard_String);
+ Check_Form_Of_Interface_Name (Ext_Nam);
+
+ -- Verify that the external name is not the name of a local
+ -- entity, which would hide the imported one and lead to
+ -- run-time surprises. The problem can only arise for entities
+ -- declared in a package body (otherwise the external name is
+ -- fully qualified and won't conflict).
+
+ declare
+ Nam : Name_Id;
+ E : Entity_Id;
+ Par : Node_Id;
+
+ begin
+ if Prag_Id = Pragma_Import then
+ String_To_Name_Buffer (Strval (Expr_Value_S (Ext_Nam)));
+ Nam := Name_Find;
+ E := Entity_Id (Get_Name_Table_Info (Nam));
+
+ if Nam /= Chars (Subprogram_Def)
+ and then Present (E)
+ and then not Is_Overloadable (E)
+ and then Is_Immediately_Visible (E)
+ and then not Is_Imported (E)
+ and then Ekind (Scope (E)) = E_Package
+ then
+ Par := Parent (E);
+
+ while Present (Par) loop
+ if Nkind (Par) = N_Package_Body then
+ Error_Msg_Sloc := Sloc (E);
+ Error_Msg_NE
+ ("imported entity is hidden by & declared#",
+ Ext_Arg, E);
+ exit;
+ end if;
+
+ Par := Parent (Par);
+ end loop;
+ end if;
+ end if;
+ end;
+ end if;
+
+ if Present (Link_Nam) then
+ Check_Arg_Is_Static_Expression (Link_Nam, Standard_String);
+ Check_Form_Of_Interface_Name (Link_Nam);
+ end if;
+
+ -- If there is no link name, just set the external name
+
+ if No (Link_Nam) then
+ Set_Encoded_Interface_Name
+ (Get_Base_Subprogram (Subprogram_Def),
+ Adjust_External_Name_Case (Expr_Value_S (Ext_Nam)));
+
+ -- For the Link_Name case, the given literal is preceded by an
+ -- asterisk, which indicates to GCC that the given name should
+ -- be taken literally, and in particular that no prepending of
+ -- underlines should occur, even in systems where this is the
+ -- normal default.
+
+ else
+ Start_String;
+ Store_String_Char (Get_Char_Code ('*'));
+ String_Val := Strval (Expr_Value_S (Link_Nam));
+
+ for J in 1 .. String_Length (String_Val) loop
+ Store_String_Char (Get_String_Char (String_Val, J));
+ end loop;
+
+ Link_Nam :=
+ Make_String_Literal (Sloc (Link_Nam), End_String);
+
+ Set_Encoded_Interface_Name
+ (Get_Base_Subprogram (Subprogram_Def), Link_Nam);
+ end if;
+ end Process_Interface_Name;
+
+ -----------------------------------------
+ -- Process_Interrupt_Or_Attach_Handler --
+ -----------------------------------------
+
+ procedure Process_Interrupt_Or_Attach_Handler is
+ Arg1_X : constant Node_Id := Expression (Arg1);
+ Prot_Proc : constant Entity_Id := Entity (Arg1_X);
+ Prot_Type : constant Entity_Id := Scope (Prot_Proc);
+
+ begin
+ Set_Is_Interrupt_Handler (Prot_Proc);
+
+ if Prag_Id = Pragma_Interrupt_Handler
+ or Prag_Id = Pragma_Attach_Handler
+ then
+ Record_Rep_Item (Prot_Type, N);
+ end if;
+
+ end Process_Interrupt_Or_Attach_Handler;
+
+ ---------------------------------
+ -- Process_Suppress_Unsuppress --
+ ---------------------------------
+
+ procedure Process_Suppress_Unsuppress (Suppress_Case : Boolean) is
+ C : Check_Id;
+ E_Id : Node_Id;
+ E : Entity_Id;
+ Effective : Boolean;
+
+ procedure Suppress_Unsuppress_Echeck (E : Entity_Id; C : Check_Id);
+ -- Used to suppress a single check on the given entity
+
+ procedure Suppress_Unsuppress_Echeck (E : Entity_Id; C : Check_Id) is
+ begin
+ -- First set appropriate suppress flags in the entity
+
+ case C is
+ when Access_Check =>
+ Effective := Suppress_Access_Checks (E);
+ Set_Suppress_Access_Checks (E, Suppress_Case);
+
+ when Accessibility_Check =>
+ Effective := Suppress_Accessibility_Checks (E);
+ Set_Suppress_Accessibility_Checks (E, Suppress_Case);
+
+ when Discriminant_Check =>
+ Effective := Suppress_Discriminant_Checks (E);
+ Set_Suppress_Discriminant_Checks (E, Suppress_Case);
+
+ when Division_Check =>
+ Effective := Suppress_Division_Checks (E);
+ Set_Suppress_Division_Checks (E, Suppress_Case);
+
+ when Elaboration_Check =>
+ Effective := Suppress_Elaboration_Checks (E);
+ Set_Suppress_Elaboration_Checks (E, Suppress_Case);
+
+ when Index_Check =>
+ Effective := Suppress_Index_Checks (E);
+ Set_Suppress_Index_Checks (E, Suppress_Case);
+
+ when Length_Check =>
+ Effective := Suppress_Length_Checks (E);
+ Set_Suppress_Length_Checks (E, Suppress_Case);
+
+ when Overflow_Check =>
+ Effective := Suppress_Overflow_Checks (E);
+ Set_Suppress_Overflow_Checks (E, Suppress_Case);
+
+ when Range_Check =>
+ Effective := Suppress_Range_Checks (E);
+ Set_Suppress_Range_Checks (E, Suppress_Case);
+
+ when Storage_Check =>
+ Effective := Suppress_Storage_Checks (E);
+ Set_Suppress_Storage_Checks (E, Suppress_Case);
+
+ when Tag_Check =>
+ Effective := Suppress_Tag_Checks (E);
+ Set_Suppress_Tag_Checks (E, Suppress_Case);
+
+ when All_Checks =>
+ Suppress_Unsuppress_Echeck (E, Access_Check);
+ Suppress_Unsuppress_Echeck (E, Accessibility_Check);
+ Suppress_Unsuppress_Echeck (E, Discriminant_Check);
+ Suppress_Unsuppress_Echeck (E, Division_Check);
+ Suppress_Unsuppress_Echeck (E, Elaboration_Check);
+ Suppress_Unsuppress_Echeck (E, Index_Check);
+ Suppress_Unsuppress_Echeck (E, Length_Check);
+ Suppress_Unsuppress_Echeck (E, Overflow_Check);
+ Suppress_Unsuppress_Echeck (E, Range_Check);
+ Suppress_Unsuppress_Echeck (E, Storage_Check);
+ Suppress_Unsuppress_Echeck (E, Tag_Check);
+ end case;
+
+ -- If the entity is not declared in the current scope, then we
+ -- make an entry in the Entity_Suppress table so that the flag
+ -- will be removed on exit. This entry is only made if the
+ -- suppress did something (i.e. the flag was not already set).
+
+ if Effective and then Scope (E) /= Current_Scope then
+ Entity_Suppress.Increment_Last;
+ Entity_Suppress.Table
+ (Entity_Suppress.Last).Entity := E;
+ Entity_Suppress.Table
+ (Entity_Suppress.Last).Check := C;
+ end if;
+
+ -- If this is a first subtype, and the base type is distinct,
+ -- then also set the suppress flags on the base type.
+
+ if Is_First_Subtype (E)
+ and then Etype (E) /= E
+ then
+ Suppress_Unsuppress_Echeck (Etype (E), C);
+ end if;
+ end Suppress_Unsuppress_Echeck;
+
+ -- Start of processing for Process_Suppress_Unsuppress
+
+ begin
+ -- Suppress/Unsuppress can appear as a configuration pragma,
+ -- or in a declarative part or a package spec (RM 11.5(5))
+
+ if not Is_Configuration_Pragma then
+ Check_Is_In_Decl_Part_Or_Package_Spec;
+ end if;
+
+ Check_At_Least_N_Arguments (1);
+ Check_At_Most_N_Arguments (2);
+ Check_No_Identifier (Arg1);
+ Check_Arg_Is_Identifier (Arg1);
+
+ if not Is_Check_Name (Chars (Expression (Arg1))) then
+ Error_Pragma_Arg
+ ("argument of pragma% is not valid check name", Arg1);
+
+ else
+ C := Get_Check_Id (Chars (Expression (Arg1)));
+ end if;
+
+ if Arg_Count = 1 then
+ case C is
+ when Access_Check =>
+ Scope_Suppress.Access_Checks := Suppress_Case;
+
+ when Accessibility_Check =>
+ Scope_Suppress.Accessibility_Checks := Suppress_Case;
+
+ when Discriminant_Check =>
+ Scope_Suppress.Discriminant_Checks := Suppress_Case;
+
+ when Division_Check =>
+ Scope_Suppress.Division_Checks := Suppress_Case;
+
+ when Elaboration_Check =>
+ Scope_Suppress.Elaboration_Checks := Suppress_Case;
+
+ when Index_Check =>
+ Scope_Suppress.Index_Checks := Suppress_Case;
+
+ when Length_Check =>
+ Scope_Suppress.Length_Checks := Suppress_Case;
+
+ when Overflow_Check =>
+ Scope_Suppress.Overflow_Checks := Suppress_Case;
+
+ when Range_Check =>
+ Scope_Suppress.Range_Checks := Suppress_Case;
+
+ when Storage_Check =>
+ Scope_Suppress.Storage_Checks := Suppress_Case;
+
+ when Tag_Check =>
+ Scope_Suppress.Tag_Checks := Suppress_Case;
+
+ when All_Checks =>
+ Scope_Suppress := (others => Suppress_Case);
+
+ end case;
+
+ -- Case of two arguments present, where the check is
+ -- suppressed for a specified entity (given as the second
+ -- argument of the pragma)
+
+ else
+ Check_Optional_Identifier (Arg2, Name_On);
+ E_Id := Expression (Arg2);
+ Analyze (E_Id);
+
+ if not Is_Entity_Name (E_Id) then
+ Error_Pragma_Arg
+ ("second argument of pragma% must be entity name", Arg2);
+ end if;
+
+ E := Entity (E_Id);
+
+ if E = Any_Id then
+ return;
+ else
+ loop
+ Suppress_Unsuppress_Echeck (E, C);
+
+ if Is_Generic_Instance (E)
+ and then Is_Subprogram (E)
+ and then Present (Alias (E))
+ then
+ Suppress_Unsuppress_Echeck (Alias (E), C);
+ end if;
+
+ if C = Elaboration_Check and then Suppress_Case then
+ Set_Suppress_Elaboration_Warnings (E);
+ end if;
+
+ -- If we are within a package specification, the
+ -- pragma only applies to homonyms in the same scope.
+
+ exit when No (Homonym (E))
+ or else (Scope (Homonym (E)) /= Current_Scope
+ and then Ekind (Current_Scope) = E_Package
+ and then not In_Package_Body (Current_Scope));
+
+ E := Homonym (E);
+ end loop;
+ end if;
+ end if;
+
+ end Process_Suppress_Unsuppress;
+
+ ------------------
+ -- Set_Exported --
+ ------------------
+
+ procedure Set_Exported (E : Entity_Id; Arg : Node_Id) is
+ begin
+ if Is_Imported (E) then
+ Error_Pragma_Arg
+ ("cannot export entity& that was previously imported", Arg);
+
+ elsif Present (Address_Clause (E)) then
+ Error_Pragma_Arg
+ ("cannot export entity& that has an address clause", Arg);
+ end if;
+
+ Set_Is_Exported (E);
+
+ -- Deal with exporting non-library level entity
+
+ if not Is_Library_Level_Entity (E) then
+
+ -- Not allowed at all for subprograms
+
+ if Is_Subprogram (E) then
+ Error_Pragma_Arg ("local subprogram& cannot be exported", Arg);
+
+ -- Otherwise set public and statically allocated
+
+ else
+ Set_Is_Public (E);
+ Set_Is_Statically_Allocated (E);
+ end if;
+ end if;
+
+ if Inside_A_Generic then
+ Error_Msg_NE
+ ("all instances of& will have the same external name?", Arg, E);
+ end if;
+
+ end Set_Exported;
+
+ ----------------------------------------------
+ -- Set_Extended_Import_Export_External_Name --
+ ----------------------------------------------
+
+ procedure Set_Extended_Import_Export_External_Name
+ (Internal_Ent : Entity_Id;
+ Arg_External : Node_Id)
+ is
+ Old_Name : constant Node_Id := Interface_Name (Internal_Ent);
+ New_Name : Node_Id;
+
+ begin
+ if No (Arg_External) then
+ return;
+
+ elsif Nkind (Arg_External) = N_String_Literal then
+ if String_Length (Strval (Arg_External)) = 0 then
+ return;
+ else
+ New_Name := Adjust_External_Name_Case (Arg_External);
+ end if;
+
+ elsif Nkind (Arg_External) = N_Identifier then
+ New_Name := Get_Default_External_Name (Arg_External);
+
+ else
+ Error_Pragma_Arg
+ ("incorrect form for External parameter for pragma%",
+ Arg_External);
+ end if;
+
+ -- If we already have an external name set (by a prior normal
+ -- Import or Export pragma), then the external names must match
+
+ if Present (Interface_Name (Internal_Ent)) then
+ declare
+ S1 : constant String_Id := Strval (Old_Name);
+ S2 : constant String_Id := Strval (New_Name);
+
+ procedure Mismatch;
+ -- Called if names do not match
+
+ procedure Mismatch is
+ begin
+ Error_Msg_Sloc := Sloc (Old_Name);
+ Error_Pragma_Arg
+ ("external name does not match that given #",
+ Arg_External);
+ end Mismatch;
+
+ begin
+ if String_Length (S1) /= String_Length (S2) then
+ Mismatch;
+
+ else
+ for J in 1 .. String_Length (S1) loop
+ if Get_String_Char (S1, J) /= Get_String_Char (S2, J) then
+ Mismatch;
+ end if;
+ end loop;
+ end if;
+ end;
+
+ -- Otherwise set the given name
+
+ else
+ Set_Encoded_Interface_Name (Internal_Ent, New_Name);
+ end if;
+
+ end Set_Extended_Import_Export_External_Name;
+
+ ------------------
+ -- Set_Imported --
+ ------------------
+
+ procedure Set_Imported (E : Entity_Id) is
+ begin
+ Error_Msg_Sloc := Sloc (E);
+
+ if Is_Exported (E) or else Is_Imported (E) then
+ Error_Msg_NE ("import of& declared# not allowed", N, E);
+
+ if Is_Exported (E) then
+ Error_Msg_N ("\entity was previously exported", N);
+ else
+ Error_Msg_N ("\entity was previously imported", N);
+ end if;
+
+ Error_Pragma ("\(pragma% applies to all previous entities)");
+
+ else
+ Set_Is_Imported (E);
+
+ -- If the entity is an object that is not at the library
+ -- level, then it is statically allocated. We do not worry
+ -- about objects with address clauses in this context since
+ -- they are not really imported in the linker sense.
+
+ if Is_Object (E)
+ and then not Is_Library_Level_Entity (E)
+ and then No (Address_Clause (E))
+ then
+ Set_Is_Statically_Allocated (E);
+ end if;
+ end if;
+ end Set_Imported;
+
+ -------------------------
+ -- Set_Mechanism_Value --
+ -------------------------
+
+ -- Note: the mechanism name has not been analyzed (and cannot indeed
+ -- be analyzed, since it is semantic nonsense), so we get it in the
+ -- exact form created by the parser.
+
+ procedure Set_Mechanism_Value (Ent : Entity_Id; Mech_Name : Node_Id) is
+ Class : Node_Id;
+ Param : Node_Id;
+
+ procedure Bad_Class;
+ -- Signal bad descriptor class name
+
+ procedure Bad_Mechanism;
+ -- Signal bad mechanism name
+
+ procedure Bad_Class is
+ begin
+ Error_Pragma_Arg ("unrecognized descriptor class name", Class);
+ end Bad_Class;
+
+ procedure Bad_Mechanism is
+ begin
+ Error_Pragma_Arg ("unrecognized mechanism name", Mech_Name);
+ end Bad_Mechanism;
+
+ -- Start of processing for Set_Mechanism_Value
+
+ begin
+ if Mechanism (Ent) /= Default_Mechanism then
+ Error_Msg_NE
+ ("mechanism for & has already been set", Mech_Name, Ent);
+ end if;
+
+ -- MECHANISM_NAME ::= value | reference | descriptor
+
+ if Nkind (Mech_Name) = N_Identifier then
+ if Chars (Mech_Name) = Name_Value then
+ Set_Mechanism (Ent, By_Copy);
+ return;
+
+ elsif Chars (Mech_Name) = Name_Reference then
+ Set_Mechanism (Ent, By_Reference);
+ return;
+
+ elsif Chars (Mech_Name) = Name_Descriptor then
+ Check_VMS (Mech_Name);
+ Set_Mechanism (Ent, By_Descriptor);
+ return;
+
+ elsif Chars (Mech_Name) = Name_Copy then
+ Error_Pragma_Arg
+ ("bad mechanism name, Value assumed", Mech_Name);
+
+ else
+ Bad_Mechanism;
+ end if;
+
+ -- MECHANISM_NAME ::= descriptor (CLASS_NAME)
+ -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
+
+ -- Note: this form is parsed as an indexed component
+
+ elsif Nkind (Mech_Name) = N_Indexed_Component then
+ Class := First (Expressions (Mech_Name));
+
+ if Nkind (Prefix (Mech_Name)) /= N_Identifier
+ or else Chars (Prefix (Mech_Name)) /= Name_Descriptor
+ or else Present (Next (Class))
+ then
+ Bad_Mechanism;
+ end if;
+
+ -- MECHANISM_NAME ::= descriptor (Class => CLASS_NAME)
+ -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
+
+ -- Note: this form is parsed as a function call
+
+ elsif Nkind (Mech_Name) = N_Function_Call then
+
+ Param := First (Parameter_Associations (Mech_Name));
+
+ if Nkind (Name (Mech_Name)) /= N_Identifier
+ or else Chars (Name (Mech_Name)) /= Name_Descriptor
+ or else Present (Next (Param))
+ or else No (Selector_Name (Param))
+ or else Chars (Selector_Name (Param)) /= Name_Class
+ then
+ Bad_Mechanism;
+ else
+ Class := Explicit_Actual_Parameter (Param);
+ end if;
+
+ else
+ Bad_Mechanism;
+ end if;
+
+ -- Fall through here with Class set to descriptor class name
+
+ Check_VMS (Mech_Name);
+
+ if Nkind (Class) /= N_Identifier then
+ Bad_Class;
+
+ elsif Chars (Class) = Name_UBS then
+ Set_Mechanism (Ent, By_Descriptor_UBS);
+
+ elsif Chars (Class) = Name_UBSB then
+ Set_Mechanism (Ent, By_Descriptor_UBSB);
+
+ elsif Chars (Class) = Name_UBA then
+ Set_Mechanism (Ent, By_Descriptor_UBA);
+
+ elsif Chars (Class) = Name_S then
+ Set_Mechanism (Ent, By_Descriptor_S);
+
+ elsif Chars (Class) = Name_SB then
+ Set_Mechanism (Ent, By_Descriptor_SB);
+
+ elsif Chars (Class) = Name_A then
+ Set_Mechanism (Ent, By_Descriptor_A);
+
+ elsif Chars (Class) = Name_NCA then
+ Set_Mechanism (Ent, By_Descriptor_NCA);
+
+ else
+ Bad_Class;
+ end if;
+
+ end Set_Mechanism_Value;
+
+ -- Start of processing for Analyze_Pragma
+
+ begin
+ if not Is_Pragma_Name (Chars (N)) then
+ Error_Pragma ("unrecognized pragma%!?");
+ else
+ Prag_Id := Get_Pragma_Id (Chars (N));
+ end if;
+
+ -- Preset arguments
+
+ Arg1 := Empty;
+ Arg2 := Empty;
+ Arg3 := Empty;
+ Arg4 := Empty;
+
+ if Present (Pragma_Argument_Associations (N)) then
+ Arg1 := First (Pragma_Argument_Associations (N));
+
+ if Present (Arg1) then
+ Arg2 := Next (Arg1);
+
+ if Present (Arg2) then
+ Arg3 := Next (Arg2);
+
+ if Present (Arg3) then
+ Arg4 := Next (Arg3);
+ end if;
+ end if;
+ end if;
+ end if;
+
+ -- Count number of arguments
+
+ declare
+ Arg_Node : Node_Id;
+
+ begin
+ Arg_Count := 0;
+ Arg_Node := Arg1;
+
+ while Present (Arg_Node) loop
+ Arg_Count := Arg_Count + 1;
+ Next (Arg_Node);
+ end loop;
+ end;
+
+ -- An enumeration type defines the pragmas that are supported by the
+ -- implementation. Get_Pragma_Id (in package Prag) transorms a name
+ -- into the corresponding enumeration value for the following case.
+
+ case Prag_Id is
+
+ -----------------
+ -- Abort_Defer --
+ -----------------
+
+ -- pragma Abort_Defer;
+
+ when Pragma_Abort_Defer =>
+ GNAT_Pragma;
+ Check_Arg_Count (0);
+
+ -- The only required semantic processing is to check the
+ -- placement. This pragma must appear at the start of the
+ -- statement sequence of a handled sequence of statements.
+
+ if Nkind (Parent (N)) /= N_Handled_Sequence_Of_Statements
+ or else N /= First (Statements (Parent (N)))
+ then
+ Pragma_Misplaced;
+ end if;
+
+ ------------
+ -- Ada_83 --
+ ------------
+
+ -- pragma Ada_83;
+
+ -- Note: this pragma also has some specific processing in Par.Prag
+ -- because we want to set the Ada 83 mode switch during parsing.
+
+ when Pragma_Ada_83 =>
+ GNAT_Pragma;
+ Ada_83 := True;
+ Ada_95 := False;
+ Check_Arg_Count (0);
+
+ ------------
+ -- Ada_95 --
+ ------------
+
+ -- pragma Ada_95;
+
+ -- Note: this pragma also has some specific processing in Par.Prag
+ -- because we want to set the Ada 83 mode switch during parsing.
+
+ when Pragma_Ada_95 =>
+ GNAT_Pragma;
+ Ada_83 := False;
+ Ada_95 := True;
+ Check_Arg_Count (0);
+
+ ----------------------
+ -- All_Calls_Remote --
+ ----------------------
+
+ -- pragma All_Calls_Remote [(library_package_NAME)];
+
+ when Pragma_All_Calls_Remote => All_Calls_Remote : declare
+ Lib_Entity : Entity_Id;
+
+ begin
+ Check_Ada_83_Warning;
+ Check_Valid_Library_Unit_Pragma;
+
+ if Nkind (N) = N_Null_Statement then
+ return;
+ end if;
+
+ Lib_Entity := Find_Lib_Unit_Name;
+
+ -- This pragma should only apply to a RCI unit (RM E.2.3(23)).
+
+ if Present (Lib_Entity)
+ and then not Debug_Flag_U
+ then
+ if not Is_Remote_Call_Interface (Lib_Entity) then
+ Error_Pragma ("pragma% only apply to rci unit");
+
+ -- Set flag for entity of the library unit
+
+ else
+ Set_Has_All_Calls_Remote (Lib_Entity);
+ end if;
+
+ end if;
+ end All_Calls_Remote;
+
+ --------------
+ -- Annotate --
+ --------------
+
+ -- pragma Annotate (IDENTIFIER {, ARG});
+ -- ARG ::= NAME | EXPRESSION
+
+ when Pragma_Annotate => Annotate : begin
+ GNAT_Pragma;
+ Check_At_Least_N_Arguments (1);
+ Check_Arg_Is_Identifier (Arg1);
+
+ declare
+ Arg : Node_Id := Arg2;
+ Exp : Node_Id;
+
+ begin
+ while Present (Arg) loop
+ Exp := Expression (Arg);
+ Analyze (Exp);
+
+ if Is_Entity_Name (Exp) then
+ null;
+
+ elsif Nkind (Exp) = N_String_Literal then
+ Resolve (Exp, Standard_String);
+
+ elsif Is_Overloaded (Exp) then
+ Error_Pragma_Arg ("ambiguous argument for pragma%", Exp);
+
+ else
+ Resolve (Exp, Etype (Exp));
+ end if;
+
+ Next (Arg);
+ end loop;
+ end;
+ end Annotate;
+
+ ------------
+ -- Assert --
+ ------------
+
+ -- pragma Assert (Boolean_EXPRESSION [, static_string_EXPRESSION]);
+
+ when Pragma_Assert =>
+ GNAT_Pragma;
+ Check_No_Identifiers;
+
+ if Arg_Count > 1 then
+ Check_Arg_Count (2);
+ Check_Arg_Is_Static_Expression (Arg2, Standard_String);
+ end if;
+
+ -- If expansion is active and assertions are inactive, then
+ -- we rewrite the Assertion as:
+
+ -- if False and then condition then
+ -- null;
+ -- end if;
+
+ -- The reason we do this rewriting during semantic analysis
+ -- rather than as part of normal expansion is that we cannot
+ -- analyze and expand the code for the boolean expression
+ -- directly, or it may cause insertion of actions that would
+ -- escape the attempt to suppress the assertion code.
+
+ if Expander_Active and not Assertions_Enabled then
+ Rewrite (N,
+ Make_If_Statement (Loc,
+ Condition =>
+ Make_And_Then (Loc,
+ Left_Opnd => New_Occurrence_Of (Standard_False, Loc),
+ Right_Opnd => Get_Pragma_Arg (Arg1)),
+ Then_Statements => New_List (
+ Make_Null_Statement (Loc))));
+
+ Analyze (N);
+
+ -- Otherwise (if assertions are enabled, or if we are not
+ -- operating with expansion active), then we just analyze
+ -- and resolve the expression.
+
+ else
+ Analyze_And_Resolve (Expression (Arg1), Any_Boolean);
+ end if;
+
+ ---------------
+ -- AST_Entry --
+ ---------------
+
+ -- pragma AST_Entry (entry_IDENTIFIER);
+
+ when Pragma_AST_Entry => AST_Entry : declare
+ Ent : Node_Id;
+
+ begin
+ GNAT_Pragma;
+ Check_VMS (N);
+ Check_Arg_Count (1);
+ Check_No_Identifiers;
+ Check_Arg_Is_Local_Name (Arg1);
+ Ent := Entity (Expression (Arg1));
+
+ -- Note: the implementation of the AST_Entry pragma could handle
+ -- the entry family case fine, but for now we are consistent with
+ -- the DEC rules, and do not allow the pragma, which of course
+ -- has the effect of also forbidding the attribute.
+
+ if Ekind (Ent) /= E_Entry then
+ Error_Pragma_Arg
+ ("pragma% argument must be simple entry name", Arg1);
+
+ elsif Is_AST_Entry (Ent) then
+ Error_Pragma_Arg
+ ("duplicate % pragma for entry", Arg1);
+
+ elsif Has_Homonym (Ent) then
+ Error_Pragma_Arg
+ ("pragma% argument cannot specify overloaded entry", Arg1);
+
+ else
+ declare
+ FF : constant Entity_Id := First_Formal (Ent);
+
+ begin
+ if Present (FF) then
+ if Present (Next_Formal (FF)) then
+ Error_Pragma_Arg
+ ("entry for pragma% can have only one argument",
+ Arg1);
+
+ elsif Parameter_Mode (FF) /= E_In_Parameter then
+ Error_Pragma_Arg
+ ("entry parameter for pragma% must have mode IN",
+ Arg1);
+ end if;
+ end if;
+ end;
+
+ Set_Is_AST_Entry (Ent);
+ end if;
+ end AST_Entry;
+
+ ------------------
+ -- Asynchronous --
+ ------------------
+
+ -- pragma Asynchronous (LOCAL_NAME);
+
+ when Pragma_Asynchronous => Asynchronous : declare
+ Nm : Entity_Id;
+ C_Ent : Entity_Id;
+ L : List_Id;
+ S : Node_Id;
+ N : Node_Id;
+ Formal : Entity_Id;
+
+ procedure Process_Async_Pragma;
+ -- Common processing for procedure and access-to-procedure case
+
+ --------------------------
+ -- Process_Async_Pragma --
+ --------------------------
+
+ procedure Process_Async_Pragma is
+ begin
+ if not Present (L) then
+ Set_Is_Asynchronous (Nm);
+ return;
+ end if;
+
+ -- The formals should be of mode IN (RM E.4.1(6))
+
+ S := First (L);
+ while Present (S) loop
+ Formal := Defining_Identifier (S);
+
+ if Nkind (Formal) = N_Defining_Identifier
+ and then Ekind (Formal) /= E_In_Parameter
+ then
+ Error_Pragma_Arg
+ ("pragma% procedure can only have IN parameter",
+ Arg1);
+ end if;
+
+ Next (S);
+ end loop;
+
+ Set_Is_Asynchronous (Nm);
+ end Process_Async_Pragma;
+
+ -- Start of processing for pragma Asynchronous
+
+ begin
+ Check_Ada_83_Warning;
+ Check_No_Identifiers;
+ Check_Arg_Count (1);
+ Check_Arg_Is_Local_Name (Arg1);
+
+ if Debug_Flag_U then
+ return;
+ end if;
+
+ C_Ent := Cunit_Entity (Current_Sem_Unit);
+ Analyze (Expression (Arg1));
+ Nm := Entity (Expression (Arg1));
+
+ if not Is_Remote_Call_Interface (C_Ent)
+ and then not Is_Remote_Types (C_Ent)
+ then
+ -- This pragma should only appear in an RCI or Remote Types
+ -- unit (RM E.4.1(4))
+
+ Error_Pragma
+ ("pragma% not in Remote_Call_Interface or " &
+ "Remote_Types unit");
+ end if;
+
+ if Ekind (Nm) = E_Procedure
+ and then Nkind (Parent (Nm)) = N_Procedure_Specification
+ then
+ if not Is_Remote_Call_Interface (Nm) then
+ Error_Pragma_Arg
+ ("pragma% cannot be applied on non-remote procedure",
+ Arg1);
+ end if;
+
+ L := Parameter_Specifications (Parent (Nm));
+ Process_Async_Pragma;
+ return;
+
+ elsif Ekind (Nm) = E_Function then
+ Error_Pragma_Arg
+ ("pragma% cannot be applied to function", Arg1);
+
+ elsif Ekind (Nm) = E_Record_Type
+ and then Present (Corresponding_Remote_Type (Nm))
+ then
+ N := Declaration_Node (Corresponding_Remote_Type (Nm));
+
+ if Nkind (N) = N_Full_Type_Declaration
+ and then Nkind (Type_Definition (N)) =
+ N_Access_Procedure_Definition
+ then
+ L := Parameter_Specifications (Type_Definition (N));
+ Process_Async_Pragma;
+
+ else
+ Error_Pragma_Arg
+ ("pragma% cannot reference access-to-function type",
+ Arg1);
+ end if;
+
+ -- Only other possibility is Access-to-class-wide type
+
+ elsif Is_Access_Type (Nm)
+ and then Is_Class_Wide_Type (Designated_Type (Nm))
+ then
+ Check_First_Subtype (Arg1);
+ Set_Is_Asynchronous (Nm);
+ if Expander_Active then
+ RACW_Type_Is_Asynchronous (Nm);
+ end if;
+
+ else
+ Error_Pragma_Arg ("inappropriate argument for pragma%", Arg1);
+ end if;
+
+ end Asynchronous;
+
+ ------------
+ -- Atomic --
+ ------------
+
+ -- pragma Atomic (LOCAL_NAME);
+
+ when Pragma_Atomic =>
+ Process_Atomic_Shared_Volatile;
+
+ -----------------------
+ -- Atomic_Components --
+ -----------------------
+
+ -- pragma Atomic_Components (array_LOCAL_NAME);
+
+ -- This processing is shared by Volatile_Components
+
+ when Pragma_Atomic_Components |
+ Pragma_Volatile_Components =>
+
+ Atomic_Components : declare
+ E_Id : Node_Id;
+ E : Entity_Id;
+ D : Node_Id;
+ K : Node_Kind;
+
+ begin
+ GNAT_Pragma;
+ Check_Ada_83_Warning;
+ Check_No_Identifiers;
+ Check_Arg_Count (1);
+ Check_Arg_Is_Local_Name (Arg1);
+ E_Id := Expression (Arg1);
+
+ if Etype (E_Id) = Any_Type then
+ return;
+ end if;
+
+ E := Entity (E_Id);
+
+ if Rep_Item_Too_Early (E, N)
+ or else
+ Rep_Item_Too_Late (E, N)
+ then
+ return;
+ end if;
+
+ D := Declaration_Node (E);
+ K := Nkind (D);
+
+ if (K = N_Full_Type_Declaration and then Is_Array_Type (E))
+ or else
+ ((Ekind (E) = E_Constant or else Ekind (E) = E_Variable)
+ and then Nkind (D) = N_Object_Declaration
+ and then Nkind (Object_Definition (D)) =
+ N_Constrained_Array_Definition)
+ then
+ -- The flag is set on the object, or on the base type
+
+ if Nkind (D) /= N_Object_Declaration then
+ E := Base_Type (E);
+ end if;
+
+ Set_Has_Volatile_Components (E);
+
+ if Prag_Id = Pragma_Atomic_Components then
+ Set_Has_Atomic_Components (E);
+
+ if Is_Packed (E) then
+ Set_Is_Packed (E, False);
+
+ Error_Pragma_Arg
+ ("?Pack canceled, cannot pack atomic components",
+ Arg1);
+ end if;
+ end if;
+
+ else
+ Error_Pragma_Arg ("inappropriate entity for pragma%", Arg1);
+ end if;
+ end Atomic_Components;
+
+ --------------------
+ -- Attach_Handler --
+ --------------------
+
+ -- pragma Attach_Handler (handler_NAME, EXPRESSION);
+
+ when Pragma_Attach_Handler =>
+ Check_Ada_83_Warning;
+ Check_No_Identifiers;
+ Check_Arg_Count (2);
+ Check_Interrupt_Or_Attach_Handler;
+ Analyze_And_Resolve (Expression (Arg2), RTE (RE_Interrupt_Id));
+ Process_Interrupt_Or_Attach_Handler;
+
+ --------------------
+ -- C_Pass_By_Copy --
+ --------------------
+
+ -- pragma C_Pass_By_Copy ([Max_Size =>] static_integer_EXPRESSION);
+
+ when Pragma_C_Pass_By_Copy => C_Pass_By_Copy : declare
+ Arg : Node_Id;
+ Val : Uint;
+
+ begin
+ GNAT_Pragma;
+ Check_Valid_Configuration_Pragma;
+ Check_Arg_Count (1);
+ Check_Optional_Identifier (Arg1, "max_size");
+
+ Arg := Expression (Arg1);
+ Check_Arg_Is_Static_Expression (Arg, Any_Integer);
+
+ Val := Expr_Value (Arg);
+
+ if Val <= 0 then
+ Error_Pragma_Arg
+ ("maximum size for pragma% must be positive", Arg1);
+
+ elsif UI_Is_In_Int_Range (Val) then
+ Default_C_Record_Mechanism := UI_To_Int (Val);
+
+ -- If a giant value is given, Int'Last will do well enough.
+ -- If sometime someone complains that a record larger than
+ -- two gigabytes is not copied, we will worry about it then!
+
+ else
+ Default_C_Record_Mechanism := Mechanism_Type'Last;
+ end if;
+ end C_Pass_By_Copy;
+
+ -------------
+ -- Comment --
+ -------------
+
+ -- pragma Comment (static_string_EXPRESSION)
+
+ -- Processing for pragma Comment shares the circuitry for
+ -- pragma Ident. The only differences are that Ident enforces
+ -- a limit of 31 characters on its argument, and also enforces
+ -- limitations on placement for DEC compatibility. Pragma
+ -- Comment shares neither of these restrictions.
+
+ -------------------
+ -- Common_Object --
+ -------------------
+
+ -- pragma Common_Object (
+ -- [Internal =>] LOCAL_NAME,
+ -- [, [External =>] EXTERNAL_SYMBOL]
+ -- [, [Size =>] EXTERNAL_SYMBOL]);
+
+ -- Processing for this pragma is shared with Psect_Object
+
+ ----------------------------
+ -- Complex_Representation --
+ ----------------------------
+
+ -- pragma Complex_Representation ([Entity =>] LOCAL_NAME);
+
+ when Pragma_Complex_Representation => Complex_Representation : declare
+ E_Id : Entity_Id;
+ E : Entity_Id;
+ Ent : Entity_Id;
+
+ begin
+ GNAT_Pragma;
+ Check_Arg_Count (1);
+ Check_Optional_Identifier (Arg1, Name_Entity);
+ Check_Arg_Is_Local_Name (Arg1);
+ E_Id := Expression (Arg1);
+
+ if Etype (E_Id) = Any_Type then
+ return;
+ end if;
+
+ E := Entity (E_Id);
+
+ if not Is_Record_Type (E) then
+ Error_Pragma_Arg
+ ("argument for pragma% must be record type", Arg1);
+ end if;
+
+ Ent := First_Entity (E);
+
+ if No (Ent)
+ or else No (Next_Entity (Ent))
+ or else Present (Next_Entity (Next_Entity (Ent)))
+ or else not Is_Floating_Point_Type (Etype (Ent))
+ or else Etype (Ent) /= Etype (Next_Entity (Ent))
+ then
+ Error_Pragma_Arg
+ ("record for pragma% must have two fields of same fpt type",
+ Arg1);
+
+ else
+ Set_Has_Complex_Representation (Base_Type (E));
+ end if;
+ end Complex_Representation;
+
+ -------------------------
+ -- Component_Alignment --
+ -------------------------
+
+ -- pragma Component_Alignment (
+ -- [Form =>] ALIGNMENT_CHOICE
+ -- [, [Name =>] type_LOCAL_NAME]);
+ --
+ -- ALIGNMENT_CHOICE ::=
+ -- Component_Size
+ -- | Component_Size_4
+ -- | Storage_Unit
+ -- | Default
+
+ when Pragma_Component_Alignment => Component_AlignmentP : declare
+ Args : Args_List (1 .. 2);
+ Names : Name_List (1 .. 2) := (
+ Name_Form,
+ Name_Name);
+
+ Form : Node_Id renames Args (1);
+ Name : Node_Id renames Args (2);
+
+ Atype : Component_Alignment_Kind;
+ Typ : Entity_Id;
+
+ begin
+ GNAT_Pragma;
+ Gather_Associations (Names, Args);
+
+ if No (Form) then
+ Error_Pragma ("missing Form argument for pragma%");
+ end if;
+
+ Check_Arg_Is_Identifier (Form);
+
+ -- Get proper alignment, note that Default = Component_Size
+ -- on all machines we have so far, and we want to set this
+ -- value rather than the default value to indicate that it
+ -- has been explicitly set (and thus will not get overridden
+ -- by the default component alignment for the current scope)
+
+ if Chars (Form) = Name_Component_Size then
+ Atype := Calign_Component_Size;
+
+ elsif Chars (Form) = Name_Component_Size_4 then
+ Atype := Calign_Component_Size_4;
+
+ elsif Chars (Form) = Name_Default then
+ Atype := Calign_Component_Size;
+
+ elsif Chars (Form) = Name_Storage_Unit then
+ Atype := Calign_Storage_Unit;
+
+ else
+ Error_Pragma_Arg
+ ("invalid Form parameter for pragma%", Form);
+ end if;
+
+ -- Case with no name, supplied, affects scope table entry
+
+ if No (Name) then
+ Scope_Stack.Table
+ (Scope_Stack.Last).Component_Alignment_Default := Atype;
+
+ -- Case of name supplied
+
+ else
+ Check_Arg_Is_Local_Name (Name);
+ Find_Type (Name);
+ Typ := Entity (Name);
+
+ if Typ = Any_Type
+ or else Rep_Item_Too_Early (Typ, N)
+ then
+ return;
+ else
+ Typ := Underlying_Type (Typ);
+ end if;
+
+ if not Is_Record_Type (Typ)
+ and then not Is_Array_Type (Typ)
+ then
+ Error_Pragma_Arg
+ ("Name parameter of pragma% must identify record or " &
+ "array type", Name);
+ end if;
+
+ -- An explicit Component_Alignment pragma overrides an
+ -- implicit pragma Pack, but not an explicit one.
+
+ if not Has_Pragma_Pack (Base_Type (Typ)) then
+ Set_Is_Packed (Base_Type (Typ), False);
+ Set_Component_Alignment (Base_Type (Typ), Atype);
+ end if;
+ end if;
+
+ end Component_AlignmentP;
+
+ ----------------
+ -- Controlled --
+ ----------------
+
+ -- pragma Controlled (first_subtype_LOCAL_NAME);
+
+ when Pragma_Controlled => Controlled : declare
+ Arg : Node_Id;
+
+ begin
+ Check_No_Identifiers;
+ Check_Arg_Count (1);
+ Check_Arg_Is_Local_Name (Arg1);
+ Arg := Expression (Arg1);
+
+ if not Is_Entity_Name (Arg)
+ or else not Is_Access_Type (Entity (Arg))
+ then
+ Error_Pragma_Arg ("pragma% requires access type", Arg1);
+ else
+ Set_Has_Pragma_Controlled (Base_Type (Entity (Arg)));
+ end if;
+ end Controlled;
+
+ ----------------
+ -- Convention --
+ ----------------
+
+ -- pragma Convention ([Convention =>] convention_IDENTIFIER,
+ -- [Entity =>] LOCAL_NAME);
+
+ when Pragma_Convention => Convention : declare
+ C : Convention_Id;
+ E : Entity_Id;
+
+ begin
+ Check_Ada_83_Warning;
+ Check_Arg_Count (2);
+ Process_Convention (C, E);
+ end Convention;
+
+ ---------------
+ -- CPP_Class --
+ ---------------
+
+ -- pragma CPP_Class ([Entity =>] local_NAME)
+
+ when Pragma_CPP_Class => CPP_Class : declare
+ Arg : Node_Id;
+ Typ : Entity_Id;
+ Default_DTC : Entity_Id := Empty;
+ VTP_Type : constant Entity_Id := RTE (RE_Vtable_Ptr);
+ C : Entity_Id;
+ Tag_C : Entity_Id;
+
+ begin
+ GNAT_Pragma;
+ Check_Arg_Count (1);
+ Check_Optional_Identifier (Arg1, Name_Entity);
+ Check_Arg_Is_Local_Name (Arg1);
+
+ Arg := Expression (Arg1);
+ Analyze (Arg);
+
+ if Etype (Arg) = Any_Type then
+ return;
+ end if;
+
+ if not Is_Entity_Name (Arg)
+ or else not Is_Type (Entity (Arg))
+ then
+ Error_Pragma_Arg ("pragma% requires a type mark", Arg1);
+ end if;
+
+ Typ := Entity (Arg);
+
+ if not Is_Record_Type (Typ) then
+ Error_Pragma_Arg ("pragma% applicable to a record, "
+ & "tagged record or record extension", Arg1);
+ end if;
+
+ Default_DTC := First_Component (Typ);
+ while Present (Default_DTC)
+ and then Etype (Default_DTC) /= VTP_Type
+ loop
+ Next_Component (Default_DTC);
+ end loop;
+
+ -- Case of non tagged type
+
+ if not Is_Tagged_Type (Typ) then
+ Set_Is_CPP_Class (Typ);
+
+ if Present (Default_DTC) then
+ Error_Pragma_Arg
+ ("only tagged records can contain vtable pointers", Arg1);
+ end if;
+
+ -- Case of tagged type with no vtable ptr
+
+ -- What is test for Typ = Root_Typ (Typ) about here ???
+
+ elsif Is_Tagged_Type (Typ)
+ and then Typ = Root_Type (Typ)
+ and then No (Default_DTC)
+ then
+ Error_Pragma_Arg
+ ("a cpp_class must contain a vtable pointer", Arg1);
+
+ -- Tagged type that has a vtable ptr
+
+ elsif Present (Default_DTC) then
+ Set_Is_CPP_Class (Typ);
+ Set_Is_Limited_Record (Typ);
+ Set_Is_Tag (Default_DTC);
+ Set_DT_Entry_Count (Default_DTC, No_Uint);
+
+ -- Since a CPP type has no direct link to its associated tag
+ -- most tags checks cannot be performed
+
+ Set_Suppress_Tag_Checks (Typ);
+ Set_Suppress_Tag_Checks (Class_Wide_Type (Typ));
+
+ -- Get rid of the _tag component when there was one.
+ -- It is only useful for regular tagged types
+
+ if Expander_Active and then Typ = Root_Type (Typ) then
+
+ Tag_C := Tag_Component (Typ);
+ C := First_Entity (Typ);
+
+ if C = Tag_C then
+ Set_First_Entity (Typ, Next_Entity (Tag_C));
+
+ else
+ while Next_Entity (C) /= Tag_C loop
+ Next_Entity (C);
+ end loop;
+
+ Set_Next_Entity (C, Next_Entity (Tag_C));
+ end if;
+ end if;
+ end if;
+ end CPP_Class;
+
+ ---------------------
+ -- CPP_Constructor --
+ ---------------------
+
+ -- pragma CPP_Constructor ([Entity =>] LOCAL_NAME);
+
+ when Pragma_CPP_Constructor => CPP_Constructor : declare
+ Id : Entity_Id;
+ Def_Id : Entity_Id;
+
+ begin
+ GNAT_Pragma;
+ Check_Arg_Count (1);
+ Check_Optional_Identifier (Arg1, Name_Entity);
+ Check_Arg_Is_Local_Name (Arg1);
+
+ Id := Expression (Arg1);
+ Find_Program_Unit_Name (Id);
+
+ -- If we did not find the name, we are done
+
+ if Etype (Id) = Any_Type then
+ return;
+ end if;
+
+ Def_Id := Entity (Id);
+
+ if Ekind (Def_Id) = E_Function
+ and then Is_Class_Wide_Type (Etype (Def_Id))
+ and then Is_CPP_Class (Etype (Etype (Def_Id)))
+ then
+ -- What the heck is this??? this pragma allows only 1 arg
+
+ if Arg_Count >= 2 then
+ Check_At_Most_N_Arguments (3);
+ Process_Interface_Name (Def_Id, Arg2, Arg3);
+ end if;
+
+ if No (Parameter_Specifications (Parent (Def_Id))) then
+ Set_Has_Completion (Def_Id);
+ Set_Is_Constructor (Def_Id);
+ else
+ Error_Pragma_Arg
+ ("non-default constructors not implemented", Arg1);
+ end if;
+
+ else
+ Error_Pragma_Arg
+ ("pragma% requires function returning a 'C'P'P_Class type",
+ Arg1);
+ end if;
+ end CPP_Constructor;
+
+ -----------------
+ -- CPP_Virtual --
+ -----------------
+
+ -- pragma CPP_Virtual
+ -- [Entity =>] LOCAL_NAME
+ -- [ [Vtable_Ptr =>] LOCAL_NAME,
+ -- [Position =>] static_integer_EXPRESSION]);
+
+ when Pragma_CPP_Virtual => CPP_Virtual : declare
+ Arg : Node_Id;
+ Typ : Entity_Id;
+ Subp : Entity_Id;
+ VTP_Type : constant Entity_Id := RTE (RE_Vtable_Ptr);
+ DTC : Entity_Id;
+ V : Uint;
+
+ begin
+ GNAT_Pragma;
+
+ if Arg_Count = 3 then
+ Check_Optional_Identifier (Arg2, "vtable_ptr");
+
+ -- We allow Entry_Count as well as Position for the third
+ -- parameter for back compatibility with versions of GNAT
+ -- before version 3.12. The documentation has always said
+ -- Position, but the code up to 3.12 said Entry_Count.
+
+ if Chars (Arg3) /= Name_Position then
+ Check_Optional_Identifier (Arg3, "entry_count");
+ end if;
+
+ else
+ Check_Arg_Count (1);
+ end if;
+
+ Check_Optional_Identifier (Arg1, Name_Entity);
+ Check_Arg_Is_Local_Name (Arg1);
+
+ -- First argument must be a subprogram name
+
+ Arg := Expression (Arg1);
+ Find_Program_Unit_Name (Arg);
+
+ if Etype (Arg) = Any_Type then
+ return;
+ else
+ Subp := Entity (Arg);
+ end if;
+
+ if not (Is_Subprogram (Subp)
+ and then Is_Dispatching_Operation (Subp))
+ then
+ Error_Pragma_Arg
+ ("pragma% must reference a primitive operation", Arg1);
+ end if;
+
+ Typ := Find_Dispatching_Type (Subp);
+
+ -- If only one Argument defaults are :
+ -- . DTC_Entity is the default Vtable pointer
+ -- . DT_Position will be set at the freezing point
+
+ if Arg_Count = 1 then
+ Set_DTC_Entity (Subp, Tag_Component (Typ));
+ return;
+ end if;
+
+ -- Second argument is a component name of type Vtable_Ptr
+
+ Arg := Expression (Arg2);
+
+ if Nkind (Arg) /= N_Identifier then
+ Error_Msg_NE ("must be a& component name", Arg, Typ);
+ raise Pragma_Exit;
+ end if;
+
+ DTC := First_Component (Typ);
+ while Present (DTC) and then Chars (DTC) /= Chars (Arg) loop
+ Next_Component (DTC);
+ end loop;
+
+ if No (DTC) then
+ Error_Msg_NE ("must be a& component name", Arg, Typ);
+ raise Pragma_Exit;
+
+ elsif Etype (DTC) /= VTP_Type then
+ Wrong_Type (Arg, VTP_Type);
+ return;
+ end if;
+
+ -- Third argument is an integer (DT_Position)
+
+ Arg := Expression (Arg3);
+ Analyze_And_Resolve (Arg, Any_Integer);
+
+ if not Is_Static_Expression (Arg) then
+ Error_Pragma_Arg
+ ("third argument of pragma% must be a static expression",
+ Arg3);
+
+ else
+ V := Expr_Value (Expression (Arg3));
+
+ if V <= 0 then
+ Error_Pragma_Arg
+ ("third argument of pragma% must be positive",
+ Arg3);
+
+ else
+ Set_DTC_Entity (Subp, DTC);
+ Set_DT_Position (Subp, V);
+ end if;
+ end if;
+ end CPP_Virtual;
+
+ ----------------
+ -- CPP_Vtable --
+ ----------------
+
+ -- pragma CPP_Vtable (
+ -- [Entity =>] LOCAL_NAME
+ -- [Vtable_Ptr =>] LOCAL_NAME,
+ -- [Entry_Count =>] static_integer_EXPRESSION);
+
+ when Pragma_CPP_Vtable => CPP_Vtable : declare
+ Arg : Node_Id;
+ Typ : Entity_Id;
+ VTP_Type : constant Entity_Id := RTE (RE_Vtable_Ptr);
+ DTC : Entity_Id;
+ V : Uint;
+ Elmt : Elmt_Id;
+
+ begin
+ GNAT_Pragma;
+ Check_Arg_Count (3);
+ Check_Optional_Identifier (Arg1, Name_Entity);
+ Check_Optional_Identifier (Arg2, "vtable_ptr");
+ Check_Optional_Identifier (Arg3, "entry_count");
+ Check_Arg_Is_Local_Name (Arg1);
+
+ -- First argument is a record type name
+
+ Arg := Expression (Arg1);
+ Analyze (Arg);
+
+ if Etype (Arg) = Any_Type then
+ return;
+ else
+ Typ := Entity (Arg);
+ end if;
+
+ if not (Is_Tagged_Type (Typ) and then Is_CPP_Class (Typ)) then
+ Error_Pragma_Arg ("'C'P'P_Class tagged type expected", Arg1);
+ end if;
+
+ -- Second argument is a component name of type Vtable_Ptr
+
+ Arg := Expression (Arg2);
+
+ if Nkind (Arg) /= N_Identifier then
+ Error_Msg_NE ("must be a& component name", Arg, Typ);
+ raise Pragma_Exit;
+ end if;
+
+ DTC := First_Component (Typ);
+ while Present (DTC) and then Chars (DTC) /= Chars (Arg) loop
+ Next_Component (DTC);
+ end loop;
+
+ if No (DTC) then
+ Error_Msg_NE ("must be a& component name", Arg, Typ);
+ raise Pragma_Exit;
+
+ elsif Etype (DTC) /= VTP_Type then
+ Wrong_Type (DTC, VTP_Type);
+ return;
+
+ -- If it is the first pragma Vtable, This becomes the default tag
+
+ elsif (not Is_Tag (DTC))
+ and then DT_Entry_Count (Tag_Component (Typ)) = No_Uint
+ then
+ Set_Is_Tag (Tag_Component (Typ), False);
+ Set_Is_Tag (DTC, True);
+ Set_DT_Entry_Count (DTC, No_Uint);
+ end if;
+
+ -- Those pragmas must appear before any primitive operation
+ -- definition (except inherited ones) otherwise the default
+ -- may be wrong
+
+ Elmt := First_Elmt (Primitive_Operations (Typ));
+ while Present (Elmt) loop
+ if No (Alias (Node (Elmt))) then
+ Error_Msg_Sloc := Sloc (Node (Elmt));
+ Error_Pragma
+ ("pragma% must appear before this primitive operation");
+ end if;
+
+ Next_Elmt (Elmt);
+ end loop;
+
+ -- Third argument is an integer (DT_Entry_Count)
+
+ Arg := Expression (Arg3);
+ Analyze_And_Resolve (Arg, Any_Integer);
+
+ if not Is_Static_Expression (Arg) then
+ Error_Pragma_Arg
+ ("entry count for pragma% must be a static expression", Arg3);
+
+ else
+ V := Expr_Value (Expression (Arg3));
+
+ if V <= 0 then
+ Error_Pragma_Arg
+ ("entry count for pragma% must be positive", Arg3);
+ else
+ Set_DT_Entry_Count (DTC, V);
+ end if;
+ end if;
+
+ end CPP_Vtable;
+
+ -----------
+ -- Debug --
+ -----------
+
+ -- pragma Debug (PROCEDURE_CALL_STATEMENT);
+
+ when Pragma_Debug => Debug : begin
+ GNAT_Pragma;
+
+ -- If assertions are enabled, and we are expanding code, then
+ -- we rewrite the pragma with its corresponding procedure call
+ -- and then analyze the call.
+
+ if Assertions_Enabled and Expander_Active then
+ Rewrite (N, Relocate_Node (Debug_Statement (N)));
+ Analyze (N);
+
+ -- Otherwise we work a bit to get a tree that makes sense
+ -- for ASIS purposes, namely a pragma with an analyzed
+ -- argument that looks like a procedure call.
+
+ else
+ Expander_Mode_Save_And_Set (False);
+ Rewrite (N, Relocate_Node (Debug_Statement (N)));
+ Analyze (N);
+ Rewrite (N,
+ Make_Pragma (Loc,
+ Chars => Name_Debug,
+ Pragma_Argument_Associations =>
+ New_List (Relocate_Node (N))));
+ Expander_Mode_Restore;
+ end if;
+ end Debug;
+
+ -------------------
+ -- Discard_Names --
+ -------------------
+
+ -- pragma Discard_Names [([On =>] LOCAL_NAME)];
+
+ when Pragma_Discard_Names => Discard_Names : declare
+ E_Id : Entity_Id;
+ E : Entity_Id;
+
+ begin
+ GNAT_Pragma;
+ Check_Ada_83_Warning;
+
+ -- Deal with configuration pragma case
+
+ if Arg_Count = 0 and then Is_Configuration_Pragma then
+ Global_Discard_Names := True;
+ return;
+
+ -- Otherwise, check correct appropriate context
+
+ else
+ Check_Is_In_Decl_Part_Or_Package_Spec;
+
+ if Arg_Count = 0 then
+
+ -- If there is no parameter, then from now on this pragma
+ -- applies to any enumeration, exception or tagged type
+ -- defined in the current declarative part.
+
+ Set_Discard_Names (Current_Scope);
+ return;
+
+ else
+ Check_Arg_Count (1);
+ Check_Optional_Identifier (Arg1, Name_On);
+ Check_Arg_Is_Local_Name (Arg1);
+ E_Id := Expression (Arg1);
+
+ if Etype (E_Id) = Any_Type then
+ return;
+ else
+ E := Entity (E_Id);
+ end if;
+
+ if (Is_First_Subtype (E)
+ and then (Is_Enumeration_Type (E)
+ or else Is_Tagged_Type (E)))
+ or else Ekind (E) = E_Exception
+ then
+ Set_Discard_Names (E);
+ else
+ Error_Pragma_Arg
+ ("inappropriate entity for pragma%", Arg1);
+ end if;
+ end if;
+ end if;
+ end Discard_Names;
+
+ ---------------
+ -- Elaborate --
+ ---------------
+
+ -- pragma Elaborate (library_unit_NAME {, library_unit_NAME});
+
+ when Pragma_Elaborate => Elaborate : declare
+ Plist : List_Id;
+ Parent_Node : Node_Id;
+ Arg : Node_Id;
+ Citem : Node_Id;
+
+ begin
+ -- Pragma must be in context items list of a compilation unit
+
+ if not Is_List_Member (N) then
+ Pragma_Misplaced;
+ return;
+
+ else
+ Plist := List_Containing (N);
+ Parent_Node := Parent (Plist);
+
+ if Parent_Node = Empty
+ or else Nkind (Parent_Node) /= N_Compilation_Unit
+ or else Context_Items (Parent_Node) /= Plist
+ then
+ Pragma_Misplaced;
+ return;
+ end if;
+ end if;
+
+ -- Must be at least one argument
+
+ if Arg_Count = 0 then
+ Error_Pragma ("pragma% requires at least one argument");
+ end if;
+
+ -- In Ada 83 mode, there can be no items following it in the
+ -- context list except other pragmas and implicit with clauses
+ -- (e.g. those added by use of Rtsfind). In Ada 95 mode, this
+ -- placement rule does not apply.
+
+ if Ada_83 and then Comes_From_Source (N) then
+ Citem := Next (N);
+
+ while Present (Citem) loop
+ if Nkind (Citem) = N_Pragma
+ or else (Nkind (Citem) = N_With_Clause
+ and then Implicit_With (Citem))
+ then
+ null;
+ else
+ Error_Pragma
+ ("(Ada 83) pragma% must be at end of context clause");
+ end if;
+
+ Next (Citem);
+ end loop;
+ end if;
+
+ -- Finally, the arguments must all be units mentioned in a with
+ -- clause in the same context clause. Note we already checked
+ -- (in Par.Prag) that the arguments are either identifiers or
+
+ Arg := Arg1;
+ Outer : while Present (Arg) loop
+ Citem := First (Plist);
+
+ Inner : while Citem /= N loop
+ if Nkind (Citem) = N_With_Clause
+ and then Same_Name (Name (Citem), Expression (Arg))
+ then
+ Set_Elaborate_Present (Citem, True);
+ Set_Unit_Name (Expression (Arg), Name (Citem));
+ Set_Suppress_Elaboration_Warnings (Entity (Name (Citem)));
+ exit Inner;
+ end if;
+
+ Next (Citem);
+ end loop Inner;
+
+ if Citem = N then
+ Error_Pragma_Arg
+ ("argument of pragma% is not with'ed unit", Arg);
+ end if;
+
+ Next (Arg);
+ end loop Outer;
+ end Elaborate;
+
+ -------------------
+ -- Elaborate_All --
+ -------------------
+
+ -- pragma Elaborate_All (library_unit_NAME {, library_unit_NAME});
+
+ when Pragma_Elaborate_All => Elaborate_All : declare
+ Plist : List_Id;
+ Parent_Node : Node_Id;
+ Arg : Node_Id;
+ Citem : Node_Id;
+
+ begin
+ Check_Ada_83_Warning;
+
+ -- Pragma must be in context items list of a compilation unit
+
+ if not Is_List_Member (N) then
+ Pragma_Misplaced;
+ return;
+
+ else
+ Plist := List_Containing (N);
+ Parent_Node := Parent (Plist);
+
+ if Parent_Node = Empty
+ or else Nkind (Parent_Node) /= N_Compilation_Unit
+ or else Context_Items (Parent_Node) /= Plist
+ then
+ Pragma_Misplaced;
+ return;
+ end if;
+ end if;
+
+ -- Must be at least one argument
+
+ if Arg_Count = 0 then
+ Error_Pragma ("pragma% requires at least one argument");
+ end if;
+
+ -- Note: unlike pragma Elaborate, pragma Elaborate_All does not
+ -- have to appear at the end of the context clause, but may
+ -- appear mixed in with other items, even in Ada 83 mode.
+
+ -- Final check: the arguments must all be units mentioned in
+ -- a with clause in the same context clause. Note that we
+ -- already checked (in Par.Prag) that all the arguments are
+ -- either identifiers or selected components.
+
+ Arg := Arg1;
+ Outr : while Present (Arg) loop
+ Citem := First (Plist);
+
+ Innr : while Citem /= N loop
+ if Nkind (Citem) = N_With_Clause
+ and then Same_Name (Name (Citem), Expression (Arg))
+ then
+ Set_Elaborate_All_Present (Citem, True);
+ Set_Unit_Name (Expression (Arg), Name (Citem));
+ Set_Suppress_Elaboration_Warnings (Entity (Name (Citem)));
+ exit Innr;
+ end if;
+
+ Next (Citem);
+ end loop Innr;
+
+ if Citem = N then
+ Error_Pragma_Arg
+ ("argument of pragma% is not with'ed unit", Arg);
+ end if;
+
+ Next (Arg);
+ end loop Outr;
+ end Elaborate_All;
+
+ --------------------
+ -- Elaborate_Body --
+ --------------------
+
+ -- pragma Elaborate_Body [( library_unit_NAME )];
+
+ when Pragma_Elaborate_Body => Elaborate_Body : declare
+ Cunit_Node : Node_Id;
+ Cunit_Ent : Entity_Id;
+
+ begin
+ Check_Ada_83_Warning;
+ Check_Valid_Library_Unit_Pragma;
+
+ if Nkind (N) = N_Null_Statement then
+ return;
+ end if;
+
+ Cunit_Node := Cunit (Current_Sem_Unit);
+ Cunit_Ent := Cunit_Entity (Current_Sem_Unit);
+
+ if Nkind (Unit (Cunit_Node)) = N_Package_Body
+ or else
+ Nkind (Unit (Cunit_Node)) = N_Subprogram_Body
+ then
+ Error_Pragma ("pragma% must refer to a spec, not a body");
+ else
+ Set_Body_Required (Cunit_Node, True);
+ Set_Has_Pragma_Elaborate_Body (Cunit_Ent);
+
+ -- If we are in dynamic elaboration mode, then we suppress
+ -- elaboration warnings for the unit, since it is definitely
+ -- fine NOT to do dynamic checks at the first level (and such
+ -- checks will be suppressed because no elaboration boolean
+ -- is created for Elaborate_Body packages).
+
+ -- But in the static model of elaboration, Elaborate_Body is
+ -- definitely NOT good enough to ensure elaboration safety on
+ -- its own, since the body may WITH other units that are not
+ -- safe from an elaboration point of view, so a client must
+ -- still do an Elaborate_All on such units.
+
+ -- Debug flag -gnatdD restores the old behavior of 3.13,
+ -- where Elaborate_Body always suppressed elab warnings.
+
+ if Dynamic_Elaboration_Checks or Debug_Flag_DD then
+ Set_Suppress_Elaboration_Warnings (Cunit_Ent);
+ end if;
+ end if;
+ end Elaborate_Body;
+
+ ------------------------
+ -- Elaboration_Checks --
+ ------------------------
+
+ -- pragma Elaboration_Checks (Static | Dynamic);
+
+ when Pragma_Elaboration_Checks =>
+ GNAT_Pragma;
+ Check_Arg_Count (1);
+ Check_Arg_Is_One_Of (Arg1, Name_Static, Name_Dynamic);
+ Dynamic_Elaboration_Checks :=
+ (Chars (Get_Pragma_Arg (Arg1)) = Name_Dynamic);
+
+ ---------------
+ -- Eliminate --
+ ---------------
+
+ -- pragma Eliminate (
+ -- [Unit_Name =>] IDENTIFIER |
+ -- SELECTED_COMPONENT
+ -- [,[Entity =>] IDENTIFIER |
+ -- SELECTED_COMPONENT |
+ -- STRING_LITERAL]
+ -- [,[Parameter_Types =>] PARAMETER_TYPES]
+ -- [,[Result_Type =>] result_SUBTYPE_MARK]);
+
+ -- PARAMETER_TYPES ::=
+ -- null
+ -- (SUBTYPE_MARK, SUBTYPE_MARK, ...)
+
+ when Pragma_Eliminate => Eliminate : begin
+ GNAT_Pragma;
+ Check_Ada_83_Warning;
+ Check_Valid_Configuration_Pragma;
+ Check_At_Least_N_Arguments (1);
+ Check_At_Most_N_Arguments (4);
+
+ if Arg_Count = 3
+ and then Chars (Arg3) = Name_Result_Type
+ then
+ Arg4 := Arg3;
+ Arg3 := Empty;
+
+ else
+ Check_Optional_Identifier (Arg1, "unit_name");
+ Check_Optional_Identifier (Arg2, Name_Entity);
+ Check_Optional_Identifier (Arg3, Name_Parameter_Types);
+ Check_Optional_Identifier (Arg4, Name_Result_Type);
+ end if;
+
+ Process_Eliminate_Pragma (Arg1, Arg2, Arg3, Arg4);
+ end Eliminate;
+
+ ------------
+ -- Export --
+ ------------
+
+ -- pragma Export (
+ -- [ Convention =>] convention_IDENTIFIER,
+ -- [ Entity =>] local_NAME
+ -- [, [External_Name =>] static_string_EXPRESSION ]
+ -- [, [Link_Name =>] static_string_EXPRESSION ]);
+
+ when Pragma_Export => Export : declare
+ C : Convention_Id;
+ Def_Id : Entity_Id;
+
+ begin
+ Check_Ada_83_Warning;
+ Check_At_Least_N_Arguments (2);
+ Check_At_Most_N_Arguments (4);
+ Process_Convention (C, Def_Id);
+ Note_Possible_Modification (Expression (Arg2));
+ Process_Interface_Name (Def_Id, Arg3, Arg4);
+ Set_Exported (Def_Id, Arg2);
+ end Export;
+
+ ----------------------
+ -- Export_Exception --
+ ----------------------
+
+ -- pragma Export_Exception (
+ -- [Internal =>] LOCAL_NAME,
+ -- [, [External =>] EXTERNAL_SYMBOL,]
+ -- [, [Form =>] Ada | VMS]
+ -- [, [Code =>] static_integer_EXPRESSION]);
+
+ when Pragma_Export_Exception => Export_Exception : declare
+ Args : Args_List (1 .. 4);
+ Names : Name_List (1 .. 4) := (
+ Name_Internal,
+ Name_External,
+ Name_Form,
+ Name_Code);
+
+ Internal : Node_Id renames Args (1);
+ External : Node_Id renames Args (2);
+ Form : Node_Id renames Args (3);
+ Code : Node_Id renames Args (4);
+
+ begin
+ GNAT_Pragma;
+
+ if Inside_A_Generic then
+ Error_Pragma ("pragma% cannot be used for generic entities");
+ end if;
+
+ Gather_Associations (Names, Args);
+ Process_Extended_Import_Export_Exception_Pragma (
+ Arg_Internal => Internal,
+ Arg_External => External,
+ Arg_Form => Form,
+ Arg_Code => Code);
+
+ if not Is_VMS_Exception (Entity (Internal)) then
+ Set_Exported (Entity (Internal), Internal);
+ end if;
+
+ end Export_Exception;
+
+ ---------------------
+ -- Export_Function --
+ ---------------------
+
+ -- pragma Export_Function (
+ -- [Internal =>] LOCAL_NAME,
+ -- [, [External =>] EXTERNAL_SYMBOL,]
+ -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
+ -- [, [Result_Type =>] SUBTYPE_MARK]
+ -- [, [Mechanism =>] MECHANISM]
+ -- [, [Result_Mechanism =>] MECHANISM_NAME]);
+
+ when Pragma_Export_Function => Export_Function : declare
+ Args : Args_List (1 .. 6);
+ Names : Name_List (1 .. 6) := (
+ Name_Internal,
+ Name_External,
+ Name_Parameter_Types,
+ Name_Result_Type,
+ Name_Mechanism,
+ Name_Result_Mechanism);
+
+ Internal : Node_Id renames Args (1);
+ External : Node_Id renames Args (2);
+ Parameter_Types : Node_Id renames Args (3);
+ Result_Type : Node_Id renames Args (4);
+ Mechanism : Node_Id renames Args (5);
+ Result_Mechanism : Node_Id renames Args (6);
+
+ begin
+ GNAT_Pragma;
+ Gather_Associations (Names, Args);
+ Process_Extended_Import_Export_Subprogram_Pragma (
+ Arg_Internal => Internal,
+ Arg_External => External,
+ Arg_Parameter_Types => Parameter_Types,
+ Arg_Result_Type => Result_Type,
+ Arg_Mechanism => Mechanism,
+ Arg_Result_Mechanism => Result_Mechanism);
+ end Export_Function;
+
+ -------------------
+ -- Export_Object --
+ -------------------
+
+ -- pragma Export_Object (
+ -- [Internal =>] LOCAL_NAME,
+ -- [, [External =>] EXTERNAL_SYMBOL]
+ -- [, [Size =>] EXTERNAL_SYMBOL]);
+
+ when Pragma_Export_Object => Export_Object : declare
+ Args : Args_List (1 .. 3);
+ Names : Name_List (1 .. 3) := (
+ Name_Internal,
+ Name_External,
+ Name_Size);
+
+ Internal : Node_Id renames Args (1);
+ External : Node_Id renames Args (2);
+ Size : Node_Id renames Args (3);
+
+ begin
+ GNAT_Pragma;
+ Gather_Associations (Names, Args);
+ Process_Extended_Import_Export_Object_Pragma (
+ Arg_Internal => Internal,
+ Arg_External => External,
+ Arg_Size => Size);
+ end Export_Object;
+
+ ----------------------
+ -- Export_Procedure --
+ ----------------------
+
+ -- pragma Export_Procedure (
+ -- [Internal =>] LOCAL_NAME,
+ -- [, [External =>] EXTERNAL_SYMBOL,]
+ -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
+ -- [, [Mechanism =>] MECHANISM]);
+
+ when Pragma_Export_Procedure => Export_Procedure : declare
+ Args : Args_List (1 .. 4);
+ Names : Name_List (1 .. 4) := (
+ Name_Internal,
+ Name_External,
+ Name_Parameter_Types,
+ Name_Mechanism);
+
+ Internal : Node_Id renames Args (1);
+ External : Node_Id renames Args (2);
+ Parameter_Types : Node_Id renames Args (3);
+ Mechanism : Node_Id renames Args (4);
+
+ begin
+ GNAT_Pragma;
+ Gather_Associations (Names, Args);
+ Process_Extended_Import_Export_Subprogram_Pragma (
+ Arg_Internal => Internal,
+ Arg_External => External,
+ Arg_Parameter_Types => Parameter_Types,
+ Arg_Mechanism => Mechanism);
+ end Export_Procedure;
+
+ -----------------------------
+ -- Export_Valued_Procedure --
+ -----------------------------
+
+ -- pragma Export_Valued_Procedure (
+ -- [Internal =>] LOCAL_NAME,
+ -- [, [External =>] EXTERNAL_SYMBOL,]
+ -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
+ -- [, [Mechanism =>] MECHANISM]);
+
+ when Pragma_Export_Valued_Procedure =>
+ Export_Valued_Procedure : declare
+ Args : Args_List (1 .. 4);
+ Names : Name_List (1 .. 4) := (
+ Name_Internal,
+ Name_External,
+ Name_Parameter_Types,
+ Name_Mechanism);
+
+ Internal : Node_Id renames Args (1);
+ External : Node_Id renames Args (2);
+ Parameter_Types : Node_Id renames Args (3);
+ Mechanism : Node_Id renames Args (4);
+
+ begin
+ GNAT_Pragma;
+ Gather_Associations (Names, Args);
+ Process_Extended_Import_Export_Subprogram_Pragma (
+ Arg_Internal => Internal,
+ Arg_External => External,
+ Arg_Parameter_Types => Parameter_Types,
+ Arg_Mechanism => Mechanism);
+ end Export_Valued_Procedure;
+
+ -------------------
+ -- Extend_System --
+ -------------------
+
+ -- pragma Extend_System ([Name =>] Identifier);
+
+ when Pragma_Extend_System => Extend_System : declare
+ begin
+ GNAT_Pragma;
+ Check_Valid_Configuration_Pragma;
+ Check_Arg_Count (1);
+ Check_Optional_Identifier (Arg1, Name_Name);
+ Check_Arg_Is_Identifier (Arg1);
+
+ Get_Name_String (Chars (Expression (Arg1)));
+
+ if Name_Len > 4
+ and then Name_Buffer (1 .. 4) = "aux_"
+ then
+ if Present (System_Extend_Pragma_Arg) then
+ if Chars (Expression (Arg1)) =
+ Chars (Expression (System_Extend_Pragma_Arg))
+ then
+ null;
+ else
+ Error_Msg_Sloc := Sloc (System_Extend_Pragma_Arg);
+ Error_Pragma ("pragma% conflicts with that at#");
+ end if;
+
+ else
+ System_Extend_Pragma_Arg := Arg1;
+ end if;
+ else
+ Error_Pragma ("incorrect name for pragma%, must be Aux_xxx");
+ end if;
+ end Extend_System;
+
+ ------------------------
+ -- Extensions_Allowed --
+ ------------------------
+
+ -- pragma Extensions_Allowed (ON | OFF);
+
+ when Pragma_Extensions_Allowed =>
+ GNAT_Pragma;
+ Check_Arg_Count (1);
+ Check_No_Identifiers;
+ Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
+ Extensions_Allowed := (Chars (Expression (Arg1)) = Name_On);
+
+ --------------------------
+ -- External_Name_Casing --
+ --------------------------
+
+ -- pragma External_Name_Casing (
+ -- UPPERCASE | LOWERCASE
+ -- [, AS_IS | UPPERCASE | LOWERCASE]);
+
+ when Pragma_External_Name_Casing =>
+
+ External_Name_Casing : declare
+ begin
+ GNAT_Pragma;
+ Check_No_Identifiers;
+
+ if Arg_Count = 2 then
+ Check_Arg_Is_One_Of
+ (Arg2, Name_As_Is, Name_Uppercase, Name_Lowercase);
+
+ case Chars (Get_Pragma_Arg (Arg2)) is
+ when Name_As_Is =>
+ Opt.External_Name_Exp_Casing := As_Is;
+
+ when Name_Uppercase =>
+ Opt.External_Name_Exp_Casing := Uppercase;
+
+ when Name_Lowercase =>
+ Opt.External_Name_Exp_Casing := Lowercase;
+
+ when others =>
+ null;
+ end case;
+
+ else
+ Check_Arg_Count (1);
+ end if;
+
+ Check_Arg_Is_One_Of (Arg1, Name_Uppercase, Name_Lowercase);
+
+ case Chars (Get_Pragma_Arg (Arg1)) is
+ when Name_Uppercase =>
+ Opt.External_Name_Imp_Casing := Uppercase;
+
+ when Name_Lowercase =>
+ Opt.External_Name_Imp_Casing := Lowercase;
+
+ when others =>
+ null;
+ end case;
+
+ end External_Name_Casing;
+
+ ---------------------------
+ -- Finalize_Storage_Only --
+ ---------------------------
+
+ -- pragma Finalize_Storage_Only (first_subtype_LOCAL_NAME);
+
+ when Pragma_Finalize_Storage_Only => Finalize_Storage : declare
+ Assoc : Node_Id := Arg1;
+ Type_Id : Node_Id := Expression (Assoc);
+ Typ : Entity_Id;
+
+ begin
+ Check_No_Identifiers;
+ Check_Arg_Count (1);
+ Check_Arg_Is_Local_Name (Arg1);
+
+ Find_Type (Type_Id);
+ Typ := Entity (Type_Id);
+
+ if Typ = Any_Type
+ or else Rep_Item_Too_Early (Typ, N)
+ then
+ return;
+ else
+ Typ := Underlying_Type (Typ);
+ end if;
+
+ if not Is_Controlled (Typ) then
+ Error_Pragma ("pragma% must specify controlled type");
+ end if;
+
+ Check_First_Subtype (Arg1);
+
+ if Finalize_Storage_Only (Typ) then
+ Error_Pragma ("duplicate pragma%, only one allowed");
+
+ elsif not Rep_Item_Too_Late (Typ, N) then
+ Set_Finalize_Storage_Only (Typ, True);
+ end if;
+ end Finalize_Storage;
+
+ --------------------------
+ -- Float_Representation --
+ --------------------------
+
+ -- pragma Float_Representation (VAX_Float | IEEE_Float);
+
+ when Pragma_Float_Representation => Float_Representation : declare
+ Argx : Node_Id;
+ Digs : Nat;
+ Ent : Entity_Id;
+
+ begin
+ GNAT_Pragma;
+
+ if Arg_Count = 1 then
+ Check_Valid_Configuration_Pragma;
+ else
+ Check_Arg_Count (2);
+ Check_Optional_Identifier (Arg2, Name_Entity);
+ Check_Arg_Is_Local_Name (Arg2);
+ end if;
+
+ Check_No_Identifier (Arg1);
+ Check_Arg_Is_One_Of (Arg1, Name_VAX_Float, Name_IEEE_Float);
+
+ if not OpenVMS_On_Target then
+ if Chars (Expression (Arg1)) = Name_VAX_Float then
+ Error_Pragma
+ ("?pragma% ignored (applies only to Open'V'M'S)");
+ end if;
+
+ return;
+ end if;
+
+ -- One argument case
+
+ if Arg_Count = 1 then
+
+ if Chars (Expression (Arg1)) = Name_VAX_Float then
+
+ if Opt.Float_Format = 'I' then
+ Error_Pragma ("'I'E'E'E format previously specified");
+ end if;
+
+ Opt.Float_Format := 'V';
+
+ else
+ if Opt.Float_Format = 'V' then
+ Error_Pragma ("'V'A'X format previously specified");
+ end if;
+
+ Opt.Float_Format := 'I';
+ end if;
+
+ Set_Standard_Fpt_Formats;
+
+ -- Two argument case
+
+ else
+ Argx := Get_Pragma_Arg (Arg2);
+
+ if not Is_Entity_Name (Argx)
+ or else not Is_Floating_Point_Type (Entity (Argx))
+ then
+ Error_Pragma_Arg
+ ("second argument of% pragma must be floating-point type",
+ Arg2);
+ end if;
+
+ Ent := Entity (Argx);
+ Digs := UI_To_Int (Digits_Value (Ent));
+
+ -- Two arguments, VAX_Float case
+
+ if Chars (Expression (Arg1)) = Name_VAX_Float then
+
+ case Digs is
+ when 6 => Set_F_Float (Ent);
+ when 9 => Set_D_Float (Ent);
+ when 15 => Set_G_Float (Ent);
+
+ when others =>
+ Error_Pragma_Arg
+ ("wrong digits value, must be 6,9 or 15", Arg2);
+ end case;
+
+ -- Two arguments, IEEE_Float case
+
+ else
+ case Digs is
+ when 6 => Set_IEEE_Short (Ent);
+ when 15 => Set_IEEE_Long (Ent);
+
+ when others =>
+ Error_Pragma_Arg
+ ("wrong digits value, must be 6 or 15", Arg2);
+ end case;
+ end if;
+ end if;
+
+ end Float_Representation;
+
+ -----------
+ -- Ident --
+ -----------
+
+ -- pragma Ident (static_string_EXPRESSION)
+
+ -- Note: pragma Comment shares this processing. Pragma Comment
+ -- is identical to Ident, except that the restriction of the
+ -- argument to 31 characters and the placement restrictions
+ -- are not enforced for pragma Comment.
+
+ when Pragma_Ident | Pragma_Comment => Ident : declare
+ Str : Node_Id;
+
+ begin
+ GNAT_Pragma;
+ Check_Arg_Count (1);
+ Check_No_Identifiers;
+ Check_Arg_Is_Static_Expression (Arg1, Standard_String);
+
+ -- For pragma Ident, preserve DEC compatibility by requiring
+ -- the pragma to appear in a declarative part or package spec.
+
+ if Prag_Id = Pragma_Ident then
+ Check_Is_In_Decl_Part_Or_Package_Spec;
+ end if;
+
+ Str := Expr_Value_S (Expression (Arg1));
+
+ -- For pragma Ident, preserve DEC compatibility by limiting
+ -- the length to 31 characters.
+
+ if Prag_Id = Pragma_Ident
+ and then String_Length (Strval (Str)) > 31
+ then
+ Error_Pragma_Arg
+ ("argument for pragma% is too long, maximum is 31", Arg1);
+ end if;
+
+ declare
+ CS : Node_Id;
+ GP : Node_Id;
+
+ begin
+ GP := Parent (Parent (N));
+
+ if Nkind (GP) = N_Package_Declaration
+ or else
+ Nkind (GP) = N_Generic_Package_Declaration
+ then
+ GP := Parent (GP);
+ end if;
+
+ -- If we have a compilation unit, then record the ident
+ -- value, checking for improper duplication.
+
+ if Nkind (GP) = N_Compilation_Unit then
+ CS := Ident_String (Current_Sem_Unit);
+
+ if Present (CS) then
+
+ -- For Ident, we do not permit multiple instances
+
+ if Prag_Id = Pragma_Ident then
+ Error_Pragma ("duplicate% pragma not permitted");
+
+ -- For Comment, we concatenate the string, unless we
+ -- want to preserve the tree structure for ASIS.
+
+ elsif not Tree_Output then
+ Start_String (Strval (CS));
+ Store_String_Char (' ');
+ Store_String_Chars (Strval (Str));
+ Set_Strval (CS, End_String);
+ end if;
+
+ else
+ -- In VMS, the effect of IDENT is achieved by passing
+ -- IDENTIFICATION=name as a --for-linker switch.
+
+ if OpenVMS_On_Target then
+ Start_String;
+ Store_String_Chars
+ ("--for-linker=IDENTIFICATION=");
+ String_To_Name_Buffer (Strval (Str));
+ Store_String_Chars (Name_Buffer (1 .. Name_Len));
+
+ -- Only the last processed IDENT is saved. The main
+ -- purpose is so an IDENT associated with a main
+ -- procedure will be used in preference to an IDENT
+ -- associated with a with'd package.
+
+ Replace_Linker_Option_String
+ (End_String, "--for-linker=IDENTIFICATION=");
+ end if;
+
+ Set_Ident_String (Current_Sem_Unit, Str);
+ end if;
+
+ -- For subunits, we just ignore the Ident, since in GNAT
+ -- these are not separate object files, and hence not
+ -- separate units in the unit table.
+
+ elsif Nkind (GP) = N_Subunit then
+ null;
+
+ -- Otherwise we have a misplaced pragma Ident, but we ignore
+ -- this if we are in an instantiation, since it comes from
+ -- a generic, and has no relevance to the instantiation.
+
+ elsif Prag_Id = Pragma_Ident then
+ if Instantiation_Location (Loc) = No_Location then
+ Error_Pragma ("pragma% only allowed at outer level");
+ end if;
+ end if;
+ end;
+ end Ident;
+
+ ------------
+ -- Import --
+ ------------
+
+ -- pragma Import (
+ -- [ Convention =>] convention_IDENTIFIER,
+ -- [ Entity =>] local_NAME
+ -- [, [External_Name =>] static_string_EXPRESSION ]
+ -- [, [Link_Name =>] static_string_EXPRESSION ]);
+
+ when Pragma_Import =>
+ Check_Ada_83_Warning;
+ Check_At_Least_N_Arguments (2);
+ Check_At_Most_N_Arguments (4);
+ Process_Import_Or_Interface;
+
+ ----------------------
+ -- Import_Exception --
+ ----------------------
+
+ -- pragma Import_Exception (
+ -- [Internal =>] LOCAL_NAME,
+ -- [, [External =>] EXTERNAL_SYMBOL,]
+ -- [, [Form =>] Ada | VMS]
+ -- [, [Code =>] static_integer_EXPRESSION]);
+
+ when Pragma_Import_Exception => Import_Exception : declare
+ Args : Args_List (1 .. 4);
+ Names : Name_List (1 .. 4) := (
+ Name_Internal,
+ Name_External,
+ Name_Form,
+ Name_Code);
+
+ Internal : Node_Id renames Args (1);
+ External : Node_Id renames Args (2);
+ Form : Node_Id renames Args (3);
+ Code : Node_Id renames Args (4);
+
+ begin
+ GNAT_Pragma;
+ Gather_Associations (Names, Args);
+
+ if Present (External) and then Present (Code) then
+ Error_Pragma
+ ("cannot give both External and Code options for pragma%");
+ end if;
+
+ Process_Extended_Import_Export_Exception_Pragma (
+ Arg_Internal => Internal,
+ Arg_External => External,
+ Arg_Form => Form,
+ Arg_Code => Code);
+
+ if not Is_VMS_Exception (Entity (Internal)) then
+ Set_Imported (Entity (Internal));
+ end if;
+
+ end Import_Exception;
+
+ ---------------------
+ -- Import_Function --
+ ---------------------
+
+ -- pragma Import_Function (
+ -- [Internal =>] LOCAL_NAME,
+ -- [, [External =>] EXTERNAL_SYMBOL]
+ -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
+ -- [, [Result_Type =>] SUBTYPE_MARK]
+ -- [, [Mechanism =>] MECHANISM]
+ -- [, [Result_Mechanism =>] MECHANISM_NAME]
+ -- [, [First_Optional_Parameter =>] IDENTIFIER]);
+
+ when Pragma_Import_Function => Import_Function : declare
+ Args : Args_List (1 .. 7);
+ Names : Name_List (1 .. 7) := (
+ Name_Internal,
+ Name_External,
+ Name_Parameter_Types,
+ Name_Result_Type,
+ Name_Mechanism,
+ Name_Result_Mechanism,
+ Name_First_Optional_Parameter);
+
+ Internal : Node_Id renames Args (1);
+ External : Node_Id renames Args (2);
+ Parameter_Types : Node_Id renames Args (3);
+ Result_Type : Node_Id renames Args (4);
+ Mechanism : Node_Id renames Args (5);
+ Result_Mechanism : Node_Id renames Args (6);
+ First_Optional_Parameter : Node_Id renames Args (7);
+
+ begin
+ GNAT_Pragma;
+ Gather_Associations (Names, Args);
+ Process_Extended_Import_Export_Subprogram_Pragma (
+ Arg_Internal => Internal,
+ Arg_External => External,
+ Arg_Parameter_Types => Parameter_Types,
+ Arg_Result_Type => Result_Type,
+ Arg_Mechanism => Mechanism,
+ Arg_Result_Mechanism => Result_Mechanism,
+ Arg_First_Optional_Parameter => First_Optional_Parameter);
+ end Import_Function;
+
+ -------------------
+ -- Import_Object --
+ -------------------
+
+ -- pragma Import_Object (
+ -- [Internal =>] LOCAL_NAME,
+ -- [, [External =>] EXTERNAL_SYMBOL]
+ -- [, [Size =>] EXTERNAL_SYMBOL]);
+
+ when Pragma_Import_Object => Import_Object : declare
+ Args : Args_List (1 .. 3);
+ Names : Name_List (1 .. 3) := (
+ Name_Internal,
+ Name_External,
+ Name_Size);
+
+ Internal : Node_Id renames Args (1);
+ External : Node_Id renames Args (2);
+ Size : Node_Id renames Args (3);
+
+ begin
+ GNAT_Pragma;
+ Gather_Associations (Names, Args);
+ Process_Extended_Import_Export_Object_Pragma (
+ Arg_Internal => Internal,
+ Arg_External => External,
+ Arg_Size => Size);
+ end Import_Object;
+
+ ----------------------
+ -- Import_Procedure --
+ ----------------------
+
+ -- pragma Import_Procedure (
+ -- [Internal =>] LOCAL_NAME,
+ -- [, [External =>] EXTERNAL_SYMBOL]
+ -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
+ -- [, [Mechanism =>] MECHANISM]
+ -- [, [First_Optional_Parameter =>] IDENTIFIER]);
+
+ when Pragma_Import_Procedure => Import_Procedure : declare
+ Args : Args_List (1 .. 5);
+ Names : Name_List (1 .. 5) := (
+ Name_Internal,
+ Name_External,
+ Name_Parameter_Types,
+ Name_Mechanism,
+ Name_First_Optional_Parameter);
+
+ Internal : Node_Id renames Args (1);
+ External : Node_Id renames Args (2);
+ Parameter_Types : Node_Id renames Args (3);
+ Mechanism : Node_Id renames Args (4);
+ First_Optional_Parameter : Node_Id renames Args (5);
+
+ begin
+ GNAT_Pragma;
+ Gather_Associations (Names, Args);
+ Process_Extended_Import_Export_Subprogram_Pragma (
+ Arg_Internal => Internal,
+ Arg_External => External,
+ Arg_Parameter_Types => Parameter_Types,
+ Arg_Mechanism => Mechanism,
+ Arg_First_Optional_Parameter => First_Optional_Parameter);
+ end Import_Procedure;
+
+ -----------------------------
+ -- Import_Valued_Procedure --
+ -----------------------------
+
+ -- pragma Import_Valued_Procedure (
+ -- [Internal =>] LOCAL_NAME,
+ -- [, [External =>] EXTERNAL_SYMBOL]
+ -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
+ -- [, [Mechanism =>] MECHANISM]
+ -- [, [First_Optional_Parameter =>] IDENTIFIER]);
+
+ when Pragma_Import_Valued_Procedure =>
+ Import_Valued_Procedure : declare
+ Args : Args_List (1 .. 5);
+ Names : Name_List (1 .. 5) := (
+ Name_Internal,
+ Name_External,
+ Name_Parameter_Types,
+ Name_Mechanism,
+ Name_First_Optional_Parameter);
+
+ Internal : Node_Id renames Args (1);
+ External : Node_Id renames Args (2);
+ Parameter_Types : Node_Id renames Args (3);
+ Mechanism : Node_Id renames Args (4);
+ First_Optional_Parameter : Node_Id renames Args (5);
+
+ begin
+ GNAT_Pragma;
+ Gather_Associations (Names, Args);
+ Process_Extended_Import_Export_Subprogram_Pragma (
+ Arg_Internal => Internal,
+ Arg_External => External,
+ Arg_Parameter_Types => Parameter_Types,
+ Arg_Mechanism => Mechanism,
+ Arg_First_Optional_Parameter => First_Optional_Parameter);
+ end Import_Valued_Procedure;
+
+ ------------------------
+ -- Initialize_Scalars --
+ ------------------------
+
+ -- pragma Initialize_Scalars;
+
+ when Pragma_Initialize_Scalars =>
+ GNAT_Pragma;
+ Check_Arg_Count (0);
+ Check_Valid_Configuration_Pragma;
+ Init_Or_Norm_Scalars := True;
+ Initialize_Scalars := True;
+
+ ------------
+ -- Inline --
+ ------------
+
+ -- pragma Inline ( NAME {, NAME} );
+
+ when Pragma_Inline =>
+
+ -- Pragma is active if inlining option is active
+
+ if Inline_Active then
+ Process_Inline (True);
+
+ -- Pragma is active in a predefined file in no run time mode
+
+ elsif No_Run_Time
+ and then
+ Is_Predefined_File_Name (Unit_File_Name (Current_Sem_Unit))
+ then
+ Process_Inline (True);
+
+ else
+ Process_Inline (False);
+ end if;
+
+ -------------------
+ -- Inline_Always --
+ -------------------
+
+ -- pragma Inline_Always ( NAME {, NAME} );
+
+ when Pragma_Inline_Always =>
+ Process_Inline (True);
+
+ --------------------
+ -- Inline_Generic --
+ --------------------
+
+ -- pragma Inline_Generic (NAME {, NAME});
+
+ when Pragma_Inline_Generic =>
+ Process_Generic_List;
+
+ ----------------------
+ -- Inspection_Point --
+ ----------------------
+
+ -- pragma Inspection_Point [(object_NAME {, object_NAME})];
+
+ when Pragma_Inspection_Point => Inspection_Point : declare
+ Arg : Node_Id;
+ Exp : Node_Id;
+
+ begin
+ if Arg_Count > 0 then
+ Arg := Arg1;
+ loop
+ Exp := Expression (Arg);
+ Analyze (Exp);
+
+ if not Is_Entity_Name (Exp)
+ or else not Is_Object (Entity (Exp))
+ then
+ Error_Pragma_Arg ("object name required", Arg);
+ end if;
+
+ Next (Arg);
+ exit when No (Arg);
+ end loop;
+ end if;
+ end Inspection_Point;
+
+ ---------------
+ -- Interface --
+ ---------------
+
+ -- pragma Interface (
+ -- convention_IDENTIFIER,
+ -- local_NAME );
+
+ when Pragma_Interface =>
+ GNAT_Pragma;
+ Check_Arg_Count (2);
+ Check_No_Identifiers;
+ Process_Import_Or_Interface;
+
+ --------------------
+ -- Interface_Name --
+ --------------------
+
+ -- pragma Interface_Name (
+ -- [ Entity =>] local_NAME
+ -- [,[External_Name =>] static_string_EXPRESSION ]
+ -- [,[Link_Name =>] static_string_EXPRESSION ]);
+
+ when Pragma_Interface_Name => Interface_Name : declare
+ Id : Node_Id;
+ Def_Id : Entity_Id;
+ Hom_Id : Entity_Id;
+ Found : Boolean;
+
+ begin
+ GNAT_Pragma;
+ Check_At_Least_N_Arguments (2);
+ Check_At_Most_N_Arguments (3);
+ Id := Expression (Arg1);
+ Analyze (Id);
+
+ if not Is_Entity_Name (Id) then
+ Error_Pragma_Arg
+ ("first argument for pragma% must be entity name", Arg1);
+ elsif Etype (Id) = Any_Type then
+ return;
+ else
+ Def_Id := Entity (Id);
+ end if;
+
+ -- Special DEC-compatible processing for the object case,
+ -- forces object to be imported.
+
+ if Ekind (Def_Id) = E_Variable then
+ Kill_Size_Check_Code (Def_Id);
+ Note_Possible_Modification (Id);
+
+ -- Initialization is not allowed for imported variable
+
+ if Present (Expression (Parent (Def_Id)))
+ and then Comes_From_Source (Expression (Parent (Def_Id)))
+ then
+ Error_Msg_Sloc := Sloc (Def_Id);
+ Error_Pragma_Arg
+ ("no initialization allowed for declaration of& #",
+ Arg2);
+
+ else
+ -- For compatibility, support VADS usage of providing both
+ -- pragmas Interface and Interface_Name to obtain the effect
+ -- of a single Import pragma.
+
+ if Is_Imported (Def_Id)
+ and then Present (First_Rep_Item (Def_Id))
+ and then Nkind (First_Rep_Item (Def_Id)) = N_Pragma
+ and then Chars (First_Rep_Item (Def_Id)) = Name_Interface
+ then
+ null;
+ else
+ Set_Imported (Def_Id);
+ end if;
+
+ Set_Is_Public (Def_Id);
+ Process_Interface_Name (Def_Id, Arg2, Arg3);
+ end if;
+
+ -- Otherwise must be subprogram
+
+ elsif not Is_Subprogram (Def_Id) then
+ Error_Pragma_Arg
+ ("argument of pragma% is not subprogram", Arg1);
+
+ else
+ Check_At_Most_N_Arguments (3);
+ Hom_Id := Def_Id;
+ Found := False;
+
+ -- Loop through homonyms
+
+ loop
+ Def_Id := Get_Base_Subprogram (Hom_Id);
+
+ if Is_Imported (Def_Id) then
+ Process_Interface_Name (Def_Id, Arg2, Arg3);
+ Found := True;
+ end if;
+
+ Hom_Id := Homonym (Hom_Id);
+
+ exit when No (Hom_Id)
+ or else Scope (Hom_Id) /= Current_Scope;
+ end loop;
+
+ if not Found then
+ Error_Pragma_Arg
+ ("argument of pragma% is not imported subprogram",
+ Arg1);
+ end if;
+ end if;
+ end Interface_Name;
+
+ -----------------------
+ -- Interrupt_Handler --
+ -----------------------
+
+ -- pragma Interrupt_Handler (handler_NAME);
+
+ when Pragma_Interrupt_Handler =>
+ Check_Ada_83_Warning;
+ Check_Arg_Count (1);
+ Check_No_Identifiers;
+ Check_Interrupt_Or_Attach_Handler;
+ Process_Interrupt_Or_Attach_Handler;
+
+ ------------------------
+ -- Interrupt_Priority --
+ ------------------------
+
+ -- pragma Interrupt_Priority [(EXPRESSION)];
+
+ when Pragma_Interrupt_Priority => Interrupt_Priority : declare
+ P : constant Node_Id := Parent (N);
+ Arg : Node_Id;
+
+ begin
+ Check_Ada_83_Warning;
+
+ if Arg_Count /= 0 then
+ Arg := Expression (Arg1);
+ Check_Arg_Count (1);
+ Check_No_Identifiers;
+
+ -- Set In_Default_Expression for per-object case???
+
+ Analyze_And_Resolve (Arg, Standard_Integer);
+ if Expander_Active then
+ Rewrite (Arg,
+ Convert_To (RTE (RE_Interrupt_Priority), Arg));
+ end if;
+ end if;
+
+ if Nkind (P) /= N_Task_Definition
+ and then Nkind (P) /= N_Protected_Definition
+ then
+ Pragma_Misplaced;
+ return;
+
+ elsif Has_Priority_Pragma (P) then
+ Error_Pragma ("duplicate pragma% not allowed");
+
+ else
+ Set_Has_Priority_Pragma (P, True);
+ Record_Rep_Item (Defining_Identifier (Parent (P)), N);
+ end if;
+ end Interrupt_Priority;
+
+ ----------------------
+ -- Java_Constructor --
+ ----------------------
+
+ -- pragma Java_Constructor ([Entity =>] LOCAL_NAME);
+
+ when Pragma_Java_Constructor => Java_Constructor : declare
+ Id : Entity_Id;
+ Def_Id : Entity_Id;
+ Hom_Id : Entity_Id;
+
+ begin
+ GNAT_Pragma;
+ Check_Arg_Count (1);
+ Check_Optional_Identifier (Arg1, Name_Entity);
+ Check_Arg_Is_Local_Name (Arg1);
+
+ Id := Expression (Arg1);
+ Find_Program_Unit_Name (Id);
+
+ -- If we did not find the name, we are done
+
+ if Etype (Id) = Any_Type then
+ return;
+ end if;
+
+ Hom_Id := Entity (Id);
+
+ -- Loop through homonyms
+
+ loop
+ Def_Id := Get_Base_Subprogram (Hom_Id);
+
+ -- The constructor is required to be a function returning
+ -- an access type whose designated type has convention Java.
+
+ if Ekind (Def_Id) = E_Function
+ and then Ekind (Etype (Def_Id)) in Access_Kind
+ and then
+ (Atree.Convention
+ (Designated_Type (Etype (Def_Id))) = Convention_Java
+ or else
+ Atree.Convention
+ (Root_Type (Designated_Type (Etype (Def_Id))))
+ = Convention_Java)
+ then
+ Set_Is_Constructor (Def_Id);
+ Set_Convention (Def_Id, Convention_Java);
+
+ else
+ Error_Pragma_Arg
+ ("pragma% requires function returning a 'Java access type",
+ Arg1);
+ end if;
+
+ Hom_Id := Homonym (Hom_Id);
+
+ exit when No (Hom_Id) or else Scope (Hom_Id) /= Current_Scope;
+ end loop;
+ end Java_Constructor;
+
+ ----------------------
+ -- Java_Interface --
+ ----------------------
+
+ -- pragma Java_Interface ([Entity =>] LOCAL_NAME);
+
+ when Pragma_Java_Interface => Java_Interface : declare
+ Arg : Node_Id;
+ Typ : Entity_Id;
+
+ begin
+ GNAT_Pragma;
+ Check_Arg_Count (1);
+ Check_Optional_Identifier (Arg1, Name_Entity);
+ Check_Arg_Is_Local_Name (Arg1);
+
+ Arg := Expression (Arg1);
+ Analyze (Arg);
+
+ if Etype (Arg) = Any_Type then
+ return;
+ end if;
+
+ if not Is_Entity_Name (Arg)
+ or else not Is_Type (Entity (Arg))
+ then
+ Error_Pragma_Arg ("pragma% requires a type mark", Arg1);
+ end if;
+
+ Typ := Underlying_Type (Entity (Arg));
+
+ -- For now we simply check some of the semantic constraints
+ -- on the type. This currently leaves out some restrictions
+ -- on interface types, namely that the parent type must be
+ -- java.lang.Object.Typ and that all primitives of the type
+ -- should be declared abstract. ???
+
+ if not Is_Tagged_Type (Typ) or else not Is_Abstract (Typ) then
+ Error_Pragma_Arg ("pragma% requires an abstract "
+ & "tagged type", Arg1);
+
+ elsif not Has_Discriminants (Typ)
+ or else Ekind (Etype (First_Discriminant (Typ)))
+ /= E_Anonymous_Access_Type
+ or else
+ not Is_Class_Wide_Type
+ (Designated_Type (Etype (First_Discriminant (Typ))))
+ then
+ Error_Pragma_Arg
+ ("type must have a class-wide access discriminant", Arg1);
+ end if;
+ end Java_Interface;
+
+ -------------
+ -- License --
+ -------------
+
+ -- pragma License (RESTRICTED | UNRESRICTED | GPL | MODIFIED_GPL);
+
+ when Pragma_License =>
+ GNAT_Pragma;
+ Check_Arg_Count (1);
+ Check_No_Identifiers;
+ Check_Valid_Configuration_Pragma;
+ Check_Arg_Is_Identifier (Arg1);
+
+ declare
+ Sind : constant Source_File_Index :=
+ Source_Index (Current_Sem_Unit);
+
+ begin
+ case Chars (Get_Pragma_Arg (Arg1)) is
+ when Name_GPL =>
+ Set_License (Sind, GPL);
+
+ when Name_Modified_GPL =>
+ Set_License (Sind, Modified_GPL);
+
+ when Name_Restricted =>
+ Set_License (Sind, Restricted);
+
+ when Name_Unrestricted =>
+ Set_License (Sind, Unrestricted);
+
+ when others =>
+ Error_Pragma_Arg ("invalid license name", Arg1);
+ end case;
+ end;
+
+ ---------------
+ -- Link_With --
+ ---------------
+
+ -- pragma Link_With (string_EXPRESSION {, string_EXPRESSION});
+
+ when Pragma_Link_With => Link_With : declare
+ Arg : Node_Id;
+
+ begin
+ GNAT_Pragma;
+
+ if Operating_Mode = Generate_Code
+ and then In_Extended_Main_Source_Unit (N)
+ then
+ Check_At_Least_N_Arguments (1);
+ Check_No_Identifiers;
+ Check_Is_In_Decl_Part_Or_Package_Spec;
+ Check_Arg_Is_Static_Expression (Arg1, Standard_String);
+ Start_String;
+
+ Arg := Arg1;
+ while Present (Arg) loop
+ Check_Arg_Is_Static_Expression (Arg, Standard_String);
+
+ -- Store argument, converting sequences of spaces to
+ -- a single null character (this is the difference in
+ -- processing between Link_With, and Linker_Options).
+
+ declare
+ C : constant Char_Code := Get_Char_Code (' ');
+ S : constant String_Id :=
+ Strval (Expr_Value_S (Expression (Arg)));
+
+ F : Nat := 1;
+ L : Nat := String_Length (S);
+
+ procedure Skip_Spaces;
+ -- Advance F past any spaces
+
+ procedure Skip_Spaces is
+ begin
+ while F <= L and then Get_String_Char (S, F) = C loop
+ F := F + 1;
+ end loop;
+ end Skip_Spaces;
+
+ begin
+ Skip_Spaces; -- skip leading spaces
+
+ -- Loop through characters, changing any embedded
+ -- sequence of spaces to a single null character
+ -- (this is how Link_With/Linker_Options differ)
+
+ while F <= L loop
+ if Get_String_Char (S, F) = C then
+ Skip_Spaces;
+ exit when F > L;
+ Store_String_Char (ASCII.NUL);
+
+ else
+ Store_String_Char (Get_String_Char (S, F));
+ F := F + 1;
+ end if;
+ end loop;
+ end;
+
+ Arg := Next (Arg);
+
+ if Present (Arg) then
+ Store_String_Char (ASCII.NUL);
+ end if;
+ end loop;
+
+ Store_Linker_Option_String (End_String);
+ end if;
+ end Link_With;
+
+ ------------------
+ -- Linker_Alias --
+ ------------------
+
+ -- pragma Linker_Alias (
+ -- [Entity =>] LOCAL_NAME
+ -- [Alias =>] static_string_EXPRESSION);
+
+ when Pragma_Linker_Alias =>
+ GNAT_Pragma;
+ Check_Arg_Count (2);
+ Check_Optional_Identifier (Arg1, Name_Entity);
+ Check_Optional_Identifier (Arg2, "alias");
+ Check_Arg_Is_Library_Level_Local_Name (Arg1);
+ Check_Arg_Is_Static_Expression (Arg2, Standard_String);
+
+ -- The only processing required is to link this item on to the
+ -- list of rep items for the given entity. This is accomplished
+ -- by the call to Rep_Item_Too_Late (when no error is detected
+ -- and False is returned).
+
+ if Rep_Item_Too_Late (Entity (Expression (Arg1)), N) then
+ return;
+ else
+ Set_Has_Gigi_Rep_Item (Entity (Expression (Arg1)));
+ end if;
+
+ --------------------
+ -- Linker_Options --
+ --------------------
+
+ -- pragma Linker_Options (string_EXPRESSION {, string_EXPRESSION});
+
+ -- Note: the use of multiple arguments is a GNAT extension
+
+ when Pragma_Linker_Options => Linker_Options : declare
+ Arg : Node_Id;
+
+ begin
+ if Operating_Mode = Generate_Code
+ and then In_Extended_Main_Source_Unit (N)
+ then
+ Check_Ada_83_Warning;
+ Check_At_Least_N_Arguments (1);
+ Check_No_Identifiers;
+ Check_Is_In_Decl_Part_Or_Package_Spec;
+ Check_Arg_Is_Static_Expression (Arg1, Standard_String);
+ Start_String (Strval (Expr_Value_S (Expression (Arg1))));
+
+ Arg := Arg2;
+ while Present (Arg) loop
+ Check_Arg_Is_Static_Expression (Arg, Standard_String);
+ Store_String_Char (ASCII.NUL);
+ Store_String_Chars
+ (Strval (Expr_Value_S (Expression (Arg))));
+ Arg := Next (Arg);
+ end loop;
+
+ Store_Linker_Option_String (End_String);
+ end if;
+ end Linker_Options;
+
+ --------------------
+ -- Linker_Section --
+ --------------------
+
+ -- pragma Linker_Section (
+ -- [Entity =>] LOCAL_NAME
+ -- [Section =>] static_string_EXPRESSION);
+
+ when Pragma_Linker_Section =>
+ GNAT_Pragma;
+ Check_Arg_Count (2);
+ Check_Optional_Identifier (Arg1, Name_Entity);
+ Check_Optional_Identifier (Arg2, Name_Section);
+ Check_Arg_Is_Library_Level_Local_Name (Arg1);
+ Check_Arg_Is_Static_Expression (Arg2, Standard_String);
+
+ -- The only processing required is to link this item on to the
+ -- list of rep items for the given entity. This is accomplished
+ -- by the call to Rep_Item_Too_Late (when no error is detected
+ -- and False is returned).
+
+ if Rep_Item_Too_Late (Entity (Expression (Arg1)), N) then
+ return;
+ else
+ Set_Has_Gigi_Rep_Item (Entity (Expression (Arg1)));
+ end if;
+
+ ----------
+ -- List --
+ ----------
+
+ -- pragma List (On | Off)
+
+ -- There is nothing to do here, since we did all the processing
+ -- for this pragma in Par.Prag (so that it works properly even in
+ -- syntax only mode)
+
+ when Pragma_List =>
+ null;
+
+ --------------------
+ -- Locking_Policy --
+ --------------------
+
+ -- pragma Locking_Policy (policy_IDENTIFIER);
+
+ when Pragma_Locking_Policy => declare
+ LP : Character;
+
+ begin
+ Check_Ada_83_Warning;
+ Check_Arg_Count (1);
+ Check_No_Identifiers;
+ Check_Arg_Is_Locking_Policy (Arg1);
+ Check_Valid_Configuration_Pragma;
+ Get_Name_String (Chars (Expression (Arg1)));
+ LP := Fold_Upper (Name_Buffer (1));
+
+ if Locking_Policy /= ' '
+ and then Locking_Policy /= LP
+ then
+ Error_Msg_Sloc := Locking_Policy_Sloc;
+ Error_Pragma ("locking policy incompatible with policy#");
+ else
+ Locking_Policy := LP;
+ Locking_Policy_Sloc := Loc;
+ end if;
+ end;
+
+ ----------------
+ -- Long_Float --
+ ----------------
+
+ -- pragma Long_Float (D_Float | G_Float);
+
+ when Pragma_Long_Float =>
+ GNAT_Pragma;
+ Check_Valid_Configuration_Pragma;
+ Check_Arg_Count (1);
+ Check_No_Identifier (Arg1);
+ Check_Arg_Is_One_Of (Arg1, Name_D_Float, Name_G_Float);
+
+ if not OpenVMS_On_Target then
+ Error_Pragma ("?pragma% ignored (applies only to Open'V'M'S)");
+ end if;
+
+ -- D_Float case
+
+ if Chars (Expression (Arg1)) = Name_D_Float then
+ if Opt.Float_Format_Long = 'G' then
+ Error_Pragma ("G_Float previously specified");
+ end if;
+
+ Opt.Float_Format_Long := 'D';
+
+ -- G_Float case (this is the default, does not need overriding)
+
+ else
+ if Opt.Float_Format_Long = 'D' then
+ Error_Pragma ("D_Float previously specified");
+ end if;
+
+ Opt.Float_Format_Long := 'G';
+ end if;
+
+ Set_Standard_Fpt_Formats;
+
+ -----------------------
+ -- Machine_Attribute --
+ -----------------------
+
+ -- pragma Machine_Attribute (
+ -- [Entity =>] LOCAL_NAME,
+ -- [Attribute_Name =>] static_string_EXPRESSION
+ -- [,[Info =>] static_string_EXPRESSION] );
+
+ when Pragma_Machine_Attribute => Machine_Attribute : declare
+ Def_Id : Entity_Id;
+
+ begin
+ GNAT_Pragma;
+
+ if Arg_Count = 3 then
+ Check_Optional_Identifier (Arg3, "info");
+ Check_Arg_Is_Static_Expression (Arg3, Standard_String);
+ else
+ Check_Arg_Count (2);
+ end if;
+
+ Check_Arg_Is_Local_Name (Arg1);
+ Check_Optional_Identifier (Arg2, "attribute_name");
+ Check_Optional_Identifier (Arg1, Name_Entity);
+ Check_Arg_Is_Static_Expression (Arg2, Standard_String);
+ Def_Id := Entity (Expression (Arg1));
+
+ if Is_Access_Type (Def_Id) then
+ Def_Id := Designated_Type (Def_Id);
+ end if;
+
+ if Rep_Item_Too_Early (Def_Id, N) then
+ return;
+ end if;
+
+ Def_Id := Underlying_Type (Def_Id);
+
+ -- The only processing required is to link this item on to the
+ -- list of rep items for the given entity. This is accomplished
+ -- by the call to Rep_Item_Too_Late (when no error is detected
+ -- and False is returned).
+
+ if Rep_Item_Too_Late (Def_Id, N) then
+ return;
+ else
+ Set_Has_Gigi_Rep_Item (Entity (Expression (Arg1)));
+ end if;
+ end Machine_Attribute;
+
+ ----------
+ -- Main --
+ ----------
+
+ -- pragma Main_Storage
+ -- (MAIN_STORAGE_OPTION [, MAIN_STORAGE_OPTION]);
+
+ -- MAIN_STORAGE_OPTION ::=
+ -- [WORKING_STORAGE =>] static_SIMPLE_EXPRESSION
+ -- | [TOP_GUARD =>] static_SIMPLE_EXPRESSION
+
+ when Pragma_Main => Main : declare
+ Args : Args_List (1 .. 3);
+ Names : Name_List (1 .. 3) := (
+ Name_Stack_Size,
+ Name_Task_Stack_Size_Default,
+ Name_Time_Slicing_Enabled);
+
+ Nod : Node_Id;
+
+ begin
+ GNAT_Pragma;
+ Gather_Associations (Names, Args);
+
+ for J in 1 .. 2 loop
+ if Present (Args (J)) then
+ Check_Arg_Is_Static_Expression (Args (J), Any_Integer);
+ end if;
+ end loop;
+
+ if Present (Args (3)) then
+ Check_Arg_Is_Static_Expression (Args (3), Standard_Boolean);
+ end if;
+
+ Nod := Next (N);
+ while Present (Nod) loop
+ if Nkind (Nod) = N_Pragma
+ and then Chars (Nod) = Name_Main
+ then
+ Error_Msg_Name_1 := Chars (N);
+ Error_Msg_N ("duplicate pragma% not permitted", Nod);
+ end if;
+
+ Next (Nod);
+ end loop;
+ end Main;
+
+ ------------------
+ -- Main_Storage --
+ ------------------
+
+ -- pragma Main_Storage
+ -- (MAIN_STORAGE_OPTION [, MAIN_STORAGE_OPTION]);
+
+ -- MAIN_STORAGE_OPTION ::=
+ -- [WORKING_STORAGE =>] static_SIMPLE_EXPRESSION
+ -- | [TOP_GUARD =>] static_SIMPLE_EXPRESSION
+
+ when Pragma_Main_Storage => Main_Storage : declare
+ Args : Args_List (1 .. 2);
+ Names : Name_List (1 .. 2) := (
+ Name_Working_Storage,
+ Name_Top_Guard);
+
+ Nod : Node_Id;
+
+ begin
+ GNAT_Pragma;
+ Gather_Associations (Names, Args);
+
+ for J in 1 .. 2 loop
+ if Present (Args (J)) then
+ Check_Arg_Is_Static_Expression (Args (J), Any_Integer);
+ end if;
+ end loop;
+
+ Check_In_Main_Program;
+
+ Nod := Next (N);
+ while Present (Nod) loop
+ if Nkind (Nod) = N_Pragma
+ and then Chars (Nod) = Name_Main_Storage
+ then
+ Error_Msg_Name_1 := Chars (N);
+ Error_Msg_N ("duplicate pragma% not permitted", Nod);
+ end if;
+
+ Next (Nod);
+ end loop;
+
+ end Main_Storage;
+
+ -----------------
+ -- Memory_Size --
+ -----------------
+
+ -- pragma Memory_Size (NUMERIC_LITERAL)
+
+ when Pragma_Memory_Size =>
+ GNAT_Pragma;
+
+ -- Memory size is simply ignored
+
+ Check_No_Identifiers;
+ Check_Arg_Count (1);
+ Check_Arg_Is_Integer_Literal (Arg1);
+
+ ---------------
+ -- No_Return --
+ ---------------
+
+ -- pragma No_Return (procedure_LOCAL_NAME);
+
+ when Pragma_No_Return => declare
+ Id : Node_Id;
+ E : Entity_Id;
+ Found : Boolean;
+
+ begin
+ GNAT_Pragma;
+ Check_Arg_Count (1);
+ Check_No_Identifiers;
+ Check_Arg_Is_Local_Name (Arg1);
+ Id := Expression (Arg1);
+ Analyze (Id);
+
+ if not Is_Entity_Name (Id) then
+ Error_Pragma_Arg ("entity name required", Arg1);
+ end if;
+
+ if Etype (Id) = Any_Type then
+ raise Pragma_Exit;
+ end if;
+
+ E := Entity (Id);
+
+ Found := False;
+ while Present (E)
+ and then Scope (E) = Current_Scope
+ loop
+ if Ekind (E) = E_Procedure
+ or else Ekind (E) = E_Generic_Procedure
+ then
+ Set_No_Return (E);
+ Found := True;
+ end if;
+
+ E := Homonym (E);
+ end loop;
+
+ if not Found then
+ Error_Pragma ("no procedures found for pragma%");
+ end if;
+ end;
+
+ -----------------
+ -- No_Run_Time --
+ -----------------
+
+ -- pragma No_Run_Time
+
+ when Pragma_No_Run_Time =>
+ GNAT_Pragma;
+ Check_Valid_Configuration_Pragma;
+ Check_Arg_Count (0);
+ Set_No_Run_Time_Mode;
+
+ -----------------------
+ -- Normalize_Scalars --
+ -----------------------
+
+ -- pragma Normalize_Scalars;
+
+ when Pragma_Normalize_Scalars =>
+ Check_Ada_83_Warning;
+ Check_Arg_Count (0);
+ Check_Valid_Configuration_Pragma;
+ Normalize_Scalars := True;
+ Init_Or_Norm_Scalars := True;
+
+ --------------
+ -- Optimize --
+ --------------
+
+ -- pragma Optimize (Time | Space);
+
+ -- The actual check for optimize is done in Gigi. Note that this
+ -- pragma does not actually change the optimization setting, it
+ -- simply checks that it is consistent with the pragma.
+
+ when Pragma_Optimize =>
+ Check_No_Identifiers;
+ Check_Arg_Count (1);
+ Check_Arg_Is_One_Of (Arg1, Name_Time, Name_Space, Name_Off);
+
+ ----------
+ -- Pack --
+ ----------
+
+ -- pragma Pack (first_subtype_LOCAL_NAME);
+
+ when Pragma_Pack => Pack : declare
+ Assoc : Node_Id := Arg1;
+ Type_Id : Node_Id;
+ Typ : Entity_Id;
+
+ begin
+ Check_No_Identifiers;
+ Check_Arg_Count (1);
+ Check_Arg_Is_Local_Name (Arg1);
+
+ Type_Id := Expression (Assoc);
+ Find_Type (Type_Id);
+ Typ := Entity (Type_Id);
+
+ if Typ = Any_Type
+ or else Rep_Item_Too_Early (Typ, N)
+ then
+ return;
+ else
+ Typ := Underlying_Type (Typ);
+ end if;
+
+ if not Is_Array_Type (Typ) and then not Is_Record_Type (Typ) then
+ Error_Pragma ("pragma% must specify array or record type");
+ end if;
+
+ Check_First_Subtype (Arg1);
+
+ if Has_Pragma_Pack (Typ) then
+ Error_Pragma ("duplicate pragma%, only one allowed");
+
+ -- Array type. We set the Has_Pragma_Pack flag, and Is_Packed,
+ -- but not Has_Non_Standard_Rep, because we don't actually know
+ -- till freeze time if the array can have packed representation.
+ -- That's because in the general case we do not know enough about
+ -- the component type until it in turn is frozen, which certainly
+ -- happens before the array type is frozen, but not necessarily
+ -- till that point (i.e. right now it may be unfrozen).
+
+ elsif Is_Array_Type (Typ) then
+
+ if Has_Aliased_Components (Base_Type (Typ)) then
+ Error_Pragma
+ ("pragma% ignored, cannot pack aliased components?");
+
+ elsif Has_Atomic_Components (Typ) then
+ Error_Pragma
+ ("?pragma% ignored, cannot pack atomic components");
+
+ elsif not Rep_Item_Too_Late (Typ, N) then
+ Set_Is_Packed (Base_Type (Typ));
+ Set_Has_Pragma_Pack (Base_Type (Typ));
+ Set_Has_Non_Standard_Rep (Base_Type (Typ));
+ end if;
+
+ -- Record type. For record types, the pack is always effective
+
+ else -- Is_Record_Type (Typ)
+ if not Rep_Item_Too_Late (Typ, N) then
+ Set_Has_Pragma_Pack (Base_Type (Typ));
+ Set_Is_Packed (Base_Type (Typ));
+ Set_Has_Non_Standard_Rep (Base_Type (Typ));
+ end if;
+ end if;
+ end Pack;
+
+ ----------
+ -- Page --
+ ----------
+
+ -- pragma Page;
+
+ -- There is nothing to do here, since we did all the processing
+ -- for this pragma in Par.Prag (so that it works properly even in
+ -- syntax only mode)
+
+ when Pragma_Page =>
+ null;
+
+ -------------
+ -- Passive --
+ -------------
+
+ -- pragma Passive [(PASSIVE_FORM)];
+
+ -- PASSIVE_FORM ::= Semaphore | No
+
+ when Pragma_Passive =>
+ GNAT_Pragma;
+
+ if Nkind (Parent (N)) /= N_Task_Definition then
+ Error_Pragma ("pragma% must be within task definition");
+ end if;
+
+ if Arg_Count /= 0 then
+ Check_Arg_Count (1);
+ Check_Arg_Is_One_Of (Arg1, Name_Semaphore, Name_No);
+ end if;
+
+ -------------
+ -- Polling --
+ -------------
+
+ -- pragma Polling (ON | OFF);
+
+ when Pragma_Polling =>
+ GNAT_Pragma;
+ Check_Arg_Count (1);
+ Check_No_Identifiers;
+ Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
+ Polling_Required := (Chars (Expression (Arg1)) = Name_On);
+
+ ------------------
+ -- Preelaborate --
+ ------------------
+
+ -- pragma Preelaborate [(library_unit_NAME)];
+
+ -- Set the flag Is_Preelaborated of program unit name entity
+
+ when Pragma_Preelaborate => Preelaborate : declare
+ Ent : Entity_Id;
+ Pa : Node_Id := Parent (N);
+ Pk : Node_Kind := Nkind (Pa);
+
+ begin
+ Check_Ada_83_Warning;
+ Check_Valid_Library_Unit_Pragma;
+
+ if Nkind (N) = N_Null_Statement then
+ return;
+ end if;
+
+ Ent := Find_Lib_Unit_Name;
+
+ -- This filters out pragmas inside generic parent then
+ -- show up inside instantiation
+
+ if Present (Ent)
+ and then not (Pk = N_Package_Specification
+ and then Present (Generic_Parent (Pa)))
+ then
+ if not Debug_Flag_U then
+ Set_Is_Preelaborated (Ent);
+ Set_Suppress_Elaboration_Warnings (Ent);
+ end if;
+ end if;
+ end Preelaborate;
+
+ --------------
+ -- Priority --
+ --------------
+
+ -- pragma Priority (EXPRESSION);
+
+ when Pragma_Priority => Priority : declare
+ P : constant Node_Id := Parent (N);
+ Arg : Node_Id;
+
+ begin
+ Check_No_Identifiers;
+ Check_Arg_Count (1);
+
+ Arg := Expression (Arg1);
+ Analyze_And_Resolve (Arg, Standard_Integer);
+
+ if not Is_Static_Expression (Arg) then
+ Check_Restriction (Static_Priorities, Arg);
+ end if;
+
+ -- Subprogram case
+
+ if Nkind (P) = N_Subprogram_Body then
+ Check_In_Main_Program;
+
+ -- Must be static
+
+ if not Is_Static_Expression (Arg) then
+ Error_Pragma_Arg
+ ("main subprogram priority is not static", Arg1);
+
+ -- If constraint error, then we already signalled an error
+
+ elsif Raises_Constraint_Error (Arg) then
+ null;
+
+ -- Otherwise check in range
+
+ else
+ declare
+ Val : constant Uint := Expr_Value (Arg);
+
+ begin
+ if Val < 0
+ or else Val > Expr_Value (Expression
+ (Parent (RTE (RE_Max_Priority))))
+ then
+ Error_Pragma_Arg
+ ("main subprogram priority is out of range", Arg1);
+ end if;
+ end;
+ end if;
+
+ Set_Main_Priority
+ (Current_Sem_Unit, UI_To_Int (Expr_Value (Arg)));
+
+ -- Task or Protected, must be of type Integer
+
+ elsif Nkind (P) = N_Protected_Definition
+ or else
+ Nkind (P) = N_Task_Definition
+ then
+ if Expander_Active then
+ Rewrite (Arg,
+ Convert_To (RTE (RE_Any_Priority), Arg));
+ end if;
+
+ -- Anything else is incorrect
+
+ else
+ Pragma_Misplaced;
+ end if;
+
+ if Has_Priority_Pragma (P) then
+ Error_Pragma ("duplicate pragma% not allowed");
+ else
+ Set_Has_Priority_Pragma (P, True);
+
+ if Nkind (P) = N_Protected_Definition
+ or else
+ Nkind (P) = N_Task_Definition
+ then
+ Record_Rep_Item (Defining_Identifier (Parent (P)), N);
+ -- exp_ch9 should use this ???
+ end if;
+ end if;
+
+ end Priority;
+
+ --------------------------
+ -- Propagate_Exceptions --
+ --------------------------
+
+ -- pragma Propagate_Exceptions;
+
+ when Pragma_Propagate_Exceptions =>
+ GNAT_Pragma;
+ Check_Arg_Count (0);
+
+ if In_Extended_Main_Source_Unit (N) then
+ Propagate_Exceptions := True;
+ end if;
+
+ ------------------
+ -- Psect_Object --
+ ------------------
+
+ -- pragma Psect_Object (
+ -- [Internal =>] LOCAL_NAME,
+ -- [, [External =>] EXTERNAL_SYMBOL]
+ -- [, [Size =>] EXTERNAL_SYMBOL]);
+
+ when Pragma_Psect_Object | Pragma_Common_Object =>
+ Psect_Object : declare
+ Args : Args_List (1 .. 3);
+ Names : Name_List (1 .. 3) := (
+ Name_Internal,
+ Name_External,
+ Name_Size);
+
+ Internal : Node_Id renames Args (1);
+ External : Node_Id renames Args (2);
+ Size : Node_Id renames Args (3);
+
+ R_Internal : Node_Id;
+ R_External : Node_Id;
+
+ MA : Node_Id;
+ Str : String_Id;
+
+ Def_Id : Entity_Id;
+
+ procedure Check_Too_Long (Arg : Node_Id);
+ -- Posts message if the argument is an identifier with more
+ -- than 31 characters, or a string literal with more than
+ -- 31 characters, and we are operating under VMS
+
+ procedure Check_Too_Long (Arg : Node_Id) is
+ X : Node_Id := Original_Node (Arg);
+
+ begin
+ if Nkind (X) /= N_String_Literal
+ and then
+ Nkind (X) /= N_Identifier
+ then
+ Error_Pragma_Arg
+ ("inappropriate argument for pragma %", Arg);
+ end if;
+
+ if OpenVMS_On_Target then
+ if (Nkind (X) = N_String_Literal
+ and then String_Length (Strval (X)) > 31)
+ or else
+ (Nkind (X) = N_Identifier
+ and then Length_Of_Name (Chars (X)) > 31)
+ then
+ Error_Pragma_Arg
+ ("argument for pragma % is longer than 31 characters",
+ Arg);
+ end if;
+ end if;
+ end Check_Too_Long;
+
+ -- Start of processing for Common_Object/Psect_Object
+
+ begin
+ GNAT_Pragma;
+ Gather_Associations (Names, Args);
+ Process_Extended_Import_Export_Internal_Arg (Internal);
+
+ R_Internal := Relocate_Node (Internal);
+
+ Def_Id := Entity (R_Internal);
+
+ if Ekind (Def_Id) /= E_Constant
+ and then Ekind (Def_Id) /= E_Variable
+ then
+ Error_Pragma_Arg
+ ("pragma% must designate an object", Internal);
+ end if;
+
+ Check_Too_Long (R_Internal);
+
+ if Is_Imported (Def_Id) or else Is_Exported (Def_Id) then
+ Error_Pragma_Arg
+ ("cannot use pragma% for imported/exported object",
+ R_Internal);
+ end if;
+
+ if Is_Concurrent_Type (Etype (R_Internal)) then
+ Error_Pragma_Arg
+ ("cannot specify pragma % for task/protected object",
+ R_Internal);
+ end if;
+
+ if Is_Psected (Def_Id) then
+ Error_Msg_N ("?duplicate Psect_Object pragma", N);
+ else
+ Set_Is_Psected (Def_Id);
+ end if;
+
+ if Ekind (Def_Id) = E_Constant then
+ Error_Pragma_Arg
+ ("cannot specify pragma % for a constant", R_Internal);
+ end if;
+
+ if Is_Record_Type (Etype (R_Internal)) then
+ declare
+ Ent : Entity_Id;
+ Decl : Entity_Id;
+
+ begin
+ Ent := First_Entity (Etype (R_Internal));
+ while Present (Ent) loop
+ Decl := Declaration_Node (Ent);
+
+ if Ekind (Ent) = E_Component
+ and then Nkind (Decl) = N_Component_Declaration
+ and then Present (Expression (Decl))
+ then
+ Error_Msg_N
+ ("?object for pragma % has defaults", R_Internal);
+ exit;
+
+ else
+ Next_Entity (Ent);
+ end if;
+ end loop;
+ end;
+ end if;
+
+ if Present (Size) then
+ Check_Too_Long (Size);
+ end if;
+
+ -- Make Psect case-insensitive.
+
+ if Present (External) then
+ Check_Too_Long (External);
+
+ if Nkind (External) = N_String_Literal then
+ String_To_Name_Buffer (Strval (External));
+ else
+ Get_Name_String (Chars (External));
+ end if;
+
+ Set_All_Upper_Case;
+ Start_String;
+ Store_String_Chars (Name_Buffer (1 .. Name_Len));
+ Str := End_String;
+ R_External := Make_String_Literal
+ (Sloc => Sloc (External), Strval => Str);
+ else
+ Get_Name_String (Chars (Internal));
+ Set_All_Upper_Case;
+ Start_String;
+ Store_String_Chars (Name_Buffer (1 .. Name_Len));
+ Str := End_String;
+ R_External := Make_String_Literal
+ (Sloc => Sloc (Internal), Strval => Str);
+ end if;
+
+ -- Transform into pragma Linker_Section, add attributes to
+ -- match what DEC Ada does. Ignore size for now?
+
+ Rewrite (N,
+ Make_Pragma
+ (Sloc (N),
+ Name_Linker_Section,
+ New_List
+ (Make_Pragma_Argument_Association
+ (Sloc => Sloc (R_Internal),
+ Expression => R_Internal),
+ Make_Pragma_Argument_Association
+ (Sloc => Sloc (R_External),
+ Expression => R_External))));
+
+ Analyze (N);
+
+ -- Add Machine_Attribute of "overlaid", so the section overlays
+ -- other sections of the same name.
+
+ Start_String;
+ Store_String_Chars ("overlaid");
+ Str := End_String;
+
+ MA :=
+ Make_Pragma
+ (Sloc (N),
+ Name_Machine_Attribute,
+ New_List
+ (Make_Pragma_Argument_Association
+ (Sloc => Sloc (R_Internal),
+ Expression => R_Internal),
+ Make_Pragma_Argument_Association
+ (Sloc => Sloc (R_External),
+ Expression =>
+ Make_String_Literal
+ (Sloc => Sloc (R_External),
+ Strval => Str))));
+ Analyze (MA);
+
+ -- Add Machine_Attribute of "global", so the section is visible
+ -- everywhere
+
+ Start_String;
+ Store_String_Chars ("global");
+ Str := End_String;
+
+ MA :=
+ Make_Pragma
+ (Sloc (N),
+ Name_Machine_Attribute,
+ New_List
+ (Make_Pragma_Argument_Association
+ (Sloc => Sloc (R_Internal),
+ Expression => R_Internal),
+ Make_Pragma_Argument_Association
+ (Sloc => Sloc (R_External),
+ Expression =>
+ Make_String_Literal
+ (Sloc => Sloc (R_External),
+ Strval => Str))));
+ Analyze (MA);
+
+ -- Add Machine_Attribute of "initialize", so the section is
+ -- demand zeroed.
+
+ Start_String;
+ Store_String_Chars ("initialize");
+ Str := End_String;
+
+ MA :=
+ Make_Pragma
+ (Sloc (N),
+ Name_Machine_Attribute,
+ New_List
+ (Make_Pragma_Argument_Association
+ (Sloc => Sloc (R_Internal),
+ Expression => R_Internal),
+ Make_Pragma_Argument_Association
+ (Sloc => Sloc (R_External),
+ Expression =>
+ Make_String_Literal
+ (Sloc => Sloc (R_External),
+ Strval => Str))));
+ Analyze (MA);
+
+ end Psect_Object;
+
+ ----------
+ -- Pure --
+ ----------
+
+ -- pragma Pure [(library_unit_NAME)];
+
+ when Pragma_Pure => Pure : declare
+ Ent : Entity_Id;
+ begin
+ Check_Ada_83_Warning;
+ Check_Valid_Library_Unit_Pragma;
+
+ if Nkind (N) = N_Null_Statement then
+ return;
+ end if;
+
+ Ent := Find_Lib_Unit_Name;
+ Set_Is_Pure (Ent);
+ Set_Suppress_Elaboration_Warnings (Ent);
+ end Pure;
+
+ -------------------
+ -- Pure_Function --
+ -------------------
+
+ -- pragma Pure_Function ([Entity =>] function_LOCAL_NAME);
+
+ when Pragma_Pure_Function => Pure_Function : declare
+ E_Id : Node_Id;
+ E : Entity_Id;
+ Def_Id : Entity_Id;
+
+ begin
+ GNAT_Pragma;
+ Check_Arg_Count (1);
+ Check_Optional_Identifier (Arg1, Name_Entity);
+ Check_Arg_Is_Local_Name (Arg1);
+ E_Id := Expression (Arg1);
+
+ if Error_Posted (E_Id) then
+ return;
+ end if;
+
+ -- Loop through homonyms (overloadings) of referenced entity
+
+ E := Entity (E_Id);
+ while Present (E) loop
+ Def_Id := Get_Base_Subprogram (E);
+
+ if Ekind (Def_Id) /= E_Function
+ and then Ekind (Def_Id) /= E_Generic_Function
+ and then Ekind (Def_Id) /= E_Operator
+ then
+ Error_Pragma_Arg ("pragma% requires a function name", Arg1);
+ end if;
+
+ Set_Is_Pure (Def_Id);
+ E := Homonym (E);
+ end loop;
+ end Pure_Function;
+
+ --------------------
+ -- Queuing_Policy --
+ --------------------
+
+ -- pragma Queuing_Policy (policy_IDENTIFIER);
+
+ when Pragma_Queuing_Policy => declare
+ QP : Character;
+
+ begin
+ Check_Ada_83_Warning;
+ Check_Arg_Count (1);
+ Check_No_Identifiers;
+ Check_Arg_Is_Queuing_Policy (Arg1);
+ Check_Valid_Configuration_Pragma;
+ Get_Name_String (Chars (Expression (Arg1)));
+ QP := Fold_Upper (Name_Buffer (1));
+
+ if Queuing_Policy /= ' '
+ and then Queuing_Policy /= QP
+ then
+ Error_Msg_Sloc := Queuing_Policy_Sloc;
+ Error_Pragma ("queuing policy incompatible with policy#");
+ else
+ Queuing_Policy := QP;
+ Queuing_Policy_Sloc := Loc;
+ end if;
+ end;
+
+ ---------------------------
+ -- Remote_Call_Interface --
+ ---------------------------
+
+ -- pragma Remote_Call_Interface [(library_unit_NAME)];
+
+ when Pragma_Remote_Call_Interface => Remote_Call_Interface : declare
+ Cunit_Node : Node_Id;
+ Cunit_Ent : Entity_Id;
+ K : Node_Kind;
+
+ begin
+ Check_Ada_83_Warning;
+ Check_Valid_Library_Unit_Pragma;
+
+ if Nkind (N) = N_Null_Statement then
+ return;
+ end if;
+
+ Cunit_Node := Cunit (Current_Sem_Unit);
+ K := Nkind (Unit (Cunit_Node));
+ Cunit_Ent := Cunit_Entity (Current_Sem_Unit);
+
+ if K = N_Package_Declaration
+ or else K = N_Generic_Package_Declaration
+ or else K = N_Subprogram_Declaration
+ or else K = N_Generic_Subprogram_Declaration
+ or else (K = N_Subprogram_Body
+ and then Acts_As_Spec (Unit (Cunit_Node)))
+ then
+ null;
+ else
+ Error_Pragma (
+ "pragma% must apply to package or subprogram declaration");
+ end if;
+
+ Set_Is_Remote_Call_Interface (Cunit_Ent);
+ end Remote_Call_Interface;
+
+ ------------------
+ -- Remote_Types --
+ ------------------
+
+ -- pragma Remote_Types [(library_unit_NAME)];
+
+ when Pragma_Remote_Types => Remote_Types : declare
+ Cunit_Node : Node_Id;
+ Cunit_Ent : Entity_Id;
+
+ begin
+ Check_Ada_83_Warning;
+ Check_Valid_Library_Unit_Pragma;
+
+ if Nkind (N) = N_Null_Statement then
+ return;
+ end if;
+
+ Cunit_Node := Cunit (Current_Sem_Unit);
+ Cunit_Ent := Cunit_Entity (Current_Sem_Unit);
+
+ if Nkind (Unit (Cunit_Node)) /= N_Package_Declaration
+ and then
+ Nkind (Unit (Cunit_Node)) /= N_Generic_Package_Declaration
+ then
+ Error_Pragma (
+ "pragma% can only apply to a package declaration");
+ end if;
+
+ Set_Is_Remote_Types (Cunit_Ent);
+ end Remote_Types;
+
+ ---------------
+ -- Ravenscar --
+ ---------------
+
+ when Pragma_Ravenscar =>
+ GNAT_Pragma;
+ Check_Arg_Count (0);
+ Check_Valid_Configuration_Pragma;
+ Set_Ravenscar;
+
+ -------------------------
+ -- Restricted_Run_Time --
+ -------------------------
+
+ when Pragma_Restricted_Run_Time =>
+ GNAT_Pragma;
+ Check_Arg_Count (0);
+ Check_Valid_Configuration_Pragma;
+ Set_Restricted_Profile;
+
+ ------------------
+ -- Restrictions --
+ ------------------
+
+ -- pragma Restrictions (RESTRICTION {, RESTRICTION});
+
+ -- RESTRICTION ::=
+ -- restriction_IDENTIFIER
+ -- | restriction_parameter_IDENTIFIER => EXPRESSION
+
+ when Pragma_Restrictions => Restrictions_Pragma : declare
+ Arg : Node_Id;
+ R_Id : Restriction_Id;
+ RP_Id : Restriction_Parameter_Id;
+ Id : Name_Id;
+ Expr : Node_Id;
+ Val : Uint;
+
+ begin
+ Check_Ada_83_Warning;
+ Check_At_Least_N_Arguments (1);
+ Check_Valid_Configuration_Pragma;
+
+ Arg := Arg1;
+
+ while Present (Arg) loop
+ Id := Chars (Arg);
+ Expr := Expression (Arg);
+
+ -- Case of no restriction identifier
+
+ if Id = No_Name then
+ if Nkind (Expr) /= N_Identifier then
+ Error_Pragma_Arg
+ ("invalid form for restriction", Arg);
+
+ else
+ R_Id := Get_Restriction_Id (Chars (Expr));
+
+ if R_Id = Not_A_Restriction_Id then
+ Error_Pragma_Arg
+ ("invalid restriction identifier", Arg);
+
+ -- Restriction is active
+
+ else
+ Restrictions (R_Id) := True;
+ Restrictions_Loc (R_Id) := Sloc (N);
+
+ -- Record the restriction if we are in the main unit,
+ -- or in the extended main unit. The reason that we
+ -- test separately for Main_Unit is that gnat.adc is
+ -- processed with Current_Sem_Unit = Main_Unit, but
+ -- nodes in gnat.adc do not appear to be the extended
+ -- main source unit (they probably should do ???)
+
+ if Current_Sem_Unit = Main_Unit
+ or else In_Extended_Main_Source_Unit (N)
+ then
+ Main_Restrictions (R_Id) := True;
+ end if;
+
+ -- A very special case that must be processed here:
+ -- pragma Restrictions (No_Exceptions) turns off all
+ -- run-time checking. This is a bit dubious in terms
+ -- of the formal language definition, but it is what
+ -- is intended by the wording of RM H.4(12).
+
+ if R_Id = No_Exceptions then
+ Scope_Suppress := (others => True);
+ end if;
+ end if;
+ end if;
+
+ -- Case of restriction identifier present
+
+ else
+ RP_Id := Get_Restriction_Parameter_Id (Id);
+ Analyze_And_Resolve (Expr, Any_Integer);
+
+ if RP_Id = Not_A_Restriction_Parameter_Id then
+ Error_Pragma_Arg
+ ("invalid restriction parameter identifier", Arg);
+
+ elsif not Is_OK_Static_Expression (Expr)
+ or else not Is_Integer_Type (Etype (Expr))
+ or else Expr_Value (Expr) < 0
+ then
+ Error_Pragma_Arg
+ ("value must be non-negative static integer", Arg);
+
+ -- Restriction pragma is active
+
+ else
+ Val := Expr_Value (Expr);
+
+ -- Record pragma if most restrictive so far
+
+ if Restriction_Parameters (RP_Id) = No_Uint
+ or else Val < Restriction_Parameters (RP_Id)
+ then
+ Restriction_Parameters (RP_Id) := Expr_Value (Expr);
+ Restriction_Parameters_Loc (RP_Id) := Sloc (N);
+ end if;
+ end if;
+ end if;
+
+ Next (Arg);
+ end loop;
+ end Restrictions_Pragma;
+
+ ----------------
+ -- Reviewable --
+ ----------------
+
+ -- pragma Reviewable;
+
+ when Pragma_Reviewable =>
+ Check_Ada_83_Warning;
+ Check_Arg_Count (0);
+
+ -------------------
+ -- Share_Generic --
+ -------------------
+
+ -- pragma Share_Generic (NAME {, NAME});
+
+ when Pragma_Share_Generic =>
+ GNAT_Pragma;
+ Process_Generic_List;
+
+ ------------
+ -- Shared --
+ ------------
+
+ -- pragma Shared (LOCAL_NAME);
+
+ when Pragma_Shared =>
+ Process_Atomic_Shared_Volatile;
+
+ --------------------
+ -- Shared_Passive --
+ --------------------
+
+ -- pragma Shared_Passive [(library_unit_NAME)];
+
+ -- Set the flag Is_Shared_Passive of program unit name entity
+
+ when Pragma_Shared_Passive => Shared_Passive : declare
+ Cunit_Node : Node_Id;
+ Cunit_Ent : Entity_Id;
+
+ begin
+ Check_Ada_83_Warning;
+ Check_Valid_Library_Unit_Pragma;
+
+ if Nkind (N) = N_Null_Statement then
+ return;
+ end if;
+
+ Cunit_Node := Cunit (Current_Sem_Unit);
+ Cunit_Ent := Cunit_Entity (Current_Sem_Unit);
+
+ if Nkind (Unit (Cunit_Node)) /= N_Package_Declaration
+ and then
+ Nkind (Unit (Cunit_Node)) /= N_Generic_Package_Declaration
+ then
+ Error_Pragma (
+ "pragma% can only apply to a package declaration");
+ end if;
+
+ Set_Is_Shared_Passive (Cunit_Ent);
+ end Shared_Passive;
+
+ ----------------------
+ -- Source_File_Name --
+ ----------------------
+
+ -- pragma Source_File_Name (
+ -- [UNIT_NAME =>] unit_NAME,
+ -- [BODY_FILE_NAME | SPEC_FILE_NAME] => STRING_LITERAL);
+
+ -- No processing here. Processing was completed during parsing,
+ -- since we need to have file names set as early as possible.
+ -- Units are loaded well before semantic processing starts.
+
+ -- The only processing we defer to this point is the check
+ -- for correct placement.
+
+ when Pragma_Source_File_Name =>
+ GNAT_Pragma;
+ Check_Valid_Configuration_Pragma;
+
+ ----------------------
+ -- Source_Reference --
+ ----------------------
+
+ -- pragma Source_Reference (INTEGER_LITERAL [, STRING_LITERAL]);
+
+ -- Nothing to do, all processing completed in Par.Prag, since we
+ -- need the information for possible parser messages that are output
+
+ when Pragma_Source_Reference =>
+ GNAT_Pragma;
+
+ ------------------
+ -- Storage_Size --
+ ------------------
+
+ -- pragma Storage_Size (EXPRESSION);
+
+ when Pragma_Storage_Size => Storage_Size : declare
+ P : constant Node_Id := Parent (N);
+ X : Node_Id;
+
+ begin
+ Check_No_Identifiers;
+ Check_Arg_Count (1);
+
+ -- Set In_Default_Expression for per-object case???
+
+ X := Expression (Arg1);
+ Analyze_And_Resolve (X, Any_Integer);
+
+ if not Is_Static_Expression (X) then
+ Check_Restriction (Static_Storage_Size, X);
+ end if;
+
+ if Nkind (P) /= N_Task_Definition then
+ Pragma_Misplaced;
+ return;
+
+ else
+ if Has_Storage_Size_Pragma (P) then
+ Error_Pragma ("duplicate pragma% not allowed");
+ else
+ Set_Has_Storage_Size_Pragma (P, True);
+ end if;
+
+ Record_Rep_Item (Defining_Identifier (Parent (P)), N);
+ -- ??? exp_ch9 should use this!
+ end if;
+ end Storage_Size;
+
+ ------------------
+ -- Storage_Unit --
+ ------------------
+
+ -- pragma Storage_Unit (NUMERIC_LITERAL);
+
+ -- Only permitted argument is System'Storage_Unit value
+
+ when Pragma_Storage_Unit =>
+ Check_No_Identifiers;
+ Check_Arg_Count (1);
+ Check_Arg_Is_Integer_Literal (Arg1);
+
+ if Intval (Expression (Arg1)) /=
+ UI_From_Int (Ttypes.System_Storage_Unit)
+ then
+ Error_Msg_Uint_1 := UI_From_Int (Ttypes.System_Storage_Unit);
+ Error_Pragma_Arg
+ ("the only allowed argument for pragma% is ^", Arg1);
+ end if;
+
+ --------------------
+ -- Stream_Convert --
+ --------------------
+
+ -- pragma Stream_Convert (
+ -- [Entity =>] type_LOCAL_NAME,
+ -- [Read =>] function_NAME,
+ -- [Write =>] function NAME);
+
+ when Pragma_Stream_Convert => Stream_Convert : begin
+ GNAT_Pragma;
+ Check_Arg_Count (3);
+ Check_Optional_Identifier (Arg1, Name_Entity);
+ Check_Optional_Identifier (Arg2, Name_Read);
+ Check_Optional_Identifier (Arg3, Name_Write);
+ Check_Arg_Is_Local_Name (Arg1);
+ Check_Non_Overloaded_Function (Arg2);
+ Check_Non_Overloaded_Function (Arg3);
+
+ declare
+ Typ : constant Entity_Id :=
+ Underlying_Type (Entity (Expression (Arg1)));
+ Read : constant Entity_Id := Entity (Expression (Arg2));
+ Write : constant Entity_Id := Entity (Expression (Arg3));
+
+ begin
+ if Etype (Typ) = Any_Type
+ or else
+ Etype (Read) = Any_Type
+ or else
+ Etype (Write) = Any_Type
+ then
+ return;
+ end if;
+
+ Check_First_Subtype (Arg1);
+
+ if Rep_Item_Too_Early (Typ, N)
+ or else
+ Rep_Item_Too_Late (Typ, N)
+ then
+ return;
+ end if;
+
+ if Underlying_Type (Etype (Read)) /= Typ then
+ Error_Pragma_Arg
+ ("incorrect return type for function&", Arg2);
+ end if;
+
+ if Underlying_Type (Etype (First_Formal (Write))) /= Typ then
+ Error_Pragma_Arg
+ ("incorrect parameter type for function&", Arg3);
+ end if;
+
+ if Underlying_Type (Etype (First_Formal (Read))) /=
+ Underlying_Type (Etype (Write))
+ then
+ Error_Pragma_Arg
+ ("result type of & does not match Read parameter type",
+ Arg3);
+ end if;
+ end;
+ end Stream_Convert;
+
+ -------------------------
+ -- Style_Checks (GNAT) --
+ -------------------------
+
+ -- pragma Style_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
+
+ -- This is processed by the parser since some of the style
+ -- checks take place during source scanning and parsing. This
+ -- means that we don't need to issue error messages here.
+
+ when Pragma_Style_Checks => Style_Checks : declare
+ A : constant Node_Id := Expression (Arg1);
+ S : String_Id;
+ C : Char_Code;
+
+ begin
+ GNAT_Pragma;
+ Check_No_Identifiers;
+
+ -- Two argument form
+
+ if Arg_Count = 2 then
+ Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
+
+ declare
+ E_Id : Node_Id;
+ E : Entity_Id;
+
+ begin
+ E_Id := Expression (Arg2);
+ Analyze (E_Id);
+
+ if not Is_Entity_Name (E_Id) then
+ Error_Pragma_Arg
+ ("second argument of pragma% must be entity name",
+ Arg2);
+ end if;
+
+ E := Entity (E_Id);
+
+ if E = Any_Id then
+ return;
+ else
+ loop
+ Set_Suppress_Style_Checks (E,
+ (Chars (Expression (Arg1)) = Name_Off));
+ exit when No (Homonym (E));
+ E := Homonym (E);
+ end loop;
+ end if;
+ end;
+
+ -- One argument form
+
+ else
+ Check_Arg_Count (1);
+
+ if Nkind (A) = N_String_Literal then
+ S := Strval (A);
+
+ declare
+ Slen : Natural := Natural (String_Length (S));
+ Options : String (1 .. Slen);
+ J : Natural;
+
+ begin
+ J := 1;
+ loop
+ C := Get_String_Char (S, Int (J));
+ exit when not In_Character_Range (C);
+ Options (J) := Get_Character (C);
+
+ if J = Slen then
+ Set_Style_Check_Options (Options);
+ exit;
+ else
+ J := J + 1;
+ end if;
+ end loop;
+ end;
+
+ elsif Nkind (A) = N_Identifier then
+
+ if Chars (A) = Name_All_Checks then
+ Set_Default_Style_Check_Options;
+
+ elsif Chars (A) = Name_On then
+ Style_Check := True;
+
+ elsif Chars (A) = Name_Off then
+ Style_Check := False;
+
+ end if;
+ end if;
+ end if;
+ end Style_Checks;
+
+ --------------
+ -- Subtitle --
+ --------------
+
+ -- pragma Subtitle ([Subtitle =>] STRING_LITERAL);
+
+ when Pragma_Subtitle =>
+ GNAT_Pragma;
+ Check_Arg_Count (1);
+ Check_Optional_Identifier (Arg1, Name_Subtitle);
+ Check_Arg_Is_String_Literal (Arg1);
+
+ --------------
+ -- Suppress --
+ --------------
+
+ -- pragma Suppress (IDENTIFIER [, [On =>] NAME]);
+
+ when Pragma_Suppress =>
+ Process_Suppress_Unsuppress (True);
+
+ ------------------
+ -- Suppress_All --
+ ------------------
+
+ -- pragma Suppress_All;
+
+ -- The only check made here is that the pragma appears in the
+ -- proper place, i.e. following a compilation unit. If indeed
+ -- it appears in this context, then the parser has already
+ -- inserted an equivalent pragma Suppress (All_Checks) to get
+ -- the required effect.
+
+ when Pragma_Suppress_All =>
+ GNAT_Pragma;
+ Check_Arg_Count (0);
+
+ if Nkind (Parent (N)) /= N_Compilation_Unit_Aux
+ or else not Is_List_Member (N)
+ or else List_Containing (N) /= Pragmas_After (Parent (N))
+ then
+ Error_Pragma
+ ("misplaced pragma%, must follow compilation unit");
+ end if;
+
+ -------------------------
+ -- Suppress_Debug_Info --
+ -------------------------
+
+ -- pragma Suppress_Debug_Info ([Entity =>] LOCAL_NAME);
+
+ when Pragma_Suppress_Debug_Info =>
+ GNAT_Pragma;
+ Check_Arg_Count (1);
+ Check_Arg_Is_Local_Name (Arg1);
+ Check_Optional_Identifier (Arg1, Name_Entity);
+ Set_Debug_Info_Off (Entity (Get_Pragma_Arg (Arg1)));
+
+ -----------------------------
+ -- Suppress_Initialization --
+ -----------------------------
+
+ -- pragma Suppress_Initialization ([Entity =>] type_Name);
+
+ when Pragma_Suppress_Initialization => Suppress_Init : declare
+ E_Id : Node_Id;
+ E : Entity_Id;
+
+ begin
+ GNAT_Pragma;
+ Check_Arg_Count (1);
+ Check_Optional_Identifier (Arg1, Name_Entity);
+ Check_Arg_Is_Local_Name (Arg1);
+
+ E_Id := Expression (Arg1);
+
+ if Etype (E_Id) = Any_Type then
+ return;
+ end if;
+
+ E := Entity (E_Id);
+
+ if Is_Type (E) then
+ if Is_Incomplete_Or_Private_Type (E) then
+ if No (Full_View (Base_Type (E))) then
+ Error_Pragma_Arg
+ ("argument of pragma% cannot be an incomplete type",
+ Arg1);
+ else
+ Set_Suppress_Init_Proc (Full_View (Base_Type (E)));
+ end if;
+ else
+ Set_Suppress_Init_Proc (Base_Type (E));
+ end if;
+
+ else
+ Error_Pragma_Arg
+ ("pragma% requires argument that is a type name", Arg1);
+ end if;
+ end Suppress_Init;
+
+ -----------------
+ -- System_Name --
+ -----------------
+
+ -- pragma System_Name (DIRECT_NAME);
+
+ -- Syntax check: one argument, which must be the identifier GNAT
+ -- or the identifier GCC, no other identifiers are acceptable.
+
+ when Pragma_System_Name =>
+ Check_No_Identifiers;
+ Check_Arg_Count (1);
+ Check_Arg_Is_One_Of (Arg1, Name_Gcc, Name_Gnat);
+
+ -----------------------------
+ -- Task_Dispatching_Policy --
+ -----------------------------
+
+ -- pragma Task_Dispatching_Policy (policy_IDENTIFIER);
+
+ when Pragma_Task_Dispatching_Policy => declare
+ DP : Character;
+
+ begin
+ Check_Ada_83_Warning;
+ Check_Arg_Count (1);
+ Check_No_Identifiers;
+ Check_Arg_Is_Task_Dispatching_Policy (Arg1);
+ Check_Valid_Configuration_Pragma;
+ Get_Name_String (Chars (Expression (Arg1)));
+ DP := Fold_Upper (Name_Buffer (1));
+
+ if Task_Dispatching_Policy /= ' '
+ and then Task_Dispatching_Policy /= DP
+ then
+ Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
+ Error_Pragma
+ ("task dispatching policy incompatible with policy#");
+ else
+ Task_Dispatching_Policy := DP;
+ Task_Dispatching_Policy_Sloc := Loc;
+ end if;
+ end;
+
+ --------------
+ -- Task_Info --
+ --------------
+
+ -- pragma Task_Info (EXPRESSION);
+
+ when Pragma_Task_Info => Task_Info : declare
+ P : constant Node_Id := Parent (N);
+
+ begin
+ GNAT_Pragma;
+
+ if Nkind (P) /= N_Task_Definition then
+ Error_Pragma ("pragma% must appear in task definition");
+ end if;
+
+ Check_No_Identifiers;
+ Check_Arg_Count (1);
+
+ Analyze_And_Resolve (Expression (Arg1), RTE (RE_Task_Info_Type));
+
+ if Etype (Expression (Arg1)) = Any_Type then
+ return;
+ end if;
+
+ if Has_Task_Info_Pragma (P) then
+ Error_Pragma ("duplicate pragma% not allowed");
+ else
+ Set_Has_Task_Info_Pragma (P, True);
+ end if;
+
+ end Task_Info;
+
+ ---------------
+ -- Task_Name --
+ ---------------
+
+ -- pragma Task_Name (string_EXPRESSION);
+
+ when Pragma_Task_Name => Task_Name : declare
+ -- pragma Priority (EXPRESSION);
+
+ P : constant Node_Id := Parent (N);
+ Arg : Node_Id;
+
+ begin
+ Check_No_Identifiers;
+ Check_Arg_Count (1);
+
+ Arg := Expression (Arg1);
+ Analyze_And_Resolve (Arg, Standard_String);
+
+ if Nkind (P) /= N_Task_Definition then
+ Pragma_Misplaced;
+ end if;
+
+ if Has_Task_Name_Pragma (P) then
+ Error_Pragma ("duplicate pragma% not allowed");
+ else
+ Set_Has_Task_Name_Pragma (P, True);
+ Record_Rep_Item (Defining_Identifier (Parent (P)), N);
+ end if;
+
+ end Task_Name;
+
+ ------------------
+ -- Task_Storage --
+ ------------------
+
+ -- pragma Task_Storage (
+ -- [Task_Type =>] LOCAL_NAME,
+ -- [Top_Guard =>] static_integer_EXPRESSION);
+
+ when Pragma_Task_Storage => Task_Storage : declare
+ Args : Args_List (1 .. 2);
+ Names : Name_List (1 .. 2) := (
+ Name_Task_Type,
+ Name_Top_Guard);
+
+ Task_Type : Node_Id renames Args (1);
+ Top_Guard : Node_Id renames Args (2);
+
+ Ent : Entity_Id;
+
+ begin
+ GNAT_Pragma;
+ Gather_Associations (Names, Args);
+ Check_Arg_Is_Local_Name (Task_Type);
+
+ Ent := Entity (Task_Type);
+
+ if not Is_Task_Type (Ent) then
+ Error_Pragma_Arg
+ ("argument for pragma% must be task type", Task_Type);
+ end if;
+
+ if No (Top_Guard) then
+ Error_Pragma_Arg
+ ("pragma% takes two arguments", Task_Type);
+ else
+ Check_Arg_Is_Static_Expression (Top_Guard, Any_Integer);
+ end if;
+
+ Check_First_Subtype (Task_Type);
+
+ if Rep_Item_Too_Late (Ent, N) then
+ raise Pragma_Exit;
+ end if;
+
+ end Task_Storage;
+
+ ----------------
+ -- Time_Slice --
+ ----------------
+
+ -- pragma Time_Slice (static_duration_EXPRESSION);
+
+ when Pragma_Time_Slice => Time_Slice : declare
+ Val : Ureal;
+ Nod : Node_Id;
+
+ begin
+ GNAT_Pragma;
+ Check_Arg_Count (1);
+ Check_No_Identifiers;
+ Check_In_Main_Program;
+ Check_Arg_Is_Static_Expression (Arg1, Standard_Duration);
+
+ if not Error_Posted (Arg1) then
+ Nod := Next (N);
+ while Present (Nod) loop
+ if Nkind (Nod) = N_Pragma
+ and then Chars (Nod) = Name_Time_Slice
+ then
+ Error_Msg_Name_1 := Chars (N);
+ Error_Msg_N ("duplicate pragma% not permitted", Nod);
+ end if;
+
+ Next (Nod);
+ end loop;
+ end if;
+
+ -- Process only if in main unit
+
+ if Get_Source_Unit (Loc) = Main_Unit then
+ Opt.Time_Slice_Set := True;
+ Val := Expr_Value_R (Expression (Arg1));
+
+ if Val <= Ureal_0 then
+ Opt.Time_Slice_Value := 0;
+
+ elsif Val > UR_From_Uint (UI_From_Int (1000)) then
+ Opt.Time_Slice_Value := 1_000_000_000;
+
+ else
+ Opt.Time_Slice_Value :=
+ UI_To_Int (UR_To_Uint (Val * UI_From_Int (1_000_000)));
+ end if;
+ end if;
+ end Time_Slice;
+
+ -----------
+ -- Title --
+ -----------
+
+ -- pragma Title (TITLING_OPTION [, TITLING OPTION]);
+
+ -- TITLING_OPTION ::=
+ -- [Title =>] STRING_LITERAL
+ -- | [Subtitle =>] STRING_LITERAL
+
+ when Pragma_Title => Title : declare
+ Args : Args_List (1 .. 2);
+ Names : Name_List (1 .. 2) := (
+ Name_Title,
+ Name_Subtitle);
+
+ begin
+ GNAT_Pragma;
+ Gather_Associations (Names, Args);
+
+ for J in 1 .. 2 loop
+ if Present (Args (J)) then
+ Check_Arg_Is_String_Literal (Args (J));
+ end if;
+ end loop;
+ end Title;
+
+ ---------------------
+ -- Unchecked_Union --
+ ---------------------
+
+ -- pragma Unchecked_Union (first_subtype_LOCAL_NAME)
+
+ when Pragma_Unchecked_Union => Unchecked_Union : declare
+ Assoc : Node_Id := Arg1;
+ Type_Id : Node_Id := Expression (Assoc);
+ Typ : Entity_Id;
+ Discr : Entity_Id;
+ Tdef : Node_Id;
+ Clist : Node_Id;
+ Vpart : Node_Id;
+ Comp : Node_Id;
+ Variant : Node_Id;
+
+ begin
+ GNAT_Pragma;
+ Check_No_Identifiers;
+ Check_Arg_Count (1);
+ Check_Arg_Is_Local_Name (Arg1);
+
+ Find_Type (Type_Id);
+ Typ := Entity (Type_Id);
+
+ if Typ = Any_Type
+ or else Rep_Item_Too_Early (Typ, N)
+ then
+ return;
+ else
+ Typ := Underlying_Type (Typ);
+ end if;
+
+ if Rep_Item_Too_Late (Typ, N) then
+ return;
+ end if;
+
+ Check_First_Subtype (Arg1);
+
+ -- Note remaining cases are references to a type in the current
+ -- declarative part. If we find an error, we post the error on
+ -- the relevant type declaration at an appropriate point.
+
+ if not Is_Record_Type (Typ) then
+ Error_Msg_N ("Unchecked_Union must be record type", Typ);
+ return;
+
+ elsif Is_Tagged_Type (Typ) then
+ Error_Msg_N ("Unchecked_Union must not be tagged", Typ);
+ return;
+
+ elsif Is_Limited_Type (Typ) then
+ Error_Msg_N
+ ("Unchecked_Union must not be limited record type", Typ);
+ return;
+
+ else
+ if not Has_Discriminants (Typ) then
+ Error_Msg_N
+ ("Unchecked_Union must have one discriminant", Typ);
+ return;
+ end if;
+
+ Discr := First_Discriminant (Typ);
+
+ if Present (Next_Discriminant (Discr)) then
+ Error_Msg_N
+ ("Unchecked_Union must have exactly one discriminant",
+ Next_Discriminant (Discr));
+ return;
+ end if;
+
+ if No (Discriminant_Default_Value (Discr)) then
+ Error_Msg_N
+ ("Unchecked_Union discriminant must have default value",
+ Discr);
+ end if;
+
+ Tdef := Type_Definition (Declaration_Node (Typ));
+ Clist := Component_List (Tdef);
+
+ if No (Clist) or else No (Variant_Part (Clist)) then
+ Error_Msg_N
+ ("Unchecked_Union must have variant part",
+ Tdef);
+ return;
+ end if;
+
+ Vpart := Variant_Part (Clist);
+
+ if Is_Non_Empty_List (Component_Items (Clist)) then
+ Error_Msg_N
+ ("components before variant not allowed " &
+ "in Unchecked_Union",
+ First (Component_Items (Clist)));
+ end if;
+
+ Variant := First (Variants (Vpart));
+ while Present (Variant) loop
+ Clist := Component_List (Variant);
+
+ if Present (Variant_Part (Clist)) then
+ Error_Msg_N
+ ("Unchecked_Union may not have nested variants",
+ Variant_Part (Clist));
+ end if;
+
+ if not Is_Non_Empty_List (Component_Items (Clist)) then
+ Error_Msg_N
+ ("Unchecked_Union may not have empty component list",
+ Variant);
+ return;
+ end if;
+
+ Comp := First (Component_Items (Clist));
+
+ if Nkind (Comp) = N_Component_Declaration then
+
+ if Present (Expression (Comp)) then
+ Error_Msg_N
+ ("default initialization not allowed " &
+ "in Unchecked_Union",
+ Expression (Comp));
+ end if;
+
+ declare
+ Sindic : constant Node_Id :=
+ Subtype_Indication (Comp);
+
+ begin
+ if Nkind (Sindic) = N_Subtype_Indication then
+ Check_Static_Constraint (Constraint (Sindic));
+ end if;
+ end;
+ end if;
+
+ if Present (Next (Comp)) then
+ Error_Msg_N
+ ("Unchecked_Union variant can have only one component",
+ Next (Comp));
+ end if;
+
+ Next (Variant);
+ end loop;
+ end if;
+
+ Set_Is_Unchecked_Union (Typ, True);
+ Set_Suppress_Discriminant_Checks (Typ, True);
+ Set_Convention (Typ, Convention_C);
+
+ Set_Has_Unchecked_Union (Base_Type (Typ), True);
+ Set_Is_Unchecked_Union (Base_Type (Typ), True);
+
+ end Unchecked_Union;
+
+ ------------------------
+ -- Unimplemented_Unit --
+ ------------------------
+
+ -- pragma Unimplemented_Unit;
+
+ -- Note: this only gives an error if we are generating code,
+ -- or if we are in a generic library unit (where the pragma
+ -- appears in the body, not in the spec).
+
+ when Pragma_Unimplemented_Unit => Unimplemented_Unit : declare
+ Cunitent : Entity_Id := Cunit_Entity (Get_Source_Unit (Loc));
+ Ent_Kind : Entity_Kind := Ekind (Cunitent);
+
+ begin
+ GNAT_Pragma;
+ Check_Arg_Count (0);
+
+ if Operating_Mode = Generate_Code
+ or else Ent_Kind = E_Generic_Function
+ or else Ent_Kind = E_Generic_Procedure
+ or else Ent_Kind = E_Generic_Package
+ then
+ Get_Name_String (Chars (Cunitent));
+ Set_Casing (Mixed_Case);
+ Write_Str (Name_Buffer (1 .. Name_Len));
+ Write_Str (" is not implemented");
+ Write_Eol;
+ raise Unrecoverable_Error;
+ end if;
+ end Unimplemented_Unit;
+
+ ------------------------------
+ -- Unreserve_All_Interrupts --
+ ------------------------------
+
+ -- pragma Unreserve_All_Interrupts;
+
+ when Pragma_Unreserve_All_Interrupts =>
+ GNAT_Pragma;
+ Check_Arg_Count (0);
+
+ if In_Extended_Main_Code_Unit (Main_Unit_Entity) then
+ Unreserve_All_Interrupts := True;
+ end if;
+
+ ----------------
+ -- Unsuppress --
+ ----------------
+
+ -- pragma Unsuppress (IDENTIFIER [, [On =>] NAME]);
+
+ when Pragma_Unsuppress =>
+ GNAT_Pragma;
+ Process_Suppress_Unsuppress (False);
+
+ -------------------
+ -- Use_VADS_Size --
+ -------------------
+
+ -- pragma Use_VADS_Size;
+
+ when Pragma_Use_VADS_Size =>
+ GNAT_Pragma;
+ Check_Arg_Count (0);
+ Check_Valid_Configuration_Pragma;
+ Use_VADS_Size := True;
+
+ ---------------------
+ -- Validity_Checks --
+ ---------------------
+
+ -- pragma Validity_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
+
+ when Pragma_Validity_Checks => Validity_Checks : declare
+ A : constant Node_Id := Expression (Arg1);
+ S : String_Id;
+ C : Char_Code;
+
+ begin
+ GNAT_Pragma;
+ Check_Arg_Count (1);
+ Check_Valid_Configuration_Pragma;
+ Check_No_Identifiers;
+
+ if Nkind (A) = N_String_Literal then
+ S := Strval (A);
+
+ declare
+ Slen : Natural := Natural (String_Length (S));
+ Options : String (1 .. Slen);
+ J : Natural;
+
+ begin
+ J := 1;
+ loop
+ C := Get_String_Char (S, Int (J));
+ exit when not In_Character_Range (C);
+ Options (J) := Get_Character (C);
+
+ if J = Slen then
+ Set_Validity_Check_Options (Options);
+ exit;
+ else
+ J := J + 1;
+ end if;
+ end loop;
+ end;
+
+ elsif Nkind (A) = N_Identifier then
+
+ if Chars (A) = Name_All_Checks then
+ Set_Validity_Check_Options ("a");
+
+ elsif Chars (A) = Name_On then
+ Validity_Checks_On := True;
+
+ elsif Chars (A) = Name_Off then
+ Validity_Checks_On := False;
+
+ end if;
+ end if;
+ end Validity_Checks;
+
+ --------------
+ -- Volatile --
+ --------------
+
+ -- pragma Volatile (LOCAL_NAME);
+
+ when Pragma_Volatile =>
+ Process_Atomic_Shared_Volatile;
+
+ -------------------------
+ -- Volatile_Components --
+ -------------------------
+
+ -- pragma Volatile_Components (array_LOCAL_NAME);
+
+ -- Volatile is handled by the same circuit as Atomic_Components
+
+ --------------
+ -- Warnings --
+ --------------
+
+ -- pragma Warnings (On | Off, [LOCAL_NAME])
+
+ when Pragma_Warnings =>
+ GNAT_Pragma;
+ Check_At_Least_N_Arguments (1);
+ Check_At_Most_N_Arguments (2);
+ Check_No_Identifiers;
+
+ -- One argument case was processed by parser in Par.Prag
+
+ if Arg_Count /= 1 then
+ Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
+ Check_Arg_Count (2);
+
+ declare
+ E_Id : Node_Id;
+ E : Entity_Id;
+
+ begin
+ E_Id := Expression (Arg2);
+ Analyze (E_Id);
+
+ if not Is_Entity_Name (E_Id) then
+ Error_Pragma_Arg
+ ("second argument of pragma% must be entity name",
+ Arg2);
+ end if;
+
+ E := Entity (E_Id);
+
+ if E = Any_Id then
+ return;
+ else
+ loop
+ Set_Warnings_Off (E,
+ (Chars (Expression (Arg1)) = Name_Off));
+
+ if Is_Enumeration_Type (E) then
+ declare
+ Lit : Entity_Id := First_Literal (E);
+
+ begin
+ while Present (Lit) loop
+ Set_Warnings_Off (Lit);
+ Next_Literal (Lit);
+ end loop;
+ end;
+ end if;
+
+ exit when No (Homonym (E));
+ E := Homonym (E);
+ end loop;
+ end if;
+ end;
+ end if;
+
+ -------------------
+ -- Weak_External --
+ -------------------
+
+ -- pragma Weak_External ([Entity =>] LOCAL_NAME);
+
+ when Pragma_Weak_External => Weak_External : declare
+ Ent : Entity_Id;
+
+ begin
+ GNAT_Pragma;
+ Check_Arg_Count (1);
+ Check_Optional_Identifier (Arg1, Name_Entity);
+ Check_Arg_Is_Library_Level_Local_Name (Arg1);
+ Ent := Entity (Expression (Arg1));
+
+ if Rep_Item_Too_Early (Ent, N) then
+ return;
+ else
+ Ent := Underlying_Type (Ent);
+ end if;
+
+ -- The only processing required is to link this item on to the
+ -- list of rep items for the given entity. This is accomplished
+ -- by the call to Rep_Item_Too_Late (when no error is detected
+ -- and False is returned).
+
+ if Rep_Item_Too_Late (Ent, N) then
+ return;
+ else
+ Set_Has_Gigi_Rep_Item (Ent);
+ end if;
+ end Weak_External;
+
+ end case;
+
+ exception
+ when Pragma_Exit => null;
+
+ end Analyze_Pragma;
+
+ -------------------------
+ -- Get_Base_Subprogram --
+ -------------------------
+
+ function Get_Base_Subprogram (Def_Id : Entity_Id) return Entity_Id is
+ Result : Entity_Id;
+
+ begin
+ Result := Def_Id;
+
+ -- Follow subprogram renaming chain
+
+ while Is_Subprogram (Result)
+ and then
+ (Is_Generic_Instance (Result)
+ or else Nkind (Parent (Declaration_Node (Result))) =
+ N_Subprogram_Renaming_Declaration)
+ and then Present (Alias (Result))
+ loop
+ Result := Alias (Result);
+ end loop;
+
+ return Result;
+ end Get_Base_Subprogram;
+
+ ---------------------------
+ -- Is_Generic_Subprogram --
+ ---------------------------
+
+ function Is_Generic_Subprogram (Id : Entity_Id) return Boolean is
+ begin
+ return Ekind (Id) = E_Generic_Procedure
+ or else Ekind (Id) = E_Generic_Function;
+ end Is_Generic_Subprogram;
+
+ ------------------------------
+ -- Is_Pragma_String_Literal --
+ ------------------------------
+
+ -- This function returns true if the corresponding pragma argument is
+ -- a static string expression. These are the only cases in which string
+ -- literals can appear as pragma arguments. We also allow a string
+ -- literal as the first argument to pragma Assert (although it will
+ -- of course always generate a type error).
+
+ function Is_Pragma_String_Literal (Par : Node_Id) return Boolean is
+ Pragn : constant Node_Id := Parent (Par);
+ Assoc : constant List_Id := Pragma_Argument_Associations (Pragn);
+ Pname : constant Name_Id := Chars (Pragn);
+ Argn : Natural;
+ N : Node_Id;
+
+ begin
+ Argn := 1;
+ N := First (Assoc);
+ loop
+ exit when N = Par;
+ Argn := Argn + 1;
+ Next (N);
+ end loop;
+
+ if Pname = Name_Assert then
+ return True;
+
+ elsif Pname = Name_Export then
+ return Argn > 2;
+
+ elsif Pname = Name_Ident then
+ return Argn = 1;
+
+ elsif Pname = Name_Import then
+ return Argn > 2;
+
+ elsif Pname = Name_Interface_Name then
+ return Argn > 1;
+
+ elsif Pname = Name_Linker_Alias then
+ return Argn = 2;
+
+ elsif Pname = Name_Linker_Section then
+ return Argn = 2;
+
+ elsif Pname = Name_Machine_Attribute then
+ return Argn = 2;
+
+ elsif Pname = Name_Source_File_Name then
+ return True;
+
+ elsif Pname = Name_Source_Reference then
+ return Argn = 2;
+
+ elsif Pname = Name_Title then
+ return True;
+
+ elsif Pname = Name_Subtitle then
+ return True;
+
+ else
+ return False;
+ end if;
+
+ end Is_Pragma_String_Literal;
+
+ --------------------------------------
+ -- Process_Compilation_Unit_Pragmas --
+ --------------------------------------
+
+ procedure Process_Compilation_Unit_Pragmas (N : Node_Id) is
+ begin
+ -- A special check for pragma Suppress_All. This is a strange DEC
+ -- pragma, strange because it comes at the end of the unit. If we
+ -- have a pragma Suppress_All in the Pragmas_After of the current
+ -- unit, then we insert a pragma Suppress (All_Checks) at the start
+ -- of the context clause to ensure the correct processing.
+
+ declare
+ PA : constant List_Id := Pragmas_After (Aux_Decls_Node (N));
+ P : Node_Id;
+
+ begin
+ if Present (PA) then
+ P := First (PA);
+ while Present (P) loop
+ if Chars (P) = Name_Suppress_All then
+ Prepend_To (Context_Items (N),
+ Make_Pragma (Sloc (P),
+ Chars => Name_Suppress,
+ Pragma_Argument_Associations => New_List (
+ Make_Pragma_Argument_Association (Sloc (P),
+ Expression =>
+ Make_Identifier (Sloc (P),
+ Chars => Name_All_Checks)))));
+ exit;
+ end if;
+
+ Next (P);
+ end loop;
+ end if;
+ end;
+ end Process_Compilation_Unit_Pragmas;
+
+ --------------------------------
+ -- Set_Encoded_Interface_Name --
+ --------------------------------
+
+ procedure Set_Encoded_Interface_Name (E : Entity_Id; S : Node_Id) is
+ Str : constant String_Id := Strval (S);
+ Len : constant Int := String_Length (Str);
+ CC : Char_Code;
+ C : Character;
+ J : Int;
+
+ Hex : constant array (0 .. 15) of Character := "0123456789abcdef";
+
+ procedure Encode;
+ -- Stores encoded value of character code CC. The encoding we
+ -- use an underscore followed by four lower case hex digits.
+
+ procedure Encode is
+ begin
+ Store_String_Char (Get_Char_Code ('_'));
+ Store_String_Char
+ (Get_Char_Code (Hex (Integer (CC / 2 ** 12))));
+ Store_String_Char
+ (Get_Char_Code (Hex (Integer (CC / 2 ** 8 and 16#0F#))));
+ Store_String_Char
+ (Get_Char_Code (Hex (Integer (CC / 2 ** 4 and 16#0F#))));
+ Store_String_Char
+ (Get_Char_Code (Hex (Integer (CC and 16#0F#))));
+ end Encode;
+
+ -- Start of processing for Set_Encoded_Interface_Name
+
+ begin
+ -- If first character is asterisk, this is a link name, and we
+ -- leave it completely unmodified. We also ignore null strings
+ -- (the latter case happens only in error cases) and no encoding
+ -- should occur for Java interface names.
+
+ if Len = 0
+ or else Get_String_Char (Str, 1) = Get_Char_Code ('*')
+ or else Java_VM
+ then
+ Set_Interface_Name (E, S);
+
+ else
+ J := 1;
+ loop
+ CC := Get_String_Char (Str, J);
+
+ exit when not In_Character_Range (CC);
+
+ C := Get_Character (CC);
+
+ exit when C /= '_' and then C /= '$'
+ and then C not in '0' .. '9'
+ and then C not in 'a' .. 'z'
+ and then C not in 'A' .. 'Z';
+
+ if J = Len then
+ Set_Interface_Name (E, S);
+ return;
+
+ else
+ J := J + 1;
+ end if;
+ end loop;
+
+ -- Here we need to encode. The encoding we use as follows:
+ -- three underscores + four hex digits (lower case)
+
+ Start_String;
+
+ for J in 1 .. String_Length (Str) loop
+ CC := Get_String_Char (Str, J);
+
+ if not In_Character_Range (CC) then
+ Encode;
+ else
+ C := Get_Character (CC);
+
+ if C = '_' or else C = '$'
+ or else C in '0' .. '9'
+ or else C in 'a' .. 'z'
+ or else C in 'A' .. 'Z'
+ then
+ Store_String_Char (CC);
+ else
+ Encode;
+ end if;
+ end if;
+ end loop;
+
+ Set_Interface_Name (E,
+ Make_String_Literal (Sloc (S),
+ Strval => End_String));
+ end if;
+ end Set_Encoded_Interface_Name;
+
+ -------------------
+ -- Set_Unit_Name --
+ -------------------
+
+ procedure Set_Unit_Name (N : Node_Id; With_Item : Node_Id) is
+ Pref : Node_Id;
+ Scop : Entity_Id;
+
+ begin
+ if Nkind (N) = N_Identifier
+ and then Nkind (With_Item) = N_Identifier
+ then
+ Set_Entity (N, Entity (With_Item));
+
+ elsif Nkind (N) = N_Selected_Component then
+ Change_Selected_Component_To_Expanded_Name (N);
+ Set_Entity (N, Entity (With_Item));
+ Set_Entity (Selector_Name (N), Entity (N));
+
+ Pref := Prefix (N);
+ Scop := Scope (Entity (N));
+
+ while Nkind (Pref) = N_Selected_Component loop
+ Change_Selected_Component_To_Expanded_Name (Pref);
+ Set_Entity (Selector_Name (Pref), Scop);
+ Set_Entity (Pref, Scop);
+ Pref := Prefix (Pref);
+ Scop := Scope (Scop);
+ end loop;
+
+ Set_Entity (Pref, Scop);
+ end if;
+ end Set_Unit_Name;
+
+end Sem_Prag;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S E M _ P R A G --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.6 $ --
+-- --
+-- Copyright (C) 1992-1997 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 handling is isolated in a separate package
+-- (logically this processing belongs in chapter 4)
+
+with Types; use Types;
+package Sem_Prag is
+
+ procedure Analyze_Pragma (N : Node_Id);
+ -- Analyze procedure for pragma reference node N
+
+ function Is_Pragma_String_Literal (Par : Node_Id) return Boolean;
+ -- Given an N_Pragma_Argument_Association node, Par, which has the form
+ -- of an operator symbol, determines whether or not it should be treated
+ -- as an string literal. This is called by Sem_Ch6.Analyze_Operator_Symbol.
+ -- If True is returned, the argument is converted to a string literal. If
+ -- False is returned, then the argument is treated as an entity reference
+ -- to the operator.
+
+ procedure Process_Compilation_Unit_Pragmas (N : Node_Id);
+ -- Called at the start of processing compilation unit N to deal with
+ -- any special issues regarding pragmas. In particular, we have to
+ -- deal with Suppress_All at this stage, since it appears after the
+ -- unit instead of before.
+
+ procedure Set_Encoded_Interface_Name (E : Entity_Id; S : Node_Id);
+ -- This routine is used to set an encoded interface name. The node
+ -- S is an N_String_Literal node for the external name to be set, and
+ -- E is an entity whose Interface_Name field is to be set. In the
+ -- normal case where S contains a name that is a valid C identifier,
+ -- then S is simply set as the value of the Interface_Name. Otherwise
+ -- it is encoded. See the body for details of the encoding. This
+ -- encoding is only done on VMS systems, since it seems pretty silly,
+ -- but is needed to pass some dubious tests in the test suite.
+
+end Sem_Prag;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S E M _ R E S --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.717 $
+-- --
+-- 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). --
+-- --
+------------------------------------------------------------------------------
+
+with Atree; use Atree;
+with Checks; use Checks;
+with Debug; use Debug;
+with Debug_A; use Debug_A;
+with Einfo; use Einfo;
+with Errout; use Errout;
+with Expander; use Expander;
+with Exp_Ch7; use Exp_Ch7;
+with Exp_Util; use Exp_Util;
+with Freeze; use Freeze;
+with Itypes; use Itypes;
+with Lib; use Lib;
+with Lib.Xref; use Lib.Xref;
+with Namet; use Namet;
+with Nmake; use Nmake;
+with Nlists; use Nlists;
+with Opt; use Opt;
+with Output; use Output;
+with Restrict; use Restrict;
+with Rtsfind; use Rtsfind;
+with Sem; use Sem;
+with Sem_Aggr; use Sem_Aggr;
+with Sem_Attr; use Sem_Attr;
+with Sem_Cat; use Sem_Cat;
+with Sem_Ch4; use Sem_Ch4;
+with Sem_Ch6; use Sem_Ch6;
+with Sem_Ch8; use Sem_Ch8;
+with Sem_Disp; use Sem_Disp;
+with Sem_Dist; use Sem_Dist;
+with Sem_Elab; use Sem_Elab;
+with Sem_Eval; use Sem_Eval;
+with Sem_Intr; use Sem_Intr;
+with Sem_Util; use Sem_Util;
+with Sem_Type; use Sem_Type;
+with Sem_Warn; use Sem_Warn;
+with Sinfo; use Sinfo;
+with Stand; use Stand;
+with Stringt; use Stringt;
+with Targparm; use Targparm;
+with Tbuild; use Tbuild;
+with Uintp; use Uintp;
+with Urealp; use Urealp;
+
+package body Sem_Res is
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ -- Second pass (top-down) type checking and overload resolution procedures
+ -- Typ is the type required by context. These procedures propagate the
+ -- type information recursively to the descendants of N. If the node
+ -- is not overloaded, its Etype is established in the first pass. If
+ -- overloaded, the Resolve routines set the correct type. For arith.
+ -- operators, the Etype is the base type of the context.
+
+ -- Note that Resolve_Attribute is separated off in Sem_Attr
+
+ procedure Ambiguous_Character (C : Node_Id);
+ -- Give list of candidate interpretations when a character literal cannot
+ -- be resolved.
+
+ procedure Check_Discriminant_Use (N : Node_Id);
+ -- Enforce the restrictions on the use of discriminants when constraining
+ -- a component of a discriminated type (record or concurrent type).
+
+ procedure Check_For_Visible_Operator (N : Node_Id; T : Entity_Id);
+ -- Given a node for an operator associated with type T, check that
+ -- the operator is visible. Operators all of whose operands are
+ -- universal must be checked for visibility during resolution
+ -- because their type is not determinable based on their operands.
+
+ function Check_Infinite_Recursion (N : Node_Id) return Boolean;
+ -- Given a call node, N, which is known to occur immediately within the
+ -- subprogram being called, determines whether it is a detectable case of
+ -- an infinite recursion, and if so, outputs appropriate messages. Returns
+ -- True if an infinite recursion is detected, and False otherwise.
+
+ procedure Check_Initialization_Call (N : Entity_Id; Nam : Entity_Id);
+ -- If the type of the object being initialized uses the secondary stack
+ -- directly or indirectly, create a transient scope for the call to the
+ -- Init_Proc. This is because we do not create transient scopes for the
+ -- initialization of individual components within the init_proc itself.
+ -- Could be optimized away perhaps?
+
+ function Is_Predefined_Op (Nam : Entity_Id) return Boolean;
+ -- Utility to check whether the name in the call is a predefined
+ -- operator, in which case the call is made into an operator node.
+ -- An instance of an intrinsic conversion operation may be given
+ -- an operator name, but is not treated like an operator.
+
+ procedure Replace_Actual_Discriminants (N : Node_Id; Default : Node_Id);
+ -- If a default expression in entry call N depends on the discriminants
+ -- of the task, it must be replaced with a reference to the discriminant
+ -- of the task being called.
+
+ procedure Resolve_Allocator (N : Node_Id; Typ : Entity_Id);
+ procedure Resolve_Arithmetic_Op (N : Node_Id; Typ : Entity_Id);
+ procedure Resolve_Call (N : Node_Id; Typ : Entity_Id);
+ procedure Resolve_Character_Literal (N : Node_Id; Typ : Entity_Id);
+ procedure Resolve_Comparison_Op (N : Node_Id; Typ : Entity_Id);
+ procedure Resolve_Conditional_Expression (N : Node_Id; Typ : Entity_Id);
+ procedure Resolve_Equality_Op (N : Node_Id; Typ : Entity_Id);
+ procedure Resolve_Explicit_Dereference (N : Node_Id; Typ : Entity_Id);
+ procedure Resolve_Entity_Name (N : Node_Id; Typ : Entity_Id);
+ procedure Resolve_Indexed_Component (N : Node_Id; Typ : Entity_Id);
+ procedure Resolve_Integer_Literal (N : Node_Id; Typ : Entity_Id);
+ procedure Resolve_Logical_Op (N : Node_Id; Typ : Entity_Id);
+ procedure Resolve_Membership_Op (N : Node_Id; Typ : Entity_Id);
+ procedure Resolve_Null (N : Node_Id; Typ : Entity_Id);
+ procedure Resolve_Operator_Symbol (N : Node_Id; Typ : Entity_Id);
+ procedure Resolve_Op_Concat (N : Node_Id; Typ : Entity_Id);
+ procedure Resolve_Op_Expon (N : Node_Id; Typ : Entity_Id);
+ procedure Resolve_Op_Not (N : Node_Id; Typ : Entity_Id);
+ procedure Resolve_Qualified_Expression (N : Node_Id; Typ : Entity_Id);
+ procedure Resolve_Range (N : Node_Id; Typ : Entity_Id);
+ procedure Resolve_Real_Literal (N : Node_Id; Typ : Entity_Id);
+ procedure Resolve_Reference (N : Node_Id; Typ : Entity_Id);
+ procedure Resolve_Selected_Component (N : Node_Id; Typ : Entity_Id);
+ procedure Resolve_Shift (N : Node_Id; Typ : Entity_Id);
+ procedure Resolve_Short_Circuit (N : Node_Id; Typ : Entity_Id);
+ procedure Resolve_Slice (N : Node_Id; Typ : Entity_Id);
+ procedure Resolve_String_Literal (N : Node_Id; Typ : Entity_Id);
+ procedure Resolve_Subprogram_Info (N : Node_Id; Typ : Entity_Id);
+ procedure Resolve_Type_Conversion (N : Node_Id; Typ : Entity_Id);
+ procedure Resolve_Unary_Op (N : Node_Id; Typ : Entity_Id);
+ procedure Resolve_Unchecked_Expression (N : Node_Id; Typ : Entity_Id);
+ procedure Resolve_Unchecked_Type_Conversion (N : Node_Id; Typ : Entity_Id);
+
+ function Operator_Kind
+ (Op_Name : Name_Id;
+ Is_Binary : Boolean)
+ return Node_Kind;
+ -- Utility to map the name of an operator into the corresponding Node. Used
+ -- by other node rewriting procedures.
+
+ procedure Resolve_Actuals (N : Node_Id; Nam : Entity_Id);
+ -- Resolve actuals of call, and add default expressions for missing ones.
+
+ procedure Resolve_Entry_Call (N : Node_Id; Typ : Entity_Id);
+ -- Called from Resolve_Call, when the prefix denotes an entry or element
+ -- of entry family. Actuals are resolved as for subprograms, and the node
+ -- is rebuilt as an entry call. Also called for protected operations. Typ
+ -- is the context type, which is used when the operation is a protected
+ -- function with no arguments, and the return value is indexed.
+
+ procedure Resolve_Intrinsic_Operator (N : Node_Id; Typ : Entity_Id);
+ -- A call to a user-defined intrinsic operator is rewritten as a call
+ -- to the corresponding predefined operator, with suitable conversions.
+
+ procedure Rewrite_Operator_As_Call (N : Node_Id; Nam : Entity_Id);
+ -- If an operator node resolves to a call to a user-defined operator,
+ -- rewrite the node as a function call.
+
+ procedure Make_Call_Into_Operator
+ (N : Node_Id;
+ Typ : Entity_Id;
+ Op_Id : Entity_Id);
+ -- Inverse transformation: if an operator is given in functional notation,
+ -- then after resolving the node, transform into an operator node, so
+ -- that operands are resolved properly. Recall that predefined operators
+ -- do not have a full signature and special resolution rules apply.
+
+ procedure Rewrite_Renamed_Operator (N : Node_Id; Op : Entity_Id);
+ -- An operator can rename another, e.g. in an instantiation. In that
+ -- case, the proper operator node must be constructed.
+
+ procedure Set_String_Literal_Subtype (N : Node_Id; Typ : Entity_Id);
+ -- The String_Literal_Subtype is built for all strings that are not
+ -- operands of a static concatenation operation. If the argument is not
+ -- a String the function is a no-op.
+
+ procedure Set_Slice_Subtype (N : Node_Id);
+ -- Build subtype of array type, with the range specified by the slice.
+
+ function Unique_Fixed_Point_Type (N : Node_Id) return Entity_Id;
+ -- A universal_fixed expression in an universal context is unambiguous if
+ -- there is only one applicable fixed point type. Determining whether
+ -- there is only one requires a search over all visible entities, and
+ -- happens only in very pathological cases (see 6115-006).
+
+ function Valid_Conversion
+ (N : Node_Id;
+ Target : Entity_Id;
+ Operand : Node_Id)
+ return Boolean;
+ -- Verify legality rules given in 4.6 (8-23). Target is the target
+ -- type of the conversion, which may be an implicit conversion of
+ -- an actual parameter to an anonymous access type (in which case
+ -- N denotes the actual parameter and N = Operand).
+
+ -------------------------
+ -- Ambiguous_Character --
+ -------------------------
+
+ procedure Ambiguous_Character (C : Node_Id) is
+ E : Entity_Id;
+
+ begin
+ if Nkind (C) = N_Character_Literal then
+ Error_Msg_N ("ambiguous character literal", C);
+ Error_Msg_N
+ ("\possible interpretations: Character, Wide_Character!", C);
+
+ E := Current_Entity (C);
+
+ if Present (E) then
+
+ while Present (E) loop
+ Error_Msg_NE ("\possible interpretation:}!", C, Etype (E));
+ E := Homonym (E);
+ end loop;
+ end if;
+ end if;
+ end Ambiguous_Character;
+
+ -------------------------
+ -- Analyze_And_Resolve --
+ -------------------------
+
+ procedure Analyze_And_Resolve (N : Node_Id) is
+ begin
+ Analyze (N);
+ Resolve (N, Etype (N));
+ end Analyze_And_Resolve;
+
+ procedure Analyze_And_Resolve (N : Node_Id; Typ : Entity_Id) is
+ begin
+ Analyze (N);
+ Resolve (N, Typ);
+ end Analyze_And_Resolve;
+
+ -- Version withs check(s) suppressed
+
+ procedure Analyze_And_Resolve
+ (N : Node_Id;
+ Typ : Entity_Id;
+ Suppress : Check_Id)
+ is
+ Scop : Entity_Id := Current_Scope;
+
+ begin
+ if Suppress = All_Checks then
+ declare
+ Svg : constant Suppress_Record := Scope_Suppress;
+
+ begin
+ Scope_Suppress := (others => True);
+ Analyze_And_Resolve (N, Typ);
+ Scope_Suppress := Svg;
+ end;
+
+ else
+ declare
+ Svg : constant Boolean := Get_Scope_Suppress (Suppress);
+
+ begin
+ Set_Scope_Suppress (Suppress, True);
+ Analyze_And_Resolve (N, Typ);
+ Set_Scope_Suppress (Suppress, Svg);
+ end;
+ end if;
+
+ if Current_Scope /= Scop
+ and then Scope_Is_Transient
+ then
+ -- This can only happen if a transient scope was created
+ -- for an inner expression, which will be removed upon
+ -- completion of the analysis of an enclosing construct.
+ -- The transient scope must have the suppress status of
+ -- the enclosing environment, not of this Analyze call.
+
+ Scope_Stack.Table (Scope_Stack.Last).Save_Scope_Suppress :=
+ Scope_Suppress;
+ end if;
+ end Analyze_And_Resolve;
+
+ procedure Analyze_And_Resolve
+ (N : Node_Id;
+ Suppress : Check_Id)
+ is
+ Scop : Entity_Id := Current_Scope;
+
+ begin
+ if Suppress = All_Checks then
+ declare
+ Svg : constant Suppress_Record := Scope_Suppress;
+
+ begin
+ Scope_Suppress := (others => True);
+ Analyze_And_Resolve (N);
+ Scope_Suppress := Svg;
+ end;
+
+ else
+ declare
+ Svg : constant Boolean := Get_Scope_Suppress (Suppress);
+
+ begin
+ Set_Scope_Suppress (Suppress, True);
+ Analyze_And_Resolve (N);
+ Set_Scope_Suppress (Suppress, Svg);
+ end;
+ end if;
+
+ if Current_Scope /= Scop
+ and then Scope_Is_Transient
+ then
+ Scope_Stack.Table (Scope_Stack.Last).Save_Scope_Suppress :=
+ Scope_Suppress;
+ end if;
+ end Analyze_And_Resolve;
+
+ ----------------------------
+ -- Check_Discriminant_Use --
+ ----------------------------
+
+ procedure Check_Discriminant_Use (N : Node_Id) is
+ PN : constant Node_Id := Parent (N);
+ Disc : constant Entity_Id := Entity (N);
+ P : Node_Id;
+ D : Node_Id;
+
+ begin
+ -- Any use in a default expression is legal.
+
+ if In_Default_Expression then
+ null;
+
+ elsif Nkind (PN) = N_Range then
+
+ -- Discriminant cannot be used to constrain a scalar type.
+
+ P := Parent (PN);
+
+ if Nkind (P) = N_Range_Constraint
+ and then Nkind (Parent (P)) = N_Subtype_Indication
+ and then Nkind (Parent (Parent (P))) = N_Component_Declaration
+ then
+ Error_Msg_N ("discriminant cannot constrain scalar type", N);
+
+ elsif Nkind (P) = N_Index_Or_Discriminant_Constraint then
+
+ -- The following check catches the unusual case where
+ -- a discriminant appears within an index constraint
+ -- that is part of a larger expression within a constraint
+ -- on a component, e.g. "C : Int range 1 .. F (new A(1 .. D))".
+ -- For now we only check case of record components, and
+ -- note that a similar check should also apply in the
+ -- case of discriminant constraints below. ???
+
+ -- Note that the check for N_Subtype_Declaration below is to
+ -- detect the valid use of discriminants in the constraints of a
+ -- subtype declaration when this subtype declaration appears
+ -- inside the scope of a record type (which is syntactically
+ -- illegal, but which may be created as part of derived type
+ -- processing for records). See Sem_Ch3.Build_Derived_Record_Type
+ -- for more info.
+
+ if Ekind (Current_Scope) = E_Record_Type
+ and then Scope (Disc) = Current_Scope
+ and then not
+ (Nkind (Parent (P)) = N_Subtype_Indication
+ and then
+ (Nkind (Parent (Parent (P))) = N_Component_Declaration
+ or else Nkind (Parent (Parent (P))) = N_Subtype_Declaration)
+ and then Paren_Count (N) = 0)
+ then
+ Error_Msg_N
+ ("discriminant must appear alone in component constraint", N);
+ return;
+ end if;
+
+ -- Detect a common beginner error:
+ -- type R (D : Positive := 100) is record
+ -- Name: String (1 .. D);
+ -- end record;
+
+ -- The default value causes an object of type R to be
+ -- allocated with room for Positive'Last characters.
+
+ declare
+ SI : Node_Id;
+ T : Entity_Id;
+ TB : Node_Id;
+ CB : Entity_Id;
+
+ function Large_Storage_Type (T : Entity_Id) return Boolean;
+ -- Return True if type T has a large enough range that
+ -- any array whose index type covered the whole range of
+ -- the type would likely raise Storage_Error.
+
+ function Large_Storage_Type (T : Entity_Id) return Boolean is
+ begin
+ return
+ T = Standard_Integer
+ or else
+ T = Standard_Positive
+ or else
+ T = Standard_Natural;
+ end Large_Storage_Type;
+
+ begin
+ -- Check that the Disc has a large range
+
+ if not Large_Storage_Type (Etype (Disc)) then
+ goto No_Danger;
+ end if;
+
+ -- If the enclosing type is limited, we allocate only the
+ -- default value, not the maximum, and there is no need for
+ -- a warning.
+
+ if Is_Limited_Type (Scope (Disc)) then
+ goto No_Danger;
+ end if;
+
+ -- Check that it is the high bound
+
+ if N /= High_Bound (PN)
+ or else not Present (Discriminant_Default_Value (Disc))
+ then
+ goto No_Danger;
+ end if;
+
+ -- Check the array allows a large range at this bound.
+ -- First find the array
+
+ SI := Parent (P);
+
+ if Nkind (SI) /= N_Subtype_Indication then
+ goto No_Danger;
+ end if;
+
+ T := Entity (Subtype_Mark (SI));
+
+ if not Is_Array_Type (T) then
+ goto No_Danger;
+ end if;
+
+ -- Next, find the dimension
+
+ TB := First_Index (T);
+ CB := First (Constraints (P));
+ while True
+ and then Present (TB)
+ and then Present (CB)
+ and then CB /= PN
+ loop
+ Next_Index (TB);
+ Next (CB);
+ end loop;
+
+ if CB /= PN then
+ goto No_Danger;
+ end if;
+
+ -- Now, check the dimension has a large range
+
+ if not Large_Storage_Type (Etype (TB)) then
+ goto No_Danger;
+ end if;
+
+ -- Warn about the danger
+
+ Error_Msg_N
+ ("creation of object of this type may raise Storage_Error?",
+ N);
+
+ <<No_Danger>>
+ null;
+
+ end;
+ end if;
+
+ -- Legal case is in index or discriminant constraint
+
+ elsif Nkind (PN) = N_Index_Or_Discriminant_Constraint
+ or else Nkind (PN) = N_Discriminant_Association
+ then
+ if Paren_Count (N) > 0 then
+ Error_Msg_N
+ ("discriminant in constraint must appear alone", N);
+ end if;
+
+ return;
+
+ -- Otherwise, context is an expression. It should not be within
+ -- (i.e. a subexpression of) a constraint for a component.
+
+ else
+ D := PN;
+ P := Parent (PN);
+
+ while Nkind (P) /= N_Component_Declaration
+ and then Nkind (P) /= N_Subtype_Indication
+ and then Nkind (P) /= N_Entry_Declaration
+ loop
+ D := P;
+ P := Parent (P);
+ exit when No (P);
+ end loop;
+
+ -- If the discriminant is used in an expression that is a bound
+ -- of a scalar type, an Itype is created and the bounds are attached
+ -- to its range, not to the original subtype indication. Such use
+ -- is of course a double fault.
+
+ if (Nkind (P) = N_Subtype_Indication
+ and then
+ (Nkind (Parent (P)) = N_Component_Declaration
+ or else Nkind (Parent (P)) = N_Derived_Type_Definition)
+ and then D = Constraint (P))
+
+ -- The constraint itself may be given by a subtype indication,
+ -- rather than by a more common discrete range.
+
+ or else (Nkind (P) = N_Subtype_Indication
+ and then Nkind (Parent (P)) = N_Index_Or_Discriminant_Constraint)
+
+ or else Nkind (P) = N_Entry_Declaration
+ or else Nkind (D) = N_Defining_Identifier
+ then
+ Error_Msg_N
+ ("discriminant in constraint must appear alone", N);
+ end if;
+ end if;
+ end Check_Discriminant_Use;
+
+ --------------------------------
+ -- Check_For_Visible_Operator --
+ --------------------------------
+
+ procedure Check_For_Visible_Operator (N : Node_Id; T : Entity_Id) is
+ Orig_Node : Node_Id := Original_Node (N);
+
+ begin
+ if Comes_From_Source (Orig_Node)
+ and then not In_Open_Scopes (Scope (T))
+ and then not Is_Potentially_Use_Visible (T)
+ and then not In_Use (T)
+ and then not In_Use (Scope (T))
+ and then (not Present (Entity (N))
+ or else Ekind (Entity (N)) /= E_Function)
+ and then (Nkind (Orig_Node) /= N_Function_Call
+ or else Nkind (Name (Orig_Node)) /= N_Expanded_Name
+ or else Entity (Prefix (Name (Orig_Node))) /= Scope (T))
+ and then not In_Instance
+ then
+ Error_Msg_NE
+ ("operator for} is not directly visible!", N, First_Subtype (T));
+ Error_Msg_N ("use clause would make operation legal!", N);
+ end if;
+ end Check_For_Visible_Operator;
+
+ ------------------------------
+ -- Check_Infinite_Recursion --
+ ------------------------------
+
+ function Check_Infinite_Recursion (N : Node_Id) return Boolean is
+ P : Node_Id;
+ C : Node_Id;
+
+ begin
+ -- Loop moving up tree, quitting if something tells us we are
+ -- definitely not in an infinite recursion situation.
+
+ C := N;
+ loop
+ P := Parent (C);
+ exit when Nkind (P) = N_Subprogram_Body;
+
+ if Nkind (P) = N_Or_Else or else
+ Nkind (P) = N_And_Then or else
+ Nkind (P) = N_If_Statement or else
+ Nkind (P) = N_Case_Statement
+ then
+ return False;
+
+ elsif Nkind (P) = N_Handled_Sequence_Of_Statements
+ and then C /= First (Statements (P))
+ then
+ return False;
+
+ else
+ C := P;
+ end if;
+ end loop;
+
+ Warn_On_Instance := True;
+ Error_Msg_N ("possible infinite recursion?", N);
+ Error_Msg_N ("\Storage_Error may be raised at run time?", N);
+ Warn_On_Instance := False;
+
+ return True;
+ end Check_Infinite_Recursion;
+
+ -------------------------------
+ -- Check_Initialization_Call --
+ -------------------------------
+
+ procedure Check_Initialization_Call (N : Entity_Id; Nam : Entity_Id) is
+ Typ : Entity_Id := Etype (First_Formal (Nam));
+
+ function Uses_SS (T : Entity_Id) return Boolean;
+
+ function Uses_SS (T : Entity_Id) return Boolean is
+ Comp : Entity_Id;
+ Expr : Node_Id;
+
+ begin
+ if Is_Controlled (T)
+ or else Has_Controlled_Component (T)
+ or else Functions_Return_By_DSP_On_Target
+ then
+ return False;
+
+ elsif Is_Array_Type (T) then
+ return Uses_SS (Component_Type (T));
+
+ elsif Is_Record_Type (T) then
+ Comp := First_Component (T);
+
+ while Present (Comp) loop
+
+ if Ekind (Comp) = E_Component
+ and then Nkind (Parent (Comp)) = N_Component_Declaration
+ then
+ Expr := Expression (Parent (Comp));
+
+ if Nkind (Expr) = N_Function_Call
+ and then Requires_Transient_Scope (Etype (Expr))
+ then
+ return True;
+
+ elsif Uses_SS (Etype (Comp)) then
+ return True;
+ end if;
+ end if;
+
+ Next_Component (Comp);
+ end loop;
+
+ return False;
+
+ else
+ return False;
+ end if;
+ end Uses_SS;
+
+ begin
+ if Uses_SS (Typ) then
+ Establish_Transient_Scope (First_Actual (N), Sec_Stack => True);
+ end if;
+ end Check_Initialization_Call;
+
+ ------------------------------
+ -- Check_Parameterless_Call --
+ ------------------------------
+
+ procedure Check_Parameterless_Call (N : Node_Id) is
+ Nam : Node_Id;
+
+ begin
+ if Nkind (N) in N_Has_Etype and then Etype (N) = Any_Type then
+ return;
+ end if;
+
+ -- Rewrite as call if overloadable entity that is (or could be, in
+ -- the overloaded case) a function call. If we know for sure that
+ -- the entity is an enumeration literal, we do not rewrite it.
+
+ if (Is_Entity_Name (N)
+ and then Is_Overloadable (Entity (N))
+ and then (Ekind (Entity (N)) /= E_Enumeration_Literal
+ or else Is_Overloaded (N)))
+
+ -- Rewrite as call if it is an explicit deference of an expression of
+ -- a subprogram access type, and the suprogram type is not that of a
+ -- procedure or entry.
+
+ or else
+ (Nkind (N) = N_Explicit_Dereference
+ and then Ekind (Etype (N)) = E_Subprogram_Type
+ and then Base_Type (Etype (Etype (N))) /= Standard_Void_Type)
+
+ -- Rewrite as call if it is a selected component which is a function,
+ -- this is the case of a call to a protected function (which may be
+ -- overloaded with other protected operations).
+
+ or else
+ (Nkind (N) = N_Selected_Component
+ and then (Ekind (Entity (Selector_Name (N))) = E_Function
+ or else ((Ekind (Entity (Selector_Name (N))) = E_Entry
+ or else
+ Ekind (Entity (Selector_Name (N))) = E_Procedure)
+ and then Is_Overloaded (Selector_Name (N)))))
+
+ -- If one of the above three conditions is met, rewrite as call.
+ -- Apply the rewriting only once.
+
+ then
+ if Nkind (Parent (N)) /= N_Function_Call
+ or else N /= Name (Parent (N))
+ then
+ Nam := New_Copy (N);
+
+ -- If overloaded, overload set belongs to new copy.
+
+ Save_Interps (N, Nam);
+
+ -- Change node to parameterless function call (note that the
+ -- Parameter_Associations associations field is left set to Empty,
+ -- its normal default value since there are no parameters)
+
+ Change_Node (N, N_Function_Call);
+ Set_Name (N, Nam);
+ Set_Sloc (N, Sloc (Nam));
+ Analyze_Call (N);
+ end if;
+
+ elsif Nkind (N) = N_Parameter_Association then
+ Check_Parameterless_Call (Explicit_Actual_Parameter (N));
+ end if;
+ end Check_Parameterless_Call;
+
+ ----------------------
+ -- Is_Predefined_Op --
+ ----------------------
+
+ function Is_Predefined_Op (Nam : Entity_Id) return Boolean is
+ begin
+ return Is_Intrinsic_Subprogram (Nam)
+ and then not Is_Generic_Instance (Nam)
+ and then Chars (Nam) in Any_Operator_Name
+ and then (No (Alias (Nam))
+ or else Is_Predefined_Op (Alias (Nam)));
+ end Is_Predefined_Op;
+
+ -----------------------------
+ -- Make_Call_Into_Operator --
+ -----------------------------
+
+ procedure Make_Call_Into_Operator
+ (N : Node_Id;
+ Typ : Entity_Id;
+ Op_Id : Entity_Id)
+ is
+ Op_Name : constant Name_Id := Chars (Op_Id);
+ Act1 : Node_Id := First_Actual (N);
+ Act2 : Node_Id := Next_Actual (Act1);
+ Error : Boolean := False;
+ Is_Binary : constant Boolean := Present (Act2);
+ Op_Node : Node_Id;
+ Opnd_Type : Entity_Id;
+ Orig_Type : Entity_Id := Empty;
+ Pack : Entity_Id;
+
+ type Kind_Test is access function (E : Entity_Id) return Boolean;
+
+ function Is_Definite_Access_Type (E : Entity_Id) return Boolean;
+ -- Determine whether E is an acess type declared by an access decla-
+ -- ration, and not an (anonymous) allocator type.
+
+ function Operand_Type_In_Scope (S : Entity_Id) return Boolean;
+ -- If the operand is not universal, and the operator is given by a
+ -- expanded name, verify that the operand has an interpretation with
+ -- a type defined in the given scope of the operator.
+
+ function Type_In_P (Test : Kind_Test) return Entity_Id;
+ -- Find a type of the given class in the package Pack that contains
+ -- the operator.
+
+ -----------------------------
+ -- Is_Definite_Access_Type --
+ -----------------------------
+
+ function Is_Definite_Access_Type (E : Entity_Id) return Boolean is
+ Btyp : constant Entity_Id := Base_Type (E);
+ begin
+ return Ekind (Btyp) = E_Access_Type
+ or else (Ekind (Btyp) = E_Access_Subprogram_Type
+ and then Comes_From_Source (Btyp));
+ end Is_Definite_Access_Type;
+
+ ---------------------------
+ -- Operand_Type_In_Scope --
+ ---------------------------
+
+ function Operand_Type_In_Scope (S : Entity_Id) return Boolean is
+ Nod : constant Node_Id := Right_Opnd (Op_Node);
+ I : Interp_Index;
+ It : Interp;
+
+ begin
+ if not Is_Overloaded (Nod) then
+ return Scope (Base_Type (Etype (Nod))) = S;
+
+ else
+ Get_First_Interp (Nod, I, It);
+
+ while Present (It.Typ) loop
+
+ if Scope (Base_Type (It.Typ)) = S then
+ return True;
+ end if;
+
+ Get_Next_Interp (I, It);
+ end loop;
+
+ return False;
+ end if;
+ end Operand_Type_In_Scope;
+
+ ---------------
+ -- Type_In_P --
+ ---------------
+
+ function Type_In_P (Test : Kind_Test) return Entity_Id is
+ E : Entity_Id;
+
+ function In_Decl return Boolean;
+ -- Verify that node is not part of the type declaration for the
+ -- candidate type, which would otherwise be invisible.
+
+ -------------
+ -- In_Decl --
+ -------------
+
+ function In_Decl return Boolean is
+ Decl_Node : constant Node_Id := Parent (E);
+ N2 : Node_Id;
+
+ begin
+ N2 := N;
+
+ if Etype (E) = Any_Type then
+ return True;
+
+ elsif No (Decl_Node) then
+ return False;
+
+ else
+ while Present (N2)
+ and then Nkind (N2) /= N_Compilation_Unit
+ loop
+ if N2 = Decl_Node then
+ return True;
+ else
+ N2 := Parent (N2);
+ end if;
+ end loop;
+
+ return False;
+ end if;
+ end In_Decl;
+
+ -- Start of processing for Type_In_P
+
+ begin
+ -- If the context type is declared in the prefix package, this
+ -- is the desired base type.
+
+ if Scope (Base_Type (Typ)) = Pack
+ and then Test (Typ)
+ then
+ return Base_Type (Typ);
+
+ else
+ E := First_Entity (Pack);
+
+ while Present (E) loop
+
+ if Test (E)
+ and then not In_Decl
+ then
+ return E;
+ end if;
+
+ Next_Entity (E);
+ end loop;
+
+ return Empty;
+ end if;
+ end Type_In_P;
+
+ ---------------------------
+ -- Operand_Type_In_Scope --
+ ---------------------------
+
+ -- Start of processing for Make_Call_Into_Operator
+
+ begin
+ Op_Node := New_Node (Operator_Kind (Op_Name, Is_Binary), Sloc (N));
+
+ -- Binary operator
+
+ if Is_Binary then
+ Set_Left_Opnd (Op_Node, Relocate_Node (Act1));
+ Set_Right_Opnd (Op_Node, Relocate_Node (Act2));
+ Save_Interps (Act1, Left_Opnd (Op_Node));
+ Save_Interps (Act2, Right_Opnd (Op_Node));
+ Act1 := Left_Opnd (Op_Node);
+ Act2 := Right_Opnd (Op_Node);
+
+ -- Unary operator
+
+ else
+ Set_Right_Opnd (Op_Node, Relocate_Node (Act1));
+ Save_Interps (Act1, Right_Opnd (Op_Node));
+ Act1 := Right_Opnd (Op_Node);
+ end if;
+
+ -- If the operator is denoted by an expanded name, and the prefix is
+ -- not Standard, but the operator is a predefined one whose scope is
+ -- Standard, then this is an implicit_operator, inserted as an
+ -- interpretation by the procedure of the same name. This procedure
+ -- overestimates the presence of implicit operators, because it does
+ -- not examine the type of the operands. Verify now that the operand
+ -- type appears in the given scope. If right operand is universal,
+ -- check the other operand. In the case of concatenation, either
+ -- argument can be the component type, so check the type of the result.
+ -- If both arguments are literals, look for a type of the right kind
+ -- defined in the given scope. This elaborate nonsense is brought to
+ -- you courtesy of b33302a. The type itself must be frozen, so we must
+ -- find the type of the proper class in the given scope.
+
+ -- A final wrinkle is the multiplication operator for fixed point
+ -- types, which is defined in Standard only, and not in the scope of
+ -- the fixed_point type itself.
+
+ if Nkind (Name (N)) = N_Expanded_Name then
+ Pack := Entity (Prefix (Name (N)));
+
+ -- If the entity being called is defined in the given package,
+ -- it is a renaming of a predefined operator, and known to be
+ -- legal.
+
+ if Scope (Entity (Name (N))) = Pack
+ and then Pack /= Standard_Standard
+ then
+ null;
+
+ elsif (Op_Name = Name_Op_Multiply
+ or else Op_Name = Name_Op_Divide)
+ and then Is_Fixed_Point_Type (Etype (Left_Opnd (Op_Node)))
+ and then Is_Fixed_Point_Type (Etype (Right_Opnd (Op_Node)))
+ then
+ if Pack /= Standard_Standard then
+ Error := True;
+ end if;
+
+ else
+ Opnd_Type := Base_Type (Etype (Right_Opnd (Op_Node)));
+
+ if Op_Name = Name_Op_Concat then
+ Opnd_Type := Base_Type (Typ);
+
+ elsif (Scope (Opnd_Type) = Standard_Standard
+ and then Is_Binary)
+ or else (Nkind (Right_Opnd (Op_Node)) = N_Attribute_Reference
+ and then Is_Binary
+ and then not Comes_From_Source (Opnd_Type))
+ then
+ Opnd_Type := Base_Type (Etype (Left_Opnd (Op_Node)));
+ end if;
+
+ if Scope (Opnd_Type) = Standard_Standard then
+
+ -- Verify that the scope contains a type that corresponds to
+ -- the given literal. Optimize the case where Pack is Standard.
+
+ if Pack /= Standard_Standard then
+
+ if Opnd_Type = Universal_Integer then
+ Orig_Type := Type_In_P (Is_Integer_Type'Access);
+
+ elsif Opnd_Type = Universal_Real then
+ Orig_Type := Type_In_P (Is_Real_Type'Access);
+
+ elsif Opnd_Type = Any_String then
+ Orig_Type := Type_In_P (Is_String_Type'Access);
+
+ elsif Opnd_Type = Any_Access then
+ Orig_Type := Type_In_P (Is_Definite_Access_Type'Access);
+
+ elsif Opnd_Type = Any_Composite then
+ Orig_Type := Type_In_P (Is_Composite_Type'Access);
+
+ if Present (Orig_Type) then
+ if Has_Private_Component (Orig_Type) then
+ Orig_Type := Empty;
+ else
+ Set_Etype (Act1, Orig_Type);
+
+ if Is_Binary then
+ Set_Etype (Act2, Orig_Type);
+ end if;
+ end if;
+ end if;
+
+ else
+ Orig_Type := Empty;
+ end if;
+
+ Error := No (Orig_Type);
+ end if;
+
+ elsif Ekind (Opnd_Type) = E_Allocator_Type
+ and then No (Type_In_P (Is_Definite_Access_Type'Access))
+ then
+ Error := True;
+
+ -- If the type is defined elsewhere, and the operator is not
+ -- defined in the given scope (by a renaming declaration, e.g.)
+ -- then this is an error as well. If an extension of System is
+ -- present, and the type may be defined there, Pack must be
+ -- System itself.
+
+ elsif Scope (Opnd_Type) /= Pack
+ and then Scope (Op_Id) /= Pack
+ and then (No (System_Aux_Id)
+ or else Scope (Opnd_Type) /= System_Aux_Id
+ or else Pack /= Scope (System_Aux_Id))
+ then
+ Error := True;
+
+ elsif Pack = Standard_Standard
+ and then not Operand_Type_In_Scope (Standard_Standard)
+ then
+ Error := True;
+ end if;
+ end if;
+
+ if Error then
+ Error_Msg_Node_2 := Pack;
+ Error_Msg_NE
+ ("& not declared in&", N, Selector_Name (Name (N)));
+ Set_Etype (N, Any_Type);
+ return;
+ end if;
+ end if;
+
+ Set_Chars (Op_Node, Op_Name);
+ Set_Etype (Op_Node, Base_Type (Etype (N)));
+ Set_Entity (Op_Node, Op_Id);
+ Generate_Reference (Op_Id, N, ' ');
+ Rewrite (N, Op_Node);
+ Resolve (N, Typ);
+
+ -- For predefined operators on literals, the operation freezes
+ -- their type.
+
+ if Present (Orig_Type) then
+ Set_Etype (Act1, Orig_Type);
+ Freeze_Expression (Act1);
+ end if;
+ end Make_Call_Into_Operator;
+
+ -------------------
+ -- Operator_Kind --
+ -------------------
+
+ function Operator_Kind
+ (Op_Name : Name_Id;
+ Is_Binary : Boolean)
+ return Node_Kind
+ is
+ Kind : Node_Kind;
+
+ begin
+ if Is_Binary then
+ if Op_Name = Name_Op_And then Kind := N_Op_And;
+ elsif Op_Name = Name_Op_Or then Kind := N_Op_Or;
+ elsif Op_Name = Name_Op_Xor then Kind := N_Op_Xor;
+ elsif Op_Name = Name_Op_Eq then Kind := N_Op_Eq;
+ elsif Op_Name = Name_Op_Ne then Kind := N_Op_Ne;
+ elsif Op_Name = Name_Op_Lt then Kind := N_Op_Lt;
+ elsif Op_Name = Name_Op_Le then Kind := N_Op_Le;
+ elsif Op_Name = Name_Op_Gt then Kind := N_Op_Gt;
+ elsif Op_Name = Name_Op_Ge then Kind := N_Op_Ge;
+ elsif Op_Name = Name_Op_Add then Kind := N_Op_Add;
+ elsif Op_Name = Name_Op_Subtract then Kind := N_Op_Subtract;
+ elsif Op_Name = Name_Op_Concat then Kind := N_Op_Concat;
+ elsif Op_Name = Name_Op_Multiply then Kind := N_Op_Multiply;
+ elsif Op_Name = Name_Op_Divide then Kind := N_Op_Divide;
+ elsif Op_Name = Name_Op_Mod then Kind := N_Op_Mod;
+ elsif Op_Name = Name_Op_Rem then Kind := N_Op_Rem;
+ elsif Op_Name = Name_Op_Expon then Kind := N_Op_Expon;
+ else
+ raise Program_Error;
+ end if;
+
+ -- Unary operators
+
+ else
+ if Op_Name = Name_Op_Add then Kind := N_Op_Plus;
+ elsif Op_Name = Name_Op_Subtract then Kind := N_Op_Minus;
+ elsif Op_Name = Name_Op_Abs then Kind := N_Op_Abs;
+ elsif Op_Name = Name_Op_Not then Kind := N_Op_Not;
+ else
+ raise Program_Error;
+ end if;
+ end if;
+
+ return Kind;
+ end Operator_Kind;
+
+ -----------------------------
+ -- Pre_Analyze_And_Resolve --
+ -----------------------------
+
+ procedure Pre_Analyze_And_Resolve (N : Node_Id; T : Entity_Id) is
+ Save_Full_Analysis : constant Boolean := Full_Analysis;
+
+ begin
+ Full_Analysis := False;
+ Expander_Mode_Save_And_Set (False);
+
+ -- We suppress all checks for this analysis, since the checks will
+ -- be applied properly, and in the right location, when the default
+ -- expression is reanalyzed and reexpanded later on.
+
+ Analyze_And_Resolve (N, T, Suppress => All_Checks);
+
+ Expander_Mode_Restore;
+ Full_Analysis := Save_Full_Analysis;
+ end Pre_Analyze_And_Resolve;
+
+ -- Version without context type.
+
+ procedure Pre_Analyze_And_Resolve (N : Node_Id) is
+ Save_Full_Analysis : constant Boolean := Full_Analysis;
+
+ begin
+ Full_Analysis := False;
+ Expander_Mode_Save_And_Set (False);
+
+ Analyze (N);
+ Resolve (N, Etype (N), Suppress => All_Checks);
+
+ Expander_Mode_Restore;
+ Full_Analysis := Save_Full_Analysis;
+ end Pre_Analyze_And_Resolve;
+
+ ----------------------------------
+ -- Replace_Actual_Discriminants --
+ ----------------------------------
+
+ procedure Replace_Actual_Discriminants (N : Node_Id; Default : Node_Id) is
+ Loc : constant Source_Ptr := Sloc (N);
+ Tsk : Node_Id := Empty;
+
+ function Process_Discr (Nod : Node_Id) return Traverse_Result;
+
+ -------------------
+ -- Process_Discr --
+ -------------------
+
+ function Process_Discr (Nod : Node_Id) return Traverse_Result is
+ Ent : Entity_Id;
+
+ begin
+ if Nkind (Nod) = N_Identifier then
+ Ent := Entity (Nod);
+
+ if Present (Ent)
+ and then Ekind (Ent) = E_Discriminant
+ then
+ Rewrite (Nod,
+ Make_Selected_Component (Loc,
+ Prefix => New_Copy_Tree (Tsk, New_Sloc => Loc),
+ Selector_Name => Make_Identifier (Loc, Chars (Ent))));
+
+ Set_Etype (Nod, Etype (Ent));
+ end if;
+
+ end if;
+
+ return OK;
+ end Process_Discr;
+
+ procedure Replace_Discrs is new Traverse_Proc (Process_Discr);
+
+ -- Start of processing for Replace_Actual_Discriminants
+
+ begin
+ if not Expander_Active then
+ return;
+ end if;
+
+ if Nkind (Name (N)) = N_Selected_Component then
+ Tsk := Prefix (Name (N));
+
+ elsif Nkind (Name (N)) = N_Indexed_Component then
+ Tsk := Prefix (Prefix (Name (N)));
+ end if;
+
+ if No (Tsk) then
+ return;
+ else
+ Replace_Discrs (Default);
+ end if;
+ end Replace_Actual_Discriminants;
+
+ -------------
+ -- Resolve --
+ -------------
+
+ procedure Resolve (N : Node_Id; Typ : Entity_Id) is
+ I : Interp_Index;
+ I1 : Interp_Index := 0; -- prevent junk warning
+ It : Interp;
+ It1 : Interp;
+ Found : Boolean := False;
+ Seen : Entity_Id := Empty; -- prevent junk warning
+ Ctx_Type : Entity_Id := Typ;
+ Expr_Type : Entity_Id := Empty; -- prevent junk warning
+ Ambiguous : Boolean := False;
+
+ procedure Patch_Up_Value (N : Node_Id; Typ : Entity_Id);
+ -- Try and fix up a literal so that it matches its expected type. New
+ -- literals are manufactured if necessary to avoid cascaded errors.
+
+ procedure Resolution_Failed;
+ -- Called when attempt at resolving current expression fails
+
+ --------------------
+ -- Patch_Up_Value --
+ --------------------
+
+ procedure Patch_Up_Value (N : Node_Id; Typ : Entity_Id) is
+ begin
+ if Nkind (N) = N_Integer_Literal
+ and then Is_Real_Type (Typ)
+ then
+ Rewrite (N,
+ Make_Real_Literal (Sloc (N),
+ Realval => UR_From_Uint (Intval (N))));
+ Set_Etype (N, Universal_Real);
+ Set_Is_Static_Expression (N);
+
+ elsif Nkind (N) = N_Real_Literal
+ and then Is_Integer_Type (Typ)
+ then
+ Rewrite (N,
+ Make_Integer_Literal (Sloc (N),
+ Intval => UR_To_Uint (Realval (N))));
+ Set_Etype (N, Universal_Integer);
+ Set_Is_Static_Expression (N);
+ elsif Nkind (N) = N_String_Literal
+ and then Is_Character_Type (Typ)
+ then
+ Set_Character_Literal_Name (Char_Code (Character'Pos ('A')));
+ Rewrite (N,
+ Make_Character_Literal (Sloc (N),
+ Chars => Name_Find,
+ Char_Literal_Value => Char_Code (Character'Pos ('A'))));
+ Set_Etype (N, Any_Character);
+ Set_Is_Static_Expression (N);
+
+ elsif Nkind (N) /= N_String_Literal
+ and then Is_String_Type (Typ)
+ then
+ Rewrite (N,
+ Make_String_Literal (Sloc (N),
+ Strval => End_String));
+
+ elsif Nkind (N) = N_Range then
+ Patch_Up_Value (Low_Bound (N), Typ);
+ Patch_Up_Value (High_Bound (N), Typ);
+ end if;
+ end Patch_Up_Value;
+
+ -----------------------
+ -- Resolution_Failed --
+ -----------------------
+
+ procedure Resolution_Failed is
+ begin
+ Patch_Up_Value (N, Typ);
+ Set_Etype (N, Typ);
+ Debug_A_Exit ("resolving ", N, " (done, resolution failed)");
+ Set_Is_Overloaded (N, False);
+
+ -- The caller will return without calling the expander, so we need
+ -- to set the analyzed flag. Note that it is fine to set Analyzed
+ -- to True even if we are in the middle of a shallow analysis,
+ -- (see the spec of sem for more details) since this is an error
+ -- situation anyway, and there is no point in repeating the
+ -- analysis later (indeed it won't work to repeat it later, since
+ -- we haven't got a clear resolution of which entity is being
+ -- referenced.)
+
+ Set_Analyzed (N, True);
+ return;
+ end Resolution_Failed;
+
+ -- Start of processing for Resolve
+
+ begin
+ -- Access attribute on remote subprogram cannot be used for
+ -- a non-remote access-to-subprogram type.
+
+ if Nkind (N) = N_Attribute_Reference
+ and then (Attribute_Name (N) = Name_Access
+ or else Attribute_Name (N) = Name_Unrestricted_Access
+ or else Attribute_Name (N) = Name_Unchecked_Access)
+ and then Comes_From_Source (N)
+ and then Is_Entity_Name (Prefix (N))
+ and then Is_Subprogram (Entity (Prefix (N)))
+ and then Is_Remote_Call_Interface (Entity (Prefix (N)))
+ and then not Is_Remote_Access_To_Subprogram_Type (Typ)
+ then
+ Error_Msg_N
+ ("prefix must statically denote a non-remote subprogram", N);
+ end if;
+
+ -- If the context is a Remote_Access_To_Subprogram, access attributes
+ -- must be resolved with the corresponding fat pointer. There is no need
+ -- to check for the attribute name since the return type of an
+ -- attribute is never a remote type.
+
+ if Nkind (N) = N_Attribute_Reference
+ and then Comes_From_Source (N)
+ and then (Is_Remote_Call_Interface (Typ)
+ or else Is_Remote_Types (Typ))
+ then
+ declare
+ Attr : constant Attribute_Id :=
+ Get_Attribute_Id (Attribute_Name (N));
+ Pref : constant Node_Id := Prefix (N);
+ Decl : Node_Id;
+ Spec : Node_Id;
+ Is_Remote : Boolean := True;
+
+ begin
+ -- Check that Typ is a fat pointer with a reference to a RAS as
+ -- original access type.
+
+ if
+ (Ekind (Typ) = E_Access_Subprogram_Type
+ and then Present (Equivalent_Type (Typ)))
+ or else
+ (Ekind (Typ) = E_Record_Type
+ and then Present (Corresponding_Remote_Type (Typ)))
+
+ then
+ -- Prefix (N) must statically denote a remote subprogram
+ -- declared in a package specification.
+
+ if Attr = Attribute_Access then
+ Decl := Unit_Declaration_Node (Entity (Pref));
+
+ if Nkind (Decl) = N_Subprogram_Body then
+ Spec := Corresponding_Spec (Decl);
+
+ if not No (Spec) then
+ Decl := Unit_Declaration_Node (Spec);
+ end if;
+ end if;
+
+ Spec := Parent (Decl);
+
+ if not Is_Entity_Name (Prefix (N))
+ or else Nkind (Spec) /= N_Package_Specification
+ or else
+ not Is_Remote_Call_Interface (Defining_Entity (Spec))
+ then
+ Is_Remote := False;
+ Error_Msg_N
+ ("prefix must statically denote a remote subprogram ",
+ N);
+ end if;
+ end if;
+
+ if Attr = Attribute_Access
+ or else Attr = Attribute_Unchecked_Access
+ or else Attr = Attribute_Unrestricted_Access
+ then
+ Check_Subtype_Conformant
+ (New_Id => Entity (Prefix (N)),
+ Old_Id => Designated_Type
+ (Corresponding_Remote_Type (Typ)),
+ Err_Loc => N);
+ if Is_Remote then
+ Process_Remote_AST_Attribute (N, Typ);
+ end if;
+ end if;
+ end if;
+ end;
+ end if;
+
+ Debug_A_Entry ("resolving ", N);
+
+ if Is_Fixed_Point_Type (Typ) then
+ Check_Restriction (No_Fixed_Point, N);
+
+ elsif Is_Floating_Point_Type (Typ)
+ and then Typ /= Universal_Real
+ and then Typ /= Any_Real
+ then
+ Check_Restriction (No_Floating_Point, N);
+ end if;
+
+ -- Return if already analyzed
+
+ if Analyzed (N) then
+ Debug_A_Exit ("resolving ", N, " (done, already analyzed)");
+ return;
+
+ -- Return if type = Any_Type (previous error encountered)
+
+ elsif Etype (N) = Any_Type then
+ Debug_A_Exit ("resolving ", N, " (done, Etype = Any_Type)");
+ return;
+ end if;
+
+ Check_Parameterless_Call (N);
+
+ -- If not overloaded, then we know the type, and all that needs doing
+ -- is to check that this type is compatible with the context.
+
+ if not Is_Overloaded (N) then
+ Found := Covers (Typ, Etype (N));
+ Expr_Type := Etype (N);
+
+ -- In the overloaded case, we must select the interpretation that
+ -- is compatible with the context (i.e. the type passed to Resolve)
+
+ else
+ Get_First_Interp (N, I, It);
+
+ -- Loop through possible interpretations
+
+ Interp_Loop : while Present (It.Typ) loop
+
+ -- We are only interested in interpretations that are compatible
+ -- with the expected type, any other interpretations are ignored
+
+ if Covers (Typ, It.Typ) then
+
+ -- First matching interpretation
+
+ if not Found then
+ Found := True;
+ I1 := I;
+ Seen := It.Nam;
+ Expr_Type := It.Typ;
+
+ -- Matching intepretation that is not the first, maybe an
+ -- error, but there are some cases where preference rules are
+ -- used to choose between the two possibilities. These and
+ -- some more obscure cases are handled in Disambiguate.
+
+ else
+ Error_Msg_Sloc := Sloc (Seen);
+ It1 := Disambiguate (N, I1, I, Typ);
+
+ if It1 = No_Interp then
+
+ -- Before we issue an ambiguity complaint, check for
+ -- the case of a subprogram call where at least one
+ -- of the arguments is Any_Type, and if so, suppress
+ -- the message, since it is a cascaded error.
+
+ if Nkind (N) = N_Function_Call
+ or else Nkind (N) = N_Procedure_Call_Statement
+ then
+ declare
+ A : Node_Id := First_Actual (N);
+ E : Node_Id;
+
+ begin
+ while Present (A) loop
+ E := A;
+
+ if Nkind (E) = N_Parameter_Association then
+ E := Explicit_Actual_Parameter (E);
+ end if;
+
+ if Etype (E) = Any_Type then
+ if Debug_Flag_V then
+ Write_Str ("Any_Type in call");
+ Write_Eol;
+ end if;
+
+ exit Interp_Loop;
+ end if;
+
+ Next_Actual (A);
+ end loop;
+ end;
+
+ elsif Nkind (N) in N_Binary_Op
+ and then (Etype (Left_Opnd (N)) = Any_Type
+ or else Etype (Right_Opnd (N)) = Any_Type)
+ then
+ exit Interp_Loop;
+
+ elsif Nkind (N) in N_Unary_Op
+ and then Etype (Right_Opnd (N)) = Any_Type
+ then
+ exit Interp_Loop;
+ end if;
+
+ -- Not that special case, so issue message using the
+ -- flag Ambiguous to control printing of the header
+ -- message only at the start of an ambiguous set.
+
+ if not Ambiguous then
+ Error_Msg_NE
+ ("ambiguous expression (cannot resolve&)!",
+ N, It.Nam);
+ Error_Msg_N
+ ("possible interpretation#!", N);
+ Ambiguous := True;
+ end if;
+
+ Error_Msg_Sloc := Sloc (It.Nam);
+ Error_Msg_N ("possible interpretation#!", N);
+
+ -- Disambiguation has succeeded. Skip the remaining
+ -- interpretations.
+ else
+ Seen := It1.Nam;
+ Expr_Type := It1.Typ;
+
+ while Present (It.Typ) loop
+ Get_Next_Interp (I, It);
+ end loop;
+ end if;
+ end if;
+
+ -- We have a matching interpretation, Expr_Type is the
+ -- type from this interpretation, and Seen is the entity.
+
+ -- For an operator, just set the entity name. The type will
+ -- be set by the specific operator resolution routine.
+
+ if Nkind (N) in N_Op then
+ Set_Entity (N, Seen);
+ Generate_Reference (Seen, N);
+
+ elsif Nkind (N) = N_Character_Literal then
+ Set_Etype (N, Expr_Type);
+
+ -- For an explicit dereference, attribute reference, range,
+ -- short-circuit form (which is not an operator node),
+ -- or a call with a name that is an explicit dereference,
+ -- there is nothing to be done at this point.
+
+ elsif Nkind (N) = N_Explicit_Dereference
+ or else Nkind (N) = N_Attribute_Reference
+ or else Nkind (N) = N_And_Then
+ or else Nkind (N) = N_Indexed_Component
+ or else Nkind (N) = N_Or_Else
+ or else Nkind (N) = N_Range
+ or else Nkind (N) = N_Selected_Component
+ or else Nkind (N) = N_Slice
+ or else Nkind (Name (N)) = N_Explicit_Dereference
+ then
+ null;
+
+ -- For procedure or function calls, set the type of the
+ -- name, and also the entity pointer for the prefix
+
+ elsif (Nkind (N) = N_Procedure_Call_Statement
+ or else Nkind (N) = N_Function_Call)
+ and then (Is_Entity_Name (Name (N))
+ or else Nkind (Name (N)) = N_Operator_Symbol)
+ then
+ Set_Etype (Name (N), Expr_Type);
+ Set_Entity (Name (N), Seen);
+ Generate_Reference (Seen, Name (N));
+
+ elsif Nkind (N) = N_Function_Call
+ and then Nkind (Name (N)) = N_Selected_Component
+ then
+ Set_Etype (Name (N), Expr_Type);
+ Set_Entity (Selector_Name (Name (N)), Seen);
+ Generate_Reference (Seen, Selector_Name (Name (N)));
+
+ -- For all other cases, just set the type of the Name
+
+ else
+ Set_Etype (Name (N), Expr_Type);
+ end if;
+
+ -- Here if interpetation is incompatible with context type
+
+ else
+ if Debug_Flag_V then
+ Write_Str (" intepretation incompatible with context");
+ Write_Eol;
+ end if;
+ end if;
+
+ -- Move to next interpretation
+
+ exit Interp_Loop when not Present (It.Typ);
+
+ Get_Next_Interp (I, It);
+ end loop Interp_Loop;
+ end if;
+
+ -- At this stage Found indicates whether or not an acceptable
+ -- interpretation exists. If not, then we have an error, except
+ -- that if the context is Any_Type as a result of some other error,
+ -- then we suppress the error report.
+
+ if not Found then
+ if Typ /= Any_Type then
+
+ -- If type we are looking for is Void, then this is the
+ -- procedure call case, and the error is simply that what
+ -- we gave is not a procedure name (we think of procedure
+ -- calls as expressions with types internally, but the user
+ -- doesn't think of them this way!)
+
+ if Typ = Standard_Void_Type then
+ Error_Msg_N ("expect procedure name in procedure call", N);
+ Found := True;
+
+ -- Otherwise we do have a subexpression with the wrong type
+
+ -- Check for the case of an allocator which uses an access
+ -- type instead of the designated type. This is a common
+ -- error and we specialize the message, posting an error
+ -- on the operand of the allocator, complaining that we
+ -- expected the designated type of the allocator.
+
+ elsif Nkind (N) = N_Allocator
+ and then Ekind (Typ) in Access_Kind
+ and then Ekind (Etype (N)) in Access_Kind
+ and then Designated_Type (Etype (N)) = Typ
+ then
+ Wrong_Type (Expression (N), Designated_Type (Typ));
+ Found := True;
+
+ -- Check for an aggregate. Sometimes we can get bogus
+ -- aggregates from misuse of parentheses, and we are
+ -- about to complain about the aggregate without even
+ -- looking inside it.
+
+ -- Instead, if we have an aggregate of type Any_Composite,
+ -- then analyze and resolve the component fields, and then
+ -- only issue another message if we get no errors doing
+ -- this (otherwise assume that the errors in the aggregate
+ -- caused the problem).
+
+ elsif Nkind (N) = N_Aggregate
+ and then Etype (N) = Any_Composite
+ then
+
+ -- Disable expansion in any case. If there is a type mismatch
+ -- it may be fatal to try to expand the aggregate. The flag
+ -- would otherwise be set to false when the error is posted.
+
+ Expander_Active := False;
+
+ declare
+ procedure Check_Aggr (Aggr : Node_Id);
+ -- Check one aggregate, and set Found to True if we
+ -- have a definite error in any of its elements
+
+ procedure Check_Elmt (Aelmt : Node_Id);
+ -- Check one element of aggregate and set Found to
+ -- True if we definitely have an error in the element.
+
+ procedure Check_Aggr (Aggr : Node_Id) is
+ Elmt : Node_Id;
+
+ begin
+ if Present (Expressions (Aggr)) then
+ Elmt := First (Expressions (Aggr));
+ while Present (Elmt) loop
+ Check_Elmt (Elmt);
+ Next (Elmt);
+ end loop;
+ end if;
+
+ if Present (Component_Associations (Aggr)) then
+ Elmt := First (Component_Associations (Aggr));
+ while Present (Elmt) loop
+ Check_Elmt (Expression (Elmt));
+ Next (Elmt);
+ end loop;
+ end if;
+ end Check_Aggr;
+
+ procedure Check_Elmt (Aelmt : Node_Id) is
+ begin
+ -- If we have a nested aggregate, go inside it (to
+ -- attempt a naked analyze-resolve of the aggregate
+ -- can cause undesirable cascaded errors). Do not
+ -- resolve expression if it needs a type from context,
+ -- as for integer * fixed expression.
+
+ if Nkind (Aelmt) = N_Aggregate then
+ Check_Aggr (Aelmt);
+
+ else
+ Analyze (Aelmt);
+
+ if not Is_Overloaded (Aelmt)
+ and then Etype (Aelmt) /= Any_Fixed
+ then
+ Resolve (Aelmt, Etype (Aelmt));
+ end if;
+
+ if Etype (Aelmt) = Any_Type then
+ Found := True;
+ end if;
+ end if;
+ end Check_Elmt;
+
+ begin
+ Check_Aggr (N);
+ end;
+ end if;
+
+ -- If an error message was issued already, Found got reset
+ -- to True, so if it is still False, issue the standard
+ -- Wrong_Type message.
+
+ if not Found then
+ if Is_Overloaded (N)
+ and then Nkind (N) = N_Function_Call
+ then
+ Error_Msg_Node_2 := Typ;
+ Error_Msg_NE ("no visible interpretation of&" &
+ " matches expected type&", N, Name (N));
+
+ if All_Errors_Mode then
+ declare
+ Index : Interp_Index;
+ It : Interp;
+
+ begin
+ Error_Msg_N ("\possible interpretations:", N);
+ Get_First_Interp (Name (N), Index, It);
+
+ while Present (It.Nam) loop
+
+ Error_Msg_Sloc := Sloc (It.Nam);
+ Error_Msg_Node_2 := It.Typ;
+ Error_Msg_NE ("\& declared#, type&",
+ N, It.Nam);
+
+ Get_Next_Interp (Index, It);
+ end loop;
+ end;
+ else
+ Error_Msg_N ("\use -gnatf for details", N);
+ end if;
+ else
+ Wrong_Type (N, Typ);
+ end if;
+ end if;
+ end if;
+
+ Resolution_Failed;
+ return;
+
+ -- Test if we have more than one interpretation for the context
+
+ elsif Ambiguous then
+ Resolution_Failed;
+ return;
+
+ -- Here we have an acceptable interpretation for the context
+
+ else
+ -- A user-defined operator is tranformed into a function call at
+ -- this point, so that further processing knows that operators are
+ -- really operators (i.e. are predefined operators). User-defined
+ -- operators that are intrinsic are just renamings of the predefined
+ -- ones, and need not be turned into calls either, but if they rename
+ -- a different operator, we must transform the node accordingly.
+ -- Instantiations of Unchecked_Conversion are intrinsic but are
+ -- treated as functions, even if given an operator designator.
+
+ if Nkind (N) in N_Op
+ and then Present (Entity (N))
+ and then Ekind (Entity (N)) /= E_Operator
+ then
+
+ if not Is_Predefined_Op (Entity (N)) then
+ Rewrite_Operator_As_Call (N, Entity (N));
+
+ elsif Present (Alias (Entity (N))) then
+ Rewrite_Renamed_Operator (N, Alias (Entity (N)));
+ end if;
+ end if;
+
+ -- Propagate type information and normalize tree for various
+ -- predefined operations. If the context only imposes a class of
+ -- types, rather than a specific type, propagate the actual type
+ -- downward.
+
+ if Typ = Any_Integer
+ or else Typ = Any_Boolean
+ or else Typ = Any_Modular
+ or else Typ = Any_Real
+ or else Typ = Any_Discrete
+ then
+ Ctx_Type := Expr_Type;
+
+ -- Any_Fixed is legal in a real context only if a specific
+ -- fixed point type is imposed. If Norman Cohen can be
+ -- confused by this, it deserves a separate message.
+
+ if Typ = Any_Real
+ and then Expr_Type = Any_Fixed
+ then
+ Error_Msg_N ("Illegal context for mixed mode operation", N);
+ Set_Etype (N, Universal_Real);
+ Ctx_Type := Universal_Real;
+ end if;
+ end if;
+
+ case N_Subexpr'(Nkind (N)) is
+
+ when N_Aggregate => Resolve_Aggregate (N, Ctx_Type);
+
+ when N_Allocator => Resolve_Allocator (N, Ctx_Type);
+
+ when N_And_Then | N_Or_Else
+ => Resolve_Short_Circuit (N, Ctx_Type);
+
+ when N_Attribute_Reference
+ => Resolve_Attribute (N, Ctx_Type);
+
+ when N_Character_Literal
+ => Resolve_Character_Literal (N, Ctx_Type);
+
+ when N_Conditional_Expression
+ => Resolve_Conditional_Expression (N, Ctx_Type);
+
+ when N_Expanded_Name
+ => Resolve_Entity_Name (N, Ctx_Type);
+
+ when N_Extension_Aggregate
+ => Resolve_Extension_Aggregate (N, Ctx_Type);
+
+ when N_Explicit_Dereference
+ => Resolve_Explicit_Dereference (N, Ctx_Type);
+
+ when N_Function_Call
+ => Resolve_Call (N, Ctx_Type);
+
+ when N_Identifier
+ => Resolve_Entity_Name (N, Ctx_Type);
+
+ when N_In | N_Not_In
+ => Resolve_Membership_Op (N, Ctx_Type);
+
+ when N_Indexed_Component
+ => Resolve_Indexed_Component (N, Ctx_Type);
+
+ when N_Integer_Literal
+ => Resolve_Integer_Literal (N, Ctx_Type);
+
+ when N_Null => Resolve_Null (N, Ctx_Type);
+
+ when N_Op_And | N_Op_Or | N_Op_Xor
+ => Resolve_Logical_Op (N, Ctx_Type);
+
+ when N_Op_Eq | N_Op_Ne
+ => Resolve_Equality_Op (N, Ctx_Type);
+
+ when N_Op_Lt | N_Op_Le | N_Op_Gt | N_Op_Ge
+ => Resolve_Comparison_Op (N, Ctx_Type);
+
+ when N_Op_Not => Resolve_Op_Not (N, Ctx_Type);
+
+ when N_Op_Add | N_Op_Subtract | N_Op_Multiply |
+ N_Op_Divide | N_Op_Mod | N_Op_Rem
+
+ => Resolve_Arithmetic_Op (N, Ctx_Type);
+
+ when N_Op_Concat => Resolve_Op_Concat (N, Ctx_Type);
+
+ when N_Op_Expon => Resolve_Op_Expon (N, Ctx_Type);
+
+ when N_Op_Plus | N_Op_Minus | N_Op_Abs
+ => Resolve_Unary_Op (N, Ctx_Type);
+
+ when N_Op_Shift => Resolve_Shift (N, Ctx_Type);
+
+ when N_Procedure_Call_Statement
+ => Resolve_Call (N, Ctx_Type);
+
+ when N_Operator_Symbol
+ => Resolve_Operator_Symbol (N, Ctx_Type);
+
+ when N_Qualified_Expression
+ => Resolve_Qualified_Expression (N, Ctx_Type);
+
+ when N_Raise_xxx_Error
+ => Set_Etype (N, Ctx_Type);
+
+ when N_Range => Resolve_Range (N, Ctx_Type);
+
+ when N_Real_Literal
+ => Resolve_Real_Literal (N, Ctx_Type);
+
+ when N_Reference => Resolve_Reference (N, Ctx_Type);
+
+ when N_Selected_Component
+ => Resolve_Selected_Component (N, Ctx_Type);
+
+ when N_Slice => Resolve_Slice (N, Ctx_Type);
+
+ when N_String_Literal
+ => Resolve_String_Literal (N, Ctx_Type);
+
+ when N_Subprogram_Info
+ => Resolve_Subprogram_Info (N, Ctx_Type);
+
+ when N_Type_Conversion
+ => Resolve_Type_Conversion (N, Ctx_Type);
+
+ when N_Unchecked_Expression =>
+ Resolve_Unchecked_Expression (N, Ctx_Type);
+
+ when N_Unchecked_Type_Conversion =>
+ Resolve_Unchecked_Type_Conversion (N, Ctx_Type);
+
+ end case;
+
+ -- If the subexpression was replaced by a non-subexpression, then
+ -- all we do is to expand it. The only legitimate case we know of
+ -- is converting procedure call statement to entry call statements,
+ -- but there may be others, so we are making this test general.
+
+ if Nkind (N) not in N_Subexpr then
+ Debug_A_Exit ("resolving ", N, " (done)");
+ Expand (N);
+ return;
+ end if;
+
+ -- The expression is definitely NOT overloaded at this point, so
+ -- we reset the Is_Overloaded flag to avoid any confusion when
+ -- reanalyzing the node.
+
+ Set_Is_Overloaded (N, False);
+
+ -- Freeze expression type, entity if it is a name, and designated
+ -- type if it is an allocator (RM 13.14(9,10)).
+
+ -- Now that the resolution of the type of the node is complete,
+ -- and we did not detect an error, we can expand this node. We
+ -- skip the expand call if we are in a default expression, see
+ -- section "Handling of Default Expressions" in Sem spec.
+
+ Debug_A_Exit ("resolving ", N, " (done)");
+
+ -- We unconditionally freeze the expression, even if we are in
+ -- default expression mode (the Freeze_Expression routine tests
+ -- this flag and only freezes static types if it is set).
+
+ Freeze_Expression (N);
+
+ -- Now we can do the expansion
+
+ Expand (N);
+ end if;
+
+ end Resolve;
+
+ -- Version with check(s) suppressed
+
+ procedure Resolve (N : Node_Id; Typ : Entity_Id; Suppress : Check_Id) is
+ begin
+ if Suppress = All_Checks then
+ declare
+ Svg : constant Suppress_Record := Scope_Suppress;
+
+ begin
+ Scope_Suppress := (others => True);
+ Resolve (N, Typ);
+ Scope_Suppress := Svg;
+ end;
+
+ else
+ declare
+ Svg : constant Boolean := Get_Scope_Suppress (Suppress);
+
+ begin
+ Set_Scope_Suppress (Suppress, True);
+ Resolve (N, Typ);
+ Set_Scope_Suppress (Suppress, Svg);
+ end;
+ end if;
+ end Resolve;
+
+ ---------------------
+ -- Resolve_Actuals --
+ ---------------------
+
+ procedure Resolve_Actuals (N : Node_Id; Nam : Entity_Id) is
+ Loc : constant Source_Ptr := Sloc (N);
+ A : Node_Id;
+ F : Entity_Id;
+ A_Typ : Entity_Id;
+ F_Typ : Entity_Id;
+ Prev : Node_Id := Empty;
+
+ procedure Insert_Default;
+ -- If the actual is missing in a call, insert in the actuals list
+ -- an instance of the default expression. The insertion is always
+ -- a named association.
+
+ --------------------
+ -- Insert_Default --
+ --------------------
+
+ procedure Insert_Default is
+ Actval : Node_Id;
+ Assoc : Node_Id;
+
+ begin
+ -- Note that we do a full New_Copy_Tree, so that any associated
+ -- Itypes are properly copied. This may not be needed any more,
+ -- but it does no harm as a safety measure! Defaults of a generic
+ -- formal may be out of bounds of the corresponding actual (see
+ -- cc1311b) and an additional check may be required.
+
+ if Present (Default_Value (F)) then
+
+ Actval := New_Copy_Tree (Default_Value (F),
+ New_Scope => Current_Scope, New_Sloc => Loc);
+
+ if Is_Concurrent_Type (Scope (Nam))
+ and then Has_Discriminants (Scope (Nam))
+ then
+ Replace_Actual_Discriminants (N, Actval);
+ end if;
+
+ if Is_Overloadable (Nam)
+ and then Present (Alias (Nam))
+ then
+ if Base_Type (Etype (F)) /= Base_Type (Etype (Actval))
+ and then not Is_Tagged_Type (Etype (F))
+ then
+ -- If default is a real literal, do not introduce a
+ -- conversion whose effect may depend on the run-time
+ -- size of universal real.
+
+ if Nkind (Actval) = N_Real_Literal then
+ Set_Etype (Actval, Base_Type (Etype (F)));
+ else
+ Actval := Unchecked_Convert_To (Etype (F), Actval);
+ end if;
+ end if;
+
+ if Is_Scalar_Type (Etype (F)) then
+ Enable_Range_Check (Actval);
+ end if;
+
+ Set_Parent (Actval, N);
+ Analyze_And_Resolve (Actval, Etype (Actval));
+ else
+ Set_Parent (Actval, N);
+
+ -- Resolve aggregates with their base type, to avoid scope
+ -- anomalies: the subtype was first built in the suprogram
+ -- declaration, and the current call may be nested.
+
+ if Nkind (Actval) = N_Aggregate
+ and then Has_Discriminants (Etype (Actval))
+ then
+ Analyze_And_Resolve (Actval, Base_Type (Etype (Actval)));
+ else
+ Analyze_And_Resolve (Actval, Etype (Actval));
+ end if;
+ end if;
+
+ -- If default is a tag indeterminate function call, propagate
+ -- tag to obtain proper dispatching.
+
+ if Is_Controlling_Formal (F)
+ and then Nkind (Default_Value (F)) = N_Function_Call
+ then
+ Set_Is_Controlling_Actual (Actval);
+ end if;
+
+ else
+ -- Missing argument in call, nothing to insert.
+ return;
+ end if;
+
+ -- If the default expression raises constraint error, then just
+ -- silently replace it with an N_Raise_Constraint_Error node,
+ -- since we already gave the warning on the subprogram spec.
+
+ if Raises_Constraint_Error (Actval) then
+ Rewrite (Actval,
+ Make_Raise_Constraint_Error (Loc));
+ Set_Raises_Constraint_Error (Actval);
+ Set_Etype (Actval, Etype (F));
+ end if;
+
+ Assoc :=
+ Make_Parameter_Association (Loc,
+ Explicit_Actual_Parameter => Actval,
+ Selector_Name => Make_Identifier (Loc, Chars (F)));
+
+ -- Case of insertion is first named actual
+
+ if No (Prev) or else
+ Nkind (Parent (Prev)) /= N_Parameter_Association
+ then
+ Set_Next_Named_Actual (Assoc, First_Named_Actual (N));
+ Set_First_Named_Actual (N, Actval);
+
+ if No (Prev) then
+ if not Present (Parameter_Associations (N)) then
+ Set_Parameter_Associations (N, New_List (Assoc));
+ else
+ Append (Assoc, Parameter_Associations (N));
+ end if;
+
+ else
+ Insert_After (Prev, Assoc);
+ end if;
+
+ -- Case of insertion is not first named actual
+
+ else
+ Set_Next_Named_Actual
+ (Assoc, Next_Named_Actual (Parent (Prev)));
+ Set_Next_Named_Actual (Parent (Prev), Actval);
+ Append (Assoc, Parameter_Associations (N));
+ end if;
+
+ Mark_Rewrite_Insertion (Assoc);
+ Mark_Rewrite_Insertion (Actval);
+
+ Prev := Actval;
+ end Insert_Default;
+
+ -- Start of processing for Resolve_Actuals
+
+ begin
+ A := First_Actual (N);
+ F := First_Formal (Nam);
+
+ while Present (F) loop
+
+ if Present (A)
+ and then (Nkind (Parent (A)) /= N_Parameter_Association
+ or else
+ Chars (Selector_Name (Parent (A))) = Chars (F))
+ then
+ -- If the formal is Out or In_Out, do not resolve and expand the
+ -- conversion, because it is subsequently expanded into explicit
+ -- temporaries and assignments. However, the object of the
+ -- conversion can be resolved. An exception is the case of
+ -- a tagged type conversion with a class-wide actual. In that
+ -- case we want the tag check to occur and no temporary will
+ -- will be needed (no representation change can occur) and
+ -- the parameter is passed by reference, so we go ahead and
+ -- resolve the type conversion.
+
+ if Ekind (F) /= E_In_Parameter
+ and then Nkind (A) = N_Type_Conversion
+ and then not Is_Class_Wide_Type (Etype (Expression (A)))
+ then
+ if Conversion_OK (A)
+ or else Valid_Conversion (A, Etype (A), Expression (A))
+ then
+ Resolve (Expression (A), Etype (Expression (A)));
+ end if;
+
+ else
+ Resolve (A, Etype (F));
+ end if;
+
+ A_Typ := Etype (A);
+ F_Typ := Etype (F);
+
+ if Ekind (F) /= E_In_Parameter
+ and then not Is_OK_Variable_For_Out_Formal (A)
+ then
+ -- Specialize error message for protected procedure call
+ -- within function call of the same protected object.
+
+ if Is_Entity_Name (A)
+ and then Chars (Entity (A)) = Name_uObject
+ and then Ekind (Current_Scope) = E_Function
+ and then Convention (Current_Scope) = Convention_Protected
+ and then Ekind (Nam) /= E_Function
+ then
+ Error_Msg_N ("within protected function, protected " &
+ "object is constant", A);
+ Error_Msg_N ("\cannot call operation that may modify it", A);
+ else
+ Error_Msg_NE ("actual for& must be a variable", A, F);
+ end if;
+ end if;
+
+ if Ekind (F) /= E_Out_Parameter then
+ Check_Unset_Reference (A);
+
+ if Ada_83
+ and then Is_Entity_Name (A)
+ and then Ekind (Entity (A)) = E_Out_Parameter
+ then
+ Error_Msg_N ("(Ada 83) illegal reading of out parameter", A);
+ end if;
+ end if;
+
+ -- Apply appropriate range checks for in, out, and in-out
+ -- parameters. Out and in-out parameters also need a separate
+ -- check, if there is a type conversion, to make sure the return
+ -- value meets the constraints of the variable before the
+ -- conversion.
+
+ -- Gigi looks at the check flag and uses the appropriate types.
+ -- For now since one flag is used there is an optimization which
+ -- might not be done in the In Out case since Gigi does not do
+ -- any analysis. More thought required about this ???
+
+ if Ekind (F) = E_In_Parameter
+ or else Ekind (F) = E_In_Out_Parameter
+ then
+ if Is_Scalar_Type (Etype (A)) then
+ Apply_Scalar_Range_Check (A, F_Typ);
+
+ elsif Is_Array_Type (Etype (A)) then
+ Apply_Length_Check (A, F_Typ);
+
+ elsif Is_Record_Type (F_Typ)
+ and then Has_Discriminants (F_Typ)
+ and then Is_Constrained (F_Typ)
+ and then (not Is_Derived_Type (F_Typ)
+ or else Comes_From_Source (Nam))
+ then
+ Apply_Discriminant_Check (A, F_Typ);
+
+ elsif Is_Access_Type (F_Typ)
+ and then Is_Array_Type (Designated_Type (F_Typ))
+ and then Is_Constrained (Designated_Type (F_Typ))
+ then
+ Apply_Length_Check (A, F_Typ);
+
+ elsif Is_Access_Type (F_Typ)
+ and then Has_Discriminants (Designated_Type (F_Typ))
+ and then Is_Constrained (Designated_Type (F_Typ))
+ then
+ Apply_Discriminant_Check (A, F_Typ);
+
+ else
+ Apply_Range_Check (A, F_Typ);
+ end if;
+ end if;
+
+ if Ekind (F) = E_Out_Parameter
+ or else Ekind (F) = E_In_Out_Parameter
+ then
+
+ if Nkind (A) = N_Type_Conversion then
+ if Is_Scalar_Type (A_Typ) then
+ Apply_Scalar_Range_Check
+ (Expression (A), Etype (Expression (A)), A_Typ);
+ else
+ Apply_Range_Check
+ (Expression (A), Etype (Expression (A)), A_Typ);
+ end if;
+
+ else
+ if Is_Scalar_Type (F_Typ) then
+ Apply_Scalar_Range_Check (A, A_Typ, F_Typ);
+
+ elsif Is_Array_Type (F_Typ)
+ and then Ekind (F) = E_Out_Parameter
+ then
+ Apply_Length_Check (A, F_Typ);
+
+ else
+ Apply_Range_Check (A, A_Typ, F_Typ);
+ end if;
+ end if;
+ end if;
+
+ -- An actual associated with an access parameter is implicitly
+ -- converted to the anonymous access type of the formal and
+ -- must satisfy the legality checks for access conversions.
+
+ if Ekind (F_Typ) = E_Anonymous_Access_Type then
+ if not Valid_Conversion (A, F_Typ, A) then
+ Error_Msg_N
+ ("invalid implicit conversion for access parameter", A);
+ end if;
+ end if;
+
+ -- Check bad case of atomic/volatile argument (RM C.6(12))
+
+ if Is_By_Reference_Type (Etype (F))
+ and then Comes_From_Source (N)
+ then
+ if Is_Atomic_Object (A)
+ and then not Is_Atomic (Etype (F))
+ then
+ Error_Msg_N
+ ("cannot pass atomic argument to non-atomic formal",
+ N);
+
+ elsif Is_Volatile_Object (A)
+ and then not Is_Volatile (Etype (F))
+ then
+ Error_Msg_N
+ ("cannot pass volatile argument to non-volatile formal",
+ N);
+ end if;
+ end if;
+
+ -- Check that subprograms don't have improper controlling
+ -- arguments (RM 3.9.2 (9))
+
+ if Is_Controlling_Formal (F) then
+ Set_Is_Controlling_Actual (A);
+ elsif Nkind (A) = N_Explicit_Dereference then
+ Validate_Remote_Access_To_Class_Wide_Type (A);
+ end if;
+
+ if (Is_Class_Wide_Type (A_Typ) or else Is_Dynamically_Tagged (A))
+ and then not Is_Class_Wide_Type (F_Typ)
+ and then not Is_Controlling_Formal (F)
+ then
+ Error_Msg_N ("class-wide argument not allowed here!", A);
+ if Is_Subprogram (Nam) then
+ Error_Msg_Node_2 := F_Typ;
+ Error_Msg_NE
+ ("& is not a primitive operation of &!", A, Nam);
+ end if;
+
+ elsif Is_Access_Type (A_Typ)
+ and then Is_Access_Type (F_Typ)
+ and then Ekind (F_Typ) /= E_Access_Subprogram_Type
+ and then (Is_Class_Wide_Type (Designated_Type (A_Typ))
+ or else (Nkind (A) = N_Attribute_Reference
+ and then Is_Class_Wide_Type (Etype (Prefix (A)))))
+ and then not Is_Class_Wide_Type (Designated_Type (F_Typ))
+ and then not Is_Controlling_Formal (F)
+ then
+ Error_Msg_N
+ ("access to class-wide argument not allowed here!", A);
+ if Is_Subprogram (Nam) then
+ Error_Msg_Node_2 := Designated_Type (F_Typ);
+ Error_Msg_NE
+ ("& is not a primitive operation of &!", A, Nam);
+ end if;
+ end if;
+
+ Eval_Actual (A);
+
+ -- If it is a named association, treat the selector_name as
+ -- a proper identifier, and mark the corresponding entity.
+
+ if Nkind (Parent (A)) = N_Parameter_Association then
+ Set_Entity (Selector_Name (Parent (A)), F);
+ Generate_Reference (F, Selector_Name (Parent (A)));
+ Set_Etype (Selector_Name (Parent (A)), F_Typ);
+ Generate_Reference (F_Typ, N, ' ');
+ end if;
+
+ Prev := A;
+ Next_Actual (A);
+
+ else
+ Insert_Default;
+ end if;
+
+ Next_Formal (F);
+ end loop;
+
+ end Resolve_Actuals;
+
+ -----------------------
+ -- Resolve_Allocator --
+ -----------------------
+
+ procedure Resolve_Allocator (N : Node_Id; Typ : Entity_Id) is
+ E : constant Node_Id := Expression (N);
+ Subtyp : Entity_Id;
+ Discrim : Entity_Id;
+ Constr : Node_Id;
+ Disc_Exp : Node_Id;
+
+ begin
+ -- Replace general access with specific type
+
+ if Ekind (Etype (N)) = E_Allocator_Type then
+ Set_Etype (N, Base_Type (Typ));
+ end if;
+
+ if Is_Abstract (Typ) then
+ Error_Msg_N ("type of allocator cannot be abstract", N);
+ end if;
+
+ -- For qualified expression, resolve the expression using the
+ -- given subtype (nothing to do for type mark, subtype indication)
+
+ if Nkind (E) = N_Qualified_Expression then
+ if Is_Class_Wide_Type (Etype (E))
+ and then not Is_Class_Wide_Type (Designated_Type (Typ))
+ then
+ Error_Msg_N
+ ("class-wide allocator not allowed for this access type", N);
+ end if;
+
+ Resolve (Expression (E), Etype (E));
+ Check_Unset_Reference (Expression (E));
+
+ -- For a subtype mark or subtype indication, freeze the subtype
+
+ else
+ Freeze_Expression (E);
+
+ if Is_Access_Constant (Typ) and then not No_Initialization (N) then
+ Error_Msg_N
+ ("initialization required for access-to-constant allocator", N);
+ end if;
+
+ -- A special accessibility check is needed for allocators that
+ -- constrain access discriminants. The level of the type of the
+ -- expression used to contrain an access discriminant cannot be
+ -- deeper than the type of the allocator (in constrast to access
+ -- parameters, where the level of the actual can be arbitrary).
+ -- We can't use Valid_Conversion to perform this check because
+ -- in general the type of the allocator is unrelated to the type
+ -- of the access discriminant. Note that specialized checks are
+ -- needed for the cases of a constraint expression which is an
+ -- access attribute or an access discriminant.
+
+ if Nkind (Original_Node (E)) = N_Subtype_Indication
+ and then Ekind (Typ) /= E_Anonymous_Access_Type
+ then
+ Subtyp := Entity (Subtype_Mark (Original_Node (E)));
+
+ if Has_Discriminants (Subtyp) then
+ Discrim := First_Discriminant (Base_Type (Subtyp));
+ Constr := First (Constraints (Constraint (Original_Node (E))));
+
+ while Present (Discrim) and then Present (Constr) loop
+ if Ekind (Etype (Discrim)) = E_Anonymous_Access_Type then
+ if Nkind (Constr) = N_Discriminant_Association then
+ Disc_Exp := Original_Node (Expression (Constr));
+ else
+ Disc_Exp := Original_Node (Constr);
+ end if;
+
+ if Type_Access_Level (Etype (Disc_Exp))
+ > Type_Access_Level (Typ)
+ then
+ Error_Msg_N
+ ("operand type has deeper level than allocator type",
+ Disc_Exp);
+
+ elsif Nkind (Disc_Exp) = N_Attribute_Reference
+ and then Get_Attribute_Id (Attribute_Name (Disc_Exp))
+ = Attribute_Access
+ and then Object_Access_Level (Prefix (Disc_Exp))
+ > Type_Access_Level (Typ)
+ then
+ Error_Msg_N
+ ("prefix of attribute has deeper level than"
+ & " allocator type", Disc_Exp);
+
+ -- When the operand is an access discriminant the check
+ -- is against the level of the prefix object.
+
+ elsif Ekind (Etype (Disc_Exp)) = E_Anonymous_Access_Type
+ and then Nkind (Disc_Exp) = N_Selected_Component
+ and then Object_Access_Level (Prefix (Disc_Exp))
+ > Type_Access_Level (Typ)
+ then
+ Error_Msg_N
+ ("access discriminant has deeper level than"
+ & " allocator type", Disc_Exp);
+ end if;
+ end if;
+ Next_Discriminant (Discrim);
+ Next (Constr);
+ end loop;
+ end if;
+ end if;
+ end if;
+
+ -- Check for allocation from an empty storage pool
+
+ if No_Pool_Assigned (Typ) then
+ declare
+ Loc : constant Source_Ptr := Sloc (N);
+
+ begin
+ Error_Msg_N ("?allocation from empty storage pool!", N);
+ Error_Msg_N ("?Storage_Error will be raised at run time!", N);
+ Insert_Action (N,
+ Make_Raise_Storage_Error (Loc));
+ end;
+ end if;
+ end Resolve_Allocator;
+
+ ---------------------------
+ -- Resolve_Arithmetic_Op --
+ ---------------------------
+
+ -- Used for resolving all arithmetic operators except exponentiation
+
+ procedure Resolve_Arithmetic_Op (N : Node_Id; Typ : Entity_Id) is
+ L : constant Node_Id := Left_Opnd (N);
+ R : constant Node_Id := Right_Opnd (N);
+ T : Entity_Id;
+ TL : Entity_Id := Base_Type (Etype (L));
+ TR : Entity_Id := Base_Type (Etype (R));
+
+ B_Typ : constant Entity_Id := Base_Type (Typ);
+ -- We do the resolution using the base type, because intermediate values
+ -- in expressions always are of the base type, not a subtype of it.
+
+ function Is_Integer_Or_Universal (N : Node_Id) return Boolean;
+ -- Return True iff given type is Integer or universal real/integer
+
+ procedure Set_Mixed_Mode_Operand (N : Node_Id; T : Entity_Id);
+ -- Choose type of integer literal in fixed-point operation to conform
+ -- to available fixed-point type. T is the type of the other operand,
+ -- which is needed to determine the expected type of N.
+
+ procedure Set_Operand_Type (N : Node_Id);
+ -- Set operand type to T if universal
+
+ function Universal_Interpretation (N : Node_Id) return Entity_Id;
+ -- Find universal type of operand, if any.
+
+ -----------------------------
+ -- Is_Integer_Or_Universal --
+ -----------------------------
+
+ function Is_Integer_Or_Universal (N : Node_Id) return Boolean is
+ T : Entity_Id;
+ Index : Interp_Index;
+ It : Interp;
+
+ begin
+ if not Is_Overloaded (N) then
+ T := Etype (N);
+ return Base_Type (T) = Base_Type (Standard_Integer)
+ or else T = Universal_Integer
+ or else T = Universal_Real;
+ else
+ Get_First_Interp (N, Index, It);
+
+ while Present (It.Typ) loop
+
+ if Base_Type (It.Typ) = Base_Type (Standard_Integer)
+ or else It.Typ = Universal_Integer
+ or else It.Typ = Universal_Real
+ then
+ return True;
+ end if;
+
+ Get_Next_Interp (Index, It);
+ end loop;
+ end if;
+
+ return False;
+ end Is_Integer_Or_Universal;
+
+ ----------------------------
+ -- Set_Mixed_Mode_Operand --
+ ----------------------------
+
+ procedure Set_Mixed_Mode_Operand (N : Node_Id; T : Entity_Id) is
+ Index : Interp_Index;
+ It : Interp;
+
+ begin
+ if Universal_Interpretation (N) = Universal_Integer then
+
+ -- A universal integer literal is resolved as standard integer
+ -- except in the case of a fixed-point result, where we leave
+ -- it as universal (to be handled by Exp_Fixd later on)
+
+ if Is_Fixed_Point_Type (T) then
+ Resolve (N, Universal_Integer);
+ else
+ Resolve (N, Standard_Integer);
+ end if;
+
+ elsif Universal_Interpretation (N) = Universal_Real
+ and then (T = Base_Type (Standard_Integer)
+ or else T = Universal_Integer
+ or else T = Universal_Real)
+ then
+ -- A universal real can appear in a fixed-type context. We resolve
+ -- the literal with that context, even though this might raise an
+ -- exception prematurely (the other operand may be zero).
+
+ Resolve (N, B_Typ);
+
+ elsif Etype (N) = Base_Type (Standard_Integer)
+ and then T = Universal_Real
+ and then Is_Overloaded (N)
+ then
+ -- Integer arg in mixed-mode operation. Resolve with universal
+ -- type, in case preference rule must be applied.
+
+ Resolve (N, Universal_Integer);
+
+ elsif Etype (N) = T
+ and then B_Typ /= Universal_Fixed
+ then
+ -- Not a mixed-mode operation. Resolve with context.
+
+ Resolve (N, B_Typ);
+
+ elsif Etype (N) = Any_Fixed then
+
+ -- N may itself be a mixed-mode operation, so use context type.
+
+ Resolve (N, B_Typ);
+
+ elsif Is_Fixed_Point_Type (T)
+ and then B_Typ = Universal_Fixed
+ and then Is_Overloaded (N)
+ then
+ -- Must be (fixed * fixed) operation, operand must have one
+ -- compatible interpretation.
+
+ Resolve (N, Any_Fixed);
+
+ elsif Is_Fixed_Point_Type (B_Typ)
+ and then (T = Universal_Real
+ or else Is_Fixed_Point_Type (T))
+ and then Is_Overloaded (N)
+ then
+ -- C * F(X) in a fixed context, where C is a real literal or a
+ -- fixed-point expression. F must have either a fixed type
+ -- interpretation or an integer interpretation, but not both.
+
+ Get_First_Interp (N, Index, It);
+
+ while Present (It.Typ) loop
+
+ if Base_Type (It.Typ) = Base_Type (Standard_Integer) then
+
+ if Analyzed (N) then
+ Error_Msg_N ("ambiguous operand in fixed operation", N);
+ else
+ Resolve (N, Standard_Integer);
+ end if;
+
+ elsif Is_Fixed_Point_Type (It.Typ) then
+
+ if Analyzed (N) then
+ Error_Msg_N ("ambiguous operand in fixed operation", N);
+ else
+ Resolve (N, It.Typ);
+ end if;
+ end if;
+
+ Get_Next_Interp (Index, It);
+ end loop;
+
+ -- Reanalyze the literal with the fixed type of the context.
+
+ if N = L then
+ Set_Analyzed (R, False);
+ Resolve (R, B_Typ);
+ else
+ Set_Analyzed (L, False);
+ Resolve (L, B_Typ);
+ end if;
+
+ else
+ Resolve (N, Etype (N));
+ end if;
+ end Set_Mixed_Mode_Operand;
+
+ ----------------------
+ -- Set_Operand_Type --
+ ----------------------
+
+ procedure Set_Operand_Type (N : Node_Id) is
+ begin
+ if Etype (N) = Universal_Integer
+ or else Etype (N) = Universal_Real
+ then
+ Set_Etype (N, T);
+ end if;
+ end Set_Operand_Type;
+
+ ------------------------------
+ -- Universal_Interpretation --
+ ------------------------------
+
+ function Universal_Interpretation (N : Node_Id) return Entity_Id is
+ Index : Interp_Index;
+ It : Interp;
+
+ begin
+ if not Is_Overloaded (N) then
+
+ if Etype (N) = Universal_Integer
+ or else Etype (N) = Universal_Real
+ then
+ return Etype (N);
+ else
+ return Empty;
+ end if;
+
+ else
+ Get_First_Interp (N, Index, It);
+
+ while Present (It.Typ) loop
+
+ if It.Typ = Universal_Integer
+ or else It.Typ = Universal_Real
+ then
+ return It.Typ;
+ end if;
+
+ Get_Next_Interp (Index, It);
+ end loop;
+
+ return Empty;
+ end if;
+ end Universal_Interpretation;
+
+ -- Start of processing for Resolve_Arithmetic_Op
+
+ begin
+ if Comes_From_Source (N)
+ and then Ekind (Entity (N)) = E_Function
+ and then Is_Imported (Entity (N))
+ and then Present (First_Rep_Item (Entity (N)))
+ then
+ Resolve_Intrinsic_Operator (N, Typ);
+ return;
+
+ -- Special-case for mixed-mode universal expressions or fixed point
+ -- type operation: each argument is resolved separately. The same
+ -- treatment is required if one of the operands of a fixed point
+ -- operation is universal real, since in this case we don't do a
+ -- conversion to a specific fixed-point type (instead the expander
+ -- takes care of the case).
+
+ elsif (B_Typ = Universal_Integer
+ or else B_Typ = Universal_Real)
+ and then Present (Universal_Interpretation (L))
+ and then Present (Universal_Interpretation (R))
+ then
+ Resolve (L, Universal_Interpretation (L));
+ Resolve (R, Universal_Interpretation (R));
+ Set_Etype (N, B_Typ);
+
+ elsif (B_Typ = Universal_Real
+ or else Etype (N) = Universal_Fixed
+ or else (Etype (N) = Any_Fixed
+ and then Is_Fixed_Point_Type (B_Typ))
+ or else (Is_Fixed_Point_Type (B_Typ)
+ and then (Is_Integer_Or_Universal (L)
+ or else
+ Is_Integer_Or_Universal (R))))
+ and then (Nkind (N) = N_Op_Multiply or else
+ Nkind (N) = N_Op_Divide)
+ then
+ if TL = Universal_Integer or else TR = Universal_Integer then
+ Check_For_Visible_Operator (N, B_Typ);
+ end if;
+
+ -- If context is a fixed type and one operand is integer, the
+ -- other is resolved with the type of the context.
+
+ if Is_Fixed_Point_Type (B_Typ)
+ and then (Base_Type (TL) = Base_Type (Standard_Integer)
+ or else TL = Universal_Integer)
+ then
+ Resolve (R, B_Typ);
+ Resolve (L, TL);
+
+ elsif Is_Fixed_Point_Type (B_Typ)
+ and then (Base_Type (TR) = Base_Type (Standard_Integer)
+ or else TR = Universal_Integer)
+ then
+ Resolve (L, B_Typ);
+ Resolve (R, TR);
+
+ else
+ Set_Mixed_Mode_Operand (L, TR);
+ Set_Mixed_Mode_Operand (R, TL);
+ end if;
+
+ if Etype (N) = Universal_Fixed
+ or else Etype (N) = Any_Fixed
+ then
+ if B_Typ = Universal_Fixed
+ and then Nkind (Parent (N)) /= N_Type_Conversion
+ and then Nkind (Parent (N)) /= N_Unchecked_Type_Conversion
+ then
+ Error_Msg_N
+ ("type cannot be determined from context!", N);
+ Error_Msg_N
+ ("\explicit conversion to result type required", N);
+
+ Set_Etype (L, Any_Type);
+ Set_Etype (R, Any_Type);
+
+ else
+ if Ada_83
+ and then Etype (N) = Universal_Fixed
+ and then Nkind (Parent (N)) /= N_Type_Conversion
+ and then Nkind (Parent (N)) /= N_Unchecked_Type_Conversion
+ then
+ Error_Msg_N
+ ("(Ada 83) fixed-point operation " &
+ "needs explicit conversion",
+ N);
+ end if;
+
+ Set_Etype (N, B_Typ);
+ end if;
+
+ elsif Is_Fixed_Point_Type (B_Typ)
+ and then (Is_Integer_Or_Universal (L)
+ or else Nkind (L) = N_Real_Literal
+ or else Nkind (R) = N_Real_Literal
+ or else
+ Is_Integer_Or_Universal (R))
+ then
+ Set_Etype (N, B_Typ);
+
+ elsif Etype (N) = Any_Fixed then
+
+ -- If no previous errors, this is only possible if one operand
+ -- is overloaded and the context is universal. Resolve as such.
+
+ Set_Etype (N, B_Typ);
+ end if;
+
+ else
+ if (TL = Universal_Integer or else TL = Universal_Real)
+ and then (TR = Universal_Integer or else TR = Universal_Real)
+ then
+ Check_For_Visible_Operator (N, B_Typ);
+ end if;
+
+ -- If the context is Universal_Fixed and the operands are also
+ -- universal fixed, this is an error, unless there is only one
+ -- applicable fixed_point type (usually duration).
+
+ if B_Typ = Universal_Fixed
+ and then Etype (L) = Universal_Fixed
+ then
+ T := Unique_Fixed_Point_Type (N);
+
+ if T = Any_Type then
+ Set_Etype (N, T);
+ return;
+ else
+ Resolve (L, T);
+ Resolve (R, T);
+ end if;
+
+ else
+ Resolve (L, B_Typ);
+ Resolve (R, B_Typ);
+ end if;
+
+ -- If one of the arguments was resolved to a non-universal type.
+ -- label the result of the operation itself with the same type.
+ -- Do the same for the universal argument, if any.
+
+ T := Intersect_Types (L, R);
+ Set_Etype (N, Base_Type (T));
+ Set_Operand_Type (L);
+ Set_Operand_Type (R);
+ end if;
+
+ Generate_Operator_Reference (N);
+ Eval_Arithmetic_Op (N);
+
+ -- Set overflow and division checking bit. Much cleverer code needed
+ -- here eventually and perhaps the Resolve routines should be separated
+ -- for the various arithmetic operations, since they will need
+ -- different processing. ???
+
+ if Nkind (N) in N_Op then
+ if not Overflow_Checks_Suppressed (Etype (N)) then
+ Set_Do_Overflow_Check (N);
+ end if;
+
+ if (Nkind (N) = N_Op_Divide
+ or else Nkind (N) = N_Op_Rem
+ or else Nkind (N) = N_Op_Mod)
+ and then not Division_Checks_Suppressed (Etype (N))
+ then
+ Set_Do_Division_Check (N);
+ end if;
+ end if;
+
+ Check_Unset_Reference (L);
+ Check_Unset_Reference (R);
+
+ end Resolve_Arithmetic_Op;
+
+ ------------------
+ -- Resolve_Call --
+ ------------------
+
+ procedure Resolve_Call (N : Node_Id; Typ : Entity_Id) is
+ Loc : constant Source_Ptr := Sloc (N);
+ Subp : constant Node_Id := Name (N);
+ Nam : Entity_Id;
+ I : Interp_Index;
+ It : Interp;
+ Norm_OK : Boolean;
+ Scop : Entity_Id;
+
+ begin
+ -- The context imposes a unique interpretation with type Typ on
+ -- a procedure or function call. Find the entity of the subprogram
+ -- that yields the expected type, and propagate the corresponding
+ -- formal constraints on the actuals. The caller has established
+ -- that an interpretation exists, and emitted an error if not unique.
+
+ -- First deal with the case of a call to an access-to-subprogram,
+ -- dereference made explicit in Analyze_Call.
+
+ if Ekind (Etype (Subp)) = E_Subprogram_Type then
+
+ if not Is_Overloaded (Subp) then
+ Nam := Etype (Subp);
+
+ else
+ -- Find the interpretation whose type (a subprogram type)
+ -- has a return type that is compatible with the context.
+ -- Analysis of the node has established that one exists.
+
+ Get_First_Interp (Subp, I, It);
+ Nam := Empty;
+
+ while Present (It.Typ) loop
+
+ if Covers (Typ, Etype (It.Typ)) then
+ Nam := It.Typ;
+ exit;
+ end if;
+
+ Get_Next_Interp (I, It);
+ end loop;
+
+ if No (Nam) then
+ raise Program_Error;
+ end if;
+ end if;
+
+ -- If the prefix is not an entity, then resolve it
+
+ if not Is_Entity_Name (Subp) then
+ Resolve (Subp, Nam);
+ end if;
+
+ -- If this is a procedure call which is really an entry call, do
+ -- the conversion of the procedure call to an entry call. Protected
+ -- operations use the same circuitry because the name in the call
+ -- can be an arbitrary expression with special resolution rules.
+
+ elsif Nkind (Subp) = N_Selected_Component
+ or else Nkind (Subp) = N_Indexed_Component
+ or else (Is_Entity_Name (Subp)
+ and then Ekind (Entity (Subp)) = E_Entry)
+ then
+ Resolve_Entry_Call (N, Typ);
+ Check_Elab_Call (N);
+ return;
+
+ -- Normal subprogram call with name established in Resolve
+
+ elsif not (Is_Type (Entity (Subp))) then
+ Nam := Entity (Subp);
+ Set_Entity_With_Style_Check (Subp, Nam);
+ Generate_Reference (Nam, Subp);
+
+ -- Otherwise we must have the case of an overloaded call
+
+ else
+ pragma Assert (Is_Overloaded (Subp));
+ Nam := Empty; -- We know that it will be assigned in loop below.
+
+ Get_First_Interp (Subp, I, It);
+
+ while Present (It.Typ) loop
+ if Covers (Typ, It.Typ) then
+ Nam := It.Nam;
+ Set_Entity_With_Style_Check (Subp, Nam);
+ Generate_Reference (Nam, Subp);
+ exit;
+ end if;
+
+ Get_Next_Interp (I, It);
+ end loop;
+ end if;
+
+ -- Check that a call to Current_Task does not occur in an entry body
+
+ if Is_RTE (Nam, RE_Current_Task) then
+ declare
+ P : Node_Id;
+
+ begin
+ P := N;
+ loop
+ P := Parent (P);
+ exit when No (P);
+
+ if Nkind (P) = N_Entry_Body then
+ Error_Msg_NE
+ ("& should not be used in entry body ('R'M C.7(17))",
+ N, Nam);
+ exit;
+ end if;
+ end loop;
+ end;
+ end if;
+
+ -- Check that a procedure call does not occur in the context
+ -- of the entry call statement of a conditional or timed
+ -- entry call. Note that the case of a call to a subprogram
+ -- renaming of an entry will also be rejected. The test
+ -- for N not being an N_Entry_Call_Statement is defensive,
+ -- covering the possibility that the processing of entry
+ -- calls might reach this point due to later modifications
+ -- of the code above.
+
+ if Nkind (Parent (N)) = N_Entry_Call_Alternative
+ and then Nkind (N) /= N_Entry_Call_Statement
+ and then Entry_Call_Statement (Parent (N)) = N
+ then
+ Error_Msg_N ("entry call required in select statement", N);
+ end if;
+
+ -- Freeze the subprogram name if not in default expression. Note
+ -- that we freeze procedure calls as well as function calls.
+ -- Procedure calls are not frozen according to the rules (RM
+ -- 13.14(14)) because it is impossible to have a procedure call to
+ -- a non-frozen procedure in pure Ada, but in the code that we
+ -- generate in the expander, this rule needs extending because we
+ -- can generate procedure calls that need freezing.
+
+ if Is_Entity_Name (Subp) and then not In_Default_Expression then
+ Freeze_Expression (Subp);
+ end if;
+
+ -- For a predefined operator, the type of the result is the type
+ -- imposed by context, except for a predefined operation on universal
+ -- fixed. Otherwise The type of the call is the type returned by the
+ -- subprogram being called.
+
+ if Is_Predefined_Op (Nam) then
+
+ if Etype (N) /= Universal_Fixed then
+ Set_Etype (N, Typ);
+ end if;
+
+ -- If the subprogram returns an array type, and the context
+ -- requires the component type of that array type, the node is
+ -- really an indexing of the parameterless call. Resolve as such.
+
+ elsif Needs_No_Actuals (Nam)
+ and then
+ ((Is_Array_Type (Etype (Nam))
+ and then Covers (Typ, Component_Type (Etype (Nam))))
+ or else (Is_Access_Type (Etype (Nam))
+ and then Is_Array_Type (Designated_Type (Etype (Nam)))
+ and then
+ Covers (Typ,
+ Component_Type (Designated_Type (Etype (Nam))))))
+ then
+ declare
+ Index_Node : Node_Id;
+
+ begin
+ Check_Elab_Call (N);
+
+ if Component_Type (Etype (Nam)) /= Any_Type then
+ Index_Node :=
+ Make_Indexed_Component (Loc,
+ Prefix =>
+ Make_Function_Call (Loc,
+ Name => New_Occurrence_Of (Nam, Loc)),
+ Expressions => Parameter_Associations (N));
+
+ -- Since we are correcting a node classification error made by
+ -- the parser, we call Replace rather than Rewrite.
+
+ Replace (N, Index_Node);
+ Set_Etype (Prefix (N), Etype (Nam));
+ Set_Etype (N, Typ);
+ Resolve_Indexed_Component (N, Typ);
+ end if;
+
+ return;
+ end;
+
+ else
+ Set_Etype (N, Etype (Nam));
+ end if;
+
+ -- In the case where the call is to an overloaded subprogram, Analyze
+ -- calls Normalize_Actuals once per overloaded subprogram. Therefore in
+ -- such a case Normalize_Actuals needs to be called once more to order
+ -- the actuals correctly. Otherwise the call will have the ordering
+ -- given by the last overloaded subprogram whether this is the correct
+ -- one being called or not.
+
+ if Is_Overloaded (Subp) then
+ Normalize_Actuals (N, Nam, False, Norm_OK);
+ pragma Assert (Norm_OK);
+ end if;
+
+ -- In any case, call is fully resolved now. Reset Overload flag, to
+ -- prevent subsequent overload resolution if node is analyzed again
+
+ Set_Is_Overloaded (Subp, False);
+ Set_Is_Overloaded (N, False);
+
+ -- If we are calling the current subprogram from immediately within
+ -- its body, then that is the case where we can sometimes detect
+ -- cases of infinite recursion statically. Do not try this in case
+ -- restriction No_Recursion is in effect anyway.
+
+ Scop := Current_Scope;
+
+ if Nam = Scop
+ and then not Restrictions (No_Recursion)
+ and then Check_Infinite_Recursion (N)
+ then
+ -- Here we detected and flagged an infinite recursion, so we do
+ -- not need to test the case below for further warnings.
+
+ null;
+
+ -- If call is to immediately containing subprogram, then check for
+ -- the case of a possible run-time detectable infinite recursion.
+
+ else
+ while Scop /= Standard_Standard loop
+ if Nam = Scop then
+ -- Although in general recursion is not statically checkable,
+ -- the case of calling an immediately containing subprogram
+ -- is easy to catch.
+
+ Check_Restriction (No_Recursion, N);
+
+ -- If the recursive call is to a parameterless procedure, then
+ -- even if we can't statically detect infinite recursion, this
+ -- is pretty suspicious, and we output a warning. Furthermore,
+ -- we will try later to detect some cases here at run time by
+ -- expanding checking code (see Detect_Infinite_Recursion in
+ -- package Exp_Ch6).
+ -- If the recursive call is within a handler we do not emit a
+ -- warning, because this is a common idiom: loop until input
+ -- is correct, catch illegal input in handler and restart.
+
+ if No (First_Formal (Nam))
+ and then Etype (Nam) = Standard_Void_Type
+ and then not Error_Posted (N)
+ and then Nkind (Parent (N)) /= N_Exception_Handler
+ then
+ Set_Has_Recursive_Call (Nam);
+ Error_Msg_N ("possible infinite recursion?", N);
+ Error_Msg_N ("Storage_Error may be raised at run time?", N);
+ end if;
+
+ exit;
+ end if;
+
+ Scop := Scope (Scop);
+ end loop;
+ end if;
+
+ -- If subprogram name is a predefined operator, it was given in
+ -- functional notation. Replace call node with operator node, so
+ -- that actuals can be resolved appropriately.
+
+ if Is_Predefined_Op (Nam) or else Ekind (Nam) = E_Operator then
+ Make_Call_Into_Operator (N, Typ, Entity (Name (N)));
+ return;
+
+ elsif Present (Alias (Nam))
+ and then Is_Predefined_Op (Alias (Nam))
+ then
+ Resolve_Actuals (N, Nam);
+ Make_Call_Into_Operator (N, Typ, Alias (Nam));
+ return;
+ end if;
+
+ -- Create a transient scope if the resulting type requires it.
+ -- There are 3 notable exceptions: in init_procs, the transient scope
+ -- overhead is not needed and even incorrect due to the actual expansion
+ -- of adjust calls; the second case is enumeration literal pseudo calls,
+ -- the other case is intrinsic subprograms (Unchecked_Conversion and
+ -- source information functions) that do not use the secondary stack
+ -- even though the return type is unconstrained.
+
+ -- If this is an initialization call for a type whose initialization
+ -- uses the secondary stack, we also need to create a transient scope
+ -- for it, precisely because we will not do it within the init_proc
+ -- itself.
+
+ if Expander_Active
+ and then Is_Type (Etype (Nam))
+ and then Requires_Transient_Scope (Etype (Nam))
+ and then Ekind (Nam) /= E_Enumeration_Literal
+ and then not Within_Init_Proc
+ and then not Is_Intrinsic_Subprogram (Nam)
+ then
+ Establish_Transient_Scope
+ (N, Sec_Stack => not Functions_Return_By_DSP_On_Target);
+
+ elsif Chars (Nam) = Name_uInit_Proc
+ and then not Within_Init_Proc
+ then
+ Check_Initialization_Call (N, Nam);
+ end if;
+
+ -- A protected function cannot be called within the definition of the
+ -- enclosing protected type.
+
+ if Is_Protected_Type (Scope (Nam))
+ and then In_Open_Scopes (Scope (Nam))
+ and then not Has_Completion (Scope (Nam))
+ then
+ Error_Msg_NE
+ ("& cannot be called before end of protected definition", N, Nam);
+ end if;
+
+ -- Propagate interpretation to actuals, and add default expressions
+ -- where needed.
+
+ if Present (First_Formal (Nam)) then
+ Resolve_Actuals (N, Nam);
+
+ -- Overloaded literals are rewritten as function calls, for
+ -- purpose of resolution. After resolution, we can replace
+ -- the call with the literal itself.
+
+ elsif Ekind (Nam) = E_Enumeration_Literal then
+ Copy_Node (Subp, N);
+ Resolve_Entity_Name (N, Typ);
+
+ -- Avoid validation, since it is a static function call.
+
+ return;
+ end if;
+
+ -- If the subprogram is a primitive operation, check whether or not
+ -- it is a correct dispatching call.
+
+ if Is_Overloadable (Nam)
+ and then Is_Dispatching_Operation (Nam)
+ then
+ Check_Dispatching_Call (N);
+
+ -- If the subprogram is abstract, check that the call has a
+ -- controlling argument (i.e. is dispatching) or is disptaching on
+ -- result
+
+ if Is_Abstract (Nam)
+ and then No (Controlling_Argument (N))
+ and then not Is_Class_Wide_Type (Typ)
+ and then not Is_Tag_Indeterminate (N)
+ then
+ Error_Msg_N ("call to abstract subprogram must be dispatching", N);
+ end if;
+
+ elsif Is_Abstract (Nam)
+ and then not In_Instance
+ then
+ Error_Msg_NE ("cannot call abstract subprogram &!", N, Nam);
+ end if;
+
+ if Is_Intrinsic_Subprogram (Nam) then
+ Check_Intrinsic_Call (N);
+ end if;
+
+ -- If we fall through we definitely have a non-static call
+
+ Check_Elab_Call (N);
+
+ end Resolve_Call;
+
+ -------------------------------
+ -- Resolve_Character_Literal --
+ -------------------------------
+
+ procedure Resolve_Character_Literal (N : Node_Id; Typ : Entity_Id) is
+ B_Typ : constant Entity_Id := Base_Type (Typ);
+ C : Entity_Id;
+
+ begin
+ -- Verify that the character does belong to the type of the context
+
+ Set_Etype (N, B_Typ);
+ Eval_Character_Literal (N);
+
+ -- Wide_Character literals must always be defined, since the set of
+ -- wide character literals is complete, i.e. if a character literal
+ -- is accepted by the parser, then it is OK for wide character.
+
+ if Root_Type (B_Typ) = Standard_Wide_Character then
+ return;
+
+ -- Always accept character literal for type Any_Character, which
+ -- occurs in error situations and in comparisons of literals, both
+ -- of which should accept all literals.
+
+ elsif B_Typ = Any_Character then
+ return;
+
+ -- For Standard.Character or a type derived from it, check that
+ -- the literal is in range
+
+ elsif Root_Type (B_Typ) = Standard_Character then
+ if In_Character_Range (Char_Literal_Value (N)) then
+ return;
+ end if;
+
+ -- If the entity is already set, this has already been resolved in
+ -- a generic context, or comes from expansion. Nothing else to do.
+
+ elsif Present (Entity (N)) then
+ return;
+
+ -- Otherwise we have a user defined character type, and we can use
+ -- the standard visibility mechanisms to locate the referenced entity
+
+ else
+ C := Current_Entity (N);
+
+ while Present (C) loop
+ if Etype (C) = B_Typ then
+ Set_Entity_With_Style_Check (N, C);
+ Generate_Reference (C, N);
+ return;
+ end if;
+
+ C := Homonym (C);
+ end loop;
+ end if;
+
+ -- If we fall through, then the literal does not match any of the
+ -- entries of the enumeration type. This isn't just a constraint
+ -- error situation, it is an illegality (see RM 4.2).
+
+ Error_Msg_NE
+ ("character not defined for }", N, First_Subtype (B_Typ));
+
+ end Resolve_Character_Literal;
+
+ ---------------------------
+ -- Resolve_Comparison_Op --
+ ---------------------------
+
+ -- Context requires a boolean type, and plays no role in resolution.
+ -- Processing identical to that for equality operators.
+
+ procedure Resolve_Comparison_Op (N : Node_Id; Typ : Entity_Id) is
+ L : constant Node_Id := Left_Opnd (N);
+ R : constant Node_Id := Right_Opnd (N);
+ T : Entity_Id;
+
+ begin
+ -- If this is an intrinsic operation which is not predefined, use
+ -- the types of its declared arguments to resolve the possibly
+ -- overloaded operands. Otherwise the operands are unambiguous and
+ -- specify the expected type.
+
+ if Scope (Entity (N)) /= Standard_Standard then
+ T := Etype (First_Entity (Entity (N)));
+ else
+ T := Find_Unique_Type (L, R);
+
+ if T = Any_Fixed then
+ T := Unique_Fixed_Point_Type (L);
+ end if;
+ end if;
+
+ Set_Etype (N, Typ);
+ Generate_Reference (T, N, ' ');
+
+ if T /= Any_Type then
+
+ if T = Any_String
+ or else T = Any_Composite
+ or else T = Any_Character
+ then
+ if T = Any_Character then
+ Ambiguous_Character (L);
+ else
+ Error_Msg_N ("ambiguous operands for comparison", N);
+ end if;
+
+ Set_Etype (N, Any_Type);
+ return;
+
+ else
+ if Comes_From_Source (N)
+ and then Has_Unchecked_Union (T)
+ then
+ Error_Msg_N
+ ("cannot compare Unchecked_Union values", N);
+ end if;
+
+ Resolve (L, T);
+ Resolve (R, T);
+ Check_Unset_Reference (L);
+ Check_Unset_Reference (R);
+ Generate_Operator_Reference (N);
+ Eval_Relational_Op (N);
+ end if;
+ end if;
+
+ end Resolve_Comparison_Op;
+
+ ------------------------------------
+ -- Resolve_Conditional_Expression --
+ ------------------------------------
+
+ procedure Resolve_Conditional_Expression (N : Node_Id; Typ : Entity_Id) is
+ Condition : constant Node_Id := First (Expressions (N));
+ Then_Expr : constant Node_Id := Next (Condition);
+ Else_Expr : constant Node_Id := Next (Then_Expr);
+
+ begin
+ Resolve (Condition, Standard_Boolean);
+ Resolve (Then_Expr, Typ);
+ Resolve (Else_Expr, Typ);
+
+ Set_Etype (N, Typ);
+ Eval_Conditional_Expression (N);
+ end Resolve_Conditional_Expression;
+
+ -----------------------------------------
+ -- Resolve_Discrete_Subtype_Indication --
+ -----------------------------------------
+
+ procedure Resolve_Discrete_Subtype_Indication
+ (N : Node_Id;
+ Typ : Entity_Id)
+ is
+ R : Node_Id;
+ S : Entity_Id;
+
+ begin
+ Analyze (Subtype_Mark (N));
+ S := Entity (Subtype_Mark (N));
+
+ if Nkind (Constraint (N)) /= N_Range_Constraint then
+ Error_Msg_N ("expect range constraint for discrete type", N);
+ Set_Etype (N, Any_Type);
+
+ else
+ R := Range_Expression (Constraint (N));
+ Analyze (R);
+
+ if Base_Type (S) /= Base_Type (Typ) then
+ Error_Msg_NE
+ ("expect subtype of }", N, First_Subtype (Typ));
+
+ -- Rewrite the constraint as a range of Typ
+ -- to allow compilation to proceed further.
+
+ Set_Etype (N, Typ);
+ Rewrite (Low_Bound (R),
+ Make_Attribute_Reference (Sloc (Low_Bound (R)),
+ Prefix => New_Occurrence_Of (Typ, Sloc (R)),
+ Attribute_Name => Name_First));
+ Rewrite (High_Bound (R),
+ Make_Attribute_Reference (Sloc (High_Bound (R)),
+ Prefix => New_Occurrence_Of (Typ, Sloc (R)),
+ Attribute_Name => Name_First));
+
+ else
+ Resolve (R, Typ);
+ Set_Etype (N, Etype (R));
+
+ -- Additionally, we must check that the bounds are compatible
+ -- with the given subtype, which might be different from the
+ -- type of the context.
+
+ Apply_Range_Check (R, S);
+
+ -- ??? If the above check statically detects a Constraint_Error
+ -- it replaces the offending bound(s) of the range R with a
+ -- Constraint_Error node. When the itype which uses these bounds
+ -- is frozen the resulting call to Duplicate_Subexpr generates
+ -- a new temporary for the bounds.
+
+ -- Unfortunately there are other itypes that are also made depend
+ -- on these bounds, so when Duplicate_Subexpr is called they get
+ -- a forward reference to the newly created temporaries and Gigi
+ -- aborts on such forward references. This is probably sign of a
+ -- more fundamental problem somewhere else in either the order of
+ -- itype freezing or the way certain itypes are constructed.
+
+ -- To get around this problem we call Remove_Side_Effects right
+ -- away if either bounds of R are a Constraint_Error.
+
+ declare
+ L : Node_Id := Low_Bound (R);
+ H : Node_Id := High_Bound (R);
+
+ begin
+ if Nkind (L) = N_Raise_Constraint_Error then
+ Remove_Side_Effects (L);
+ end if;
+
+ if Nkind (H) = N_Raise_Constraint_Error then
+ Remove_Side_Effects (H);
+ end if;
+ end;
+
+ Check_Unset_Reference (Low_Bound (R));
+ Check_Unset_Reference (High_Bound (R));
+ end if;
+ end if;
+ end Resolve_Discrete_Subtype_Indication;
+
+ -------------------------
+ -- Resolve_Entity_Name --
+ -------------------------
+
+ -- Used to resolve identifiers and expanded names
+
+ procedure Resolve_Entity_Name (N : Node_Id; Typ : Entity_Id) is
+ E : constant Entity_Id := Entity (N);
+
+ begin
+ -- Replace named numbers by corresponding literals. Note that this is
+ -- the one case where Resolve_Entity_Name must reset the Etype, since
+ -- it is currently marked as universal.
+
+ if Ekind (E) = E_Named_Integer then
+ Set_Etype (N, Typ);
+ Eval_Named_Integer (N);
+
+ elsif Ekind (E) = E_Named_Real then
+ Set_Etype (N, Typ);
+ Eval_Named_Real (N);
+
+ -- Allow use of subtype only if it is a concurrent type where we are
+ -- currently inside the body. This will eventually be expanded
+ -- into a call to Self (for tasks) or _object (for protected
+ -- objects). Any other use of a subtype is invalid.
+
+ elsif Is_Type (E) then
+ if Is_Concurrent_Type (E)
+ and then In_Open_Scopes (E)
+ then
+ null;
+ else
+ Error_Msg_N
+ ("Invalid use of subtype mark in expression or call", N);
+ end if;
+
+ -- Check discriminant use if entity is discriminant in current scope,
+ -- i.e. discriminant of record or concurrent type currently being
+ -- analyzed. Uses in corresponding body are unrestricted.
+
+ elsif Ekind (E) = E_Discriminant
+ and then Scope (E) = Current_Scope
+ and then not Has_Completion (Current_Scope)
+ then
+ Check_Discriminant_Use (N);
+
+ -- A parameterless generic function cannot appear in a context that
+ -- requires resolution.
+
+ elsif Ekind (E) = E_Generic_Function then
+ Error_Msg_N ("illegal use of generic function", N);
+
+ elsif Ekind (E) = E_Out_Parameter
+ and then Ada_83
+ and then (Nkind (Parent (N)) in N_Op
+ or else (Nkind (Parent (N)) = N_Assignment_Statement
+ and then N = Expression (Parent (N)))
+ or else Nkind (Parent (N)) = N_Explicit_Dereference)
+ then
+ Error_Msg_N ("(Ada 83) illegal reading of out parameter", N);
+
+ -- In all other cases, just do the possible static evaluation
+
+ else
+ -- A deferred constant that appears in an expression must have
+ -- a completion, unless it has been removed by in-place expansion
+ -- of an aggregate.
+
+ if Ekind (E) = E_Constant
+ and then Comes_From_Source (E)
+ and then No (Constant_Value (E))
+ and then Is_Frozen (Etype (E))
+ and then not In_Default_Expression
+ and then not Is_Imported (E)
+ then
+
+ if No_Initialization (Parent (E))
+ or else (Present (Full_View (E))
+ and then No_Initialization (Parent (Full_View (E))))
+ then
+ null;
+ else
+ Error_Msg_N (
+ "deferred constant is frozen before completion", N);
+ end if;
+ end if;
+
+ Eval_Entity_Name (N);
+ end if;
+ end Resolve_Entity_Name;
+
+ -------------------
+ -- Resolve_Entry --
+ -------------------
+
+ procedure Resolve_Entry (Entry_Name : Node_Id) is
+ Loc : constant Source_Ptr := Sloc (Entry_Name);
+ Nam : Entity_Id;
+ New_N : Node_Id;
+ S : Entity_Id;
+ Tsk : Entity_Id;
+ E_Name : Node_Id;
+ Index : Node_Id;
+
+ function Actual_Index_Type (E : Entity_Id) return Entity_Id;
+ -- If the bounds of the entry family being called depend on task
+ -- discriminants, build a new index subtype where a discriminant is
+ -- replaced with the value of the discriminant of the target task.
+ -- The target task is the prefix of the entry name in the call.
+
+ -----------------------
+ -- Actual_Index_Type --
+ -----------------------
+
+ function Actual_Index_Type (E : Entity_Id) return Entity_Id is
+ Typ : Entity_Id := Entry_Index_Type (E);
+ Tsk : Entity_Id := Scope (E);
+ Lo : Node_Id := Type_Low_Bound (Typ);
+ Hi : Node_Id := Type_High_Bound (Typ);
+ New_T : Entity_Id;
+
+ function Actual_Discriminant_Ref (Bound : Node_Id) return Node_Id;
+ -- If the bound is given by a discriminant, replace with a reference
+ -- to the discriminant of the same name in the target task.
+ -- If the entry name is the target of a requeue statement and the
+ -- entry is in the current protected object, the bound to be used
+ -- is the discriminal of the object (see apply_range_checks for
+ -- details of the transformation).
+
+ -----------------------------
+ -- Actual_Discriminant_Ref --
+ -----------------------------
+
+ function Actual_Discriminant_Ref (Bound : Node_Id) return Node_Id is
+ Typ : Entity_Id := Etype (Bound);
+ Ref : Node_Id;
+
+ begin
+ Remove_Side_Effects (Bound);
+
+ if not Is_Entity_Name (Bound)
+ or else Ekind (Entity (Bound)) /= E_Discriminant
+ then
+ return Bound;
+
+ elsif Is_Protected_Type (Tsk)
+ and then In_Open_Scopes (Tsk)
+ and then Nkind (Parent (Entry_Name)) = N_Requeue_Statement
+ then
+ return New_Occurrence_Of (Discriminal (Entity (Bound)), Loc);
+
+ else
+ Ref :=
+ Make_Selected_Component (Loc,
+ Prefix => New_Copy_Tree (Prefix (Prefix (Entry_Name))),
+ Selector_Name => New_Occurrence_Of (Entity (Bound), Loc));
+ Analyze (Ref);
+ Resolve (Ref, Typ);
+ return Ref;
+ end if;
+ end Actual_Discriminant_Ref;
+
+ -- Start of processing for Actual_Index_Type
+
+ begin
+ if not Has_Discriminants (Tsk)
+ or else (not Is_Entity_Name (Lo)
+ and then not Is_Entity_Name (Hi))
+ then
+ return Entry_Index_Type (E);
+
+ else
+ New_T := Create_Itype (Ekind (Typ), Parent (Entry_Name));
+ Set_Etype (New_T, Base_Type (Typ));
+ Set_Size_Info (New_T, Typ);
+ Set_RM_Size (New_T, RM_Size (Typ));
+ Set_Scalar_Range (New_T,
+ Make_Range (Sloc (Entry_Name),
+ Low_Bound => Actual_Discriminant_Ref (Lo),
+ High_Bound => Actual_Discriminant_Ref (Hi)));
+
+ return New_T;
+ end if;
+ end Actual_Index_Type;
+
+ -- Start of processing of Resolve_Entry
+
+ begin
+ -- Find name of entry being called, and resolve prefix of name
+ -- with its own type. The prefix can be overloaded, and the name
+ -- and signature of the entry must be taken into account.
+
+ if Nkind (Entry_Name) = N_Indexed_Component then
+
+ -- Case of dealing with entry family within the current tasks
+
+ E_Name := Prefix (Entry_Name);
+
+ else
+ E_Name := Entry_Name;
+ end if;
+
+ if Is_Entity_Name (E_Name) then
+ -- Entry call to an entry (or entry family) in the current task.
+ -- This is legal even though the task will deadlock. Rewrite as
+ -- call to current task.
+
+ -- This can also be a call to an entry in an enclosing task.
+ -- If this is a single task, we have to retrieve its name,
+ -- because the scope of the entry is the task type, not the
+ -- object. If the enclosing task is a task type, the identity
+ -- of the task is given by its own self variable.
+
+ -- Finally this can be a requeue on an entry of the same task
+ -- or protected object.
+
+ S := Scope (Entity (E_Name));
+
+ for J in reverse 0 .. Scope_Stack.Last loop
+
+ if Is_Task_Type (Scope_Stack.Table (J).Entity)
+ and then not Comes_From_Source (S)
+ then
+ -- S is an enclosing task or protected object. The concurrent
+ -- declaration has been converted into a type declaration, and
+ -- the object itself has an object declaration that follows
+ -- the type in the same declarative part.
+
+ Tsk := Next_Entity (S);
+
+ while Etype (Tsk) /= S loop
+ Next_Entity (Tsk);
+ end loop;
+
+ S := Tsk;
+ exit;
+
+ elsif S = Scope_Stack.Table (J).Entity then
+
+ -- Call to current task. Will be transformed into call to Self
+
+ exit;
+
+ end if;
+ end loop;
+
+ New_N :=
+ Make_Selected_Component (Loc,
+ Prefix => New_Occurrence_Of (S, Loc),
+ Selector_Name =>
+ New_Occurrence_Of (Entity (E_Name), Loc));
+ Rewrite (E_Name, New_N);
+ Analyze (E_Name);
+
+ elsif Nkind (Entry_Name) = N_Selected_Component
+ and then Is_Overloaded (Prefix (Entry_Name))
+ then
+ -- Use the entry name (which must be unique at this point) to
+ -- find the prefix that returns the corresponding task type or
+ -- protected type.
+
+ declare
+ Pref : Node_Id := Prefix (Entry_Name);
+ I : Interp_Index;
+ It : Interp;
+ Ent : Entity_Id := Entity (Selector_Name (Entry_Name));
+
+ begin
+ Get_First_Interp (Pref, I, It);
+
+ while Present (It.Typ) loop
+
+ if Scope (Ent) = It.Typ then
+ Set_Etype (Pref, It.Typ);
+ exit;
+ end if;
+
+ Get_Next_Interp (I, It);
+ end loop;
+ end;
+ end if;
+
+ if Nkind (Entry_Name) = N_Selected_Component then
+ Resolve (Prefix (Entry_Name), Etype (Prefix (Entry_Name)));
+
+ else pragma Assert (Nkind (Entry_Name) = N_Indexed_Component);
+ Nam := Entity (Selector_Name (Prefix (Entry_Name)));
+ Resolve (Prefix (Prefix (Entry_Name)),
+ Etype (Prefix (Prefix (Entry_Name))));
+
+ Index := First (Expressions (Entry_Name));
+ Resolve (Index, Entry_Index_Type (Nam));
+
+ -- Up to this point the expression could have been the actual
+ -- in a simple entry call, and be given by a named association.
+
+ if Nkind (Index) = N_Parameter_Association then
+ Error_Msg_N ("expect expression for entry index", Index);
+ else
+ Apply_Range_Check (Index, Actual_Index_Type (Nam));
+ end if;
+ end if;
+
+ end Resolve_Entry;
+
+ ------------------------
+ -- Resolve_Entry_Call --
+ ------------------------
+
+ procedure Resolve_Entry_Call (N : Node_Id; Typ : Entity_Id) is
+ Entry_Name : constant Node_Id := Name (N);
+ Loc : constant Source_Ptr := Sloc (Entry_Name);
+ Actuals : List_Id;
+ First_Named : Node_Id;
+ Nam : Entity_Id;
+ Norm_OK : Boolean;
+ Obj : Node_Id;
+ Was_Over : Boolean;
+
+ begin
+ -- Processing of the name is similar for entry calls and protected
+ -- operation calls. Once the entity is determined, we can complete
+ -- the resolution of the actuals.
+
+ -- The selector may be overloaded, in the case of a protected object
+ -- with overloaded functions. The type of the context is used for
+ -- resolution.
+
+ if Nkind (Entry_Name) = N_Selected_Component
+ and then Is_Overloaded (Selector_Name (Entry_Name))
+ and then Typ /= Standard_Void_Type
+ then
+ declare
+ I : Interp_Index;
+ It : Interp;
+
+ begin
+ Get_First_Interp (Selector_Name (Entry_Name), I, It);
+
+ while Present (It.Typ) loop
+
+ if Covers (Typ, It.Typ) then
+ Set_Entity (Selector_Name (Entry_Name), It.Nam);
+ Set_Etype (Entry_Name, It.Typ);
+
+ Generate_Reference (It.Typ, N, ' ');
+ end if;
+
+ Get_Next_Interp (I, It);
+ end loop;
+ end;
+ end if;
+
+ Resolve_Entry (Entry_Name);
+
+ if Nkind (Entry_Name) = N_Selected_Component then
+
+ -- Simple entry call.
+
+ Nam := Entity (Selector_Name (Entry_Name));
+ Obj := Prefix (Entry_Name);
+ Was_Over := Is_Overloaded (Selector_Name (Entry_Name));
+
+ else pragma Assert (Nkind (Entry_Name) = N_Indexed_Component);
+
+ -- Call to member of entry family.
+
+ Nam := Entity (Selector_Name (Prefix (Entry_Name)));
+ Obj := Prefix (Prefix (Entry_Name));
+ Was_Over := Is_Overloaded (Selector_Name (Prefix (Entry_Name)));
+ end if;
+
+ -- Use context type to disambiguate a protected function that can be
+ -- called without actuals and that returns an array type, and where
+ -- the argument list may be an indexing of the returned value.
+
+ if Ekind (Nam) = E_Function
+ and then Needs_No_Actuals (Nam)
+ and then Present (Parameter_Associations (N))
+ and then
+ ((Is_Array_Type (Etype (Nam))
+ and then Covers (Typ, Component_Type (Etype (Nam))))
+
+ or else (Is_Access_Type (Etype (Nam))
+ and then Is_Array_Type (Designated_Type (Etype (Nam)))
+ and then Covers (Typ,
+ Component_Type (Designated_Type (Etype (Nam))))))
+ then
+ declare
+ Index_Node : Node_Id;
+
+ begin
+ Index_Node :=
+ Make_Indexed_Component (Loc,
+ Prefix =>
+ Make_Function_Call (Loc,
+ Name => Relocate_Node (Entry_Name)),
+ Expressions => Parameter_Associations (N));
+
+ -- Since we are correcting a node classification error made by
+ -- the parser, we call Replace rather than Rewrite.
+
+ Replace (N, Index_Node);
+ Set_Etype (Prefix (N), Etype (Nam));
+ Set_Etype (N, Typ);
+ Resolve_Indexed_Component (N, Typ);
+ return;
+ end;
+ end if;
+
+ -- The operation name may have been overloaded. Order the actuals
+ -- according to the formals of the resolved entity.
+
+ if Was_Over then
+ Normalize_Actuals (N, Nam, False, Norm_OK);
+ pragma Assert (Norm_OK);
+ end if;
+
+ Resolve_Actuals (N, Nam);
+ Generate_Reference (Nam, Entry_Name);
+
+ if Ekind (Nam) = E_Entry
+ or else Ekind (Nam) = E_Entry_Family
+ then
+ Check_Potentially_Blocking_Operation (N);
+ end if;
+
+ -- Verify that a procedure call cannot masquerade as an entry
+ -- call where an entry call is expected.
+
+ if Ekind (Nam) = E_Procedure then
+
+ if Nkind (Parent (N)) = N_Entry_Call_Alternative
+ and then N = Entry_Call_Statement (Parent (N))
+ then
+ Error_Msg_N ("entry call required in select statement", N);
+
+ elsif Nkind (Parent (N)) = N_Triggering_Alternative
+ and then N = Triggering_Statement (Parent (N))
+ then
+ Error_Msg_N ("triggering statement cannot be procedure call", N);
+
+ elsif Ekind (Scope (Nam)) = E_Task_Type
+ and then not In_Open_Scopes (Scope (Nam))
+ then
+ Error_Msg_N ("Task has no entry with this name", Entry_Name);
+ end if;
+ end if;
+
+ -- After resolution, entry calls and protected procedure calls
+ -- are changed into entry calls, for expansion. The structure
+ -- of the node does not change, so it can safely be done in place.
+ -- Protected function calls must keep their structure because they
+ -- are subexpressions.
+
+ if Ekind (Nam) /= E_Function then
+
+ -- A protected operation that is not a function may modify the
+ -- corresponding object, and cannot apply to a constant.
+ -- If this is an internal call, the prefix is the type itself.
+
+ if Is_Protected_Type (Scope (Nam))
+ and then not Is_Variable (Obj)
+ and then (not Is_Entity_Name (Obj)
+ or else not Is_Type (Entity (Obj)))
+ then
+ Error_Msg_N
+ ("prefix of protected procedure or entry call must be variable",
+ Entry_Name);
+ end if;
+
+ Actuals := Parameter_Associations (N);
+ First_Named := First_Named_Actual (N);
+
+ Rewrite (N,
+ Make_Entry_Call_Statement (Loc,
+ Name => Entry_Name,
+ Parameter_Associations => Actuals));
+
+ Set_First_Named_Actual (N, First_Named);
+ Set_Analyzed (N, True);
+
+ -- Protected functions can return on the secondary stack, in which
+ -- case we must trigger the transient scope mechanism
+
+ elsif Expander_Active
+ and then Requires_Transient_Scope (Etype (Nam))
+ then
+ Establish_Transient_Scope (N,
+ Sec_Stack => not Functions_Return_By_DSP_On_Target);
+ end if;
+
+ end Resolve_Entry_Call;
+
+ -------------------------
+ -- Resolve_Equality_Op --
+ -------------------------
+
+ -- Both arguments must have the same type, and the boolean context
+ -- does not participate in the resolution. The first pass verifies
+ -- that the interpretation is not ambiguous, and the type of the left
+ -- argument is correctly set, or is Any_Type in case of ambiguity.
+ -- If both arguments are strings or aggregates, allocators, or Null,
+ -- they are ambiguous even though they carry a single (universal) type.
+ -- Diagnose this case here.
+
+ procedure Resolve_Equality_Op (N : Node_Id; Typ : Entity_Id) is
+ L : constant Node_Id := Left_Opnd (N);
+ R : constant Node_Id := Right_Opnd (N);
+ T : Entity_Id := Find_Unique_Type (L, R);
+
+ function Find_Unique_Access_Type return Entity_Id;
+ -- In the case of allocators, make a last-ditch attempt to find a single
+ -- access type with the right designated type. This is semantically
+ -- dubious, and of no interest to any real code, but c48008a makes it
+ -- all worthwhile.
+
+ -----------------------------
+ -- Find_Unique_Access_Type --
+ -----------------------------
+
+ function Find_Unique_Access_Type return Entity_Id is
+ Acc : Entity_Id;
+ E : Entity_Id;
+ S : Entity_Id := Current_Scope;
+
+ begin
+ if Ekind (Etype (R)) = E_Allocator_Type then
+ Acc := Designated_Type (Etype (R));
+
+ elsif Ekind (Etype (L)) = E_Allocator_Type then
+ Acc := Designated_Type (Etype (L));
+
+ else
+ return Empty;
+ end if;
+
+ while S /= Standard_Standard loop
+ E := First_Entity (S);
+
+ while Present (E) loop
+
+ if Is_Type (E)
+ and then Is_Access_Type (E)
+ and then Ekind (E) /= E_Allocator_Type
+ and then Designated_Type (E) = Base_Type (Acc)
+ then
+ return E;
+ end if;
+
+ Next_Entity (E);
+ end loop;
+
+ S := Scope (S);
+ end loop;
+
+ return Empty;
+ end Find_Unique_Access_Type;
+
+ -- Start of processing for Resolve_Equality_Op
+
+ begin
+ Set_Etype (N, Base_Type (Typ));
+ Generate_Reference (T, N, ' ');
+
+ if T = Any_Fixed then
+ T := Unique_Fixed_Point_Type (L);
+ end if;
+
+ if T /= Any_Type then
+
+ if T = Any_String
+ or else T = Any_Composite
+ or else T = Any_Character
+ then
+
+ if T = Any_Character then
+ Ambiguous_Character (L);
+ else
+ Error_Msg_N ("ambiguous operands for equality", N);
+ end if;
+
+ Set_Etype (N, Any_Type);
+ return;
+
+ elsif T = Any_Access
+ or else Ekind (T) = E_Allocator_Type
+ then
+ T := Find_Unique_Access_Type;
+
+ if No (T) then
+ Error_Msg_N ("ambiguous operands for equality", N);
+ Set_Etype (N, Any_Type);
+ return;
+ end if;
+ end if;
+
+ if Comes_From_Source (N)
+ and then Has_Unchecked_Union (T)
+ then
+ Error_Msg_N
+ ("cannot compare Unchecked_Union values", N);
+ end if;
+
+ Resolve (L, T);
+ Resolve (R, T);
+ Check_Unset_Reference (L);
+ Check_Unset_Reference (R);
+ Generate_Operator_Reference (N);
+
+ -- If this is an inequality, it may be the implicit inequality
+ -- created for a user-defined operation, in which case the corres-
+ -- ponding equality operation is not intrinsic, and the operation
+ -- cannot be constant-folded. Else fold.
+
+ if Nkind (N) = N_Op_Eq
+ or else Comes_From_Source (Entity (N))
+ or else Ekind (Entity (N)) = E_Operator
+ or else Is_Intrinsic_Subprogram
+ (Corresponding_Equality (Entity (N)))
+ then
+ Eval_Relational_Op (N);
+ elsif Nkind (N) = N_Op_Ne
+ and then Is_Abstract (Entity (N))
+ then
+ Error_Msg_NE ("cannot call abstract subprogram &!", N, Entity (N));
+ end if;
+ end if;
+ end Resolve_Equality_Op;
+
+ ----------------------------------
+ -- Resolve_Explicit_Dereference --
+ ----------------------------------
+
+ procedure Resolve_Explicit_Dereference (N : Node_Id; Typ : Entity_Id) is
+ P : constant Node_Id := Prefix (N);
+ I : Interp_Index;
+ It : Interp;
+
+ begin
+ -- Now that we know the type, check that this is not a
+ -- dereference of an uncompleted type. Note that this
+ -- is not entirely correct, because dereferences of
+ -- private types are legal in default expressions.
+ -- This consideration also applies to similar checks
+ -- for allocators, qualified expressions, and type
+ -- conversions. ???
+
+ Check_Fully_Declared (Typ, N);
+
+ if Is_Overloaded (P) then
+
+ -- Use the context type to select the prefix that has the
+ -- correct designated type.
+
+ Get_First_Interp (P, I, It);
+ while Present (It.Typ) loop
+ exit when Is_Access_Type (It.Typ)
+ and then Covers (Typ, Designated_Type (It.Typ));
+
+ Get_Next_Interp (I, It);
+ end loop;
+
+ Resolve (P, It.Typ);
+ Set_Etype (N, Designated_Type (It.Typ));
+
+ else
+ Resolve (P, Etype (P));
+ end if;
+
+ if Is_Access_Type (Etype (P)) then
+ Apply_Access_Check (N);
+ end if;
+
+ -- If the designated type is a packed unconstrained array type,
+ -- and the explicit dereference is not in the context of an
+ -- attribute reference, then we must compute and set the actual
+ -- subtype, since it is needed by Gigi. The reason we exclude
+ -- the attribute case is that this is handled fine by Gigi, and
+ -- in fact we use such attributes to build the actual subtype.
+ -- We also exclude generated code (which builds actual subtypes
+ -- directly if they are needed).
+
+ if Is_Array_Type (Etype (N))
+ and then Is_Packed (Etype (N))
+ and then not Is_Constrained (Etype (N))
+ and then Nkind (Parent (N)) /= N_Attribute_Reference
+ and then Comes_From_Source (N)
+ then
+ Set_Etype (N, Get_Actual_Subtype (N));
+ end if;
+
+ -- Note: there is no Eval processing required for an explicit
+ -- deference, because the type is known to be an allocators, and
+ -- allocator expressions can never be static.
+
+ end Resolve_Explicit_Dereference;
+
+ -------------------------------
+ -- Resolve_Indexed_Component --
+ -------------------------------
+
+ procedure Resolve_Indexed_Component (N : Node_Id; Typ : Entity_Id) is
+ Name : constant Node_Id := Prefix (N);
+ Expr : Node_Id;
+ Array_Type : Entity_Id := Empty; -- to prevent junk warning
+ Index : Node_Id;
+
+ begin
+ if Is_Overloaded (Name) then
+
+ -- Use the context type to select the prefix that yields the
+ -- correct component type.
+
+ declare
+ I : Interp_Index;
+ It : Interp;
+ I1 : Interp_Index := 0;
+ P : constant Node_Id := Prefix (N);
+ Found : Boolean := False;
+
+ begin
+ Get_First_Interp (P, I, It);
+
+ while Present (It.Typ) loop
+
+ if (Is_Array_Type (It.Typ)
+ and then Covers (Typ, Component_Type (It.Typ)))
+ or else (Is_Access_Type (It.Typ)
+ and then Is_Array_Type (Designated_Type (It.Typ))
+ and then Covers
+ (Typ, Component_Type (Designated_Type (It.Typ))))
+ then
+ if Found then
+ It := Disambiguate (P, I1, I, Any_Type);
+
+ if It = No_Interp then
+ Error_Msg_N ("ambiguous prefix for indexing", N);
+ Set_Etype (N, Typ);
+ return;
+
+ else
+ Found := True;
+ Array_Type := It.Typ;
+ I1 := I;
+ end if;
+
+ else
+ Found := True;
+ Array_Type := It.Typ;
+ I1 := I;
+ end if;
+ end if;
+
+ Get_Next_Interp (I, It);
+ end loop;
+ end;
+
+ else
+ Array_Type := Etype (Name);
+ end if;
+
+ Resolve (Name, Array_Type);
+ Array_Type := Get_Actual_Subtype_If_Available (Name);
+
+ -- If prefix is access type, dereference to get real array type.
+ -- Note: we do not apply an access check because the expander always
+ -- introduces an explicit dereference, and the check will happen there.
+
+ if Is_Access_Type (Array_Type) then
+ Array_Type := Designated_Type (Array_Type);
+ end if;
+
+ -- If name was overloaded, set component type correctly now.
+
+ Set_Etype (N, Component_Type (Array_Type));
+
+ Index := First_Index (Array_Type);
+ Expr := First (Expressions (N));
+
+ -- The prefix may have resolved to a string literal, in which case
+ -- its etype has a special representation. This is only possible
+ -- currently if the prefix is a static concatenation, written in
+ -- functional notation.
+
+ if Ekind (Array_Type) = E_String_Literal_Subtype then
+ Resolve (Expr, Standard_Positive);
+
+ else
+ while Present (Index) and Present (Expr) loop
+ Resolve (Expr, Etype (Index));
+ Check_Unset_Reference (Expr);
+
+ if Is_Scalar_Type (Etype (Expr)) then
+ Apply_Scalar_Range_Check (Expr, Etype (Index));
+ else
+ Apply_Range_Check (Expr, Get_Actual_Subtype (Index));
+ end if;
+
+ Next_Index (Index);
+ Next (Expr);
+ end loop;
+ end if;
+
+ Eval_Indexed_Component (N);
+
+ end Resolve_Indexed_Component;
+
+ -----------------------------
+ -- Resolve_Integer_Literal --
+ -----------------------------
+
+ procedure Resolve_Integer_Literal (N : Node_Id; Typ : Entity_Id) is
+ begin
+ Set_Etype (N, Typ);
+ Eval_Integer_Literal (N);
+ end Resolve_Integer_Literal;
+
+ ---------------------------------
+ -- Resolve_Intrinsic_Operator --
+ ---------------------------------
+
+ procedure Resolve_Intrinsic_Operator (N : Node_Id; Typ : Entity_Id) is
+ Op : Entity_Id;
+ Arg1 : Node_Id := Left_Opnd (N);
+ Arg2 : Node_Id := Right_Opnd (N);
+
+ begin
+ Op := Entity (N);
+
+ while Scope (Op) /= Standard_Standard loop
+ Op := Homonym (Op);
+ pragma Assert (Present (Op));
+ end loop;
+
+ Set_Entity (N, Op);
+
+ if Typ /= Etype (Arg1) or else Typ = Etype (Arg2) then
+ Rewrite (Left_Opnd (N), Convert_To (Typ, Arg1));
+ Rewrite (Right_Opnd (N), Convert_To (Typ, Arg2));
+
+ Analyze (Left_Opnd (N));
+ Analyze (Right_Opnd (N));
+ end if;
+
+ Resolve_Arithmetic_Op (N, Typ);
+ end Resolve_Intrinsic_Operator;
+
+ ------------------------
+ -- Resolve_Logical_Op --
+ ------------------------
+
+ procedure Resolve_Logical_Op (N : Node_Id; Typ : Entity_Id) is
+ B_Typ : Entity_Id;
+
+ begin
+ -- Predefined operations on scalar types yield the base type. On
+ -- the other hand, logical operations on arrays yield the type of
+ -- the arguments (and the context).
+
+ if Is_Array_Type (Typ) then
+ B_Typ := Typ;
+ else
+ B_Typ := Base_Type (Typ);
+ end if;
+
+ -- The following test is required because the operands of the operation
+ -- may be literals, in which case the resulting type appears to be
+ -- compatible with a signed integer type, when in fact it is compatible
+ -- only with modular types. If the context itself is universal, the
+ -- operation is illegal.
+
+ if not Valid_Boolean_Arg (Typ) then
+ Error_Msg_N ("invalid context for logical operation", N);
+ Set_Etype (N, Any_Type);
+ return;
+
+ elsif Typ = Any_Modular then
+ Error_Msg_N
+ ("no modular type available in this context", N);
+ Set_Etype (N, Any_Type);
+ return;
+ end if;
+
+ Resolve (Left_Opnd (N), B_Typ);
+ Resolve (Right_Opnd (N), B_Typ);
+
+ Check_Unset_Reference (Left_Opnd (N));
+ Check_Unset_Reference (Right_Opnd (N));
+
+ Set_Etype (N, B_Typ);
+ Generate_Operator_Reference (N);
+ Eval_Logical_Op (N);
+ end Resolve_Logical_Op;
+
+ ---------------------------
+ -- Resolve_Membership_Op --
+ ---------------------------
+
+ -- The context can only be a boolean type, and does not determine
+ -- the arguments. Arguments should be unambiguous, but the preference
+ -- rule for universal types applies.
+
+ procedure Resolve_Membership_Op (N : Node_Id; Typ : Entity_Id) is
+ L : constant Node_Id := Left_Opnd (N);
+ R : constant Node_Id := Right_Opnd (N);
+ T : Entity_Id;
+
+ begin
+ if L = Error or else R = Error then
+ return;
+ end if;
+
+ if not Is_Overloaded (R)
+ and then
+ (Etype (R) = Universal_Integer or else
+ Etype (R) = Universal_Real)
+ and then Is_Overloaded (L)
+ then
+ T := Etype (R);
+ else
+ T := Intersect_Types (L, R);
+ end if;
+
+ Resolve (L, T);
+ Check_Unset_Reference (L);
+
+ if Nkind (R) = N_Range
+ and then not Is_Scalar_Type (T)
+ then
+ Error_Msg_N ("scalar type required for range", R);
+ end if;
+
+ if Is_Entity_Name (R) then
+ Freeze_Expression (R);
+ else
+ Resolve (R, T);
+ Check_Unset_Reference (R);
+ end if;
+
+ Eval_Membership_Op (N);
+ end Resolve_Membership_Op;
+
+ ------------------
+ -- Resolve_Null --
+ ------------------
+
+ procedure Resolve_Null (N : Node_Id; Typ : Entity_Id) is
+ begin
+ -- For now allow circumvention of the restriction against
+ -- anonymous null access values via a debug switch to allow
+ -- for easier trasition.
+
+ if not Debug_Flag_J
+ and then Ekind (Typ) = E_Anonymous_Access_Type
+ and then Comes_From_Source (N)
+ then
+ -- In the common case of a call which uses an explicitly null
+ -- value for an access parameter, give specialized error msg
+
+ if Nkind (Parent (N)) = N_Procedure_Call_Statement
+ or else
+ Nkind (Parent (N)) = N_Function_Call
+ then
+ Error_Msg_N
+ ("null is not allowed as argument for an access parameter", N);
+
+ -- Standard message for all other cases (are there any?)
+
+ else
+ Error_Msg_N
+ ("null cannot be of an anonymous access type", N);
+ end if;
+ end if;
+
+ -- In a distributed context, null for a remote access to subprogram
+ -- may need to be replaced with a special record aggregate. In this
+ -- case, return after having done the transformation.
+
+ if (Ekind (Typ) = E_Record_Type
+ or else Is_Remote_Access_To_Subprogram_Type (Typ))
+ and then Remote_AST_Null_Value (N, Typ)
+ then
+ return;
+ end if;
+
+ -- The null literal takes its type from the context.
+
+ Set_Etype (N, Typ);
+ end Resolve_Null;
+
+ -----------------------
+ -- Resolve_Op_Concat --
+ -----------------------
+
+ procedure Resolve_Op_Concat (N : Node_Id; Typ : Entity_Id) is
+ Btyp : constant Entity_Id := Base_Type (Typ);
+ Op1 : constant Node_Id := Left_Opnd (N);
+ Op2 : constant Node_Id := Right_Opnd (N);
+
+ procedure Resolve_Concatenation_Arg (Arg : Node_Id; Is_Comp : Boolean);
+ -- Internal procedure to resolve one operand of concatenation operator.
+ -- The operand is either of the array type or of the component type.
+ -- If the operand is an aggregate, and the component type is composite,
+ -- this is ambiguous if component type has aggregates.
+
+ -------------------------------
+ -- Resolve_Concatenation_Arg --
+ -------------------------------
+
+ procedure Resolve_Concatenation_Arg (Arg : Node_Id; Is_Comp : Boolean) is
+ begin
+ if In_Instance then
+ if Is_Comp
+ or else (not Is_Overloaded (Arg)
+ and then Etype (Arg) /= Any_Composite
+ and then Covers (Component_Type (Typ), Etype (Arg)))
+ then
+ Resolve (Arg, Component_Type (Typ));
+ else
+ Resolve (Arg, Btyp);
+ end if;
+
+ elsif Has_Compatible_Type (Arg, Component_Type (Typ)) then
+
+ if Nkind (Arg) = N_Aggregate
+ and then Is_Composite_Type (Component_Type (Typ))
+ then
+ if Is_Private_Type (Component_Type (Typ)) then
+ Resolve (Arg, Btyp);
+
+ else
+ Error_Msg_N ("ambiguous aggregate must be qualified", Arg);
+ Set_Etype (Arg, Any_Type);
+ end if;
+
+ else
+ if Is_Overloaded (Arg)
+ and then Has_Compatible_Type (Arg, Typ)
+ and then Etype (Arg) /= Any_Type
+ then
+ Error_Msg_N ("ambiguous operand for concatenation!", Arg);
+
+ declare
+ I : Interp_Index;
+ It : Interp;
+
+ begin
+ Get_First_Interp (Arg, I, It);
+
+ while Present (It.Nam) loop
+
+ if Base_Type (Etype (It.Nam)) = Base_Type (Typ)
+ or else Base_Type (Etype (It.Nam)) =
+ Base_Type (Component_Type (Typ))
+ then
+ Error_Msg_Sloc := Sloc (It.Nam);
+ Error_Msg_N ("\possible interpretation#", Arg);
+ end if;
+
+ Get_Next_Interp (I, It);
+ end loop;
+ end;
+ end if;
+
+ Resolve (Arg, Component_Type (Typ));
+
+ if Arg = Left_Opnd (N) then
+ Set_Is_Component_Left_Opnd (N);
+ else
+ Set_Is_Component_Right_Opnd (N);
+ end if;
+ end if;
+
+ else
+ Resolve (Arg, Btyp);
+ end if;
+
+ Check_Unset_Reference (Arg);
+ end Resolve_Concatenation_Arg;
+
+ -- Start of processing for Resolve_Op_Concat
+
+ begin
+ Set_Etype (N, Btyp);
+
+ if Is_Limited_Composite (Btyp) then
+ Error_Msg_N ("concatenation not available for limited array", N);
+ end if;
+
+ -- If the operands are themselves concatenations, resolve them as
+ -- such directly. This removes several layers of recursion and allows
+ -- GNAT to handle larger multiple concatenations.
+
+ if Nkind (Op1) = N_Op_Concat
+ and then not Is_Array_Type (Component_Type (Typ))
+ and then Entity (Op1) = Entity (N)
+ then
+ Resolve_Op_Concat (Op1, Typ);
+ else
+ Resolve_Concatenation_Arg
+ (Op1, Is_Component_Left_Opnd (N));
+ end if;
+
+ if Nkind (Op2) = N_Op_Concat
+ and then not Is_Array_Type (Component_Type (Typ))
+ and then Entity (Op2) = Entity (N)
+ then
+ Resolve_Op_Concat (Op2, Typ);
+ else
+ Resolve_Concatenation_Arg
+ (Op2, Is_Component_Right_Opnd (N));
+ end if;
+
+ Generate_Operator_Reference (N);
+
+ if Is_String_Type (Typ) then
+ Eval_Concatenation (N);
+ end if;
+
+ -- If this is not a static concatenation, but the result is a
+ -- string type (and not an array of strings) insure that static
+ -- string operands have their subtypes properly constructed.
+
+ if Nkind (N) /= N_String_Literal
+ and then Is_Character_Type (Component_Type (Typ))
+ then
+ Set_String_Literal_Subtype (Op1, Typ);
+ Set_String_Literal_Subtype (Op2, Typ);
+ end if;
+ end Resolve_Op_Concat;
+
+ ----------------------
+ -- Resolve_Op_Expon --
+ ----------------------
+
+ procedure Resolve_Op_Expon (N : Node_Id; Typ : Entity_Id) is
+ B_Typ : constant Entity_Id := Base_Type (Typ);
+
+ begin
+ -- Catch attempts to do fixed-point exponentation with universal
+ -- operands, which is a case where the illegality is not caught
+ -- during normal operator analysis.
+
+ if Is_Fixed_Point_Type (Typ) and then Comes_From_Source (N) then
+ Error_Msg_N ("exponentiation not available for fixed point", N);
+ return;
+ end if;
+
+ if Etype (Left_Opnd (N)) = Universal_Integer
+ or else Etype (Left_Opnd (N)) = Universal_Real
+ then
+ Check_For_Visible_Operator (N, B_Typ);
+ end if;
+
+ -- We do the resolution using the base type, because intermediate values
+ -- in expressions always are of the base type, not a subtype of it.
+
+ Resolve (Left_Opnd (N), B_Typ);
+ Resolve (Right_Opnd (N), Standard_Integer);
+
+ Check_Unset_Reference (Left_Opnd (N));
+ Check_Unset_Reference (Right_Opnd (N));
+
+ Set_Etype (N, B_Typ);
+ Generate_Operator_Reference (N);
+ Eval_Op_Expon (N);
+
+ -- Set overflow checking bit. Much cleverer code needed here eventually
+ -- and perhaps the Resolve routines should be separated for the various
+ -- arithmetic operations, since they will need different processing. ???
+
+ if Nkind (N) in N_Op then
+ if not Overflow_Checks_Suppressed (Etype (N)) then
+ Set_Do_Overflow_Check (N, True);
+ end if;
+ end if;
+
+ end Resolve_Op_Expon;
+
+ --------------------
+ -- Resolve_Op_Not --
+ --------------------
+
+ procedure Resolve_Op_Not (N : Node_Id; Typ : Entity_Id) is
+ B_Typ : Entity_Id;
+
+ function Parent_Is_Boolean return Boolean;
+ -- This function determines if the parent node is a boolean operator
+ -- or operation (comparison op, membership test, or short circuit form)
+ -- and the not in question is the left operand of this operation.
+ -- Note that if the not is in parens, then false is returned.
+
+ function Parent_Is_Boolean return Boolean is
+ begin
+ if Paren_Count (N) /= 0 then
+ return False;
+
+ else
+ case Nkind (Parent (N)) is
+ when N_Op_And |
+ N_Op_Eq |
+ N_Op_Ge |
+ N_Op_Gt |
+ N_Op_Le |
+ N_Op_Lt |
+ N_Op_Ne |
+ N_Op_Or |
+ N_Op_Xor |
+ N_In |
+ N_Not_In |
+ N_And_Then |
+ N_Or_Else =>
+
+ return Left_Opnd (Parent (N)) = N;
+
+ when others =>
+ return False;
+ end case;
+ end if;
+ end Parent_Is_Boolean;
+
+ -- Start of processing for Resolve_Op_Not
+
+ begin
+ -- Predefined operations on scalar types yield the base type. On
+ -- the other hand, logical operations on arrays yield the type of
+ -- the arguments (and the context).
+
+ if Is_Array_Type (Typ) then
+ B_Typ := Typ;
+ else
+ B_Typ := Base_Type (Typ);
+ end if;
+
+ if not Valid_Boolean_Arg (Typ) then
+ Error_Msg_N ("invalid operand type for operator&", N);
+ Set_Etype (N, Any_Type);
+ return;
+
+ elsif (Typ = Universal_Integer
+ or else Typ = Any_Modular)
+ then
+ if Parent_Is_Boolean then
+ Error_Msg_N
+ ("operand of not must be enclosed in parentheses",
+ Right_Opnd (N));
+ else
+ Error_Msg_N
+ ("no modular type available in this context", N);
+ end if;
+
+ Set_Etype (N, Any_Type);
+ return;
+
+ else
+ if not Is_Boolean_Type (Typ)
+ and then Parent_Is_Boolean
+ then
+ Error_Msg_N ("?not expression should be parenthesized here", N);
+ end if;
+
+ Resolve (Right_Opnd (N), B_Typ);
+ Check_Unset_Reference (Right_Opnd (N));
+ Set_Etype (N, B_Typ);
+ Generate_Operator_Reference (N);
+ Eval_Op_Not (N);
+ end if;
+ end Resolve_Op_Not;
+
+ -----------------------------
+ -- Resolve_Operator_Symbol --
+ -----------------------------
+
+ -- Nothing to be done, all resolved already
+
+ procedure Resolve_Operator_Symbol (N : Node_Id; Typ : Entity_Id) is
+ begin
+ null;
+ end Resolve_Operator_Symbol;
+
+ ----------------------------------
+ -- Resolve_Qualified_Expression --
+ ----------------------------------
+
+ procedure Resolve_Qualified_Expression (N : Node_Id; Typ : Entity_Id) is
+ Target_Typ : constant Entity_Id := Entity (Subtype_Mark (N));
+ Expr : constant Node_Id := Expression (N);
+
+ begin
+ Resolve (Expr, Target_Typ);
+
+ -- A qualified expression requires an exact match of the type,
+ -- class-wide matching is not allowed.
+
+ if Is_Class_Wide_Type (Target_Typ)
+ and then Base_Type (Etype (Expr)) /= Base_Type (Target_Typ)
+ then
+ Wrong_Type (Expr, Target_Typ);
+ end if;
+
+ -- If the target type is unconstrained, then we reset the type of
+ -- the result from the type of the expression. For other cases, the
+ -- actual subtype of the expression is the target type.
+
+ if Is_Composite_Type (Target_Typ)
+ and then not Is_Constrained (Target_Typ)
+ then
+ Set_Etype (N, Etype (Expr));
+ end if;
+
+ Eval_Qualified_Expression (N);
+ end Resolve_Qualified_Expression;
+
+ -------------------
+ -- Resolve_Range --
+ -------------------
+
+ procedure Resolve_Range (N : Node_Id; Typ : Entity_Id) is
+ L : constant Node_Id := Low_Bound (N);
+ H : constant Node_Id := High_Bound (N);
+
+ begin
+ Set_Etype (N, Typ);
+ Resolve (L, Typ);
+ Resolve (H, Typ);
+
+ Check_Unset_Reference (L);
+ Check_Unset_Reference (H);
+
+ -- We have to check the bounds for being within the base range as
+ -- required for a non-static context. Normally this is automatic
+ -- and done as part of evaluating expressions, but the N_Range
+ -- node is an exception, since in GNAT we consider this node to
+ -- be a subexpression, even though in Ada it is not. The circuit
+ -- in Sem_Eval could check for this, but that would put the test
+ -- on the main evaluation path for expressions.
+
+ Check_Non_Static_Context (L);
+ Check_Non_Static_Context (H);
+
+ end Resolve_Range;
+
+ --------------------------
+ -- Resolve_Real_Literal --
+ --------------------------
+
+ procedure Resolve_Real_Literal (N : Node_Id; Typ : Entity_Id) is
+ Actual_Typ : constant Entity_Id := Etype (N);
+
+ begin
+ -- Special processing for fixed-point literals to make sure that the
+ -- value is an exact multiple of small where this is required. We
+ -- skip this for the universal real case, and also for generic types.
+
+ if Is_Fixed_Point_Type (Typ)
+ and then Typ /= Universal_Fixed
+ and then Typ /= Any_Fixed
+ and then not Is_Generic_Type (Typ)
+ then
+ declare
+ Val : constant Ureal := Realval (N);
+ Cintr : constant Ureal := Val / Small_Value (Typ);
+ Cint : constant Uint := UR_Trunc (Cintr);
+ Den : constant Uint := Norm_Den (Cintr);
+ Stat : Boolean;
+
+ begin
+ -- Case of literal is not an exact multiple of the Small
+
+ if Den /= 1 then
+
+ -- For a source program literal for a decimal fixed-point
+ -- type, this is statically illegal (RM 4.9(36)).
+
+ if Is_Decimal_Fixed_Point_Type (Typ)
+ and then Actual_Typ = Universal_Real
+ and then Comes_From_Source (N)
+ then
+ Error_Msg_N ("value has extraneous low order digits", N);
+ end if;
+
+ -- Replace literal by a value that is the exact representation
+ -- of a value of the type, i.e. a multiple of the small value,
+ -- by truncation, since Machine_Rounds is false for all GNAT
+ -- fixed-point types (RM 4.9(38)).
+
+ Stat := Is_Static_Expression (N);
+ Rewrite (N,
+ Make_Real_Literal (Sloc (N),
+ Realval => Small_Value (Typ) * Cint));
+
+ Set_Is_Static_Expression (N, Stat);
+ end if;
+
+ -- In all cases, set the corresponding integer field
+
+ Set_Corresponding_Integer_Value (N, Cint);
+ end;
+ end if;
+
+ -- Now replace the actual type by the expected type as usual
+
+ Set_Etype (N, Typ);
+ Eval_Real_Literal (N);
+ end Resolve_Real_Literal;
+
+ -----------------------
+ -- Resolve_Reference --
+ -----------------------
+
+ procedure Resolve_Reference (N : Node_Id; Typ : Entity_Id) is
+ P : constant Node_Id := Prefix (N);
+
+ begin
+ -- Replace general access with specific type
+
+ if Ekind (Etype (N)) = E_Allocator_Type then
+ Set_Etype (N, Base_Type (Typ));
+ end if;
+
+ Resolve (P, Designated_Type (Etype (N)));
+
+ -- If we are taking the reference of a volatile entity, then treat
+ -- it as a potential modification of this entity. This is much too
+ -- conservative, but is neccessary because remove side effects can
+ -- result in transformations of normal assignments into reference
+ -- sequences that otherwise fail to notice the modification.
+
+ if Is_Entity_Name (P) and then Is_Volatile (Entity (P)) then
+ Note_Possible_Modification (P);
+ end if;
+ end Resolve_Reference;
+
+ --------------------------------
+ -- Resolve_Selected_Component --
+ --------------------------------
+
+ procedure Resolve_Selected_Component (N : Node_Id; Typ : Entity_Id) is
+ Comp : Entity_Id;
+ Comp1 : Entity_Id := Empty; -- prevent junk warning
+ P : constant Node_Id := Prefix (N);
+ S : constant Node_Id := Selector_Name (N);
+ T : Entity_Id := Etype (P);
+ I : Interp_Index;
+ I1 : Interp_Index := 0; -- prevent junk warning
+ It : Interp;
+ It1 : Interp;
+ Found : Boolean;
+
+ begin
+ if Is_Overloaded (P) then
+
+ -- Use the context type to select the prefix that has a selector
+ -- of the correct name and type.
+
+ Found := False;
+ Get_First_Interp (P, I, It);
+
+ Search : while Present (It.Typ) loop
+ if Is_Access_Type (It.Typ) then
+ T := Designated_Type (It.Typ);
+ else
+ T := It.Typ;
+ end if;
+
+ if Is_Record_Type (T) then
+ Comp := First_Entity (T);
+
+ while Present (Comp) loop
+
+ if Chars (Comp) = Chars (S)
+ and then Covers (Etype (Comp), Typ)
+ then
+ if not Found then
+ Found := True;
+ I1 := I;
+ It1 := It;
+ Comp1 := Comp;
+
+ else
+ It := Disambiguate (P, I1, I, Any_Type);
+
+ if It = No_Interp then
+ Error_Msg_N
+ ("ambiguous prefix for selected component", N);
+ Set_Etype (N, Typ);
+ return;
+
+ else
+ It1 := It;
+
+ if Scope (Comp1) /= It1.Typ then
+
+ -- Resolution chooses the new interpretation.
+ -- Find the component with the right name.
+
+ Comp1 := First_Entity (It1.Typ);
+
+ while Present (Comp1)
+ and then Chars (Comp1) /= Chars (S)
+ loop
+ Comp1 := Next_Entity (Comp1);
+ end loop;
+ end if;
+
+ exit Search;
+ end if;
+ end if;
+ end if;
+
+ Comp := Next_Entity (Comp);
+ end loop;
+
+ end if;
+
+ Get_Next_Interp (I, It);
+
+ end loop Search;
+
+ Resolve (P, It1.Typ);
+ Set_Etype (N, Typ);
+ Set_Entity (S, Comp1);
+
+ else
+ -- Resolve prefix with its type.
+
+ Resolve (P, T);
+ end if;
+
+ -- Deal with access type case
+
+ if Is_Access_Type (Etype (P)) then
+ Apply_Access_Check (N);
+ T := Designated_Type (Etype (P));
+ else
+ T := Etype (P);
+ end if;
+
+ if Has_Discriminants (T)
+ and then Present (Original_Record_Component (Entity (S)))
+ and then Ekind (Original_Record_Component (Entity (S))) = E_Component
+ and then Present (Discriminant_Checking_Func
+ (Original_Record_Component (Entity (S))))
+ and then not Discriminant_Checks_Suppressed (T)
+ then
+ Set_Do_Discriminant_Check (N);
+ end if;
+
+ if Ekind (Entity (S)) = E_Void then
+ Error_Msg_N ("premature use of component", S);
+ end if;
+
+ -- If the prefix is a record conversion, this may be a renamed
+ -- discriminant whose bounds differ from those of the original
+ -- one, so we must ensure that a range check is performed.
+
+ if Nkind (P) = N_Type_Conversion
+ and then Ekind (Entity (S)) = E_Discriminant
+ then
+ Set_Etype (N, Base_Type (Typ));
+ end if;
+
+ -- Note: No Eval processing is required, because the prefix is of a
+ -- record type, or protected type, and neither can possibly be static.
+
+ end Resolve_Selected_Component;
+
+ -------------------
+ -- Resolve_Shift --
+ -------------------
+
+ procedure Resolve_Shift (N : Node_Id; Typ : Entity_Id) is
+ B_Typ : constant Entity_Id := Base_Type (Typ);
+ L : constant Node_Id := Left_Opnd (N);
+ R : constant Node_Id := Right_Opnd (N);
+
+ begin
+ -- We do the resolution using the base type, because intermediate values
+ -- in expressions always are of the base type, not a subtype of it.
+
+ Resolve (L, B_Typ);
+ Resolve (R, Standard_Natural);
+
+ Check_Unset_Reference (L);
+ Check_Unset_Reference (R);
+
+ Set_Etype (N, B_Typ);
+ Generate_Operator_Reference (N);
+ Eval_Shift (N);
+ end Resolve_Shift;
+
+ ---------------------------
+ -- Resolve_Short_Circuit --
+ ---------------------------
+
+ procedure Resolve_Short_Circuit (N : Node_Id; Typ : Entity_Id) is
+ B_Typ : constant Entity_Id := Base_Type (Typ);
+ L : constant Node_Id := Left_Opnd (N);
+ R : constant Node_Id := Right_Opnd (N);
+
+ begin
+ Resolve (L, B_Typ);
+ Resolve (R, B_Typ);
+
+ Check_Unset_Reference (L);
+ Check_Unset_Reference (R);
+
+ Set_Etype (N, B_Typ);
+ Eval_Short_Circuit (N);
+ end Resolve_Short_Circuit;
+
+ -------------------
+ -- Resolve_Slice --
+ -------------------
+
+ procedure Resolve_Slice (N : Node_Id; Typ : Entity_Id) is
+ Name : constant Node_Id := Prefix (N);
+ Drange : constant Node_Id := Discrete_Range (N);
+ Array_Type : Entity_Id := Empty;
+ Index : Node_Id;
+
+ begin
+ if Is_Overloaded (Name) then
+
+ -- Use the context type to select the prefix that yields the
+ -- correct array type.
+
+ declare
+ I : Interp_Index;
+ I1 : Interp_Index := 0;
+ It : Interp;
+ P : constant Node_Id := Prefix (N);
+ Found : Boolean := False;
+
+ begin
+ Get_First_Interp (P, I, It);
+
+ while Present (It.Typ) loop
+
+ if (Is_Array_Type (It.Typ)
+ and then Covers (Typ, It.Typ))
+ or else (Is_Access_Type (It.Typ)
+ and then Is_Array_Type (Designated_Type (It.Typ))
+ and then Covers (Typ, Designated_Type (It.Typ)))
+ then
+ if Found then
+ It := Disambiguate (P, I1, I, Any_Type);
+
+ if It = No_Interp then
+ Error_Msg_N ("ambiguous prefix for slicing", N);
+ Set_Etype (N, Typ);
+ return;
+ else
+ Found := True;
+ Array_Type := It.Typ;
+ I1 := I;
+ end if;
+ else
+ Found := True;
+ Array_Type := It.Typ;
+ I1 := I;
+ end if;
+ end if;
+
+ Get_Next_Interp (I, It);
+ end loop;
+ end;
+
+ else
+ Array_Type := Etype (Name);
+ end if;
+
+ Resolve (Name, Array_Type);
+
+ if Is_Access_Type (Array_Type) then
+ Apply_Access_Check (N);
+ Array_Type := Designated_Type (Array_Type);
+
+ elsif Is_Entity_Name (Name)
+ or else (Nkind (Name) = N_Function_Call
+ and then not Is_Constrained (Etype (Name)))
+ then
+ Array_Type := Get_Actual_Subtype (Name);
+ end if;
+
+ -- If name was overloaded, set slice type correctly now
+
+ Set_Etype (N, Array_Type);
+
+ -- If the range is specified by a subtype mark, no resolution
+ -- is necessary.
+
+ if not Is_Entity_Name (Drange) then
+ Index := First_Index (Array_Type);
+ Resolve (Drange, Base_Type (Etype (Index)));
+
+ if Nkind (Drange) = N_Range then
+ Apply_Range_Check (Drange, Etype (Index));
+ end if;
+ end if;
+
+ Set_Slice_Subtype (N);
+ Eval_Slice (N);
+
+ end Resolve_Slice;
+
+ ----------------------------
+ -- Resolve_String_Literal --
+ ----------------------------
+
+ procedure Resolve_String_Literal (N : Node_Id; Typ : Entity_Id) is
+ C_Typ : constant Entity_Id := Component_Type (Typ);
+ R_Typ : constant Entity_Id := Root_Type (C_Typ);
+ Loc : constant Source_Ptr := Sloc (N);
+ Str : constant String_Id := Strval (N);
+ Strlen : constant Nat := String_Length (Str);
+ Subtype_Id : Entity_Id;
+ Need_Check : Boolean;
+
+ begin
+ -- For a string appearing in a concatenation, defer creation of the
+ -- string_literal_subtype until the end of the resolution of the
+ -- concatenation, because the literal may be constant-folded away.
+ -- This is a useful optimization for long concatenation expressions.
+
+ -- If the string is an aggregate built for a single character (which
+ -- happens in a non-static context) or a is null string to which special
+ -- checks may apply, we build the subtype. Wide strings must also get
+ -- a string subtype if they come from a one character aggregate. Strings
+ -- generated by attributes might be static, but it is often hard to
+ -- determine whether the enclosing context is static, so we generate
+ -- subtypes for them as well, thus losing some rarer optimizations ???
+ -- Same for strings that come from a static conversion.
+
+ Need_Check :=
+ (Strlen = 0 and then Typ /= Standard_String)
+ or else Nkind (Parent (N)) /= N_Op_Concat
+ or else (N /= Left_Opnd (Parent (N))
+ and then N /= Right_Opnd (Parent (N)))
+ or else (Typ = Standard_Wide_String
+ and then Nkind (Original_Node (N)) /= N_String_Literal);
+
+ -- If the resolving type is itself a string literal subtype, we
+ -- can just reuse it, since there is no point in creating another.
+
+ if Ekind (Typ) = E_String_Literal_Subtype then
+ Subtype_Id := Typ;
+
+ elsif Nkind (Parent (N)) = N_Op_Concat
+ and then not Need_Check
+ and then Nkind (Original_Node (N)) /= N_Character_Literal
+ and then Nkind (Original_Node (N)) /= N_Attribute_Reference
+ and then Nkind (Original_Node (N)) /= N_Qualified_Expression
+ and then Nkind (Original_Node (N)) /= N_Type_Conversion
+ then
+ Subtype_Id := Typ;
+
+ -- Otherwise we must create a string literal subtype. Note that the
+ -- whole idea of string literal subtypes is simply to avoid the need
+ -- for building a full fledged array subtype for each literal.
+ else
+ Set_String_Literal_Subtype (N, Typ);
+ Subtype_Id := Etype (N);
+ end if;
+
+ if Nkind (Parent (N)) /= N_Op_Concat
+ or else Need_Check
+ then
+ Set_Etype (N, Subtype_Id);
+ Eval_String_Literal (N);
+ end if;
+
+ if Is_Limited_Composite (Typ)
+ or else Is_Private_Composite (Typ)
+ then
+ Error_Msg_N ("string literal not available for private array", N);
+ Set_Etype (N, Any_Type);
+ return;
+ end if;
+
+ -- The validity of a null string has been checked in the
+ -- call to Eval_String_Literal.
+
+ if Strlen = 0 then
+ return;
+
+ -- Always accept string literal with component type Any_Character,
+ -- which occurs in error situations and in comparisons of literals,
+ -- both of which should accept all literals.
+
+ elsif R_Typ = Any_Character then
+ return;
+
+ -- If the type is bit-packed, then we always tranform the string
+ -- literal into a full fledged aggregate.
+
+ elsif Is_Bit_Packed_Array (Typ) then
+ null;
+
+ -- Deal with cases of Wide_String and String
+
+ else
+ -- For Standard.Wide_String, or any other type whose component
+ -- type is Standard.Wide_Character, we know that all the
+ -- characters in the string must be acceptable, since the parser
+ -- accepted the characters as valid character literals.
+
+ if R_Typ = Standard_Wide_Character then
+ null;
+
+ -- For the case of Standard.String, or any other type whose
+ -- component type is Standard.Character, we must make sure that
+ -- there are no wide characters in the string, i.e. that it is
+ -- entirely composed of characters in range of type String.
+
+ -- If the string literal is the result of a static concatenation,
+ -- the test has already been performed on the components, and need
+ -- not be repeated.
+
+ elsif R_Typ = Standard_Character
+ and then Nkind (Original_Node (N)) /= N_Op_Concat
+ then
+ for J in 1 .. Strlen loop
+ if not In_Character_Range (Get_String_Char (Str, J)) then
+
+ -- If we are out of range, post error. This is one of the
+ -- very few places that we place the flag in the middle of
+ -- a token, right under the offending wide character.
+
+ Error_Msg
+ ("literal out of range of type Character",
+ Source_Ptr (Int (Loc) + J));
+ return;
+ end if;
+ end loop;
+
+ -- If the root type is not a standard character, then we will convert
+ -- the string into an aggregate and will let the aggregate code do
+ -- the checking.
+
+ else
+ null;
+
+ end if;
+
+ -- See if the component type of the array corresponding to the
+ -- string has compile time known bounds. If yes we can directly
+ -- check whether the evaluation of the string will raise constraint
+ -- error. Otherwise we need to transform the string literal into
+ -- the corresponding character aggregate and let the aggregate
+ -- code do the checking.
+
+ if R_Typ = Standard_Wide_Character
+ or else R_Typ = Standard_Character
+ then
+ -- Check for the case of full range, where we are definitely OK
+
+ if Component_Type (Typ) = Base_Type (Component_Type (Typ)) then
+ return;
+ end if;
+
+ -- Here the range is not the complete base type range, so check
+
+ declare
+ Comp_Typ_Lo : constant Node_Id :=
+ Type_Low_Bound (Component_Type (Typ));
+ Comp_Typ_Hi : constant Node_Id :=
+ Type_High_Bound (Component_Type (Typ));
+
+ Char_Val : Uint;
+
+ begin
+ if Compile_Time_Known_Value (Comp_Typ_Lo)
+ and then Compile_Time_Known_Value (Comp_Typ_Hi)
+ then
+ for J in 1 .. Strlen loop
+ Char_Val := UI_From_Int (Int (Get_String_Char (Str, J)));
+
+ if Char_Val < Expr_Value (Comp_Typ_Lo)
+ or else Char_Val > Expr_Value (Comp_Typ_Hi)
+ then
+ Apply_Compile_Time_Constraint_Error
+ (N, "character out of range?",
+ Loc => Source_Ptr (Int (Loc) + J));
+ end if;
+ end loop;
+
+ return;
+ end if;
+ end;
+ end if;
+ end if;
+
+ -- If we got here we meed to transform the string literal into the
+ -- equivalent qualified positional array aggregate. This is rather
+ -- heavy artillery for this situation, but it is hard work to avoid.
+
+ declare
+ Lits : List_Id := New_List;
+ P : Source_Ptr := Loc + 1;
+ C : Char_Code;
+
+ begin
+ -- Build the character literals, we give them source locations
+ -- that correspond to the string positions, which is a bit tricky
+ -- given the possible presence of wide character escape sequences.
+
+ for J in 1 .. Strlen loop
+ C := Get_String_Char (Str, J);
+ Set_Character_Literal_Name (C);
+
+ Append_To (Lits,
+ Make_Character_Literal (P, Name_Find, C));
+
+ if In_Character_Range (C) then
+ P := P + 1;
+
+ -- Should we have a call to Skip_Wide here ???
+ -- ??? else
+ -- Skip_Wide (P);
+
+ end if;
+ end loop;
+
+ Rewrite (N,
+ Make_Qualified_Expression (Loc,
+ Subtype_Mark => New_Reference_To (Typ, Loc),
+ Expression =>
+ Make_Aggregate (Loc, Expressions => Lits)));
+
+ Analyze_And_Resolve (N, Typ);
+ end;
+ end Resolve_String_Literal;
+
+ -----------------------------
+ -- Resolve_Subprogram_Info --
+ -----------------------------
+
+ procedure Resolve_Subprogram_Info (N : Node_Id; Typ : Entity_Id) is
+ begin
+ Set_Etype (N, Typ);
+ end Resolve_Subprogram_Info;
+
+ -----------------------------
+ -- Resolve_Type_Conversion --
+ -----------------------------
+
+ procedure Resolve_Type_Conversion (N : Node_Id; Typ : Entity_Id) is
+ Target_Type : constant Entity_Id := Etype (N);
+ Conv_OK : constant Boolean := Conversion_OK (N);
+ Operand : Node_Id;
+ Opnd_Type : Entity_Id;
+ Rop : Node_Id;
+
+ begin
+ Operand := Expression (N);
+
+ if not Conv_OK
+ and then not Valid_Conversion (N, Target_Type, Operand)
+ then
+ return;
+ end if;
+
+ if Etype (Operand) = Any_Fixed then
+
+ -- Mixed-mode operation involving a literal. Context must be a fixed
+ -- type which is applied to the literal subsequently.
+
+ if Is_Fixed_Point_Type (Typ) then
+ Set_Etype (Operand, Universal_Real);
+
+ elsif Is_Numeric_Type (Typ)
+ and then (Nkind (Operand) = N_Op_Multiply
+ or else Nkind (Operand) = N_Op_Divide)
+ and then (Etype (Right_Opnd (Operand)) = Universal_Real
+ or else Etype (Left_Opnd (Operand)) = Universal_Real)
+ then
+ if Unique_Fixed_Point_Type (N) = Any_Type then
+ return; -- expression is ambiguous.
+ else
+ Set_Etype (Operand, Standard_Duration);
+ end if;
+
+ if Etype (Right_Opnd (Operand)) = Universal_Real then
+ Rop := New_Copy_Tree (Right_Opnd (Operand));
+ else
+ Rop := New_Copy_Tree (Left_Opnd (Operand));
+ end if;
+
+ Resolve (Rop, Standard_Long_Long_Float);
+
+ if Realval (Rop) /= Ureal_0
+ and then abs (Realval (Rop)) < Delta_Value (Standard_Duration)
+ then
+ Error_Msg_N ("universal real operand can only be interpreted?",
+ Rop);
+ Error_Msg_N ("\as Duration, and will lose precision?", Rop);
+ end if;
+
+ else
+ Error_Msg_N ("invalid context for mixed mode operation", N);
+ Set_Etype (Operand, Any_Type);
+ return;
+ end if;
+ end if;
+
+ Opnd_Type := Etype (Operand);
+ Resolve (Operand, Opnd_Type);
+
+ -- Note: we do the Eval_Type_Conversion call before applying the
+ -- required checks for a subtype conversion. This is important,
+ -- since both are prepared under certain circumstances to change
+ -- the type conversion to a constraint error node, but in the case
+ -- of Eval_Type_Conversion this may reflect an illegality in the
+ -- static case, and we would miss the illegality (getting only a
+ -- warning message), if we applied the type conversion checks first.
+
+ Eval_Type_Conversion (N);
+
+ -- If after evaluation, we still have a type conversion, then we
+ -- may need to apply checks required for a subtype conversion.
+
+ -- Skip these type conversion checks if universal fixed operands
+ -- operands involved, since range checks are handled separately for
+ -- these cases (in the appropriate Expand routines in unit Exp_Fixd).
+
+ if Nkind (N) = N_Type_Conversion
+ and then not Is_Generic_Type (Root_Type (Target_Type))
+ and then Target_Type /= Universal_Fixed
+ and then Opnd_Type /= Universal_Fixed
+ then
+ Apply_Type_Conversion_Checks (N);
+ end if;
+
+ -- Issue warning for conversion of simple object to its own type
+
+ if Warn_On_Redundant_Constructs
+ and then Comes_From_Source (N)
+ and then Nkind (N) = N_Type_Conversion
+ and then Is_Entity_Name (Expression (N))
+ and then Etype (Entity (Expression (N))) = Target_Type
+ then
+ Error_Msg_NE
+ ("?useless conversion, & has this type",
+ N, Entity (Expression (N)));
+ end if;
+ end Resolve_Type_Conversion;
+
+ ----------------------
+ -- Resolve_Unary_Op --
+ ----------------------
+
+ procedure Resolve_Unary_Op (N : Node_Id; Typ : Entity_Id) is
+ B_Typ : Entity_Id := Base_Type (Typ);
+ R : constant Node_Id := Right_Opnd (N);
+
+ begin
+ -- Generate warning for expressions like -5 mod 3
+
+ if Paren_Count (N) = 0
+ and then Nkind (N) = N_Op_Minus
+ and then Nkind (Right_Opnd (N)) = N_Op_Mod
+ then
+ Error_Msg_N
+ ("?unary minus expression should be parenthesized here", N);
+ end if;
+
+ if Etype (R) = Universal_Integer
+ or else Etype (R) = Universal_Real
+ then
+ Check_For_Visible_Operator (N, B_Typ);
+ end if;
+
+ Set_Etype (N, B_Typ);
+ Resolve (R, B_Typ);
+ Check_Unset_Reference (R);
+ Generate_Operator_Reference (N);
+ Eval_Unary_Op (N);
+
+ -- Set overflow checking bit. Much cleverer code needed here eventually
+ -- and perhaps the Resolve routines should be separated for the various
+ -- arithmetic operations, since they will need different processing ???
+
+ if Nkind (N) in N_Op then
+ if not Overflow_Checks_Suppressed (Etype (N)) then
+ Set_Do_Overflow_Check (N, True);
+ end if;
+ end if;
+
+ end Resolve_Unary_Op;
+
+ ----------------------------------
+ -- Resolve_Unchecked_Expression --
+ ----------------------------------
+
+ procedure Resolve_Unchecked_Expression
+ (N : Node_Id;
+ Typ : Entity_Id)
+ is
+ begin
+ Resolve (Expression (N), Typ, Suppress => All_Checks);
+ Set_Etype (N, Typ);
+ end Resolve_Unchecked_Expression;
+
+ ---------------------------------------
+ -- Resolve_Unchecked_Type_Conversion --
+ ---------------------------------------
+
+ procedure Resolve_Unchecked_Type_Conversion
+ (N : Node_Id;
+ Typ : Entity_Id)
+ is
+ Operand : constant Node_Id := Expression (N);
+ Opnd_Type : constant Entity_Id := Etype (Operand);
+
+ begin
+ -- Resolve operand using its own type.
+
+ Resolve (Operand, Opnd_Type);
+ Eval_Unchecked_Conversion (N);
+
+ end Resolve_Unchecked_Type_Conversion;
+
+ ------------------------------
+ -- Rewrite_Operator_As_Call --
+ ------------------------------
+
+ procedure Rewrite_Operator_As_Call (N : Node_Id; Nam : Entity_Id) is
+ Loc : Source_Ptr := Sloc (N);
+ Actuals : List_Id := New_List;
+ New_N : Node_Id;
+
+ begin
+ if Nkind (N) in N_Binary_Op then
+ Append (Left_Opnd (N), Actuals);
+ end if;
+
+ Append (Right_Opnd (N), Actuals);
+
+ New_N :=
+ Make_Function_Call (Sloc => Loc,
+ Name => New_Occurrence_Of (Nam, Loc),
+ Parameter_Associations => Actuals);
+
+ Preserve_Comes_From_Source (New_N, N);
+ Preserve_Comes_From_Source (Name (New_N), N);
+ Rewrite (N, New_N);
+ Set_Etype (N, Etype (Nam));
+ end Rewrite_Operator_As_Call;
+
+ ------------------------------
+ -- Rewrite_Renamed_Operator --
+ ------------------------------
+
+ procedure Rewrite_Renamed_Operator (N : Node_Id; Op : Entity_Id) is
+ Nam : constant Name_Id := Chars (Op);
+ Is_Binary : constant Boolean := Nkind (N) in N_Binary_Op;
+ Op_Node : Node_Id;
+
+ begin
+ if Chars (N) /= Nam then
+
+ -- Rewrite the operator node using the real operator, not its
+ -- renaming.
+
+ Op_Node := New_Node (Operator_Kind (Nam, Is_Binary), Sloc (N));
+ Set_Chars (Op_Node, Nam);
+ Set_Etype (Op_Node, Etype (N));
+ Set_Entity (Op_Node, Op);
+ Set_Right_Opnd (Op_Node, Right_Opnd (N));
+
+ Generate_Reference (Op, N);
+
+ if Is_Binary then
+ Set_Left_Opnd (Op_Node, Left_Opnd (N));
+ end if;
+
+ Rewrite (N, Op_Node);
+ end if;
+ end Rewrite_Renamed_Operator;
+
+ -----------------------
+ -- Set_Slice_Subtype --
+ -----------------------
+
+ -- Build an implicit subtype declaration to represent the type delivered
+ -- by the slice. This is an abbreviated version of an array subtype. We
+ -- define an index subtype for the slice, using either the subtype name
+ -- or the discrete range of the slice. To be consistent with index usage
+ -- elsewhere, we create a list header to hold the single index. This list
+ -- is not otherwise attached to the syntax tree.
+
+ procedure Set_Slice_Subtype (N : Node_Id) is
+ Loc : constant Source_Ptr := Sloc (N);
+ Index : Node_Id;
+ Index_List : List_Id := New_List;
+ Index_Subtype : Entity_Id;
+ Index_Type : Entity_Id;
+ Slice_Subtype : Entity_Id;
+ Drange : constant Node_Id := Discrete_Range (N);
+
+ begin
+ if Is_Entity_Name (Drange) then
+ Index_Subtype := Entity (Drange);
+
+ else
+ -- We force the evaluation of a range. This is definitely needed in
+ -- the renamed case, and seems safer to do unconditionally. Note in
+ -- any case that since we will create and insert an Itype referring
+ -- to this range, we must make sure any side effect removal actions
+ -- are inserted before the Itype definition.
+
+ if Nkind (Drange) = N_Range then
+ Force_Evaluation (Low_Bound (Drange));
+ Force_Evaluation (High_Bound (Drange));
+ end if;
+
+ Index_Type := Base_Type (Etype (Drange));
+
+ Index_Subtype := Create_Itype (Subtype_Kind (Ekind (Index_Type)), N);
+
+ Set_Scalar_Range (Index_Subtype, Drange);
+ Set_Etype (Index_Subtype, Index_Type);
+ Set_Size_Info (Index_Subtype, Index_Type);
+ Set_RM_Size (Index_Subtype, RM_Size (Index_Type));
+ end if;
+
+ Slice_Subtype := Create_Itype (E_Array_Subtype, N);
+
+ Index := New_Occurrence_Of (Index_Subtype, Loc);
+ Set_Etype (Index, Index_Subtype);
+ Append (Index, Index_List);
+
+ Set_Component_Type (Slice_Subtype, Component_Type (Etype (N)));
+ Set_First_Index (Slice_Subtype, Index);
+ Set_Etype (Slice_Subtype, Base_Type (Etype (N)));
+ Set_Is_Constrained (Slice_Subtype, True);
+ Init_Size_Align (Slice_Subtype);
+
+ Check_Compile_Time_Size (Slice_Subtype);
+
+ -- The Etype of the existing Slice node is reset to this slice
+ -- subtype. Its bounds are obtained from its first index.
+
+ Set_Etype (N, Slice_Subtype);
+
+ -- In the packed case, this must be immediately frozen
+
+ -- Couldn't we always freeze here??? and if we did, then the above
+ -- call to Check_Compile_Time_Size could be eliminated, which would
+ -- be nice, because then that routine could be made private to Freeze.
+
+ if Is_Packed (Slice_Subtype) and not In_Default_Expression then
+ Freeze_Itype (Slice_Subtype, N);
+ end if;
+
+ end Set_Slice_Subtype;
+
+ --------------------------------
+ -- Set_String_Literal_Subtype --
+ --------------------------------
+
+ procedure Set_String_Literal_Subtype (N : Node_Id; Typ : Entity_Id) is
+ Subtype_Id : Entity_Id;
+
+ begin
+ if Nkind (N) /= N_String_Literal then
+ return;
+
+ else
+ Subtype_Id := Create_Itype (E_String_Literal_Subtype, N);
+ end if;
+
+ Set_Component_Type (Subtype_Id, Component_Type (Typ));
+ Set_String_Literal_Length (Subtype_Id,
+ UI_From_Int (String_Length (Strval (N))));
+ Set_Etype (Subtype_Id, Base_Type (Typ));
+ Set_Is_Constrained (Subtype_Id);
+
+ -- The low bound is set from the low bound of the corresponding
+ -- index type. Note that we do not store the high bound in the
+ -- string literal subtype, but it can be deduced if necssary
+ -- from the length and the low bound.
+
+ Set_String_Literal_Low_Bound
+ (Subtype_Id, Type_Low_Bound (Etype (First_Index (Typ))));
+
+ Set_Etype (N, Subtype_Id);
+ end Set_String_Literal_Subtype;
+
+ -----------------------------
+ -- Unique_Fixed_Point_Type --
+ -----------------------------
+
+ function Unique_Fixed_Point_Type (N : Node_Id) return Entity_Id is
+ T1 : Entity_Id := Empty;
+ T2 : Entity_Id;
+ Item : Node_Id;
+ Scop : Entity_Id;
+
+ procedure Fixed_Point_Error;
+ -- If true ambiguity, give details.
+
+ procedure Fixed_Point_Error is
+ begin
+ Error_Msg_N ("ambiguous universal_fixed_expression", N);
+ Error_Msg_NE ("\possible interpretation as}", N, T1);
+ Error_Msg_NE ("\possible interpretation as}", N, T2);
+ end Fixed_Point_Error;
+
+ begin
+ -- The operations on Duration are visible, so Duration is always a
+ -- possible interpretation.
+
+ T1 := Standard_Duration;
+
+ Scop := Current_Scope;
+
+ -- Look for fixed-point types in enclosing scopes.
+
+ while Scop /= Standard_Standard loop
+ T2 := First_Entity (Scop);
+
+ while Present (T2) loop
+ if Is_Fixed_Point_Type (T2)
+ and then Current_Entity (T2) = T2
+ and then Scope (Base_Type (T2)) = Scop
+ then
+ if Present (T1) then
+ Fixed_Point_Error;
+ return Any_Type;
+ else
+ T1 := T2;
+ end if;
+ end if;
+
+ Next_Entity (T2);
+ end loop;
+
+ Scop := Scope (Scop);
+ end loop;
+
+ -- Look for visible fixed type declarations in the context.
+
+ Item := First (Context_Items (Cunit (Current_Sem_Unit)));
+
+ while Present (Item) loop
+
+ if Nkind (Item) = N_With_Clause then
+ Scop := Entity (Name (Item));
+ T2 := First_Entity (Scop);
+
+ while Present (T2) loop
+ if Is_Fixed_Point_Type (T2)
+ and then Scope (Base_Type (T2)) = Scop
+ and then (Is_Potentially_Use_Visible (T2)
+ or else In_Use (T2))
+ then
+ if Present (T1) then
+ Fixed_Point_Error;
+ return Any_Type;
+ else
+ T1 := T2;
+ end if;
+ end if;
+
+ Next_Entity (T2);
+ end loop;
+ end if;
+
+ Next (Item);
+ end loop;
+
+ if Nkind (N) = N_Real_Literal then
+ Error_Msg_NE ("real literal interpreted as }?", N, T1);
+
+ else
+ Error_Msg_NE ("universal_fixed expression interpreted as }?", N, T1);
+ end if;
+
+ return T1;
+ end Unique_Fixed_Point_Type;
+
+ ----------------------
+ -- Valid_Conversion --
+ ----------------------
+
+ function Valid_Conversion
+ (N : Node_Id;
+ Target : Entity_Id;
+ Operand : Node_Id)
+ return Boolean
+ is
+ Target_Type : Entity_Id := Base_Type (Target);
+ Opnd_Type : Entity_Id := Etype (Operand);
+
+ function Conversion_Check
+ (Valid : Boolean;
+ Msg : String)
+ return Boolean;
+ -- Little routine to post Msg if Valid is False, returns Valid value
+
+ function Valid_Tagged_Conversion
+ (Target_Type : Entity_Id;
+ Opnd_Type : Entity_Id)
+ return Boolean;
+ -- Specifically test for validity of tagged conversions
+
+ ----------------------
+ -- Conversion_Check --
+ ----------------------
+
+ function Conversion_Check
+ (Valid : Boolean;
+ Msg : String)
+ return Boolean
+ is
+ begin
+ if not Valid then
+ Error_Msg_N (Msg, Operand);
+ end if;
+
+ return Valid;
+ end Conversion_Check;
+
+ -----------------------------
+ -- Valid_Tagged_Conversion --
+ -----------------------------
+
+ function Valid_Tagged_Conversion
+ (Target_Type : Entity_Id;
+ Opnd_Type : Entity_Id)
+ return Boolean
+ is
+ begin
+ -- Upward conversions are allowed (RM 4.6(22)).
+
+ if Covers (Target_Type, Opnd_Type)
+ or else Is_Ancestor (Target_Type, Opnd_Type)
+ then
+ return True;
+
+ -- Downward conversion are allowed if the operand is
+ -- is class-wide (RM 4.6(23)).
+
+ elsif Is_Class_Wide_Type (Opnd_Type)
+ and then Covers (Opnd_Type, Target_Type)
+ then
+ return True;
+
+ elsif Covers (Opnd_Type, Target_Type)
+ or else Is_Ancestor (Opnd_Type, Target_Type)
+ then
+ return
+ Conversion_Check (False,
+ "downward conversion of tagged objects not allowed");
+ else
+ Error_Msg_NE
+ ("invalid tagged conversion, not compatible with}",
+ N, First_Subtype (Opnd_Type));
+ return False;
+ end if;
+ end Valid_Tagged_Conversion;
+
+ -- Start of processing for Valid_Conversion
+
+ begin
+ Check_Parameterless_Call (Operand);
+
+ if Is_Overloaded (Operand) then
+ declare
+ I : Interp_Index;
+ I1 : Interp_Index;
+ It : Interp;
+ It1 : Interp;
+ N1 : Entity_Id;
+
+ begin
+ -- Remove procedure calls, which syntactically cannot appear
+ -- in this context, but which cannot be removed by type checking,
+ -- because the context does not impose a type.
+
+ Get_First_Interp (Operand, I, It);
+
+ while Present (It.Typ) loop
+
+ if It.Typ = Standard_Void_Type then
+ Remove_Interp (I);
+ end if;
+
+ Get_Next_Interp (I, It);
+ end loop;
+
+ Get_First_Interp (Operand, I, It);
+ I1 := I;
+ It1 := It;
+
+ if No (It.Typ) then
+ Error_Msg_N ("illegal operand in conversion", Operand);
+ return False;
+ end if;
+
+ Get_Next_Interp (I, It);
+
+ if Present (It.Typ) then
+ N1 := It1.Nam;
+ It1 := Disambiguate (Operand, I1, I, Any_Type);
+
+ if It1 = No_Interp then
+ Error_Msg_N ("ambiguous operand in conversion", Operand);
+
+ Error_Msg_Sloc := Sloc (It.Nam);
+ Error_Msg_N ("possible interpretation#!", Operand);
+
+ Error_Msg_Sloc := Sloc (N1);
+ Error_Msg_N ("possible interpretation#!", Operand);
+
+ return False;
+ end if;
+ end if;
+
+ Set_Etype (Operand, It1.Typ);
+ Opnd_Type := It1.Typ;
+ end;
+ end if;
+
+ if Chars (Current_Scope) = Name_Unchecked_Conversion then
+
+ -- This check is dubious, what if there were a user defined
+ -- scope whose name was Unchecked_Conversion ???
+
+ return True;
+
+ elsif Is_Numeric_Type (Target_Type) then
+ if Opnd_Type = Universal_Fixed then
+ return True;
+ else
+ return Conversion_Check (Is_Numeric_Type (Opnd_Type),
+ "illegal operand for numeric conversion");
+ end if;
+
+ elsif Is_Array_Type (Target_Type) then
+ if not Is_Array_Type (Opnd_Type)
+ or else Opnd_Type = Any_Composite
+ or else Opnd_Type = Any_String
+ then
+ Error_Msg_N
+ ("illegal operand for array conversion", Operand);
+ return False;
+
+ elsif Number_Dimensions (Target_Type) /=
+ Number_Dimensions (Opnd_Type)
+ then
+ Error_Msg_N
+ ("incompatible number of dimensions for conversion", Operand);
+ return False;
+
+ else
+ declare
+ Target_Index : Node_Id := First_Index (Target_Type);
+ Opnd_Index : Node_Id := First_Index (Opnd_Type);
+
+ Target_Index_Type : Entity_Id;
+ Opnd_Index_Type : Entity_Id;
+
+ Target_Comp_Type : Entity_Id := Component_Type (Target_Type);
+ Opnd_Comp_Type : Entity_Id := Component_Type (Opnd_Type);
+
+ begin
+ while Present (Target_Index) and then Present (Opnd_Index) loop
+ Target_Index_Type := Etype (Target_Index);
+ Opnd_Index_Type := Etype (Opnd_Index);
+
+ if not (Is_Integer_Type (Target_Index_Type)
+ and then Is_Integer_Type (Opnd_Index_Type))
+ and then (Root_Type (Target_Index_Type)
+ /= Root_Type (Opnd_Index_Type))
+ then
+ Error_Msg_N
+ ("incompatible index types for array conversion",
+ Operand);
+ return False;
+ end if;
+
+ Next_Index (Target_Index);
+ Next_Index (Opnd_Index);
+ end loop;
+
+ if Base_Type (Target_Comp_Type) /=
+ Base_Type (Opnd_Comp_Type)
+ then
+ Error_Msg_N
+ ("incompatible component types for array conversion",
+ Operand);
+ return False;
+
+ elsif
+ Is_Constrained (Target_Comp_Type)
+ /= Is_Constrained (Opnd_Comp_Type)
+ or else not Subtypes_Statically_Match
+ (Target_Comp_Type, Opnd_Comp_Type)
+ then
+ Error_Msg_N
+ ("component subtypes must statically match", Operand);
+ return False;
+
+ end if;
+ end;
+ end if;
+
+ return True;
+
+ elsif (Ekind (Target_Type) = E_General_Access_Type
+ or else Ekind (Target_Type) = E_Anonymous_Access_Type)
+ and then
+ Conversion_Check
+ (Is_Access_Type (Opnd_Type)
+ and then Ekind (Opnd_Type) /=
+ E_Access_Subprogram_Type
+ and then Ekind (Opnd_Type) /=
+ E_Access_Protected_Subprogram_Type,
+ "must be an access-to-object type")
+ then
+ if Is_Access_Constant (Opnd_Type)
+ and then not Is_Access_Constant (Target_Type)
+ then
+ Error_Msg_N
+ ("access-to-constant operand type not allowed", Operand);
+ return False;
+ end if;
+
+ -- Check the static accessibility rule of 4.6(17). Note that
+ -- the check is not enforced when within an instance body, since
+ -- the RM requires such cases to be caught at run time.
+
+ if Ekind (Target_Type) /= E_Anonymous_Access_Type then
+ if Type_Access_Level (Opnd_Type)
+ > Type_Access_Level (Target_Type)
+ then
+ -- In an instance, this is a run-time check, but one we
+ -- know will fail, so generate an appropriate warning.
+ -- The raise will be generated by Expand_N_Type_Conversion.
+
+ if In_Instance_Body then
+ Error_Msg_N
+ ("?cannot convert local pointer to non-local access type",
+ Operand);
+ Error_Msg_N
+ ("?Program_Error will be raised at run time", Operand);
+
+ else
+ Error_Msg_N
+ ("cannot convert local pointer to non-local access type",
+ Operand);
+ return False;
+ end if;
+
+ elsif Ekind (Opnd_Type) = E_Anonymous_Access_Type then
+
+ -- When the operand is a selected access discriminant
+ -- the check needs to be made against the level of the
+ -- object denoted by the prefix of the selected name.
+ -- (Object_Access_Level handles checking the prefix
+ -- of the operand for this case.)
+
+ if Nkind (Operand) = N_Selected_Component
+ and then Object_Access_Level (Operand)
+ > Type_Access_Level (Target_Type)
+ then
+ -- In an instance, this is a run-time check, but one we
+ -- know will fail, so generate an appropriate warning.
+ -- The raise will be generated by Expand_N_Type_Conversion.
+
+ if In_Instance_Body then
+ Error_Msg_N
+ ("?cannot convert access discriminant to non-local" &
+ " access type", Operand);
+ Error_Msg_N
+ ("?Program_Error will be raised at run time", Operand);
+
+ else
+ Error_Msg_N
+ ("cannot convert access discriminant to non-local" &
+ " access type", Operand);
+ return False;
+ end if;
+ end if;
+
+ -- The case of a reference to an access discriminant
+ -- from within a type declaration (which will appear
+ -- as a discriminal) is always illegal because the
+ -- level of the discriminant is considered to be
+ -- deeper than any (namable) access type.
+
+ if Is_Entity_Name (Operand)
+ and then (Ekind (Entity (Operand)) = E_In_Parameter
+ or else Ekind (Entity (Operand)) = E_Constant)
+ and then Present (Discriminal_Link (Entity (Operand)))
+ then
+ Error_Msg_N
+ ("discriminant has deeper accessibility level than target",
+ Operand);
+ return False;
+ end if;
+ end if;
+ end if;
+
+ declare
+ Target : constant Entity_Id := Designated_Type (Target_Type);
+ Opnd : constant Entity_Id := Designated_Type (Opnd_Type);
+
+ begin
+ if Is_Tagged_Type (Target) then
+ return Valid_Tagged_Conversion (Target, Opnd);
+
+ else
+ if Base_Type (Target) /= Base_Type (Opnd) then
+ Error_Msg_NE
+ ("target designated type not compatible with }",
+ N, Base_Type (Opnd));
+ return False;
+
+ elsif not Subtypes_Statically_Match (Target, Opnd)
+ and then (not Has_Discriminants (Target)
+ or else Is_Constrained (Target))
+ then
+ Error_Msg_NE
+ ("target designated subtype not compatible with }",
+ N, Opnd);
+ return False;
+
+ else
+ return True;
+ end if;
+ end if;
+ end;
+
+ elsif Ekind (Target_Type) = E_Access_Subprogram_Type
+ and then Conversion_Check
+ (Ekind (Base_Type (Opnd_Type)) = E_Access_Subprogram_Type,
+ "illegal operand for access subprogram conversion")
+ then
+ -- Check that the designated types are subtype conformant
+
+ if not Subtype_Conformant (Designated_Type (Opnd_Type),
+ Designated_Type (Target_Type))
+ then
+ Error_Msg_N
+ ("operand type is not subtype conformant with target type",
+ Operand);
+ end if;
+
+ -- Check the static accessibility rule of 4.6(20)
+
+ if Type_Access_Level (Opnd_Type) >
+ Type_Access_Level (Target_Type)
+ then
+ Error_Msg_N
+ ("operand type has deeper accessibility level than target",
+ Operand);
+
+ -- Check that if the operand type is declared in a generic body,
+ -- then the target type must be declared within that same body
+ -- (enforces last sentence of 4.6(20)).
+
+ elsif Present (Enclosing_Generic_Body (Opnd_Type)) then
+ declare
+ O_Gen : constant Node_Id :=
+ Enclosing_Generic_Body (Opnd_Type);
+
+ T_Gen : Node_Id :=
+ Enclosing_Generic_Body (Target_Type);
+
+ begin
+ while Present (T_Gen) and then T_Gen /= O_Gen loop
+ T_Gen := Enclosing_Generic_Body (T_Gen);
+ end loop;
+
+ if T_Gen /= O_Gen then
+ Error_Msg_N
+ ("target type must be declared in same generic body"
+ & " as operand type", N);
+ end if;
+ end;
+ end if;
+
+ return True;
+
+ elsif Is_Remote_Access_To_Subprogram_Type (Target_Type)
+ and then Is_Remote_Access_To_Subprogram_Type (Opnd_Type)
+ then
+ -- It is valid to convert from one RAS type to another provided
+ -- that their specification statically match.
+
+ Check_Subtype_Conformant
+ (New_Id =>
+ Designated_Type (Corresponding_Remote_Type (Target_Type)),
+ Old_Id =>
+ Designated_Type (Corresponding_Remote_Type (Opnd_Type)),
+ Err_Loc =>
+ N);
+ return True;
+
+ elsif Is_Tagged_Type (Target_Type) then
+ return Valid_Tagged_Conversion (Target_Type, Opnd_Type);
+
+ -- Types derived from the same root type are convertible.
+
+ elsif Root_Type (Target_Type) = Root_Type (Opnd_Type) then
+ return True;
+
+ -- In an instance, there may be inconsistent views of the same
+ -- type, or types derived from the same type.
+
+ elsif In_Instance
+ and then Underlying_Type (Target_Type) = Underlying_Type (Opnd_Type)
+ then
+ return True;
+
+ -- Special check for common access type error case
+
+ elsif Ekind (Target_Type) = E_Access_Type
+ and then Is_Access_Type (Opnd_Type)
+ then
+ Error_Msg_N ("target type must be general access type!", N);
+ Error_Msg_NE ("add ALL to }!", N, Target_Type);
+
+ return False;
+
+ else
+ Error_Msg_NE ("invalid conversion, not compatible with }",
+ N, Opnd_Type);
+
+ return False;
+ end if;
+ end Valid_Conversion;
+
+end Sem_Res;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S E M _ R E S --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.19 $
+-- --
+-- Copyright (C) 1992-1999 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). --
+-- --
+------------------------------------------------------------------------------
+
+-- Resolution processing for all subexpression nodes. Note that the separate
+-- package Sem_Aggr contains the actual resolution routines for aggregates,
+-- which are separated off since aggregate processing is complex.
+
+with Snames; use Snames;
+with Types; use Types;
+
+package Sem_Res is
+
+ -- As described in Sem_Ch4, the type resolution proceeds in two phases.
+ -- The first phase is a bottom up pass that is achieved during the
+ -- recursive traversal performed by the Analyze procedures. This phase
+ -- determines unambiguous types, and collects sets of possible types
+ -- where the interpretation is potentially ambiguous.
+
+ -- On completing this bottom up pass, which corresponds to a call to
+ -- Analyze on a complete context, the Resolve routine is called which
+ -- performs a top down resolution with recursive calls to itself to
+ -- resolve operands.
+
+ -- Since in practice a lot of semantic analysis has to be postponed until
+ -- types are known (e.g. static folding, setting of suppress flags), the
+ -- Resolve routines also complete the semantic analyze, and also call the
+ -- expander for possibly expansion of the completely type resolved node.
+
+ procedure Resolve (N : Node_Id; Typ : Entity_Id);
+ procedure Resolve (N : Node_Id; Typ : Entity_Id; Suppress : Check_Id);
+ -- Top level type-checking procedure, called in a complete context. The
+ -- construct N, which is a subexpression, has already been analyzed, and
+ -- is required to be of type Typ given the analysis of the context (which
+ -- uses the information gathered on the bottom up phase in Analyze). The
+ -- resolve routines do various other processing, e.g. static evaluation.
+ -- If a Suppress argument is present, then the resolution is done with the
+ -- specified check suppressed (can be All_Checks to suppress all checks).
+
+ procedure Resolve_Discrete_Subtype_Indication
+ (N : Node_Id;
+ Typ : Entity_Id);
+ -- Resolve subtype indications in choices (case statements and
+ -- aggregates) and in index constraints. Note that the resulting Etype
+ -- of the subtype indication node is set to the Etype of the contained
+ -- range (i.e. an Itype is not constructed for the actual subtype).
+
+ procedure Resolve_Entry (Entry_Name : Node_Id);
+ -- Find name of entry being called, and resolve prefix of name with its
+ -- own type. For now we assume that the prefix cannot be overloaded and
+ -- the name of the entry plays no role in the resolution.
+
+ procedure Analyze_And_Resolve (N : Node_Id);
+ procedure Analyze_And_Resolve (N : Node_Id; Typ : Entity_Id);
+ procedure Analyze_And_Resolve
+ (N : Node_Id;
+ Typ : Entity_Id;
+ Suppress : Check_Id);
+ procedure Analyze_And_Resolve
+ (N : Node_Id;
+ Suppress : Check_Id);
+ -- These routines combine the effect of Analyze and Resolve. If a Suppress
+ -- argument is present, then the analysis is done with the specified check
+ -- suppressed (can be All_Checks to suppress all checks). These checks are
+ -- suppressed for both the analysis and resolution. If the type argument
+ -- is not present, then the Etype of the expression after the Analyze
+ -- call is used for the Resolve.
+
+ procedure Check_Parameterless_Call (N : Node_Id);
+ -- Several forms of names can denote calls to entities without para-
+ -- meters. The context determines whether the name denotes the entity
+ -- or a call to it. When it is a call, the node must be rebuilt
+ -- accordingly (deprocedured, in A68 terms) and renalyzed to obtain
+ -- possible interpretations.
+ --
+ -- The name may be that of an overloadable construct, or it can be an
+ -- explicit dereference of a prefix that denotes an access to subprogram.
+ -- In that case, we want to convert the name into a call only if the
+ -- context requires the return type of the subprogram. Finally, a
+ -- parameterless protected subprogram appears as a selected component.
+ --
+ -- The parameter T is the Typ for the corresponding resolve call.
+
+ procedure Pre_Analyze_And_Resolve (N : Node_Id; T : Entity_Id);
+ -- Performs a pre-analysis of expression node N. During pre-analysis
+ -- N is analyzed and then resolved against type T, but no expansion
+ -- is carried out for N or its children. For more info on pre-analysis
+ -- read the spec of Sem.
+
+ procedure Pre_Analyze_And_Resolve (N : Node_Id);
+ -- Same, but use type of node because context does not impose a single
+ -- type.
+
+end Sem_Res;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S E M _ S M E M --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.5 $
+-- --
+-- Copyright (C) 1998-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 Atree; use Atree;
+with Einfo; use Einfo;
+with Errout; use Errout;
+with Namet; use Namet;
+with Sinfo; use Sinfo;
+with Snames; use Snames;
+
+package body Sem_Smem is
+
+ function Contains_Access_Type (T : Entity_Id) return Boolean;
+ -- This function determines if type T is an access type, or contains
+ -- a component (array, record, protected type cases) that contains
+ -- an access type (recursively defined in the appropriate manner).
+
+ ----------------------
+ -- Check_Shared_Var --
+ ----------------------
+
+ procedure Check_Shared_Var
+ (Id : Entity_Id;
+ T : Entity_Id;
+ N : Node_Id)
+ is
+ begin
+ -- We cannot tolerate aliased variables, because they might be
+ -- modified via an aliased pointer, and we could not detect that
+ -- this was happening (to update the corresponding shared memory
+ -- file), so we must disallow all use of Aliased
+
+ if Aliased_Present (N) then
+ Error_Msg_N
+ ("aliased variables " &
+ "not supported in Shared_Passive partitions",
+ N);
+
+ -- We can't support access types at all, since they are local
+ -- pointers that cannot in any simple way be transmitted to other
+ -- partitions.
+
+ elsif Is_Access_Type (T) then
+ Error_Msg_N
+ ("access type variables " &
+ "not supported in Shared_Passive partitions",
+ Id);
+
+ -- We cannot tolerate types that contain access types, same reasons
+
+ elsif Contains_Access_Type (T) then
+ Error_Msg_N
+ ("types containing access components " &
+ "not supported in Shared_Passive partitions",
+ Id);
+
+ -- Currently we do not support unconstrained record types, since we
+ -- use 'Write to write out values. This could probably be special
+ -- cased and handled in the future if necessary.
+
+ elsif Is_Record_Type (T)
+ and then not Is_Constrained (T)
+ then
+ Error_Msg_N
+ ("unconstrained variant records " &
+ "not supported in Shared_Passive partitions",
+ Id);
+ end if;
+ end Check_Shared_Var;
+
+ --------------------------
+ -- Contains_Access_Type --
+ --------------------------
+
+ function Contains_Access_Type (T : Entity_Id) return Boolean is
+ C : Entity_Id;
+
+ begin
+ if Is_Access_Type (T) then
+ return True;
+
+ elsif Is_Array_Type (T) then
+ return Contains_Access_Type (Component_Type (T));
+
+ elsif Is_Record_Type (T) then
+ if Has_Discriminants (T) then
+ C := First_Discriminant (T);
+ while Present (C) loop
+ if Comes_From_Source (C) then
+ return True;
+ else
+ C := Next_Discriminant (C);
+ end if;
+ end loop;
+ end if;
+
+ C := First_Component (T);
+ while Present (C) loop
+
+ -- For components, ignore internal components other than _Parent
+
+ if Comes_From_Source (T)
+ and then
+ (Chars (C) = Name_uParent
+ or else
+ not Is_Internal_Name (Chars (C)))
+ and then Contains_Access_Type (Etype (C))
+ then
+ return True;
+ else
+ C := Next_Component (C);
+ end if;
+ end loop;
+
+ return False;
+
+ elsif Is_Protected_Type (T) then
+ return Contains_Access_Type (Corresponding_Record_Type (T));
+
+ else
+ return False;
+ end if;
+ end Contains_Access_Type;
+
+end Sem_Smem;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S E M _ S M E M --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.2 $ --
+-- --
+-- Copyright (C) 1998-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). --
+-- --
+------------------------------------------------------------------------------
+
+-- This package contains routines involved in processing of shared memory
+-- variables, i.e. variables declared in shared passive partitions.
+
+with Types; use Types;
+package Sem_Smem is
+
+ procedure Check_Shared_Var
+ (Id : Entity_Id;
+ T : Entity_Id;
+ N : Node_Id);
+ -- This routine checks that the object declaration, N, for identifier,
+ -- Id, of type, T, is valid, i.e. that it does not violate restrictions
+ -- on the kind of variables we support in shared passive partitions.
+
+end Sem_Smem;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S E M _ T Y P E --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.198 $
+-- --
+-- 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). --
+-- --
+------------------------------------------------------------------------------
+
+with Atree; use Atree;
+with Debug; use Debug;
+with Einfo; use Einfo;
+with Errout; use Errout;
+with Lib; use Lib;
+with Opt; use Opt;
+with Output; use Output;
+with Sem; use Sem;
+with Sem_Ch6; use Sem_Ch6;
+with Sem_Ch8; use Sem_Ch8;
+with Sem_Util; use Sem_Util;
+with Stand; use Stand;
+with Sinfo; use Sinfo;
+with Snames; use Snames;
+with Uintp; use Uintp;
+
+package body Sem_Type is
+
+ -------------------------------------
+ -- Handling of Overload Resolution --
+ -------------------------------------
+
+ -- Overload resolution uses two passes over the syntax tree of a complete
+ -- context. In the first, bottom-up pass, the types of actuals in calls
+ -- are used to resolve possibly overloaded subprogram and operator names.
+ -- In the second top-down pass, the type of the context (for example the
+ -- condition in a while statement) is used to resolve a possibly ambiguous
+ -- call, and the unique subprogram name in turn imposes a specific context
+ -- on each of its actuals.
+
+ -- Most expressions are in fact unambiguous, and the bottom-up pass is
+ -- sufficient to resolve most everything. To simplify the common case,
+ -- names and expressions carry a flag Is_Overloaded to indicate whether
+ -- they have more than one interpretation. If the flag is off, then each
+ -- name has already a unique meaning and type, and the bottom-up pass is
+ -- sufficient (and much simpler).
+
+ --------------------------
+ -- Operator Overloading --
+ --------------------------
+
+ -- The visibility of operators is handled differently from that of
+ -- other entities. We do not introduce explicit versions of primitive
+ -- operators for each type definition. As a result, there is only one
+ -- entity corresponding to predefined addition on all numeric types, etc.
+ -- The back-end resolves predefined operators according to their type.
+ -- The visibility of primitive operations then reduces to the visibility
+ -- of the resulting type: (a + b) is a legal interpretation of some
+ -- primitive operator + if the type of the result (which must also be
+ -- the type of a and b) is directly visible (i.e. either immediately
+ -- visible or use-visible.)
+
+ -- User-defined operators are treated like other functions, but the
+ -- visibility of these user-defined operations must be special-cased
+ -- to determine whether they hide or are hidden by predefined operators.
+ -- The form P."+" (x, y) requires additional handling.
+ --
+ -- Concatenation is treated more conventionally: for every one-dimensional
+ -- array type we introduce a explicit concatenation operator. This is
+ -- necessary to handle the case of (element & element => array) which
+ -- cannot be handled conveniently if there is no explicit instance of
+ -- resulting type of the operation.
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ procedure All_Overloads;
+ pragma Warnings (Off, All_Overloads);
+ -- Debugging procedure: list full contents of Overloads table.
+
+ function Universal_Interpretation (Opnd : Node_Id) return Entity_Id;
+ -- Yields universal_Integer or Universal_Real if this is a candidate.
+
+ function Specific_Type (T1, T2 : Entity_Id) return Entity_Id;
+ -- If T1 and T2 are compatible, return the one that is not
+ -- universal or is not a "class" type (any_character, etc).
+
+ --------------------
+ -- Add_One_Interp --
+ --------------------
+
+ procedure Add_One_Interp
+ (N : Node_Id;
+ E : Entity_Id;
+ T : Entity_Id;
+ Opnd_Type : Entity_Id := Empty)
+ is
+ Vis_Type : Entity_Id;
+
+ procedure Add_Entry (Name : Entity_Id; Typ : Entity_Id);
+ -- Add one interpretation to node. Node is already known to be
+ -- overloaded. Add new interpretation if not hidden by previous
+ -- one, and remove previous one if hidden by new one.
+
+ function Is_Universal_Operation (Op : Entity_Id) return Boolean;
+ -- True if the entity is a predefined operator and the operands have
+ -- a universal Interpretation.
+
+ ---------------
+ -- Add_Entry --
+ ---------------
+
+ procedure Add_Entry (Name : Entity_Id; Typ : Entity_Id) is
+ Index : Interp_Index;
+ It : Interp;
+
+ begin
+ Get_First_Interp (N, Index, It);
+
+ while Present (It.Nam) loop
+
+ -- A user-defined subprogram hides another declared at an outer
+ -- level, or one that is use-visible. So return if previous
+ -- definition hides new one (which is either in an outer
+ -- scope, or use-visible). Note that for functions use-visible
+ -- is the same as potentially use-visible. If new one hides
+ -- previous one, replace entry in table of interpretations.
+ -- If this is a universal operation, retain the operator in case
+ -- preference rule applies.
+
+ if (((Ekind (Name) = E_Function or else Ekind (Name) = E_Procedure)
+ and then Ekind (Name) = Ekind (It.Nam))
+ or else (Ekind (Name) = E_Operator
+ and then Ekind (It.Nam) = E_Function))
+
+ and then Is_Immediately_Visible (It.Nam)
+ and then Type_Conformant (Name, It.Nam)
+ and then Base_Type (It.Typ) = Base_Type (T)
+ then
+ if Is_Universal_Operation (Name) then
+ exit;
+
+ -- If node is an operator symbol, we have no actuals with
+ -- which to check hiding, and this is done in full in the
+ -- caller (Analyze_Subprogram_Renaming) so we include the
+ -- predefined operator in any case.
+
+ elsif Nkind (N) = N_Operator_Symbol
+ or else (Nkind (N) = N_Expanded_Name
+ and then
+ Nkind (Selector_Name (N)) = N_Operator_Symbol)
+ then
+ exit;
+
+ elsif not In_Open_Scopes (Scope (Name))
+ or else Scope_Depth (Scope (Name))
+ <= Scope_Depth (Scope (It.Nam))
+ then
+ -- If ambiguity within instance, and entity is not an
+ -- implicit operation, save for later disambiguation.
+
+ if Scope (Name) = Scope (It.Nam)
+ and then not Is_Inherited_Operation (Name)
+ and then In_Instance
+ then
+ exit;
+ else
+ return;
+ end if;
+
+ else
+ All_Interp.Table (Index).Nam := Name;
+ return;
+ end if;
+
+ -- Avoid making duplicate entries in overloads
+
+ elsif Name = It.Nam
+ and then Base_Type (It.Typ) = Base_Type (T)
+ then
+ return;
+
+ -- Otherwise keep going
+
+ else
+ Get_Next_Interp (Index, It);
+ end if;
+
+ end loop;
+
+ -- On exit, enter new interpretation. The context, or a preference
+ -- rule, will resolve the ambiguity on the second pass.
+
+ All_Interp.Table (All_Interp.Last) := (Name, Typ);
+ All_Interp.Increment_Last;
+ All_Interp.Table (All_Interp.Last) := No_Interp;
+
+ end Add_Entry;
+
+ ----------------------------
+ -- Is_Universal_Operation --
+ ----------------------------
+
+ function Is_Universal_Operation (Op : Entity_Id) return Boolean is
+ Arg : Node_Id;
+
+ begin
+ if Ekind (Op) /= E_Operator then
+ return False;
+
+ elsif Nkind (N) in N_Binary_Op then
+ return Present (Universal_Interpretation (Left_Opnd (N)))
+ and then Present (Universal_Interpretation (Right_Opnd (N)));
+
+ elsif Nkind (N) in N_Unary_Op then
+ return Present (Universal_Interpretation (Right_Opnd (N)));
+
+ elsif Nkind (N) = N_Function_Call then
+ Arg := First_Actual (N);
+
+ while Present (Arg) loop
+
+ if No (Universal_Interpretation (Arg)) then
+ return False;
+ end if;
+
+ Next_Actual (Arg);
+ end loop;
+
+ return True;
+
+ else
+ return False;
+ end if;
+ end Is_Universal_Operation;
+
+ -- Start of processing for Add_One_Interp
+
+ begin
+ -- If the interpretation is a predefined operator, verify that the
+ -- result type is visible, or that the entity has already been
+ -- resolved (case of an instantiation node that refers to a predefined
+ -- operation, or an internally generated operator node, or an operator
+ -- given as an expanded name). If the operator is a comparison or
+ -- equality, it is the type of the operand that matters to determine
+ -- whether the operator is visible. In an instance, the check is not
+ -- performed, given that the operator was visible in the generic.
+
+ if Ekind (E) = E_Operator then
+
+ if Present (Opnd_Type) then
+ Vis_Type := Opnd_Type;
+ else
+ Vis_Type := Base_Type (T);
+ end if;
+
+ if In_Open_Scopes (Scope (Vis_Type))
+ or else Is_Potentially_Use_Visible (Vis_Type)
+ or else In_Use (Vis_Type)
+ or else (In_Use (Scope (Vis_Type))
+ and then not Is_Hidden (Vis_Type))
+ or else Nkind (N) = N_Expanded_Name
+ or else (Nkind (N) in N_Op and then E = Entity (N))
+ or else In_Instance
+ then
+ null;
+
+ -- If the node is given in functional notation and the prefix
+ -- is an expanded name, then the operator is visible if the
+ -- prefix is the scope of the result type as well.
+
+ elsif Nkind (N) = N_Function_Call
+ and then Nkind (Name (N)) = N_Expanded_Name
+ and then (Entity (Prefix (Name (N))) = Scope (Base_Type (T))
+ or else Entity (Prefix (Name (N))) = Scope (Vis_Type))
+ then
+ null;
+
+ -- Save type for subsequent error message, in case no other
+ -- interpretation is found.
+
+ else
+ Candidate_Type := Vis_Type;
+ return;
+ end if;
+
+ -- In an instance, an abstract non-dispatching operation cannot
+ -- be a candidate interpretation, because it could not have been
+ -- one in the generic (it may be a spurious overloading in the
+ -- instance).
+
+ elsif In_Instance
+ and then Is_Abstract (E)
+ and then not Is_Dispatching_Operation (E)
+ then
+ return;
+ end if;
+
+ -- If this is the first interpretation of N, N has type Any_Type.
+ -- In that case place the new type on the node. If one interpretation
+ -- already exists, indicate that the node is overloaded, and store
+ -- both the previous and the new interpretation in All_Interp. If
+ -- this is a later interpretation, just add it to the set.
+
+ if Etype (N) = Any_Type then
+ if Is_Type (E) then
+ Set_Etype (N, T);
+
+ else
+ -- Record both the operator or subprogram name, and its type.
+
+ if Nkind (N) in N_Op or else Is_Entity_Name (N) then
+ Set_Entity (N, E);
+ end if;
+
+ Set_Etype (N, T);
+ end if;
+
+ -- Either there is no current interpretation in the table for any
+ -- node or the interpretation that is present is for a different
+ -- node. In both cases add a new interpretation to the table.
+
+ elsif Interp_Map.Last < 0
+ or else Interp_Map.Table (Interp_Map.Last).Node /= N
+ then
+ New_Interps (N);
+
+ if (Nkind (N) in N_Op or else Is_Entity_Name (N))
+ and then Present (Entity (N))
+ then
+ Add_Entry (Entity (N), Etype (N));
+
+ elsif (Nkind (N) = N_Function_Call
+ or else Nkind (N) = N_Procedure_Call_Statement)
+ and then (Nkind (Name (N)) = N_Operator_Symbol
+ or else Is_Entity_Name (Name (N)))
+ then
+ Add_Entry (Entity (Name (N)), Etype (N));
+
+ else
+ -- Overloaded prefix in indexed or selected component,
+ -- or call whose name is an expresion or another call.
+
+ Add_Entry (Etype (N), Etype (N));
+ end if;
+
+ Add_Entry (E, T);
+
+ else
+ Add_Entry (E, T);
+ end if;
+ end Add_One_Interp;
+
+ -------------------
+ -- All_Overloads --
+ -------------------
+
+ procedure All_Overloads is
+ begin
+ for J in All_Interp.First .. All_Interp.Last loop
+
+ if Present (All_Interp.Table (J).Nam) then
+ Write_Entity_Info (All_Interp.Table (J). Nam, " ");
+ else
+ Write_Str ("No Interp");
+ end if;
+
+ Write_Str ("=================");
+ Write_Eol;
+ end loop;
+ end All_Overloads;
+
+ ---------------------
+ -- Collect_Interps --
+ ---------------------
+
+ procedure Collect_Interps (N : Node_Id) is
+ Ent : constant Entity_Id := Entity (N);
+ H : Entity_Id;
+ First_Interp : Interp_Index;
+
+ begin
+ New_Interps (N);
+
+ -- Unconditionally add the entity that was initially matched
+
+ First_Interp := All_Interp.Last;
+ Add_One_Interp (N, Ent, Etype (N));
+
+ -- For expanded name, pick up all additional entities from the
+ -- same scope, since these are obviously also visible. Note that
+ -- these are not necessarily contiguous on the homonym chain.
+
+ if Nkind (N) = N_Expanded_Name then
+ H := Homonym (Ent);
+ while Present (H) loop
+ if Scope (H) = Scope (Entity (N)) then
+ Add_One_Interp (N, H, Etype (H));
+ end if;
+
+ H := Homonym (H);
+ end loop;
+
+ -- Case of direct name
+
+ else
+ -- First, search the homonym chain for directly visible entities
+
+ H := Current_Entity (Ent);
+ while Present (H) loop
+ exit when (not Is_Overloadable (H))
+ and then Is_Immediately_Visible (H);
+
+ if Is_Immediately_Visible (H)
+ and then H /= Ent
+ then
+ -- Only add interpretation if not hidden by an inner
+ -- immediately visible one.
+
+ for J in First_Interp .. All_Interp.Last - 1 loop
+
+ -- Current homograph is not hidden. Add to overloads.
+
+ if not Is_Immediately_Visible (All_Interp.Table (J).Nam) then
+ exit;
+
+ -- Homograph is hidden, unless it is a predefined operator.
+
+ elsif Type_Conformant (H, All_Interp.Table (J).Nam) then
+
+ -- A homograph in the same scope can occur within an
+ -- instantiation, the resulting ambiguity has to be
+ -- resolved later.
+
+ if Scope (H) = Scope (Ent)
+ and then In_Instance
+ and then not Is_Inherited_Operation (H)
+ then
+ All_Interp.Table (All_Interp.Last) := (H, Etype (H));
+ All_Interp.Increment_Last;
+ All_Interp.Table (All_Interp.Last) := No_Interp;
+ goto Next_Homograph;
+
+ elsif Scope (H) /= Standard_Standard then
+ goto Next_Homograph;
+ end if;
+ end if;
+ end loop;
+
+ -- On exit, we know that current homograph is not hidden.
+
+ Add_One_Interp (N, H, Etype (H));
+
+ if Debug_Flag_E then
+ Write_Str ("Add overloaded Interpretation ");
+ Write_Int (Int (H));
+ Write_Eol;
+ end if;
+ end if;
+
+ <<Next_Homograph>>
+ H := Homonym (H);
+ end loop;
+
+ -- Scan list of homographs for use-visible entities only.
+
+ H := Current_Entity (Ent);
+
+ while Present (H) loop
+ if Is_Potentially_Use_Visible (H)
+ and then H /= Ent
+ and then Is_Overloadable (H)
+ then
+ for J in First_Interp .. All_Interp.Last - 1 loop
+
+ if not Is_Immediately_Visible (All_Interp.Table (J).Nam) then
+ exit;
+
+ elsif Type_Conformant (H, All_Interp.Table (J).Nam) then
+ goto Next_Use_Homograph;
+ end if;
+ end loop;
+
+ Add_One_Interp (N, H, Etype (H));
+ end if;
+
+ <<Next_Use_Homograph>>
+ H := Homonym (H);
+ end loop;
+ end if;
+
+ if All_Interp.Last = First_Interp + 1 then
+
+ -- The original interpretation is in fact not overloaded.
+
+ Set_Is_Overloaded (N, False);
+ end if;
+ end Collect_Interps;
+
+ ------------
+ -- Covers --
+ ------------
+
+ function Covers (T1, T2 : Entity_Id) return Boolean is
+ begin
+ pragma Assert (Present (T1) and Present (T2));
+
+ -- Simplest case: same types are compatible, and types that have the
+ -- same base type and are not generic actuals are compatible. Generic
+ -- actuals belong to their class but are not compatible with other
+ -- types of their class, and in particular with other generic actuals.
+ -- They are however compatible with their own subtypes, and itypes
+ -- with the same base are compatible as well. Similary, constrained
+ -- subtypes obtained from expressions of an unconstrained nominal type
+ -- are compatible with the base type (may lead to spurious ambiguities
+ -- in obscure cases ???)
+
+ -- Generic actuals require special treatment to avoid spurious ambi-
+ -- guities in an instance, when two formal types are instantiated with
+ -- the same actual, so that different subprograms end up with the same
+ -- signature in the instance.
+
+ if T1 = T2 then
+ return True;
+
+ elsif Base_Type (T1) = Base_Type (T2) then
+ if not Is_Generic_Actual_Type (T1) then
+ return True;
+ else
+ return (not Is_Generic_Actual_Type (T2)
+ or else Is_Itype (T1)
+ or else Is_Itype (T2)
+ or else Is_Constr_Subt_For_U_Nominal (T1)
+ or else Is_Constr_Subt_For_U_Nominal (T2)
+ or else Scope (T1) /= Scope (T2));
+ end if;
+
+ -- Literals are compatible with types in a given "class"
+
+ elsif (T2 = Universal_Integer and then Is_Integer_Type (T1))
+ or else (T2 = Universal_Real and then Is_Real_Type (T1))
+ or else (T2 = Universal_Fixed and then Is_Fixed_Point_Type (T1))
+ or else (T2 = Any_Fixed and then Is_Fixed_Point_Type (T1))
+ or else (T2 = Any_String and then Is_String_Type (T1))
+ or else (T2 = Any_Character and then Is_Character_Type (T1))
+ or else (T2 = Any_Access and then Is_Access_Type (T1))
+ then
+ return True;
+
+ -- The context may be class wide.
+
+ elsif Is_Class_Wide_Type (T1)
+ and then Is_Ancestor (Root_Type (T1), T2)
+ then
+ return True;
+
+ elsif Is_Class_Wide_Type (T1)
+ and then Is_Class_Wide_Type (T2)
+ and then Base_Type (Etype (T1)) = Base_Type (Etype (T2))
+ then
+ return True;
+
+ -- In a dispatching call the actual may be class-wide
+
+ elsif Is_Class_Wide_Type (T2)
+ and then Base_Type (Root_Type (T2)) = Base_Type (T1)
+ then
+ return True;
+
+ -- Some contexts require a class of types rather than a specific type
+
+ elsif (T1 = Any_Integer and then Is_Integer_Type (T2))
+ or else (T1 = Any_Boolean and then Is_Boolean_Type (T2))
+ or else (T1 = Any_Real and then Is_Real_Type (T2))
+ or else (T1 = Any_Fixed and then Is_Fixed_Point_Type (T2))
+ or else (T1 = Any_Discrete and then Is_Discrete_Type (T2))
+ then
+ return True;
+
+ -- An aggregate is compatible with an array or record type
+
+ elsif T2 = Any_Composite
+ and then Ekind (T1) in E_Array_Type .. E_Record_Subtype
+ then
+ return True;
+
+ -- If the expected type is an anonymous access, the designated
+ -- type must cover that of the expression.
+
+ elsif Ekind (T1) = E_Anonymous_Access_Type
+ and then Is_Access_Type (T2)
+ and then Covers (Designated_Type (T1), Designated_Type (T2))
+ then
+ return True;
+
+ -- An Access_To_Subprogram is compatible with itself, or with an
+ -- anonymous type created for an attribute reference Access.
+
+ elsif (Ekind (Base_Type (T1)) = E_Access_Subprogram_Type
+ or else
+ Ekind (Base_Type (T1)) = E_Access_Protected_Subprogram_Type)
+ and then Is_Access_Type (T2)
+ and then (not Comes_From_Source (T1)
+ or else not Comes_From_Source (T2))
+ and then (Is_Overloadable (Designated_Type (T2))
+ or else
+ Ekind (Designated_Type (T2)) = E_Subprogram_Type)
+ and then
+ Type_Conformant (Designated_Type (T1), Designated_Type (T2))
+ and then
+ Mode_Conformant (Designated_Type (T1), Designated_Type (T2))
+ then
+ return True;
+
+ elsif Is_Record_Type (T1)
+ and then (Is_Remote_Call_Interface (T1)
+ or else Is_Remote_Types (T1))
+ and then Present (Corresponding_Remote_Type (T1))
+ then
+ return Covers (Corresponding_Remote_Type (T1), T2);
+
+ elsif Ekind (T2) = E_Access_Attribute_Type
+ and then (Ekind (Base_Type (T1)) = E_General_Access_Type
+ or else Ekind (Base_Type (T1)) = E_Access_Type)
+ and then Covers (Designated_Type (T1), Designated_Type (T2))
+ then
+ -- If the target type is a RACW type while the source is an access
+ -- attribute type, we are building a RACW that may be exported.
+
+ if Is_Remote_Access_To_Class_Wide_Type (Base_Type (T1)) then
+ Set_Has_RACW (Current_Sem_Unit);
+ end if;
+
+ return True;
+
+ elsif Ekind (T2) = E_Allocator_Type
+ and then Is_Access_Type (T1)
+ and then Covers (Designated_Type (T1), Designated_Type (T2))
+ then
+ return True;
+
+ -- A boolean operation on integer literals is compatible with a
+ -- modular context.
+
+ elsif T2 = Any_Modular
+ and then Is_Modular_Integer_Type (T1)
+ then
+ return True;
+
+ -- The actual type may be the result of a previous error
+
+ elsif Base_Type (T2) = Any_Type then
+ return True;
+
+ -- A packed array type covers its corresponding non-packed type.
+ -- This is not legitimate Ada, but allows the omission of a number
+ -- of otherwise useless unchecked conversions, and since this can
+ -- only arise in (known correct) expanded code, no harm is done
+
+ elsif Is_Array_Type (T2)
+ and then Is_Packed (T2)
+ and then T1 = Packed_Array_Type (T2)
+ then
+ return True;
+
+ -- Similarly an array type covers its corresponding packed array type
+
+ elsif Is_Array_Type (T1)
+ and then Is_Packed (T1)
+ and then T2 = Packed_Array_Type (T1)
+ then
+ return True;
+
+ -- In an instance the proper view may not always be correct for
+ -- private types, but private and full view are compatible. This
+ -- removes spurious errors from nested instantiations that involve,
+ -- among other things, types derived from privated types.
+
+ elsif In_Instance
+ and then Is_Private_Type (T1)
+ and then ((Present (Full_View (T1))
+ and then Covers (Full_View (T1), T2))
+ or else Base_Type (T1) = T2
+ or else Base_Type (T2) = T1)
+ then
+ return True;
+
+ -- In the expansion of inlined bodies, types are compatible if they
+ -- are structurally equivalent.
+
+ elsif In_Inlined_Body
+ and then (Underlying_Type (T1) = Underlying_Type (T2)
+ or else (Is_Access_Type (T1)
+ and then Is_Access_Type (T2)
+ and then
+ Designated_Type (T1) = Designated_Type (T2))
+ or else (T1 = Any_Access
+ and then Is_Access_Type (Underlying_Type (T2))))
+ then
+ return True;
+
+ -- Otherwise it doesn't cover!
+
+ else
+ return False;
+ end if;
+ end Covers;
+
+ ------------------
+ -- Disambiguate --
+ ------------------
+
+ function Disambiguate
+ (N : Node_Id;
+ I1, I2 : Interp_Index;
+ Typ : Entity_Id)
+ return Interp
+ is
+ I : Interp_Index;
+ It : Interp;
+ It1, It2 : Interp;
+ Nam1, Nam2 : Entity_Id;
+ Predef_Subp : Entity_Id;
+ User_Subp : Entity_Id;
+
+ function Matches (Actual, Formal : Node_Id) return Boolean;
+ -- Look for exact type match in an instance, to remove spurious
+ -- ambiguities when two formal types have the same actual.
+
+ function Standard_Operator return Boolean;
+
+ function Remove_Conversions return Interp;
+ -- Last chance for pathological cases involving comparisons on
+ -- literals, and user overloadings of the same operator. Such
+ -- pathologies have been removed from the ACVC, but still appear in
+ -- two DEC tests, with the following notable quote from Ben Brosgol:
+ --
+ -- [Note: I disclaim all credit/responsibility/blame for coming up with
+ -- this example; Robert Dewar brought it to our attention, since it
+ -- is apparently found in the ACVC 1.5. I did not attempt to find
+ -- the reason in the Reference Manual that makes the example legal,
+ -- since I was too nauseated by it to want to pursue it further.]
+ --
+ -- Accordingly, this is not a fully recursive solution, but it handles
+ -- DEC tests c460vsa, c460vsb. It also handles ai00136a, which pushes
+ -- pathology in the other direction with calls whose multiple overloaded
+ -- actuals make them truly unresolvable.
+
+ -------------
+ -- Matches --
+ -------------
+
+ function Matches (Actual, Formal : Node_Id) return Boolean is
+ T1 : constant Entity_Id := Etype (Actual);
+ T2 : constant Entity_Id := Etype (Formal);
+
+ begin
+ return T1 = T2
+ or else
+ (Is_Numeric_Type (T2)
+ and then
+ (T1 = Universal_Real or else T1 = Universal_Integer));
+ end Matches;
+
+ ------------------------
+ -- Remove_Conversions --
+ ------------------------
+
+ function Remove_Conversions return Interp is
+ I : Interp_Index;
+ It : Interp;
+ It1 : Interp;
+ F1 : Entity_Id;
+ Act1 : Node_Id;
+ Act2 : Node_Id;
+
+ begin
+ It1 := No_Interp;
+ Get_First_Interp (N, I, It);
+
+ while Present (It.Typ) loop
+
+ if not Is_Overloadable (It.Nam) then
+ return No_Interp;
+ end if;
+
+ F1 := First_Formal (It.Nam);
+
+ if No (F1) then
+ return It1;
+
+ else
+ if Nkind (N) = N_Function_Call
+ or else Nkind (N) = N_Procedure_Call_Statement
+ then
+ Act1 := First_Actual (N);
+
+ if Present (Act1) then
+ Act2 := Next_Actual (Act1);
+ else
+ Act2 := Empty;
+ end if;
+
+ elsif Nkind (N) in N_Unary_Op then
+ Act1 := Right_Opnd (N);
+ Act2 := Empty;
+
+ elsif Nkind (N) in N_Binary_Op then
+ Act1 := Left_Opnd (N);
+ Act2 := Right_Opnd (N);
+
+ else
+ return It1;
+ end if;
+
+ if Nkind (Act1) in N_Op
+ and then Is_Overloaded (Act1)
+ and then (Nkind (Right_Opnd (Act1)) = N_Integer_Literal
+ or else Nkind (Right_Opnd (Act1)) = N_Real_Literal)
+ and then Has_Compatible_Type (Act1, Standard_Boolean)
+ and then Etype (F1) = Standard_Boolean
+ then
+
+ if It1 /= No_Interp then
+ return No_Interp;
+
+ elsif Present (Act2)
+ and then Nkind (Act2) in N_Op
+ and then Is_Overloaded (Act2)
+ and then (Nkind (Right_Opnd (Act1)) = N_Integer_Literal
+ or else
+ Nkind (Right_Opnd (Act1)) = N_Real_Literal)
+ and then Has_Compatible_Type (Act2, Standard_Boolean)
+ then
+ -- The preference rule on the first actual is not
+ -- sufficient to disambiguate.
+
+ goto Next_Interp;
+
+ else
+ It1 := It;
+ end if;
+ end if;
+ end if;
+
+ <<Next_Interp>>
+ Get_Next_Interp (I, It);
+ end loop;
+
+ if Errors_Detected > 0 then
+
+ -- After some error, a formal may have Any_Type and yield
+ -- a spurious match. To avoid cascaded errors if possible,
+ -- check for such a formal in either candidate.
+
+ declare
+ Formal : Entity_Id;
+
+ begin
+ Formal := First_Formal (Nam1);
+ while Present (Formal) loop
+ if Etype (Formal) = Any_Type then
+ return Disambiguate.It2;
+ end if;
+
+ Next_Formal (Formal);
+ end loop;
+
+ Formal := First_Formal (Nam2);
+ while Present (Formal) loop
+ if Etype (Formal) = Any_Type then
+ return Disambiguate.It1;
+ end if;
+
+ Next_Formal (Formal);
+ end loop;
+ end;
+ end if;
+
+ return It1;
+ end Remove_Conversions;
+
+ -----------------------
+ -- Standard_Operator --
+ -----------------------
+
+ function Standard_Operator return Boolean is
+ Nam : Node_Id;
+
+ begin
+ if Nkind (N) in N_Op then
+ return True;
+
+ elsif Nkind (N) = N_Function_Call then
+ Nam := Name (N);
+
+ if Nkind (Nam) /= N_Expanded_Name then
+ return True;
+ else
+ return Entity (Prefix (Nam)) = Standard_Standard;
+ end if;
+ else
+ return False;
+ end if;
+ end Standard_Operator;
+
+ -- Start of processing for Disambiguate
+
+ begin
+ -- Recover the two legal interpretations.
+
+ Get_First_Interp (N, I, It);
+
+ while I /= I1 loop
+ Get_Next_Interp (I, It);
+ end loop;
+
+ It1 := It;
+ Nam1 := It.Nam;
+
+ while I /= I2 loop
+ Get_Next_Interp (I, It);
+ end loop;
+
+ It2 := It;
+ Nam2 := It.Nam;
+
+ -- If the context is universal, the predefined operator is preferred.
+ -- This includes bounds in numeric type declarations, and expressions
+ -- in type conversions. If no interpretation yields a universal type,
+ -- then we must check whether the user-defined entity hides the prede-
+ -- fined one.
+
+ if Chars (Nam1) in Any_Operator_Name
+ and then Standard_Operator
+ then
+ if Typ = Universal_Integer
+ or else Typ = Universal_Real
+ or else Typ = Any_Integer
+ or else Typ = Any_Discrete
+ or else Typ = Any_Real
+ or else Typ = Any_Type
+ then
+ -- Find an interpretation that yields the universal type, or else
+ -- a predefined operator that yields a predefined numeric type.
+
+ declare
+ Candidate : Interp := No_Interp;
+ begin
+ Get_First_Interp (N, I, It);
+
+ while Present (It.Typ) loop
+ if (Covers (Typ, It.Typ)
+ or else Typ = Any_Type)
+ and then
+ (It.Typ = Universal_Integer
+ or else It.Typ = Universal_Real)
+ then
+ return It;
+
+ elsif Covers (Typ, It.Typ)
+ and then Scope (It.Typ) = Standard_Standard
+ and then Scope (It.Nam) = Standard_Standard
+ and then Is_Numeric_Type (It.Typ)
+ then
+ Candidate := It;
+ end if;
+
+ Get_Next_Interp (I, It);
+ end loop;
+
+ if Candidate /= No_Interp then
+ return Candidate;
+ end if;
+ end;
+
+ elsif Chars (Nam1) /= Name_Op_Not
+ and then (Typ = Standard_Boolean
+ or else Typ = Any_Boolean)
+ then
+ -- Equality or comparison operation. Choose predefined operator
+ -- if arguments are universal. The node may be an operator, a
+ -- name, or a function call, so unpack arguments accordingly.
+
+ declare
+ Arg1, Arg2 : Node_Id;
+
+ begin
+ if Nkind (N) in N_Op then
+ Arg1 := Left_Opnd (N);
+ Arg2 := Right_Opnd (N);
+
+ elsif Is_Entity_Name (N)
+ or else Nkind (N) = N_Operator_Symbol
+ then
+ Arg1 := First_Entity (Entity (N));
+ Arg2 := Next_Entity (Arg1);
+
+ else
+ Arg1 := First_Actual (N);
+ Arg2 := Next_Actual (Arg1);
+ end if;
+
+ if Present (Arg2)
+ and then Present (Universal_Interpretation (Arg1))
+ and then Universal_Interpretation (Arg2) =
+ Universal_Interpretation (Arg1)
+ then
+ Get_First_Interp (N, I, It);
+
+ while Scope (It.Nam) /= Standard_Standard loop
+ Get_Next_Interp (I, It);
+ end loop;
+
+ return It;
+ end if;
+ end;
+ end if;
+ end if;
+
+ -- If no universal interpretation, check whether user-defined operator
+ -- hides predefined one, as well as other special cases. If the node
+ -- is a range, then one or both bounds are ambiguous. Each will have
+ -- to be disambiguated w.r.t. the context type. The type of the range
+ -- itself is imposed by the context, so we can return either legal
+ -- interpretation.
+
+ if Ekind (Nam1) = E_Operator then
+ Predef_Subp := Nam1;
+ User_Subp := Nam2;
+
+ elsif Ekind (Nam2) = E_Operator then
+ Predef_Subp := Nam2;
+ User_Subp := Nam1;
+
+ elsif Nkind (N) = N_Range then
+ return It1;
+
+ -- If two user defined-subprograms are visible, it is a true ambiguity,
+ -- unless one of them is an entry and the context is a conditional or
+ -- timed entry call, or unless we are within an instance and this is
+ -- results from two formals types with the same actual.
+
+ else
+ if Nkind (N) = N_Procedure_Call_Statement
+ and then Nkind (Parent (N)) = N_Entry_Call_Alternative
+ and then N = Entry_Call_Statement (Parent (N))
+ then
+ if Ekind (Nam2) = E_Entry then
+ return It2;
+ elsif Ekind (Nam1) = E_Entry then
+ return It1;
+ else
+ return No_Interp;
+ end if;
+
+ -- If the ambiguity occurs within an instance, it is due to several
+ -- formal types with the same actual. Look for an exact match
+ -- between the types of the formals of the overloadable entities,
+ -- and the actuals in the call, to recover the unambiguous match
+ -- in the original generic.
+
+ elsif In_Instance then
+ if (Nkind (N) = N_Function_Call
+ or else Nkind (N) = N_Procedure_Call_Statement)
+ then
+ declare
+ Actual : Node_Id;
+ Formal : Entity_Id;
+
+ begin
+ Actual := First_Actual (N);
+ Formal := First_Formal (Nam1);
+ while Present (Actual) loop
+ if Etype (Actual) /= Etype (Formal) then
+ return It2;
+ end if;
+
+ Next_Actual (Actual);
+ Next_Formal (Formal);
+ end loop;
+
+ return It1;
+ end;
+
+ elsif Nkind (N) in N_Binary_Op then
+
+ if Matches (Left_Opnd (N), First_Formal (Nam1))
+ and then
+ Matches (Right_Opnd (N), Next_Formal (First_Formal (Nam1)))
+ then
+ return It1;
+ else
+ return It2;
+ end if;
+
+ elsif Nkind (N) in N_Unary_Op then
+
+ if Etype (Right_Opnd (N)) = Etype (First_Formal (Nam1)) then
+ return It1;
+ else
+ return It2;
+ end if;
+
+ else
+ return Remove_Conversions;
+ end if;
+ else
+ return Remove_Conversions;
+ end if;
+ end if;
+
+ -- an implicit concatenation operator on a string type cannot be
+ -- disambiguated from the predefined concatenation. This can only
+ -- happen with concatenation of string literals.
+
+ if Chars (User_Subp) = Name_Op_Concat
+ and then Ekind (User_Subp) = E_Operator
+ and then Is_String_Type (Etype (First_Formal (User_Subp)))
+ then
+ return No_Interp;
+
+ -- If the user-defined operator is in an open scope, or in the scope
+ -- of the resulting type, or given by an expanded name that names its
+ -- scope, it hides the predefined operator for the type. Exponentiation
+ -- has to be special-cased because the implicit operator does not have
+ -- a symmetric signature, and may not be hidden by the explicit one.
+
+ elsif (Nkind (N) = N_Function_Call
+ and then Nkind (Name (N)) = N_Expanded_Name
+ and then (Chars (Predef_Subp) /= Name_Op_Expon
+ or else Hides_Op (User_Subp, Predef_Subp))
+ and then Scope (User_Subp) = Entity (Prefix (Name (N))))
+ or else Hides_Op (User_Subp, Predef_Subp)
+ then
+ if It1.Nam = User_Subp then
+ return It1;
+ else
+ return It2;
+ end if;
+
+ -- Otherwise, the predefined operator has precedence, or if the
+ -- user-defined operation is directly visible we have a true ambiguity.
+ -- If this is a fixed-point multiplication and division in Ada83 mode,
+ -- exclude the universal_fixed operator, which often causes ambiguities
+ -- in legacy code.
+
+ else
+ if (In_Open_Scopes (Scope (User_Subp))
+ or else Is_Potentially_Use_Visible (User_Subp))
+ and then not In_Instance
+ then
+ if Is_Fixed_Point_Type (Typ)
+ and then (Chars (Nam1) = Name_Op_Multiply
+ or else Chars (Nam1) = Name_Op_Divide)
+ and then Ada_83
+ then
+ if It2.Nam = Predef_Subp then
+ return It1;
+
+ else
+ return It2;
+ end if;
+ else
+ return No_Interp;
+ end if;
+
+ elsif It1.Nam = Predef_Subp then
+ return It1;
+
+ else
+ return It2;
+ end if;
+ end if;
+
+ end Disambiguate;
+
+ ---------------------
+ -- End_Interp_List --
+ ---------------------
+
+ procedure End_Interp_List is
+ begin
+ All_Interp.Table (All_Interp.Last) := No_Interp;
+ All_Interp.Increment_Last;
+ end End_Interp_List;
+
+ -------------------------
+ -- Entity_Matches_Spec --
+ -------------------------
+
+ function Entity_Matches_Spec (Old_S, New_S : Entity_Id) return Boolean is
+ begin
+ -- Simple case: same entity kinds, type conformance is required.
+ -- A parameterless function can also rename a literal.
+
+ if Ekind (Old_S) = Ekind (New_S)
+ or else (Ekind (New_S) = E_Function
+ and then Ekind (Old_S) = E_Enumeration_Literal)
+ then
+ return Type_Conformant (New_S, Old_S);
+
+ elsif Ekind (New_S) = E_Function
+ and then Ekind (Old_S) = E_Operator
+ then
+ return Operator_Matches_Spec (Old_S, New_S);
+
+ elsif Ekind (New_S) = E_Procedure
+ and then Is_Entry (Old_S)
+ then
+ return Type_Conformant (New_S, Old_S);
+
+ else
+ return False;
+ end if;
+ end Entity_Matches_Spec;
+
+ ----------------------
+ -- Find_Unique_Type --
+ ----------------------
+
+ function Find_Unique_Type (L : Node_Id; R : Node_Id) return Entity_Id is
+ I : Interp_Index;
+ It : Interp;
+ T : Entity_Id := Etype (L);
+ TR : Entity_Id := Any_Type;
+
+ begin
+ if Is_Overloaded (R) then
+ Get_First_Interp (R, I, It);
+
+ while Present (It.Typ) loop
+ if Covers (T, It.Typ) or else Covers (It.Typ, T) then
+
+ -- If several interpretations are possible and L is universal,
+ -- apply preference rule.
+
+ if TR /= Any_Type then
+
+ if (T = Universal_Integer or else T = Universal_Real)
+ and then It.Typ = T
+ then
+ TR := It.Typ;
+ end if;
+
+ else
+ TR := It.Typ;
+ end if;
+ end if;
+
+ Get_Next_Interp (I, It);
+ end loop;
+
+ Set_Etype (R, TR);
+
+ -- In the non-overloaded case, the Etype of R is already set
+ -- correctly.
+
+ else
+ null;
+ end if;
+
+ -- If one of the operands is Universal_Fixed, the type of the
+ -- other operand provides the context.
+
+ if Etype (R) = Universal_Fixed then
+ return T;
+
+ elsif T = Universal_Fixed then
+ return Etype (R);
+
+ else
+ return Specific_Type (T, Etype (R));
+ end if;
+
+ end Find_Unique_Type;
+
+ ----------------------
+ -- Get_First_Interp --
+ ----------------------
+
+ procedure Get_First_Interp
+ (N : Node_Id;
+ I : out Interp_Index;
+ It : out Interp)
+ is
+ Int_Ind : Interp_Index;
+ O_N : Node_Id;
+
+ begin
+ -- If a selected component is overloaded because the selector has
+ -- multiple interpretations, the node is a call to a protected
+ -- operation or an indirect call. Retrieve the interpretation from
+ -- the selector name. The selected component may be overloaded as well
+ -- if the prefix is overloaded. That case is unchanged.
+
+ if Nkind (N) = N_Selected_Component
+ and then Is_Overloaded (Selector_Name (N))
+ then
+ O_N := Selector_Name (N);
+ else
+ O_N := N;
+ end if;
+
+ for Index in 0 .. Interp_Map.Last loop
+ if Interp_Map.Table (Index).Node = O_N then
+ Int_Ind := Interp_Map.Table (Index).Index;
+ It := All_Interp.Table (Int_Ind);
+ I := Int_Ind;
+ return;
+ end if;
+ end loop;
+
+ -- Procedure should never be called if the node has no interpretations
+
+ raise Program_Error;
+ end Get_First_Interp;
+
+ ----------------------
+ -- Get_Next_Interp --
+ ----------------------
+
+ procedure Get_Next_Interp (I : in out Interp_Index; It : out Interp) is
+ begin
+ I := I + 1;
+ It := All_Interp.Table (I);
+ end Get_Next_Interp;
+
+ -------------------------
+ -- Has_Compatible_Type --
+ -------------------------
+
+ function Has_Compatible_Type
+ (N : Node_Id;
+ Typ : Entity_Id)
+ return Boolean
+ is
+ I : Interp_Index;
+ It : Interp;
+
+ begin
+ if N = Error then
+ return False;
+ end if;
+
+ if Nkind (N) = N_Subtype_Indication
+ or else not Is_Overloaded (N)
+ then
+ return Covers (Typ, Etype (N))
+ or else (not Is_Tagged_Type (Typ)
+ and then Ekind (Typ) /= E_Anonymous_Access_Type
+ and then Covers (Etype (N), Typ));
+
+ else
+ Get_First_Interp (N, I, It);
+
+ while Present (It.Typ) loop
+ if Covers (Typ, It.Typ)
+ or else (not Is_Tagged_Type (Typ)
+ and then Ekind (Typ) /= E_Anonymous_Access_Type
+ and then Covers (It.Typ, Typ))
+ then
+ return True;
+ end if;
+
+ Get_Next_Interp (I, It);
+ end loop;
+
+ return False;
+ end if;
+ end Has_Compatible_Type;
+
+ --------------
+ -- Hides_Op --
+ --------------
+
+ function Hides_Op (F : Entity_Id; Op : Entity_Id) return Boolean is
+ Btyp : constant Entity_Id := Base_Type (Etype (First_Formal (F)));
+
+ begin
+ return Operator_Matches_Spec (Op, F)
+ and then (In_Open_Scopes (Scope (F))
+ or else Scope (F) = Scope (Btyp)
+ or else (not In_Open_Scopes (Scope (Btyp))
+ and then not In_Use (Btyp)
+ and then not In_Use (Scope (Btyp))));
+ end Hides_Op;
+
+ ------------------------
+ -- Init_Interp_Tables --
+ ------------------------
+
+ procedure Init_Interp_Tables is
+ begin
+ All_Interp.Init;
+ Interp_Map.Init;
+ end Init_Interp_Tables;
+
+ ---------------------
+ -- Intersect_Types --
+ ---------------------
+
+ function Intersect_Types (L, R : Node_Id) return Entity_Id is
+ Index : Interp_Index;
+ It : Interp;
+ Typ : Entity_Id;
+
+ function Check_Right_Argument (T : Entity_Id) return Entity_Id;
+ -- Find interpretation of right arg that has type compatible with T
+
+ --------------------------
+ -- Check_Right_Argument --
+ --------------------------
+
+ function Check_Right_Argument (T : Entity_Id) return Entity_Id is
+ Index : Interp_Index;
+ It : Interp;
+ T2 : Entity_Id;
+
+ begin
+ if not Is_Overloaded (R) then
+ return Specific_Type (T, Etype (R));
+
+ else
+ Get_First_Interp (R, Index, It);
+
+ loop
+ T2 := Specific_Type (T, It.Typ);
+
+ if T2 /= Any_Type then
+ return T2;
+ end if;
+
+ Get_Next_Interp (Index, It);
+ exit when No (It.Typ);
+ end loop;
+
+ return Any_Type;
+ end if;
+ end Check_Right_Argument;
+
+ -- Start processing for Intersect_Types
+
+ begin
+ if Etype (L) = Any_Type or else Etype (R) = Any_Type then
+ return Any_Type;
+ end if;
+
+ if not Is_Overloaded (L) then
+ Typ := Check_Right_Argument (Etype (L));
+
+ else
+ Typ := Any_Type;
+ Get_First_Interp (L, Index, It);
+
+ while Present (It.Typ) loop
+ Typ := Check_Right_Argument (It.Typ);
+ exit when Typ /= Any_Type;
+ Get_Next_Interp (Index, It);
+ end loop;
+
+ end if;
+
+ -- If Typ is Any_Type, it means no compatible pair of types was found
+
+ if Typ = Any_Type then
+
+ if Nkind (Parent (L)) in N_Op then
+ Error_Msg_N ("incompatible types for operator", Parent (L));
+
+ elsif Nkind (Parent (L)) = N_Range then
+ Error_Msg_N ("incompatible types given in constraint", Parent (L));
+
+ else
+ Error_Msg_N ("incompatible types", Parent (L));
+ end if;
+ end if;
+
+ return Typ;
+ end Intersect_Types;
+
+ -----------------
+ -- Is_Ancestor --
+ -----------------
+
+ function Is_Ancestor (T1, T2 : Entity_Id) return Boolean is
+ Par : Entity_Id;
+
+ begin
+ if Base_Type (T1) = Base_Type (T2) then
+ return True;
+
+ elsif Is_Private_Type (T1)
+ and then Present (Full_View (T1))
+ and then Base_Type (T2) = Base_Type (Full_View (T1))
+ then
+ return True;
+
+ else
+ Par := Etype (T2);
+
+ loop
+ if Base_Type (T1) = Base_Type (Par)
+ or else (Is_Private_Type (T1)
+ and then Present (Full_View (T1))
+ and then Base_Type (Par) = Base_Type (Full_View (T1)))
+ then
+ return True;
+
+ elsif Is_Private_Type (Par)
+ and then Present (Full_View (Par))
+ and then Full_View (Par) = Base_Type (T1)
+ then
+ return True;
+
+ elsif Etype (Par) /= Par then
+ Par := Etype (Par);
+ else
+ return False;
+ end if;
+ end loop;
+ end if;
+ end Is_Ancestor;
+
+ -------------------
+ -- Is_Subtype_Of --
+ -------------------
+
+ function Is_Subtype_Of (T1 : Entity_Id; T2 : Entity_Id) return Boolean is
+ S : Entity_Id;
+
+ begin
+ S := Ancestor_Subtype (T1);
+ while Present (S) loop
+ if S = T2 then
+ return True;
+ else
+ S := Ancestor_Subtype (S);
+ end if;
+ end loop;
+
+ return False;
+ end Is_Subtype_Of;
+
+ -----------------
+ -- New_Interps --
+ -----------------
+
+ procedure New_Interps (N : Node_Id) is
+ begin
+ Interp_Map.Increment_Last;
+ All_Interp.Increment_Last;
+ Interp_Map.Table (Interp_Map.Last) := (N, All_Interp.Last);
+ All_Interp.Table (All_Interp.Last) := No_Interp;
+ Set_Is_Overloaded (N, True);
+ end New_Interps;
+
+ ---------------------------
+ -- Operator_Matches_Spec --
+ ---------------------------
+
+ function Operator_Matches_Spec (Op, New_S : Entity_Id) return Boolean is
+ Op_Name : constant Name_Id := Chars (Op);
+ T : constant Entity_Id := Etype (New_S);
+ New_F : Entity_Id;
+ Old_F : Entity_Id;
+ Num : Int;
+ T1 : Entity_Id;
+ T2 : Entity_Id;
+
+ begin
+ -- To verify that a predefined operator matches a given signature,
+ -- do a case analysis of the operator classes. Function can have one
+ -- or two formals and must have the proper result type.
+
+ New_F := First_Formal (New_S);
+ Old_F := First_Formal (Op);
+ Num := 0;
+
+ while Present (New_F) and then Present (Old_F) loop
+ Num := Num + 1;
+ Next_Formal (New_F);
+ Next_Formal (Old_F);
+ end loop;
+
+ -- Definite mismatch if different number of parameters
+
+ if Present (Old_F) or else Present (New_F) then
+ return False;
+
+ -- Unary operators
+
+ elsif Num = 1 then
+ T1 := Etype (First_Formal (New_S));
+
+ if Op_Name = Name_Op_Subtract
+ or else Op_Name = Name_Op_Add
+ or else Op_Name = Name_Op_Abs
+ then
+ return Base_Type (T1) = Base_Type (T)
+ and then Is_Numeric_Type (T);
+
+ elsif Op_Name = Name_Op_Not then
+ return Base_Type (T1) = Base_Type (T)
+ and then Valid_Boolean_Arg (Base_Type (T));
+
+ else
+ return False;
+ end if;
+
+ -- Binary operators
+
+ else
+ T1 := Etype (First_Formal (New_S));
+ T2 := Etype (Next_Formal (First_Formal (New_S)));
+
+ if Op_Name = Name_Op_And or else Op_Name = Name_Op_Or
+ or else Op_Name = Name_Op_Xor
+ then
+ return Base_Type (T1) = Base_Type (T2)
+ and then Base_Type (T1) = Base_Type (T)
+ and then Valid_Boolean_Arg (Base_Type (T));
+
+ elsif Op_Name = Name_Op_Eq or else Op_Name = Name_Op_Ne then
+ return Base_Type (T1) = Base_Type (T2)
+ and then not Is_Limited_Type (T1)
+ and then Is_Boolean_Type (T);
+
+ elsif Op_Name = Name_Op_Lt or else Op_Name = Name_Op_Le
+ or else Op_Name = Name_Op_Gt or else Op_Name = Name_Op_Ge
+ then
+ return Base_Type (T1) = Base_Type (T2)
+ and then Valid_Comparison_Arg (T1)
+ and then Is_Boolean_Type (T);
+
+ elsif Op_Name = Name_Op_Add or else Op_Name = Name_Op_Subtract then
+ return Base_Type (T1) = Base_Type (T2)
+ and then Base_Type (T1) = Base_Type (T)
+ and then Is_Numeric_Type (T);
+
+ -- for division and multiplication, a user-defined function does
+ -- not match the predefined universal_fixed operation, except in
+ -- Ada83 mode.
+
+ elsif Op_Name = Name_Op_Divide then
+ return (Base_Type (T1) = Base_Type (T2)
+ and then Base_Type (T1) = Base_Type (T)
+ and then Is_Numeric_Type (T)
+ and then (not Is_Fixed_Point_Type (T)
+ or else Ada_83))
+
+ -- Mixed_Mode operations on fixed-point types.
+
+ or else (Base_Type (T1) = Base_Type (T)
+ and then Base_Type (T2) = Base_Type (Standard_Integer)
+ and then Is_Fixed_Point_Type (T))
+
+ -- A user defined operator can also match (and hide) a mixed
+ -- operation on universal literals.
+
+ or else (Is_Integer_Type (T2)
+ and then Is_Floating_Point_Type (T1)
+ and then Base_Type (T1) = Base_Type (T));
+
+ elsif Op_Name = Name_Op_Multiply then
+ return (Base_Type (T1) = Base_Type (T2)
+ and then Base_Type (T1) = Base_Type (T)
+ and then Is_Numeric_Type (T)
+ and then (not Is_Fixed_Point_Type (T)
+ or else Ada_83))
+
+ -- Mixed_Mode operations on fixed-point types.
+
+ or else (Base_Type (T1) = Base_Type (T)
+ and then Base_Type (T2) = Base_Type (Standard_Integer)
+ and then Is_Fixed_Point_Type (T))
+
+ or else (Base_Type (T2) = Base_Type (T)
+ and then Base_Type (T1) = Base_Type (Standard_Integer)
+ and then Is_Fixed_Point_Type (T))
+
+ or else (Is_Integer_Type (T2)
+ and then Is_Floating_Point_Type (T1)
+ and then Base_Type (T1) = Base_Type (T))
+
+ or else (Is_Integer_Type (T1)
+ and then Is_Floating_Point_Type (T2)
+ and then Base_Type (T2) = Base_Type (T));
+
+ elsif Op_Name = Name_Op_Mod or else Op_Name = Name_Op_Rem then
+ return Base_Type (T1) = Base_Type (T2)
+ and then Base_Type (T1) = Base_Type (T)
+ and then Is_Integer_Type (T);
+
+ elsif Op_Name = Name_Op_Expon then
+ return Base_Type (T1) = Base_Type (T)
+ and then Is_Numeric_Type (T)
+ and then Base_Type (T2) = Base_Type (Standard_Integer);
+
+ elsif Op_Name = Name_Op_Concat then
+ return Is_Array_Type (T)
+ and then (Base_Type (T) = Base_Type (Etype (Op)))
+ and then (Base_Type (T1) = Base_Type (T)
+ or else
+ Base_Type (T1) = Base_Type (Component_Type (T)))
+ and then (Base_Type (T2) = Base_Type (T)
+ or else
+ Base_Type (T2) = Base_Type (Component_Type (T)));
+
+ else
+ return False;
+ end if;
+ end if;
+ end Operator_Matches_Spec;
+
+ -------------------
+ -- Remove_Interp --
+ -------------------
+
+ procedure Remove_Interp (I : in out Interp_Index) is
+ II : Interp_Index;
+
+ begin
+ -- Find end of Interp list and copy downward to erase the discarded one
+
+ II := I + 1;
+
+ while Present (All_Interp.Table (II).Typ) loop
+ II := II + 1;
+ end loop;
+
+ for J in I + 1 .. II loop
+ All_Interp.Table (J - 1) := All_Interp.Table (J);
+ end loop;
+
+ -- Back up interp. index to insure that iterator will pick up next
+ -- available interpretation.
+
+ I := I - 1;
+ end Remove_Interp;
+
+ ------------------
+ -- Save_Interps --
+ ------------------
+
+ procedure Save_Interps (Old_N : Node_Id; New_N : Node_Id) is
+ begin
+ if Is_Overloaded (Old_N) then
+ for Index in 0 .. Interp_Map.Last loop
+ if Interp_Map.Table (Index).Node = Old_N then
+ Interp_Map.Table (Index).Node := New_N;
+ exit;
+ end if;
+ end loop;
+ end if;
+ end Save_Interps;
+
+ -------------------
+ -- Specific_Type --
+ -------------------
+
+ function Specific_Type (T1, T2 : Entity_Id) return Entity_Id is
+ B1 : constant Entity_Id := Base_Type (T1);
+ B2 : constant Entity_Id := Base_Type (T2);
+
+ function Is_Remote_Access (T : Entity_Id) return Boolean;
+ -- Check whether T is the equivalent type of a remote access type.
+ -- If distribution is enabled, T is a legal context for Null.
+
+ ----------------------
+ -- Is_Remote_Access --
+ ----------------------
+
+ function Is_Remote_Access (T : Entity_Id) return Boolean is
+ begin
+ return Is_Record_Type (T)
+ and then (Is_Remote_Call_Interface (T)
+ or else Is_Remote_Types (T))
+ and then Present (Corresponding_Remote_Type (T))
+ and then Is_Access_Type (Corresponding_Remote_Type (T));
+ end Is_Remote_Access;
+
+ -- Start of processing for Specific_Type
+
+ begin
+ if (T1 = Any_Type or else T2 = Any_Type) then
+ return Any_Type;
+ end if;
+
+ if B1 = B2 then
+ return B1;
+
+ elsif (T1 = Universal_Integer and then Is_Integer_Type (T2))
+ or else (T1 = Universal_Real and then Is_Real_Type (T2))
+ or else (T1 = Any_Fixed and then Is_Fixed_Point_Type (T2))
+ then
+ return B2;
+
+ elsif (T2 = Universal_Integer and then Is_Integer_Type (T1))
+ or else (T2 = Universal_Real and then Is_Real_Type (T1))
+ or else (T2 = Any_Fixed and then Is_Fixed_Point_Type (T1))
+ then
+ return B1;
+
+ elsif (T2 = Any_String and then Is_String_Type (T1)) then
+ return B1;
+
+ elsif (T1 = Any_String and then Is_String_Type (T2)) then
+ return B2;
+
+ elsif (T2 = Any_Character and then Is_Character_Type (T1)) then
+ return B1;
+
+ elsif (T1 = Any_Character and then Is_Character_Type (T2)) then
+ return B2;
+
+ elsif (T1 = Any_Access
+ and then (Is_Access_Type (T2) or else Is_Remote_Access (T2)))
+ then
+ return T2;
+
+ elsif (T2 = Any_Access
+ and then (Is_Access_Type (T1) or else Is_Remote_Access (T1)))
+ then
+ return T1;
+
+ elsif (T2 = Any_Composite
+ and then Ekind (T1) in E_Array_Type .. E_Record_Subtype)
+ then
+ return T1;
+
+ elsif (T1 = Any_Composite
+ and then Ekind (T2) in E_Array_Type .. E_Record_Subtype)
+ then
+ return T2;
+
+ elsif (T1 = Any_Modular and then Is_Modular_Integer_Type (T2)) then
+ return T2;
+
+ elsif (T2 = Any_Modular and then Is_Modular_Integer_Type (T1)) then
+ return T1;
+
+ -- Special cases for equality operators (all other predefined
+ -- operators can never apply to tagged types)
+
+ elsif Is_Class_Wide_Type (T1)
+ and then Is_Ancestor (Root_Type (T1), T2)
+ then
+ return T1;
+
+ elsif Is_Class_Wide_Type (T2)
+ and then Is_Ancestor (Root_Type (T2), T1)
+ then
+ return T2;
+
+ elsif (Ekind (B1) = E_Access_Subprogram_Type
+ or else
+ Ekind (B1) = E_Access_Protected_Subprogram_Type)
+ and then Ekind (Designated_Type (B1)) /= E_Subprogram_Type
+ and then Is_Access_Type (T2)
+ then
+ return T2;
+
+ elsif (Ekind (B2) = E_Access_Subprogram_Type
+ or else
+ Ekind (B2) = E_Access_Protected_Subprogram_Type)
+ and then Ekind (Designated_Type (B2)) /= E_Subprogram_Type
+ and then Is_Access_Type (T1)
+ then
+ return T1;
+
+ elsif (Ekind (T1) = E_Allocator_Type
+ or else Ekind (T1) = E_Access_Attribute_Type
+ or else Ekind (T1) = E_Anonymous_Access_Type)
+ and then Is_Access_Type (T2)
+ then
+ return T2;
+
+ elsif (Ekind (T2) = E_Allocator_Type
+ or else Ekind (T2) = E_Access_Attribute_Type
+ or else Ekind (T2) = E_Anonymous_Access_Type)
+ and then Is_Access_Type (T1)
+ then
+ return T1;
+
+ -- If none of the above cases applies, types are not compatible.
+
+ else
+ return Any_Type;
+ end if;
+ end Specific_Type;
+
+ ------------------------------
+ -- Universal_Interpretation --
+ ------------------------------
+
+ function Universal_Interpretation (Opnd : Node_Id) return Entity_Id is
+ Index : Interp_Index;
+ It : Interp;
+
+ begin
+ -- The argument may be a formal parameter of an operator or subprogram
+ -- with multiple interpretations, or else an expression for an actual.
+
+ if Nkind (Opnd) = N_Defining_Identifier
+ or else not Is_Overloaded (Opnd)
+ then
+ if Etype (Opnd) = Universal_Integer
+ or else Etype (Opnd) = Universal_Real
+ then
+ return Etype (Opnd);
+ else
+ return Empty;
+ end if;
+
+ else
+ Get_First_Interp (Opnd, Index, It);
+
+ while Present (It.Typ) loop
+
+ if It.Typ = Universal_Integer
+ or else It.Typ = Universal_Real
+ then
+ return It.Typ;
+ end if;
+
+ Get_Next_Interp (Index, It);
+ end loop;
+
+ return Empty;
+ end if;
+ end Universal_Interpretation;
+
+ -----------------------
+ -- Valid_Boolean_Arg --
+ -----------------------
+
+ -- In addition to booleans and arrays of booleans, we must include
+ -- aggregates as valid boolean arguments, because in the first pass
+ -- of resolution their components are not examined. If it turns out not
+ -- to be an aggregate of booleans, this will be diagnosed in Resolve.
+ -- Any_Composite must be checked for prior to the array type checks
+ -- because Any_Composite does not have any associated indexes.
+
+ function Valid_Boolean_Arg (T : Entity_Id) return Boolean is
+ begin
+ return Is_Boolean_Type (T)
+ or else T = Any_Composite
+ or else (Is_Array_Type (T)
+ and then T /= Any_String
+ and then Number_Dimensions (T) = 1
+ and then Is_Boolean_Type (Component_Type (T))
+ and then (not Is_Private_Composite (T)
+ or else In_Instance)
+ and then (not Is_Limited_Composite (T)
+ or else In_Instance))
+ or else Is_Modular_Integer_Type (T)
+ or else T = Universal_Integer;
+ end Valid_Boolean_Arg;
+
+ --------------------------
+ -- Valid_Comparison_Arg --
+ --------------------------
+
+ function Valid_Comparison_Arg (T : Entity_Id) return Boolean is
+ begin
+ return Is_Discrete_Type (T)
+ or else Is_Real_Type (T)
+ or else (Is_Array_Type (T) and then Number_Dimensions (T) = 1
+ and then Is_Discrete_Type (Component_Type (T))
+ and then (not Is_Private_Composite (T)
+ or else In_Instance)
+ and then (not Is_Limited_Composite (T)
+ or else In_Instance))
+ or else Is_String_Type (T);
+ end Valid_Comparison_Arg;
+
+ ---------------------
+ -- Write_Overloads --
+ ---------------------
+
+ procedure Write_Overloads (N : Node_Id) is
+ I : Interp_Index;
+ It : Interp;
+ Nam : Entity_Id;
+
+ begin
+ if not Is_Overloaded (N) then
+ Write_Str ("Non-overloaded entity ");
+ Write_Eol;
+ Write_Entity_Info (Entity (N), " ");
+
+ else
+ Get_First_Interp (N, I, It);
+ Write_Str ("Overloaded entity ");
+ Write_Eol;
+ Nam := It.Nam;
+
+ while Present (Nam) loop
+ Write_Entity_Info (Nam, " ");
+ Write_Str ("=================");
+ Write_Eol;
+ Get_Next_Interp (I, It);
+ Nam := It.Nam;
+ end loop;
+ end if;
+ end Write_Overloads;
+
+end Sem_Type;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S E M _ T Y P E --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.26 $
+-- --
+-- 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 unit contains the routines used to handle type determination,
+-- including the routine used to support overload resolution.
+
+with Alloc;
+with Table;
+with Types; use Types;
+
+package Sem_Type is
+
+ ---------------------------------------------
+ -- Data Structures for Overload Resolution --
+ ---------------------------------------------
+
+ -- To determine the unique meaning of an identifier, overload resolution
+ -- may have to be performed if the visibility rules alone identify more
+ -- than one possible entity as the denotation of a given identifier. When
+ -- the visibility rules find such a potential ambiguity, the set of
+ -- possible interpretations must be attached to the identifier, and
+ -- overload resolution must be performed over the innermost enclosing
+ -- complete context. At the end of the resolution, either a single
+ -- interpretation is found for all identifiers in the context, or else a
+ -- type error (invalid type or ambiguous reference) must be signalled.
+
+ -- The set of interpretations of a given name is stored in a data structure
+ -- that is separate from the syntax tree, because it corresponds to
+ -- transient information. The interpretations themselves are stored in
+ -- table All_Interp. A mapping from tree nodes to sets of interpretations
+ -- called Interp_Map, is maintained by the overload resolution routines.
+ -- Both these structures are initialized at the beginning of every complete
+ -- context.
+
+ -- Corresponding to the set of interpretation for a given overloadable
+ -- identifier, there is a set of possible types corresponding to the types
+ -- that the overloaded call may return. We keep a 1-to-1 correspondence
+ -- between interpretations and types: for user-defined subprograms the
+ -- type is the declared return type. For operators, the type is determined
+ -- by the type of the arguments. If the arguments themselves are
+ -- overloaded, we enter the operator name in the names table for each
+ -- possible result type. In most cases, arguments are not overloaded and
+ -- only one interpretation is present anyway.
+
+ type Interp is record
+ Nam : Entity_Id;
+ Typ : Entity_Id;
+ end record;
+
+ No_Interp : constant Interp := (Empty, Empty);
+
+ package All_Interp is new Table.Table (
+ Table_Component_Type => Interp,
+ Table_Index_Type => Int,
+ Table_Low_Bound => 0,
+ Table_Initial => Alloc.All_Interp_Initial,
+ Table_Increment => Alloc.All_Interp_Increment,
+ Table_Name => "All_Interp");
+
+ -- The following data structures establish a mapping between nodes and
+ -- their interpretations. Eventually the Interp_Index corresponding to
+ -- the first interpretation of a node may be stored directly in the
+ -- corresponding node.
+
+ subtype Interp_Index is Int;
+
+ type Interp_Ref is record
+ Node : Node_Id;
+ Index : Interp_Index;
+ end record;
+
+ package Interp_Map is new Table.Table (
+ Table_Component_Type => Interp_Ref,
+ Table_Index_Type => Int,
+ Table_Low_Bound => 0,
+ Table_Initial => Alloc.Interp_Map_Initial,
+ Table_Increment => Alloc.Interp_Map_Increment,
+ Table_Name => "Interp_Map");
+
+ -- For now Interp_Map is searched sequentially
+
+ ----------------------
+ -- Error Reporting --
+ ----------------------
+
+ -- A common error is the use of an operator in infix notation on arguments
+ -- of a type that is not directly visible. Rather than diagnosing a type
+ -- mismatch, it is better to indicate that the type can be made use-visible
+ -- with the appropriate use clause. The global variable Candidate_Type is
+ -- set in Add_One_Interp whenever an interpretation might be legal for an
+ -- operator if the type were directly visible. This variable is used in
+ -- sem_ch4 when no legal interpretation is found.
+
+ Candidate_Type : Entity_Id;
+
+ -----------------
+ -- Subprograms --
+ -----------------
+
+ procedure Init_Interp_Tables;
+ -- Invoked by gnatf when processing multiple files.
+
+ procedure Collect_Interps (N : Node_Id);
+ -- Invoked when the name N has more than one visible interpretation.
+ -- This is the high level routine which accumulates the possible
+ -- interpretations of the node. The first meaning and type of N have
+ -- already been stored in N. If the name is an expanded name, the homonyms
+ -- are only those that belong to the same scope.
+
+ procedure New_Interps (N : Node_Id);
+ -- Initialize collection of interpretations for the given node, which is
+ -- either an overloaded entity, or an operation whose arguments have
+ -- multiple intepretations. Interpretations can be added to only one
+ -- node at a time.
+
+ procedure Add_One_Interp
+ (N : Node_Id;
+ E : Entity_Id;
+ T : Entity_Id;
+ Opnd_Type : Entity_Id := Empty);
+ -- Add (E, T) to the list of interpretations of the node being resolved.
+ -- For calls and operators, i.e. for nodes that have a name field,
+ -- E is an overloadable entity, and T is its type. For constructs such
+ -- as indexed expressions, the caller sets E equal to T, because the
+ -- overloading comes from other fields, and the node itself has no name
+ -- to resolve. Add_One_Interp includes the semantic processing to deal
+ -- with adding entries that hide one another etc.
+
+ -- For operators, the legality of the operation depends on the visibility
+ -- of T and its scope. If the operator is an equality or comparison, T is
+ -- always Boolean, and we use Opnd_Type, which is a candidate type for one
+ -- of the operands of N, to check visibility.
+
+ procedure End_Interp_List;
+ -- End the list of interpretations of current node.
+
+ procedure Get_First_Interp
+ (N : Node_Id;
+ I : out Interp_Index;
+ It : out Interp);
+ -- Initialize iteration over set of interpretations for Node N. The first
+ -- interpretation is placed in It, and I is initialized for subsequent
+ -- calls to Get_Next_Interp.
+
+ procedure Get_Next_Interp (I : in out Interp_Index; It : out Interp);
+ -- Iteration step over set of interpretations. Using the value in I, which
+ -- was set by a previous call to Get_First_Interp or Get_Next_Interp, the
+ -- next interpretation is placed in It, and I is updated for the next call.
+ -- The end of the list of interpretations is signalled by It.Nam = Empty.
+
+ procedure Remove_Interp (I : in out Interp_Index);
+ -- Remove an interpretation that his hidden by another, or that does not
+ -- match the context. The value of I on input was set by a call to either
+ -- Get_First_Interp or Get_Next_Interp and references the interpretation
+ -- to be removed. The only allowed use of the exit value of I is as input
+ -- to a subsequent call to Get_Next_Interp, which yields the interpretation
+ -- following the removed one.
+
+ procedure Save_Interps (Old_N : Node_Id; New_N : Node_Id);
+ -- If an overloaded node is rewritten during semantic analysis, its
+ -- possible interpretations must be linked to the copy. This procedure
+ -- transfers the overload information from Old_N, the old node, to
+ -- New_N, its new copy. It has no effect in the non-overloaded case.
+
+ function Covers (T1, T2 : Entity_Id) return Boolean;
+ -- This is the basic type compatibility routine. T1 is the expexted
+ -- type, imposed by context, and T2 is the actual type. The processing
+ -- reflects both the definition of type coverage and the rules
+ -- for operand matching.
+
+ function Disambiguate
+ (N : Node_Id;
+ I1, I2 : Interp_Index;
+ Typ : Entity_Id)
+ return Interp;
+ -- If more than one interpretation of a name in a call is legal, apply
+ -- preference rules (universal types first) and operator visibility in
+ -- order to remove ambiguity. I1 and I2 are the first two interpretations
+ -- that are compatible with the context, but there may be others.
+
+ function Entity_Matches_Spec (Old_S, New_S : Entity_Id) return Boolean;
+ -- To resolve subprogram renaming and default formal subprograms in generic
+ -- definitions. Old_S is a possible interpretation of the entity being
+ -- renamed, New_S has an explicit signature. If Old_S is a subprogram, as
+ -- opposed to an operator, type and mode conformance are required.
+
+ function Find_Unique_Type (L : Node_Id; R : Node_Id) return Entity_Id;
+ -- Used in second pass of resolution, for equality and comparison nodes.
+ -- L is the left operand, whose type is known to be correct, and R is
+ -- the right operand, which has one interpretation compatible with that
+ -- of L. Return the type intersection of the two.
+
+ function Has_Compatible_Type
+ (N : Node_Id;
+ Typ : Entity_Id)
+ return Boolean;
+ -- Verify that some interpretation of the node N has a type compatible
+ -- with Typ. If N is not overloaded, then its unique type must be
+ -- compatible with Typ. Otherwise iterate through the interpretations
+ -- of N looking for a compatible one.
+
+ function Hides_Op (F : Entity_Id; Op : Entity_Id) return Boolean;
+ -- A user-defined function hides a predefined operator if it is
+ -- matches the signature of the operator, and is declared in an
+ -- open scope, or in the scope of the result type.
+
+ function Intersect_Types (L, R : Node_Id) return Entity_Id;
+ -- Find the common interpretation to two analyzed nodes. If one of the
+ -- interpretations is universal, choose the non-universal one. If either
+ -- node is overloaded, find single common interpretation.
+
+ function Is_Subtype_Of (T1 : Entity_Id; T2 : Entity_Id) return Boolean;
+ -- Checks whether T1 is any subtype of T2 directly or indirectly. Applies
+ -- only to scalar subtypes ???
+
+ function Is_Ancestor (T1, T2 : Entity_Id) return Boolean;
+ -- T1 is a tagged type (not class-wide). Verify that it is one of the
+ -- ancestors of type T2 (which may or not be class-wide)
+
+ function Operator_Matches_Spec (Op, New_S : Entity_Id) return Boolean;
+ -- Used to resolve subprograms renaming operators, and calls to user
+ -- defined operators. Determines whether a given operator Op, matches
+ -- a specification, New_S.
+
+ function Valid_Comparison_Arg (T : Entity_Id) return Boolean;
+ -- A valid argument to an ordering operator must be a discrete type, a
+ -- real type, or a one dimensional array with a discrete component type.
+
+ function Valid_Boolean_Arg (T : Entity_Id) return Boolean;
+ -- A valid argument of a boolean operator is either some boolean type,
+ -- or a one-dimensional array of boolean type.
+
+ procedure Write_Overloads (N : Node_Id);
+ -- Debugging procedure to output info on possibly overloaded entities
+ -- for specified node.
+
+end Sem_Type;
--- /dev/null
+-----------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S E M _ U T I L --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.541 $
+-- --
+-- 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). --
+-- --
+------------------------------------------------------------------------------
+
+with Atree; use Atree;
+with Casing; use Casing;
+with Debug; use Debug;
+with Errout; use Errout;
+with Elists; use Elists;
+with Exp_Util; use Exp_Util;
+with Freeze; use Freeze;
+with Lib; use Lib;
+with Lib.Xref; use Lib.Xref;
+with Namet; use Namet;
+with Nlists; use Nlists;
+with Nmake; use Nmake;
+with Output; use Output;
+with Opt; use Opt;
+with Restrict; use Restrict;
+with Scans; use Scans;
+with Scn; use Scn;
+with Sem; use Sem;
+with Sem_Ch8; use Sem_Ch8;
+with Sem_Eval; use Sem_Eval;
+with Sem_Res; use Sem_Res;
+with Sem_Type; use Sem_Type;
+with Sinfo; use Sinfo;
+with Sinput; use Sinput;
+with Snames; use Snames;
+with Stand; use Stand;
+with Style;
+with Stringt; use Stringt;
+with Targparm; use Targparm;
+with Tbuild; use Tbuild;
+with Ttypes; use Ttypes;
+
+package body Sem_Util is
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ function Build_Component_Subtype
+ (C : List_Id;
+ Loc : Source_Ptr;
+ T : Entity_Id)
+ return Node_Id;
+ -- This function builds the subtype for Build_Actual_Subtype_Of_Component
+ -- and Build_Discriminal_Subtype_Of_Component. C is a list of constraints,
+ -- Loc is the source location, T is the original subtype.
+
+ --------------------------------
+ -- Add_Access_Type_To_Process --
+ --------------------------------
+
+ procedure Add_Access_Type_To_Process (E : Entity_Id; A : Entity_Id)
+ is
+ L : Elist_Id;
+ begin
+ Ensure_Freeze_Node (E);
+ L := Access_Types_To_Process (Freeze_Node (E));
+
+ if No (L) then
+ L := New_Elmt_List;
+ Set_Access_Types_To_Process (Freeze_Node (E), L);
+ end if;
+
+ Append_Elmt (A, L);
+ end Add_Access_Type_To_Process;
+
+ -----------------------
+ -- Alignment_In_Bits --
+ -----------------------
+
+ function Alignment_In_Bits (E : Entity_Id) return Uint is
+ begin
+ return Alignment (E) * System_Storage_Unit;
+ end Alignment_In_Bits;
+
+ -----------------------------------------
+ -- Apply_Compile_Time_Constraint_Error --
+ -----------------------------------------
+
+ procedure Apply_Compile_Time_Constraint_Error
+ (N : Node_Id;
+ Msg : String;
+ Ent : Entity_Id := Empty;
+ Typ : Entity_Id := Empty;
+ Loc : Source_Ptr := No_Location;
+ Rep : Boolean := True)
+ is
+ Stat : constant Boolean := Is_Static_Expression (N);
+ Rtyp : Entity_Id;
+
+ begin
+ if No (Typ) then
+ Rtyp := Etype (N);
+ else
+ Rtyp := Typ;
+ end if;
+
+ if No (Compile_Time_Constraint_Error (N, Msg, Ent, Loc))
+ or else not Rep
+ then
+ return;
+ end if;
+
+ -- Now we replace the node by an N_Raise_Constraint_Error node
+ -- This does not need reanalyzing, so set it as analyzed now.
+
+ Rewrite (N, Make_Raise_Constraint_Error (Sloc (N)));
+ Set_Analyzed (N, True);
+ Set_Etype (N, Rtyp);
+ Set_Raises_Constraint_Error (N);
+
+ -- If the original expression was marked as static, the result is
+ -- still marked as static, but the Raises_Constraint_Error flag is
+ -- always set so that further static evaluation is not attempted.
+
+ if Stat then
+ Set_Is_Static_Expression (N);
+ end if;
+ end Apply_Compile_Time_Constraint_Error;
+
+ --------------------------
+ -- Build_Actual_Subtype --
+ --------------------------
+
+ function Build_Actual_Subtype
+ (T : Entity_Id;
+ N : Node_Or_Entity_Id)
+ return Node_Id
+ is
+ Obj : Node_Id;
+
+ Loc : constant Source_Ptr := Sloc (N);
+ Constraints : List_Id;
+ Decl : Node_Id;
+ Discr : Entity_Id;
+ Hi : Node_Id;
+ Lo : Node_Id;
+ Subt : Entity_Id;
+ Disc_Type : Entity_Id;
+
+ begin
+ if Nkind (N) = N_Defining_Identifier then
+ Obj := New_Reference_To (N, Loc);
+ else
+ Obj := N;
+ end if;
+
+ if Is_Array_Type (T) then
+ Constraints := New_List;
+
+ for J in 1 .. Number_Dimensions (T) loop
+
+ -- Build an array subtype declaration with the nominal
+ -- subtype and the bounds of the actual. Add the declaration
+ -- in front of the local declarations for the subprogram,for
+ -- analysis before any reference to the formal in the body.
+
+ Lo :=
+ Make_Attribute_Reference (Loc,
+ Prefix => Duplicate_Subexpr (Obj, Name_Req => True),
+ Attribute_Name => Name_First,
+ Expressions => New_List (
+ Make_Integer_Literal (Loc, J)));
+
+ Hi :=
+ Make_Attribute_Reference (Loc,
+ Prefix => Duplicate_Subexpr (Obj, Name_Req => True),
+ Attribute_Name => Name_Last,
+ Expressions => New_List (
+ Make_Integer_Literal (Loc, J)));
+
+ Append (Make_Range (Loc, Lo, Hi), Constraints);
+ end loop;
+
+ -- If the type has unknown discriminants there is no constrained
+ -- subtype to build.
+
+ elsif Has_Unknown_Discriminants (T) then
+ return T;
+
+ else
+ Constraints := New_List;
+
+ if Is_Private_Type (T) and then No (Full_View (T)) then
+
+ -- Type is a generic derived type. Inherit discriminants from
+ -- Parent type.
+
+ Disc_Type := Etype (Base_Type (T));
+ else
+ Disc_Type := T;
+ end if;
+
+ Discr := First_Discriminant (Disc_Type);
+
+ while Present (Discr) loop
+ Append_To (Constraints,
+ Make_Selected_Component (Loc,
+ Prefix => Duplicate_Subexpr (Obj),
+ Selector_Name => New_Occurrence_Of (Discr, Loc)));
+ Next_Discriminant (Discr);
+ end loop;
+ end if;
+
+ Subt :=
+ Make_Defining_Identifier (Loc,
+ Chars => New_Internal_Name ('S'));
+ Set_Is_Internal (Subt);
+
+ Decl :=
+ Make_Subtype_Declaration (Loc,
+ Defining_Identifier => Subt,
+ Subtype_Indication =>
+ Make_Subtype_Indication (Loc,
+ Subtype_Mark => New_Reference_To (T, Loc),
+ Constraint =>
+ Make_Index_Or_Discriminant_Constraint (Loc,
+ Constraints => Constraints)));
+
+ Mark_Rewrite_Insertion (Decl);
+ return Decl;
+ end Build_Actual_Subtype;
+
+ ---------------------------------------
+ -- Build_Actual_Subtype_Of_Component --
+ ---------------------------------------
+
+ function Build_Actual_Subtype_Of_Component
+ (T : Entity_Id;
+ N : Node_Id)
+ return Node_Id
+ is
+ Loc : constant Source_Ptr := Sloc (N);
+ P : constant Node_Id := Prefix (N);
+ D : Elmt_Id;
+ Id : Node_Id;
+ Indx_Type : Entity_Id;
+
+ Deaccessed_T : Entity_Id;
+ -- This is either a copy of T, or if T is an access type, then it is
+ -- the directly designated type of this access type.
+
+ function Build_Actual_Array_Constraint return List_Id;
+ -- If one or more of the bounds of the component depends on
+ -- discriminants, build actual constraint using the discriminants
+ -- of the prefix.
+
+ function Build_Actual_Record_Constraint return List_Id;
+ -- Similar to previous one, for discriminated components constrained
+ -- by the discriminant of the enclosing object.
+
+ -----------------------------------
+ -- Build_Actual_Array_Constraint --
+ -----------------------------------
+
+ function Build_Actual_Array_Constraint return List_Id is
+ Constraints : List_Id := New_List;
+ Indx : Node_Id;
+ Hi : Node_Id;
+ Lo : Node_Id;
+ Old_Hi : Node_Id;
+ Old_Lo : Node_Id;
+
+ begin
+ Indx := First_Index (Deaccessed_T);
+ while Present (Indx) loop
+ Old_Lo := Type_Low_Bound (Etype (Indx));
+ Old_Hi := Type_High_Bound (Etype (Indx));
+
+ if Denotes_Discriminant (Old_Lo) then
+ Lo :=
+ Make_Selected_Component (Loc,
+ Prefix => New_Copy_Tree (P),
+ Selector_Name => New_Occurrence_Of (Entity (Old_Lo), Loc));
+
+ else
+ Lo := New_Copy_Tree (Old_Lo);
+
+ -- The new bound will be reanalyzed in the enclosing
+ -- declaration. For literal bounds that come from a type
+ -- declaration, the type of the context must be imposed, so
+ -- insure that analysis will take place. For non-universal
+ -- types this is not strictly necessary.
+
+ Set_Analyzed (Lo, False);
+ end if;
+
+ if Denotes_Discriminant (Old_Hi) then
+ Hi :=
+ Make_Selected_Component (Loc,
+ Prefix => New_Copy_Tree (P),
+ Selector_Name => New_Occurrence_Of (Entity (Old_Hi), Loc));
+
+ else
+ Hi := New_Copy_Tree (Old_Hi);
+ Set_Analyzed (Hi, False);
+ end if;
+
+ Append (Make_Range (Loc, Lo, Hi), Constraints);
+ Next_Index (Indx);
+ end loop;
+
+ return Constraints;
+ end Build_Actual_Array_Constraint;
+
+ ------------------------------------
+ -- Build_Actual_Record_Constraint --
+ ------------------------------------
+
+ function Build_Actual_Record_Constraint return List_Id is
+ Constraints : List_Id := New_List;
+ D : Elmt_Id;
+ D_Val : Node_Id;
+
+ begin
+ D := First_Elmt (Discriminant_Constraint (Deaccessed_T));
+ while Present (D) loop
+
+ if Denotes_Discriminant (Node (D)) then
+ D_Val := Make_Selected_Component (Loc,
+ Prefix => New_Copy_Tree (P),
+ Selector_Name => New_Occurrence_Of (Entity (Node (D)), Loc));
+
+ else
+ D_Val := New_Copy_Tree (Node (D));
+ end if;
+
+ Append (D_Val, Constraints);
+ Next_Elmt (D);
+ end loop;
+
+ return Constraints;
+ end Build_Actual_Record_Constraint;
+
+ -- Start of processing for Build_Actual_Subtype_Of_Component
+
+ begin
+ if Nkind (N) = N_Explicit_Dereference then
+ if Is_Composite_Type (T)
+ and then not Is_Constrained (T)
+ and then not (Is_Class_Wide_Type (T)
+ and then Is_Constrained (Root_Type (T)))
+ and then not Has_Unknown_Discriminants (T)
+ then
+ -- If the type of the dereference is already constrained, it
+ -- is an actual subtype.
+
+ if Is_Array_Type (Etype (N))
+ and then Is_Constrained (Etype (N))
+ then
+ return Empty;
+ else
+ Remove_Side_Effects (P);
+ return Build_Actual_Subtype (T, N);
+ end if;
+ else
+ return Empty;
+ end if;
+ end if;
+
+ if Ekind (T) = E_Access_Subtype then
+ Deaccessed_T := Designated_Type (T);
+ else
+ Deaccessed_T := T;
+ end if;
+
+ if Ekind (Deaccessed_T) = E_Array_Subtype then
+
+ Id := First_Index (Deaccessed_T);
+ Indx_Type := Underlying_Type (Etype (Id));
+
+ while Present (Id) loop
+
+ if Denotes_Discriminant (Type_Low_Bound (Indx_Type)) or else
+ Denotes_Discriminant (Type_High_Bound (Indx_Type))
+ then
+ Remove_Side_Effects (P);
+ return
+ Build_Component_Subtype (
+ Build_Actual_Array_Constraint, Loc, Base_Type (T));
+ end if;
+
+ Next_Index (Id);
+ end loop;
+
+ elsif Is_Composite_Type (Deaccessed_T)
+ and then Has_Discriminants (Deaccessed_T)
+ and then not Has_Unknown_Discriminants (Deaccessed_T)
+ then
+ D := First_Elmt (Discriminant_Constraint (Deaccessed_T));
+ while Present (D) loop
+
+ if Denotes_Discriminant (Node (D)) then
+ Remove_Side_Effects (P);
+ return
+ Build_Component_Subtype (
+ Build_Actual_Record_Constraint, Loc, Base_Type (T));
+ end if;
+
+ Next_Elmt (D);
+ end loop;
+ end if;
+
+ -- If none of the above, the actual and nominal subtypes are the same.
+
+ return Empty;
+
+ end Build_Actual_Subtype_Of_Component;
+
+ -----------------------------
+ -- Build_Component_Subtype --
+ -----------------------------
+
+ function Build_Component_Subtype
+ (C : List_Id;
+ Loc : Source_Ptr;
+ T : Entity_Id)
+ return Node_Id
+ is
+ Subt : Entity_Id;
+ Decl : Node_Id;
+
+ begin
+ Subt :=
+ Make_Defining_Identifier (Loc,
+ Chars => New_Internal_Name ('S'));
+ Set_Is_Internal (Subt);
+
+ Decl :=
+ Make_Subtype_Declaration (Loc,
+ Defining_Identifier => Subt,
+ Subtype_Indication =>
+ Make_Subtype_Indication (Loc,
+ Subtype_Mark => New_Reference_To (Base_Type (T), Loc),
+ Constraint =>
+ Make_Index_Or_Discriminant_Constraint (Loc,
+ Constraints => C)));
+
+ Mark_Rewrite_Insertion (Decl);
+ return Decl;
+ end Build_Component_Subtype;
+
+ --------------------------------------------
+ -- Build_Discriminal_Subtype_Of_Component --
+ --------------------------------------------
+
+ function Build_Discriminal_Subtype_Of_Component
+ (T : Entity_Id)
+ return Node_Id
+ is
+ Loc : constant Source_Ptr := Sloc (T);
+ D : Elmt_Id;
+ Id : Node_Id;
+
+ function Build_Discriminal_Array_Constraint return List_Id;
+ -- If one or more of the bounds of the component depends on
+ -- discriminants, build actual constraint using the discriminants
+ -- of the prefix.
+
+ function Build_Discriminal_Record_Constraint return List_Id;
+ -- Similar to previous one, for discriminated components constrained
+ -- by the discriminant of the enclosing object.
+
+ ----------------------------------------
+ -- Build_Discriminal_Array_Constraint --
+ ----------------------------------------
+
+ function Build_Discriminal_Array_Constraint return List_Id is
+ Constraints : List_Id := New_List;
+ Indx : Node_Id;
+ Hi : Node_Id;
+ Lo : Node_Id;
+ Old_Hi : Node_Id;
+ Old_Lo : Node_Id;
+
+ begin
+ Indx := First_Index (T);
+ while Present (Indx) loop
+ Old_Lo := Type_Low_Bound (Etype (Indx));
+ Old_Hi := Type_High_Bound (Etype (Indx));
+
+ if Denotes_Discriminant (Old_Lo) then
+ Lo := New_Occurrence_Of (Discriminal (Entity (Old_Lo)), Loc);
+
+ else
+ Lo := New_Copy_Tree (Old_Lo);
+ end if;
+
+ if Denotes_Discriminant (Old_Hi) then
+ Hi := New_Occurrence_Of (Discriminal (Entity (Old_Hi)), Loc);
+
+ else
+ Hi := New_Copy_Tree (Old_Hi);
+ end if;
+
+ Append (Make_Range (Loc, Lo, Hi), Constraints);
+ Next_Index (Indx);
+ end loop;
+
+ return Constraints;
+ end Build_Discriminal_Array_Constraint;
+
+ -----------------------------------------
+ -- Build_Discriminal_Record_Constraint --
+ -----------------------------------------
+
+ function Build_Discriminal_Record_Constraint return List_Id is
+ Constraints : List_Id := New_List;
+ D : Elmt_Id;
+ D_Val : Node_Id;
+
+ begin
+ D := First_Elmt (Discriminant_Constraint (T));
+ while Present (D) loop
+
+ if Denotes_Discriminant (Node (D)) then
+ D_Val :=
+ New_Occurrence_Of (Discriminal (Entity (Node (D))), Loc);
+
+ else
+ D_Val := New_Copy_Tree (Node (D));
+ end if;
+
+ Append (D_Val, Constraints);
+ Next_Elmt (D);
+ end loop;
+
+ return Constraints;
+ end Build_Discriminal_Record_Constraint;
+
+ -- Start of processing for Build_Discriminal_Subtype_Of_Component
+
+ begin
+ if Ekind (T) = E_Array_Subtype then
+
+ Id := First_Index (T);
+
+ while Present (Id) loop
+
+ if Denotes_Discriminant (Type_Low_Bound (Etype (Id))) or else
+ Denotes_Discriminant (Type_High_Bound (Etype (Id)))
+ then
+ return Build_Component_Subtype
+ (Build_Discriminal_Array_Constraint, Loc, T);
+ end if;
+
+ Next_Index (Id);
+ end loop;
+
+ elsif Ekind (T) = E_Record_Subtype
+ and then Has_Discriminants (T)
+ and then not Has_Unknown_Discriminants (T)
+ then
+ D := First_Elmt (Discriminant_Constraint (T));
+ while Present (D) loop
+
+ if Denotes_Discriminant (Node (D)) then
+ return Build_Component_Subtype
+ (Build_Discriminal_Record_Constraint, Loc, T);
+ end if;
+
+ Next_Elmt (D);
+ end loop;
+ end if;
+
+ -- If none of the above, the actual and nominal subtypes are the same.
+
+ return Empty;
+
+ end Build_Discriminal_Subtype_Of_Component;
+
+ ------------------------------
+ -- Build_Elaboration_Entity --
+ ------------------------------
+
+ procedure Build_Elaboration_Entity (N : Node_Id; Spec_Id : Entity_Id) is
+ Loc : constant Source_Ptr := Sloc (N);
+ Unum : constant Unit_Number_Type := Get_Source_Unit (Loc);
+ Decl : Node_Id;
+ P : Natural;
+ Elab_Ent : Entity_Id;
+
+ begin
+ -- Ignore if already constructed
+
+ if Present (Elaboration_Entity (Spec_Id)) then
+ return;
+ end if;
+
+ -- Construct name of elaboration entity as xxx_E, where xxx
+ -- is the unit name with dots replaced by double underscore.
+ -- We have to manually construct this name, since it will
+ -- be elaborated in the outer scope, and thus will not have
+ -- the unit name automatically prepended.
+
+ Get_Name_String (Unit_Name (Unum));
+
+ -- Replace the %s by _E
+
+ Name_Buffer (Name_Len - 1 .. Name_Len) := "_E";
+
+ -- Replace dots by double underscore
+
+ P := 2;
+ while P < Name_Len - 2 loop
+ if Name_Buffer (P) = '.' then
+ Name_Buffer (P + 2 .. Name_Len + 1) :=
+ Name_Buffer (P + 1 .. Name_Len);
+ Name_Len := Name_Len + 1;
+ Name_Buffer (P) := '_';
+ Name_Buffer (P + 1) := '_';
+ P := P + 3;
+ else
+ P := P + 1;
+ end if;
+ end loop;
+
+ -- Create elaboration flag
+
+ Elab_Ent :=
+ Make_Defining_Identifier (Loc, Chars => Name_Find);
+ Set_Elaboration_Entity (Spec_Id, Elab_Ent);
+
+ if No (Declarations (Aux_Decls_Node (N))) then
+ Set_Declarations (Aux_Decls_Node (N), New_List);
+ end if;
+
+ Decl :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Elab_Ent,
+ Object_Definition =>
+ New_Occurrence_Of (Standard_Boolean, Loc),
+ Expression =>
+ New_Occurrence_Of (Standard_False, Loc));
+
+ Append_To (Declarations (Aux_Decls_Node (N)), Decl);
+ Analyze (Decl);
+
+ -- Reset True_Constant indication, since we will indeed
+ -- assign a value to the variable in the binder main.
+
+ Set_Is_True_Constant (Elab_Ent, False);
+
+ -- We do not want any further qualification of the name (if we did
+ -- not do this, we would pick up the name of the generic package
+ -- in the case of a library level generic instantiation).
+
+ Set_Has_Qualified_Name (Elab_Ent);
+ Set_Has_Fully_Qualified_Name (Elab_Ent);
+ end Build_Elaboration_Entity;
+
+ --------------------------
+ -- Check_Fully_Declared --
+ --------------------------
+
+ procedure Check_Fully_Declared (T : Entity_Id; N : Node_Id) is
+ begin
+ if Ekind (T) = E_Incomplete_Type then
+ Error_Msg_NE
+ ("premature usage of incomplete}", N, First_Subtype (T));
+
+ elsif Has_Private_Component (T)
+ and then not Is_Generic_Type (Root_Type (T))
+ and then not In_Default_Expression
+ then
+ Error_Msg_NE
+ ("premature usage of incomplete}", N, First_Subtype (T));
+ end if;
+ end Check_Fully_Declared;
+
+ ------------------------------------------
+ -- Check_Potentially_Blocking_Operation --
+ ------------------------------------------
+
+ procedure Check_Potentially_Blocking_Operation (N : Node_Id) is
+ S : Entity_Id;
+ Loc : constant Source_Ptr := Sloc (N);
+
+ begin
+ -- N is one of the potentially blocking operations listed in
+ -- 9.5.1 (8). When using the Ravenscar profile, raise Program_Error
+ -- before N if the context is a protected action. Otherwise, only issue
+ -- a warning, since some users are relying on blocking operations
+ -- inside protected objects.
+ -- Indirect blocking through a subprogram call
+ -- cannot be diagnosed statically without interprocedural analysis,
+ -- so we do not attempt to do it here.
+
+ S := Scope (Current_Scope);
+
+ while Present (S) and then S /= Standard_Standard loop
+ if Is_Protected_Type (S) then
+ if Restricted_Profile then
+ Insert_Before (N,
+ Make_Raise_Statement (Loc,
+ Name => New_Occurrence_Of (Standard_Program_Error, Loc)));
+ Error_Msg_N ("potentially blocking operation, " &
+ " Program Error will be raised at run time?", N);
+
+ else
+ Error_Msg_N
+ ("potentially blocking operation in protected operation?", N);
+ end if;
+
+ return;
+ end if;
+
+ S := Scope (S);
+ end loop;
+ end Check_Potentially_Blocking_Operation;
+
+ ---------------
+ -- Check_VMS --
+ ---------------
+
+ procedure Check_VMS (Construct : Node_Id) is
+ begin
+ if not OpenVMS_On_Target then
+ Error_Msg_N
+ ("this construct is allowed only in Open'V'M'S", Construct);
+ end if;
+ end Check_VMS;
+
+ ----------------------------------
+ -- Collect_Primitive_Operations --
+ ----------------------------------
+
+ function Collect_Primitive_Operations (T : Entity_Id) return Elist_Id is
+ B_Type : constant Entity_Id := Base_Type (T);
+ B_Decl : constant Node_Id := Original_Node (Parent (B_Type));
+ B_Scope : Entity_Id := Scope (B_Type);
+ Op_List : Elist_Id;
+ Formal : Entity_Id;
+ Is_Prim : Boolean;
+ Formal_Derived : Boolean := False;
+ Id : Entity_Id;
+
+ begin
+ -- For tagged types, the primitive operations are collected as they
+ -- are declared, and held in an explicit list which is simply returned.
+
+ if Is_Tagged_Type (B_Type) then
+ return Primitive_Operations (B_Type);
+
+ -- An untagged generic type that is a derived type inherits the
+ -- primitive operations of its parent type. Other formal types only
+ -- have predefined operators, which are not explicitly represented.
+
+ elsif Is_Generic_Type (B_Type) then
+ if Nkind (B_Decl) = N_Formal_Type_Declaration
+ and then Nkind (Formal_Type_Definition (B_Decl))
+ = N_Formal_Derived_Type_Definition
+ then
+ Formal_Derived := True;
+ else
+ return New_Elmt_List;
+ end if;
+ end if;
+
+ Op_List := New_Elmt_List;
+
+ if B_Scope = Standard_Standard then
+ if B_Type = Standard_String then
+ Append_Elmt (Standard_Op_Concat, Op_List);
+
+ elsif B_Type = Standard_Wide_String then
+ Append_Elmt (Standard_Op_Concatw, Op_List);
+
+ else
+ null;
+ end if;
+
+ elsif (Is_Package (B_Scope)
+ and then Nkind (
+ Parent (Declaration_Node (First_Subtype (T))))
+ /= N_Package_Body)
+
+ or else Is_Derived_Type (B_Type)
+ then
+ -- The primitive operations appear after the base type, except
+ -- if the derivation happens within the private part of B_Scope
+ -- and the type is a private type, in which case both the type
+ -- and some primitive operations may appear before the base
+ -- type, and the list of candidates starts after the type.
+
+ if In_Open_Scopes (B_Scope)
+ and then Scope (T) = B_Scope
+ and then In_Private_Part (B_Scope)
+ then
+ Id := Next_Entity (T);
+ else
+ Id := Next_Entity (B_Type);
+ end if;
+
+ while Present (Id) loop
+
+ -- Note that generic formal subprograms are not
+ -- considered to be primitive operations and thus
+ -- are never inherited.
+
+ if Is_Overloadable (Id)
+ and then Nkind (Parent (Parent (Id)))
+ /= N_Formal_Subprogram_Declaration
+ then
+ Is_Prim := False;
+
+ if Base_Type (Etype (Id)) = B_Type then
+ Is_Prim := True;
+ else
+ Formal := First_Formal (Id);
+ while Present (Formal) loop
+ if Base_Type (Etype (Formal)) = B_Type then
+ Is_Prim := True;
+ exit;
+
+ elsif Ekind (Etype (Formal)) = E_Anonymous_Access_Type
+ and then Base_Type
+ (Designated_Type (Etype (Formal))) = B_Type
+ then
+ Is_Prim := True;
+ exit;
+ end if;
+
+ Next_Formal (Formal);
+ end loop;
+ end if;
+
+ -- For a formal derived type, the only primitives are the
+ -- ones inherited from the parent type. Operations appearing
+ -- in the package declaration are not primitive for it.
+
+ if Is_Prim
+ and then (not Formal_Derived
+ or else Present (Alias (Id)))
+ then
+ Append_Elmt (Id, Op_List);
+ end if;
+ end if;
+
+ Next_Entity (Id);
+
+ -- For a type declared in System, some of its operations
+ -- may appear in the target-specific extension to System.
+
+ if No (Id)
+ and then Chars (B_Scope) = Name_System
+ and then Scope (B_Scope) = Standard_Standard
+ and then Present_System_Aux
+ then
+ B_Scope := System_Aux_Id;
+ Id := First_Entity (System_Aux_Id);
+ end if;
+
+ end loop;
+
+ end if;
+
+ return Op_List;
+ end Collect_Primitive_Operations;
+
+ -----------------------------------
+ -- Compile_Time_Constraint_Error --
+ -----------------------------------
+
+ function Compile_Time_Constraint_Error
+ (N : Node_Id;
+ Msg : String;
+ Ent : Entity_Id := Empty;
+ Loc : Source_Ptr := No_Location)
+ return Node_Id
+ is
+ Msgc : String (1 .. Msg'Length + 2);
+ Msgl : Natural;
+ Warn : Boolean;
+ P : Node_Id;
+ Msgs : Boolean;
+
+ begin
+ -- A static constraint error in an instance body is not a fatal error.
+ -- we choose to inhibit the message altogether, because there is no
+ -- obvious node (for now) on which to post it. On the other hand the
+ -- offending node must be replaced with a constraint_error in any case.
+
+ -- No messages are generated if we already posted an error on this node
+
+ if not Error_Posted (N) then
+
+ -- Make all such messages unconditional
+
+ Msgc (1 .. Msg'Length) := Msg;
+ Msgc (Msg'Length + 1) := '!';
+ Msgl := Msg'Length + 1;
+
+ -- Message is a warning, even in Ada 95 case
+
+ if Msg (Msg'Length) = '?' then
+ Warn := True;
+
+ -- In Ada 83, all messages are warnings. In the private part and
+ -- the body of an instance, constraint_checks are only warnings.
+
+ elsif Ada_83 and then Comes_From_Source (N) then
+
+ Msgl := Msgl + 1;
+ Msgc (Msgl) := '?';
+ Warn := True;
+
+ elsif In_Instance_Not_Visible then
+
+ Msgl := Msgl + 1;
+ Msgc (Msgl) := '?';
+ Warn := True;
+ Warn_On_Instance := True;
+
+ -- Otherwise we have a real error message (Ada 95 static case)
+
+ else
+ Warn := False;
+ end if;
+
+ -- Should we generate a warning? The answer is not quite yes. The
+ -- very annoying exception occurs in the case of a short circuit
+ -- operator where the left operand is static and decisive. Climb
+ -- parents to see if that is the case we have here.
+
+ Msgs := True;
+ P := N;
+
+ loop
+ P := Parent (P);
+
+ if (Nkind (P) = N_And_Then
+ and then Compile_Time_Known_Value (Left_Opnd (P))
+ and then Is_False (Expr_Value (Left_Opnd (P))))
+ or else (Nkind (P) = N_Or_Else
+ and then Compile_Time_Known_Value (Left_Opnd (P))
+ and then Is_True (Expr_Value (Left_Opnd (P))))
+ then
+ Msgs := False;
+ exit;
+
+ elsif Nkind (P) = N_Component_Association
+ and then Nkind (Parent (P)) = N_Aggregate
+ then
+ null; -- Keep going.
+
+ else
+ exit when Nkind (P) not in N_Subexpr;
+ end if;
+ end loop;
+
+ if Msgs then
+ if Present (Ent) then
+ Error_Msg_NE (Msgc (1 .. Msgl), N, Ent);
+ else
+ Error_Msg_NE (Msgc (1 .. Msgl), N, Etype (N));
+ end if;
+
+ if Warn then
+ if Inside_Init_Proc then
+ Error_Msg_NE
+ ("\& will be raised for objects of this type!?",
+ N, Standard_Constraint_Error);
+ else
+ Error_Msg_NE
+ ("\& will be raised at run time!?",
+ N, Standard_Constraint_Error);
+ end if;
+ else
+ Error_Msg_NE
+ ("\static expression raises&!",
+ N, Standard_Constraint_Error);
+ end if;
+ end if;
+ end if;
+
+ return N;
+ end Compile_Time_Constraint_Error;
+
+ -----------------------
+ -- Conditional_Delay --
+ -----------------------
+
+ procedure Conditional_Delay (New_Ent, Old_Ent : Entity_Id) is
+ begin
+ if Has_Delayed_Freeze (Old_Ent) and then not Is_Frozen (Old_Ent) then
+ Set_Has_Delayed_Freeze (New_Ent);
+ end if;
+ end Conditional_Delay;
+
+ --------------------
+ -- Current_Entity --
+ --------------------
+
+ -- The currently visible definition for a given identifier is the
+ -- one most chained at the start of the visibility chain, i.e. the
+ -- one that is referenced by the Node_Id value of the name of the
+ -- given identifier.
+
+ function Current_Entity (N : Node_Id) return Entity_Id is
+ begin
+ return Get_Name_Entity_Id (Chars (N));
+ end Current_Entity;
+
+ -----------------------------
+ -- Current_Entity_In_Scope --
+ -----------------------------
+
+ function Current_Entity_In_Scope (N : Node_Id) return Entity_Id is
+ E : Entity_Id;
+ CS : constant Entity_Id := Current_Scope;
+
+ Transient_Case : constant Boolean := Scope_Is_Transient;
+
+ begin
+ E := Get_Name_Entity_Id (Chars (N));
+
+ while Present (E)
+ and then Scope (E) /= CS
+ and then (not Transient_Case or else Scope (E) /= Scope (CS))
+ loop
+ E := Homonym (E);
+ end loop;
+
+ return E;
+ end Current_Entity_In_Scope;
+
+ -------------------
+ -- Current_Scope --
+ -------------------
+
+ function Current_Scope return Entity_Id is
+ begin
+ if Scope_Stack.Last = -1 then
+ return Standard_Standard;
+ else
+ declare
+ C : constant Entity_Id :=
+ Scope_Stack.Table (Scope_Stack.Last).Entity;
+ begin
+ if Present (C) then
+ return C;
+ else
+ return Standard_Standard;
+ end if;
+ end;
+ end if;
+ end Current_Scope;
+
+ ------------------------
+ -- Current_Subprogram --
+ ------------------------
+
+ function Current_Subprogram return Entity_Id is
+ Scop : constant Entity_Id := Current_Scope;
+
+ begin
+ if Ekind (Scop) = E_Function
+ or else
+ Ekind (Scop) = E_Procedure
+ or else
+ Ekind (Scop) = E_Generic_Function
+ or else
+ Ekind (Scop) = E_Generic_Procedure
+ then
+ return Scop;
+
+ else
+ return Enclosing_Subprogram (Scop);
+ end if;
+ end Current_Subprogram;
+
+ ---------------------
+ -- Defining_Entity --
+ ---------------------
+
+ function Defining_Entity (N : Node_Id) return Entity_Id is
+ K : constant Node_Kind := Nkind (N);
+
+ begin
+ case K is
+ when
+ N_Subprogram_Declaration |
+ N_Abstract_Subprogram_Declaration |
+ N_Subprogram_Body |
+ N_Package_Declaration |
+ N_Subprogram_Renaming_Declaration |
+ N_Subprogram_Body_Stub |
+ N_Generic_Subprogram_Declaration |
+ N_Generic_Package_Declaration |
+ N_Formal_Subprogram_Declaration
+ =>
+ return Defining_Entity (Specification (N));
+
+ when
+ N_Component_Declaration |
+ N_Defining_Program_Unit_Name |
+ N_Discriminant_Specification |
+ N_Entry_Body |
+ N_Entry_Declaration |
+ N_Entry_Index_Specification |
+ N_Exception_Declaration |
+ N_Exception_Renaming_Declaration |
+ N_Formal_Object_Declaration |
+ N_Formal_Package_Declaration |
+ N_Formal_Type_Declaration |
+ N_Full_Type_Declaration |
+ N_Implicit_Label_Declaration |
+ N_Incomplete_Type_Declaration |
+ N_Loop_Parameter_Specification |
+ N_Number_Declaration |
+ N_Object_Declaration |
+ N_Object_Renaming_Declaration |
+ N_Package_Body_Stub |
+ N_Parameter_Specification |
+ N_Private_Extension_Declaration |
+ N_Private_Type_Declaration |
+ N_Protected_Body |
+ N_Protected_Body_Stub |
+ N_Protected_Type_Declaration |
+ N_Single_Protected_Declaration |
+ N_Single_Task_Declaration |
+ N_Subtype_Declaration |
+ N_Task_Body |
+ N_Task_Body_Stub |
+ N_Task_Type_Declaration
+ =>
+ return Defining_Identifier (N);
+
+ when N_Subunit =>
+ return Defining_Entity (Proper_Body (N));
+
+ when
+ N_Function_Instantiation |
+ N_Function_Specification |
+ N_Generic_Function_Renaming_Declaration |
+ N_Generic_Package_Renaming_Declaration |
+ N_Generic_Procedure_Renaming_Declaration |
+ N_Package_Body |
+ N_Package_Instantiation |
+ N_Package_Renaming_Declaration |
+ N_Package_Specification |
+ N_Procedure_Instantiation |
+ N_Procedure_Specification
+ =>
+ declare
+ Nam : constant Node_Id := Defining_Unit_Name (N);
+
+ begin
+ if Nkind (Nam) in N_Entity then
+ return Nam;
+ else
+ return Defining_Identifier (Nam);
+ end if;
+ end;
+
+ when N_Block_Statement =>
+ return Entity (Identifier (N));
+
+ when others =>
+ raise Program_Error;
+
+ end case;
+ end Defining_Entity;
+
+ --------------------------
+ -- Denotes_Discriminant --
+ --------------------------
+
+ function Denotes_Discriminant (N : Node_Id) return Boolean is
+ begin
+ return Is_Entity_Name (N)
+ and then Present (Entity (N))
+ and then Ekind (Entity (N)) = E_Discriminant;
+ end Denotes_Discriminant;
+
+ -----------------------------
+ -- Depends_On_Discriminant --
+ -----------------------------
+
+ function Depends_On_Discriminant (N : Node_Id) return Boolean is
+ L : Node_Id;
+ H : Node_Id;
+
+ begin
+ Get_Index_Bounds (N, L, H);
+ return Denotes_Discriminant (L) or else Denotes_Discriminant (H);
+ end Depends_On_Discriminant;
+
+ -------------------------
+ -- Designate_Same_Unit --
+ -------------------------
+
+ function Designate_Same_Unit
+ (Name1 : Node_Id;
+ Name2 : Node_Id)
+ return Boolean
+ is
+ K1 : Node_Kind := Nkind (Name1);
+ K2 : Node_Kind := Nkind (Name2);
+
+ function Prefix_Node (N : Node_Id) return Node_Id;
+ -- Returns the parent unit name node of a defining program unit name
+ -- or the prefix if N is a selected component or an expanded name.
+
+ function Select_Node (N : Node_Id) return Node_Id;
+ -- Returns the defining identifier node of a defining program unit
+ -- name or the selector node if N is a selected component or an
+ -- expanded name.
+
+ function Prefix_Node (N : Node_Id) return Node_Id is
+ begin
+ if Nkind (N) = N_Defining_Program_Unit_Name then
+ return Name (N);
+
+ else
+ return Prefix (N);
+ end if;
+ end Prefix_Node;
+
+ function Select_Node (N : Node_Id) return Node_Id is
+ begin
+ if Nkind (N) = N_Defining_Program_Unit_Name then
+ return Defining_Identifier (N);
+
+ else
+ return Selector_Name (N);
+ end if;
+ end Select_Node;
+
+ -- Start of processing for Designate_Next_Unit
+
+ begin
+ if (K1 = N_Identifier or else
+ K1 = N_Defining_Identifier)
+ and then
+ (K2 = N_Identifier or else
+ K2 = N_Defining_Identifier)
+ then
+ return Chars (Name1) = Chars (Name2);
+
+ elsif
+ (K1 = N_Expanded_Name or else
+ K1 = N_Selected_Component or else
+ K1 = N_Defining_Program_Unit_Name)
+ and then
+ (K2 = N_Expanded_Name or else
+ K2 = N_Selected_Component or else
+ K2 = N_Defining_Program_Unit_Name)
+ then
+ return
+ (Chars (Select_Node (Name1)) = Chars (Select_Node (Name2)))
+ and then
+ Designate_Same_Unit (Prefix_Node (Name1), Prefix_Node (Name2));
+
+ else
+ return False;
+ end if;
+ end Designate_Same_Unit;
+
+ ----------------------------
+ -- Enclosing_Generic_Body --
+ ----------------------------
+
+ function Enclosing_Generic_Body
+ (E : Entity_Id)
+ return Node_Id
+ is
+ P : Node_Id;
+ Decl : Node_Id;
+ Spec : Node_Id;
+
+ begin
+ P := Parent (E);
+
+ while Present (P) loop
+ if Nkind (P) = N_Package_Body
+ or else Nkind (P) = N_Subprogram_Body
+ then
+ Spec := Corresponding_Spec (P);
+
+ if Present (Spec) then
+ Decl := Unit_Declaration_Node (Spec);
+
+ if Nkind (Decl) = N_Generic_Package_Declaration
+ or else Nkind (Decl) = N_Generic_Subprogram_Declaration
+ then
+ return P;
+ end if;
+ end if;
+ end if;
+
+ P := Parent (P);
+ end loop;
+
+ return Empty;
+ end Enclosing_Generic_Body;
+
+ -------------------------------
+ -- Enclosing_Lib_Unit_Entity --
+ -------------------------------
+
+ function Enclosing_Lib_Unit_Entity return Entity_Id is
+ Unit_Entity : Entity_Id := Current_Scope;
+
+ begin
+ -- Look for enclosing library unit entity by following scope links.
+ -- Equivalent to, but faster than indexing through the scope stack.
+
+ while (Present (Scope (Unit_Entity))
+ and then Scope (Unit_Entity) /= Standard_Standard)
+ and not Is_Child_Unit (Unit_Entity)
+ loop
+ Unit_Entity := Scope (Unit_Entity);
+ end loop;
+
+ return Unit_Entity;
+ end Enclosing_Lib_Unit_Entity;
+
+ -----------------------------
+ -- Enclosing_Lib_Unit_Node --
+ -----------------------------
+
+ function Enclosing_Lib_Unit_Node (N : Node_Id) return Node_Id is
+ Current_Node : Node_Id := N;
+
+ begin
+ while Present (Current_Node)
+ and then Nkind (Current_Node) /= N_Compilation_Unit
+ loop
+ Current_Node := Parent (Current_Node);
+ end loop;
+
+ if Nkind (Current_Node) /= N_Compilation_Unit then
+ return Empty;
+ end if;
+
+ return Current_Node;
+ end Enclosing_Lib_Unit_Node;
+
+ --------------------------
+ -- Enclosing_Subprogram --
+ --------------------------
+
+ function Enclosing_Subprogram (E : Entity_Id) return Entity_Id is
+ Dynamic_Scope : constant Entity_Id := Enclosing_Dynamic_Scope (E);
+
+ begin
+ if Dynamic_Scope = Standard_Standard then
+ return Empty;
+
+ elsif Ekind (Dynamic_Scope) = E_Subprogram_Body then
+ return Corresponding_Spec (Parent (Parent (Dynamic_Scope)));
+
+ elsif Ekind (Dynamic_Scope) = E_Block then
+ return Enclosing_Subprogram (Dynamic_Scope);
+
+ elsif Ekind (Dynamic_Scope) = E_Task_Type then
+ return Get_Task_Body_Procedure (Dynamic_Scope);
+
+ elsif Convention (Dynamic_Scope) = Convention_Protected then
+ return Protected_Body_Subprogram (Dynamic_Scope);
+
+ else
+ return Dynamic_Scope;
+ end if;
+ end Enclosing_Subprogram;
+
+ ------------------------
+ -- Ensure_Freeze_Node --
+ ------------------------
+
+ procedure Ensure_Freeze_Node (E : Entity_Id) is
+ FN : Node_Id;
+
+ begin
+ if No (Freeze_Node (E)) then
+ FN := Make_Freeze_Entity (Sloc (E));
+ Set_Has_Delayed_Freeze (E);
+ Set_Freeze_Node (E, FN);
+ Set_Access_Types_To_Process (FN, No_Elist);
+ Set_TSS_Elist (FN, No_Elist);
+ Set_Entity (FN, E);
+ end if;
+ end Ensure_Freeze_Node;
+
+ ----------------
+ -- Enter_Name --
+ ----------------
+
+ procedure Enter_Name (Def_Id : Node_Id) is
+ C : constant Entity_Id := Current_Entity (Def_Id);
+ E : constant Entity_Id := Current_Entity_In_Scope (Def_Id);
+ S : constant Entity_Id := Current_Scope;
+
+ begin
+ Generate_Definition (Def_Id);
+
+ -- Add new name to current scope declarations. Check for duplicate
+ -- declaration, which may or may not be a genuine error.
+
+ if Present (E) then
+
+ -- Case of previous entity entered because of a missing declaration
+ -- or else a bad subtype indication. Best is to use the new entity,
+ -- and make the previous one invisible.
+
+ if Etype (E) = Any_Type then
+ Set_Is_Immediately_Visible (E, False);
+
+ -- Case of renaming declaration constructed for package instances.
+ -- if there is an explicit declaration with the same identifier,
+ -- the renaming is not immediately visible any longer, but remains
+ -- visible through selected component notation.
+
+ elsif Nkind (Parent (E)) = N_Package_Renaming_Declaration
+ and then not Comes_From_Source (E)
+ then
+ Set_Is_Immediately_Visible (E, False);
+
+ -- The new entity may be the package renaming, which has the same
+ -- same name as a generic formal which has been seen already.
+
+ elsif Nkind (Parent (Def_Id)) = N_Package_Renaming_Declaration
+ and then not Comes_From_Source (Def_Id)
+ then
+ Set_Is_Immediately_Visible (E, False);
+
+ -- For a fat pointer corresponding to a remote access to subprogram,
+ -- we use the same identifier as the RAS type, so that the proper
+ -- name appears in the stub. This type is only retrieved through
+ -- the RAS type and never by visibility, and is not added to the
+ -- visibility list (see below).
+
+ elsif Nkind (Parent (Def_Id)) = N_Full_Type_Declaration
+ and then Present (Corresponding_Remote_Type (Def_Id))
+ then
+ null;
+
+ -- A controller component for a type extension overrides the
+ -- inherited component.
+
+ elsif Chars (E) = Name_uController then
+ null;
+
+ -- Case of an implicit operation or derived literal. The new entity
+ -- hides the implicit one, which is removed from all visibility,
+ -- i.e. the entity list of its scope, and homonym chain of its name.
+
+ elsif (Is_Overloadable (E) and then Present (Alias (E)))
+ or else Is_Internal (E)
+ or else (Ekind (E) = E_Enumeration_Literal
+ and then Is_Derived_Type (Etype (E)))
+ then
+ declare
+ Prev : Entity_Id;
+ Prev_Vis : Entity_Id;
+
+ begin
+ -- If E is an implicit declaration, it cannot be the first
+ -- entity in the scope.
+
+ Prev := First_Entity (Current_Scope);
+
+ while Next_Entity (Prev) /= E loop
+ Next_Entity (Prev);
+ end loop;
+
+ Set_Next_Entity (Prev, Next_Entity (E));
+
+ if No (Next_Entity (Prev)) then
+ Set_Last_Entity (Current_Scope, Prev);
+ end if;
+
+ if E = Current_Entity (E) then
+ Prev_Vis := Empty;
+ else
+ Prev_Vis := Current_Entity (E);
+ while Homonym (Prev_Vis) /= E loop
+ Prev_Vis := Homonym (Prev_Vis);
+ end loop;
+ end if;
+
+ if Present (Prev_Vis) then
+
+ -- Skip E in the visibility chain
+
+ Set_Homonym (Prev_Vis, Homonym (E));
+
+ else
+ Set_Name_Entity_Id (Chars (E), Homonym (E));
+ end if;
+ end;
+
+ -- This section of code could use a comment ???
+
+ elsif Present (Etype (E))
+ and then Is_Concurrent_Type (Etype (E))
+ and then E = Def_Id
+ then
+ return;
+
+ -- In the body or private part of an instance, a type extension
+ -- may introduce a component with the same name as that of an
+ -- actual. The legality rule is not enforced, but the semantics
+ -- of the full type with two components of the same name are not
+ -- clear at this point ???
+
+ elsif In_Instance_Not_Visible then
+ null;
+
+ -- When compiling a package body, some child units may have become
+ -- visible. They cannot conflict with local entities that hide them.
+
+ elsif Is_Child_Unit (E)
+ and then In_Open_Scopes (Scope (E))
+ and then not Is_Immediately_Visible (E)
+ then
+ null;
+
+ -- Conversely, with front-end inlining we may compile the parent
+ -- body first, and a child unit subsequently. The context is now
+ -- the parent spec, and body entities are not visible.
+
+ elsif Is_Child_Unit (Def_Id)
+ and then Is_Package_Body_Entity (E)
+ and then not In_Package_Body (Current_Scope)
+ then
+ null;
+
+ -- Case of genuine duplicate declaration
+
+ else
+ Error_Msg_Sloc := Sloc (E);
+
+ -- If the previous declaration is an incomplete type declaration
+ -- this may be an attempt to complete it with a private type.
+ -- The following avoids confusing cascaded errors.
+
+ if Nkind (Parent (E)) = N_Incomplete_Type_Declaration
+ and then Nkind (Parent (Def_Id)) = N_Private_Type_Declaration
+ then
+ Error_Msg_N
+ ("incomplete type cannot be completed" &
+ " with a private declaration",
+ Parent (Def_Id));
+ Set_Is_Immediately_Visible (E, False);
+ Set_Full_View (E, Def_Id);
+
+ elsif Ekind (E) = E_Discriminant
+ and then Present (Scope (Def_Id))
+ and then Scope (Def_Id) /= Current_Scope
+ then
+ -- An inherited component of a record conflicts with
+ -- a new discriminant. The discriminant is inserted first
+ -- in the scope, but the error should be posted on it, not
+ -- on the component.
+
+ Error_Msg_Sloc := Sloc (Def_Id);
+ Error_Msg_N ("& conflicts with declaration#", E);
+ return;
+
+ else
+ Error_Msg_N ("& conflicts with declaration#", Def_Id);
+
+ -- Avoid cascaded messages with duplicate components in
+ -- derived types.
+
+ if Ekind (E) = E_Component
+ or else Ekind (E) = E_Discriminant
+ then
+ return;
+ end if;
+ end if;
+
+ if Nkind (Parent (Parent (Def_Id)))
+ = N_Generic_Subprogram_Declaration
+ and then Def_Id =
+ Defining_Entity (Specification (Parent (Parent (Def_Id))))
+ then
+ Error_Msg_N ("\generic units cannot be overloaded", Def_Id);
+ end if;
+
+ -- If entity is in standard, then we are in trouble, because
+ -- it means that we have a library package with a duplicated
+ -- name. That's hard to recover from, so abort!
+
+ if S = Standard_Standard then
+ raise Unrecoverable_Error;
+
+ -- Otherwise we continue with the declaration. Having two
+ -- identical declarations should not cause us too much trouble!
+
+ else
+ null;
+ end if;
+ end if;
+ end if;
+
+ -- If we fall through, declaration is OK , or OK enough to continue
+
+ -- If Def_Id is a discriminant or a record component we are in the
+ -- midst of inheriting components in a derived record definition.
+ -- Preserve their Ekind and Etype.
+
+ if Ekind (Def_Id) = E_Discriminant
+ or else Ekind (Def_Id) = E_Component
+ then
+ null;
+
+ -- If a type is already set, leave it alone (happens whey a type
+ -- declaration is reanalyzed following a call to the optimizer)
+
+ elsif Present (Etype (Def_Id)) then
+ null;
+
+ -- Otherwise, the kind E_Void insures that premature uses of the entity
+ -- will be detected. Any_Type insures that no cascaded errors will occur
+
+ else
+ Set_Ekind (Def_Id, E_Void);
+ Set_Etype (Def_Id, Any_Type);
+ end if;
+
+ -- Inherited discriminants and components in derived record types are
+ -- immediately visible. Itypes are not.
+
+ if Ekind (Def_Id) = E_Discriminant
+ or else Ekind (Def_Id) = E_Component
+ or else (No (Corresponding_Remote_Type (Def_Id))
+ and then not Is_Itype (Def_Id))
+ then
+ Set_Is_Immediately_Visible (Def_Id);
+ Set_Current_Entity (Def_Id);
+ end if;
+
+ Set_Homonym (Def_Id, C);
+ Append_Entity (Def_Id, S);
+ Set_Public_Status (Def_Id);
+
+ -- Warn if new entity hides an old one
+
+ if Warn_On_Hiding
+ and then Length_Of_Name (Chars (C)) /= 1
+ and then Present (C)
+ and then Comes_From_Source (C)
+ and then Comes_From_Source (Def_Id)
+ and then In_Extended_Main_Source_Unit (Def_Id)
+ then
+ Error_Msg_Sloc := Sloc (C);
+ Error_Msg_N ("declaration hides &#?", Def_Id);
+ end if;
+
+ end Enter_Name;
+
+ -------------------------------------
+ -- Find_Corresponding_Discriminant --
+ -------------------------------------
+
+ function Find_Corresponding_Discriminant
+ (Id : Node_Id;
+ Typ : Entity_Id)
+ return Entity_Id
+ is
+ Par_Disc : Entity_Id;
+ Old_Disc : Entity_Id;
+ New_Disc : Entity_Id;
+
+ begin
+ Par_Disc := Original_Record_Component (Original_Discriminant (Id));
+ Old_Disc := First_Discriminant (Scope (Par_Disc));
+
+ if Is_Class_Wide_Type (Typ) then
+ New_Disc := First_Discriminant (Root_Type (Typ));
+ else
+ New_Disc := First_Discriminant (Typ);
+ end if;
+
+ while Present (Old_Disc) and then Present (New_Disc) loop
+ if Old_Disc = Par_Disc then
+ return New_Disc;
+ else
+ Next_Discriminant (Old_Disc);
+ Next_Discriminant (New_Disc);
+ end if;
+ end loop;
+
+ -- Should always find it
+
+ raise Program_Error;
+ end Find_Corresponding_Discriminant;
+
+ ------------------
+ -- First_Actual --
+ ------------------
+
+ function First_Actual (Node : Node_Id) return Node_Id is
+ N : Node_Id;
+
+ begin
+ if No (Parameter_Associations (Node)) then
+ return Empty;
+ end if;
+
+ N := First (Parameter_Associations (Node));
+
+ if Nkind (N) = N_Parameter_Association then
+ return First_Named_Actual (Node);
+ else
+ return N;
+ end if;
+ end First_Actual;
+
+ -------------------------
+ -- Full_Qualified_Name --
+ -------------------------
+
+ function Full_Qualified_Name (E : Entity_Id) return String_Id is
+
+ Res : String_Id;
+
+ function Internal_Full_Qualified_Name (E : Entity_Id) return String_Id;
+ -- Compute recursively the qualified name without NUL at the end.
+
+ function Internal_Full_Qualified_Name (E : Entity_Id) return String_Id is
+ Ent : Entity_Id := E;
+ Parent_Name : String_Id := No_String;
+
+ begin
+ -- Deals properly with child units
+
+ if Nkind (Ent) = N_Defining_Program_Unit_Name then
+ Ent := Defining_Identifier (Ent);
+ end if;
+
+ -- Compute recursively the qualification. Only "Standard" has no
+ -- scope.
+
+ if Present (Scope (Scope (Ent))) then
+ Parent_Name := Internal_Full_Qualified_Name (Scope (Ent));
+ end if;
+
+ -- Every entity should have a name except some expanded blocks
+ -- don't bother about those.
+
+ if Chars (Ent) = No_Name then
+ return Parent_Name;
+ end if;
+
+ -- Add a period between Name and qualification
+
+ if Parent_Name /= No_String then
+ Start_String (Parent_Name);
+ Store_String_Char (Get_Char_Code ('.'));
+
+ else
+ Start_String;
+ end if;
+
+ -- Generates the entity name in upper case
+
+ Get_Name_String (Chars (Ent));
+ Set_All_Upper_Case;
+ Store_String_Chars (Name_Buffer (1 .. Name_Len));
+ return End_String;
+ end Internal_Full_Qualified_Name;
+
+ begin
+ Res := Internal_Full_Qualified_Name (E);
+ Store_String_Char (Get_Char_Code (ASCII.nul));
+ return End_String;
+ end Full_Qualified_Name;
+
+ -----------------------
+ -- Gather_Components --
+ -----------------------
+
+ procedure Gather_Components
+ (Typ : Entity_Id;
+ Comp_List : Node_Id;
+ Governed_By : List_Id;
+ Into : Elist_Id;
+ Report_Errors : out Boolean)
+ is
+ Assoc : Node_Id;
+ Variant : Node_Id;
+ Discrete_Choice : Node_Id;
+ Comp_Item : Node_Id;
+
+ Discrim : Entity_Id;
+ Discrim_Name : Node_Id;
+ Discrim_Value : Node_Id;
+
+ begin
+ Report_Errors := False;
+
+ if No (Comp_List) or else Null_Present (Comp_List) then
+ return;
+
+ elsif Present (Component_Items (Comp_List)) then
+ Comp_Item := First (Component_Items (Comp_List));
+
+ else
+ Comp_Item := Empty;
+ end if;
+
+ while Present (Comp_Item) loop
+
+ -- Skip the tag of a tagged record, as well as all items
+ -- that are not user components (anonymous types, rep clauses,
+ -- Parent field, controller field).
+
+ if Nkind (Comp_Item) = N_Component_Declaration
+ and then Chars (Defining_Identifier (Comp_Item)) /= Name_uTag
+ and then Chars (Defining_Identifier (Comp_Item)) /= Name_uParent
+ and then Chars (Defining_Identifier (Comp_Item)) /= Name_uController
+ then
+ Append_Elmt (Defining_Identifier (Comp_Item), Into);
+ end if;
+
+ Next (Comp_Item);
+ end loop;
+
+ if No (Variant_Part (Comp_List)) then
+ return;
+ else
+ Discrim_Name := Name (Variant_Part (Comp_List));
+ Variant := First_Non_Pragma (Variants (Variant_Part (Comp_List)));
+ end if;
+
+ -- Look for the discriminant that governs this variant part.
+ -- The discriminant *must* be in the Governed_By List
+
+ Assoc := First (Governed_By);
+ Find_Constraint : loop
+ Discrim := First (Choices (Assoc));
+ exit Find_Constraint when Chars (Discrim_Name) = Chars (Discrim)
+ or else (Present (Corresponding_Discriminant (Entity (Discrim)))
+ and then
+ Chars (Corresponding_Discriminant (Entity (Discrim)))
+ = Chars (Discrim_Name))
+ or else Chars (Original_Record_Component (Entity (Discrim)))
+ = Chars (Discrim_Name);
+
+ if No (Next (Assoc)) then
+ if not Is_Constrained (Typ)
+ and then Is_Derived_Type (Typ)
+ and then Present (Girder_Constraint (Typ))
+ then
+
+ -- If the type is a tagged type with inherited discriminants,
+ -- use the girder constraint on the parent in order to find
+ -- the values of discriminants that are otherwise hidden by an
+ -- explicit constraint. Renamed discriminants are handled in
+ -- the code above.
+
+ declare
+ D : Entity_Id;
+ C : Elmt_Id;
+
+ begin
+ D := First_Discriminant (Etype (Typ));
+ C := First_Elmt (Girder_Constraint (Typ));
+
+ while Present (D)
+ and then Present (C)
+ loop
+ if Chars (Discrim_Name) = Chars (D) then
+ Assoc :=
+ Make_Component_Association (Sloc (Typ),
+ New_List
+ (New_Occurrence_Of (D, Sloc (Typ))),
+ Duplicate_Subexpr (Node (C)));
+ exit Find_Constraint;
+ end if;
+
+ D := Next_Discriminant (D);
+ Next_Elmt (C);
+ end loop;
+ end;
+ end if;
+ end if;
+
+ if No (Next (Assoc)) then
+ Error_Msg_NE (" missing value for discriminant&",
+ First (Governed_By), Discrim_Name);
+ Report_Errors := True;
+ return;
+ end if;
+
+ Next (Assoc);
+ end loop Find_Constraint;
+
+ Discrim_Value := Expression (Assoc);
+
+ if not Is_OK_Static_Expression (Discrim_Value) then
+ Error_Msg_NE
+ ("value for discriminant & must be static", Discrim_Value, Discrim);
+ Report_Errors := True;
+ return;
+ end if;
+
+ Search_For_Discriminant_Value : declare
+ Low : Node_Id;
+ High : Node_Id;
+
+ UI_High : Uint;
+ UI_Low : Uint;
+ UI_Discrim_Value : constant Uint := Expr_Value (Discrim_Value);
+
+ begin
+ Find_Discrete_Value : while Present (Variant) loop
+ Discrete_Choice := First (Discrete_Choices (Variant));
+ while Present (Discrete_Choice) loop
+
+ exit Find_Discrete_Value when
+ Nkind (Discrete_Choice) = N_Others_Choice;
+
+ Get_Index_Bounds (Discrete_Choice, Low, High);
+
+ UI_Low := Expr_Value (Low);
+ UI_High := Expr_Value (High);
+
+ exit Find_Discrete_Value when
+ UI_Low <= UI_Discrim_Value
+ and then
+ UI_High >= UI_Discrim_Value;
+
+ Next (Discrete_Choice);
+ end loop;
+
+ Next_Non_Pragma (Variant);
+ end loop Find_Discrete_Value;
+ end Search_For_Discriminant_Value;
+
+ if No (Variant) then
+ Error_Msg_NE
+ ("value of discriminant & is out of range", Discrim_Value, Discrim);
+ Report_Errors := True;
+ return;
+ end if;
+
+ -- If we have found the corresponding choice, recursively add its
+ -- components to the Into list.
+
+ Gather_Components (Empty,
+ Component_List (Variant), Governed_By, Into, Report_Errors);
+ end Gather_Components;
+
+ ------------------------
+ -- Get_Actual_Subtype --
+ ------------------------
+
+ function Get_Actual_Subtype (N : Node_Id) return Entity_Id is
+ Typ : constant Entity_Id := Etype (N);
+ Utyp : Entity_Id := Underlying_Type (Typ);
+ Decl : Node_Id;
+ Atyp : Entity_Id;
+
+ begin
+ if not Present (Utyp) then
+ Utyp := Typ;
+ end if;
+
+ -- If what we have is an identifier that references a subprogram
+ -- formal, or a variable or constant object, then we get the actual
+ -- subtype from the referenced entity if one has been built.
+
+ if Nkind (N) = N_Identifier
+ and then
+ (Is_Formal (Entity (N))
+ or else Ekind (Entity (N)) = E_Constant
+ or else Ekind (Entity (N)) = E_Variable)
+ and then Present (Actual_Subtype (Entity (N)))
+ then
+ return Actual_Subtype (Entity (N));
+
+ -- Actual subtype of unchecked union is always itself. We never need
+ -- the "real" actual subtype. If we did, we couldn't get it anyway
+ -- because the discriminant is not available. The restrictions on
+ -- Unchecked_Union are designed to make sure that this is OK.
+
+ elsif Is_Unchecked_Union (Utyp) then
+ return Typ;
+
+ -- Here for the unconstrained case, we must find actual subtype
+ -- No actual subtype is available, so we must build it on the fly.
+
+ -- Checking the type, not the underlying type, for constrainedness
+ -- seems to be necessary. Maybe all the tests should be on the type???
+
+ elsif (not Is_Constrained (Typ))
+ and then (Is_Array_Type (Utyp)
+ or else (Is_Record_Type (Utyp)
+ and then Has_Discriminants (Utyp)))
+ and then not Has_Unknown_Discriminants (Utyp)
+ and then not (Ekind (Utyp) = E_String_Literal_Subtype)
+ then
+ -- Nothing to do if in default expression
+
+ if In_Default_Expression then
+ return Typ;
+
+ -- Else build the actual subtype
+
+ else
+ Decl := Build_Actual_Subtype (Typ, N);
+ Atyp := Defining_Identifier (Decl);
+
+ -- If Build_Actual_Subtype generated a new declaration then use it
+
+ if Atyp /= Typ then
+
+ -- The actual subtype is an Itype, so analyze the declaration,
+ -- but do not attach it to the tree, to get the type defined.
+
+ Set_Parent (Decl, N);
+ Set_Is_Itype (Atyp);
+ Analyze (Decl, Suppress => All_Checks);
+ Set_Associated_Node_For_Itype (Atyp, N);
+ Set_Has_Delayed_Freeze (Atyp, False);
+
+ -- We need to freeze the actual subtype immediately. This is
+ -- needed, because otherwise this Itype will not get frozen
+ -- at all, and it is always safe to freeze on creation because
+ -- any associated types must be frozen at this point.
+
+ Freeze_Itype (Atyp, N);
+ return Atyp;
+
+ -- Otherwise we did not build a declaration, so return original
+
+ else
+ return Typ;
+ end if;
+ end if;
+
+ -- For all remaining cases, the actual subtype is the same as
+ -- the nominal type.
+
+ else
+ return Typ;
+ end if;
+ end Get_Actual_Subtype;
+
+ -------------------------------------
+ -- Get_Actual_Subtype_If_Available --
+ -------------------------------------
+
+ function Get_Actual_Subtype_If_Available (N : Node_Id) return Entity_Id is
+ Typ : constant Entity_Id := Etype (N);
+
+ begin
+ -- If what we have is an identifier that references a subprogram
+ -- formal, or a variable or constant object, then we get the actual
+ -- subtype from the referenced entity if one has been built.
+
+ if Nkind (N) = N_Identifier
+ and then
+ (Is_Formal (Entity (N))
+ or else Ekind (Entity (N)) = E_Constant
+ or else Ekind (Entity (N)) = E_Variable)
+ and then Present (Actual_Subtype (Entity (N)))
+ then
+ return Actual_Subtype (Entity (N));
+
+ -- Otherwise the Etype of N is returned unchanged
+
+ else
+ return Typ;
+ end if;
+ end Get_Actual_Subtype_If_Available;
+
+ -------------------------------
+ -- Get_Default_External_Name --
+ -------------------------------
+
+ function Get_Default_External_Name (E : Node_Or_Entity_Id) return Node_Id is
+ begin
+ Get_Decoded_Name_String (Chars (E));
+
+ if Opt.External_Name_Imp_Casing = Uppercase then
+ Set_Casing (All_Upper_Case);
+ else
+ Set_Casing (All_Lower_Case);
+ end if;
+
+ return
+ Make_String_Literal (Sloc (E),
+ Strval => String_From_Name_Buffer);
+
+ end Get_Default_External_Name;
+
+ ---------------------------
+ -- Get_Enum_Lit_From_Pos --
+ ---------------------------
+
+ function Get_Enum_Lit_From_Pos
+ (T : Entity_Id;
+ Pos : Uint;
+ Loc : Source_Ptr)
+ return Node_Id
+ is
+ Lit : Node_Id;
+ P : constant Nat := UI_To_Int (Pos);
+
+ begin
+ -- In the case where the literal is either of type Wide_Character
+ -- or Character or of a type derived from them, there needs to be
+ -- some special handling since there is no explicit chain of
+ -- literals to search. Instead, an N_Character_Literal node is
+ -- created with the appropriate Char_Code and Chars fields.
+
+ if Root_Type (T) = Standard_Character
+ or else Root_Type (T) = Standard_Wide_Character
+ then
+ Set_Character_Literal_Name (Char_Code (P));
+ return
+ Make_Character_Literal (Loc,
+ Chars => Name_Find,
+ Char_Literal_Value => Char_Code (P));
+
+ -- For all other cases, we have a complete table of literals, and
+ -- we simply iterate through the chain of literal until the one
+ -- with the desired position value is found.
+ --
+
+ else
+ Lit := First_Literal (Base_Type (T));
+ for J in 1 .. P loop
+ Next_Literal (Lit);
+ end loop;
+
+ return New_Occurrence_Of (Lit, Loc);
+ end if;
+ end Get_Enum_Lit_From_Pos;
+
+ ----------------------
+ -- Get_Index_Bounds --
+ ----------------------
+
+ procedure Get_Index_Bounds (N : Node_Id; L, H : out Node_Id) is
+ Kind : constant Node_Kind := Nkind (N);
+
+ begin
+ if Kind = N_Range then
+ L := Low_Bound (N);
+ H := High_Bound (N);
+
+ elsif Kind = N_Subtype_Indication then
+ L := Low_Bound (Range_Expression (Constraint (N)));
+ H := High_Bound (Range_Expression (Constraint (N)));
+
+ elsif Is_Entity_Name (N) and then Is_Type (Entity (N)) then
+ if Error_Posted (Scalar_Range (Entity (N))) then
+ L := Error;
+ H := Error;
+
+ elsif Nkind (Scalar_Range (Entity (N))) = N_Subtype_Indication then
+ Get_Index_Bounds (Scalar_Range (Entity (N)), L, H);
+
+ else
+ L := Low_Bound (Scalar_Range (Entity (N)));
+ H := High_Bound (Scalar_Range (Entity (N)));
+ end if;
+
+ else
+ -- N is an expression, indicating a range with one value.
+
+ L := N;
+ H := N;
+ end if;
+
+ end Get_Index_Bounds;
+
+ ------------------------
+ -- Get_Name_Entity_Id --
+ ------------------------
+
+ function Get_Name_Entity_Id (Id : Name_Id) return Entity_Id is
+ begin
+ return Entity_Id (Get_Name_Table_Info (Id));
+ end Get_Name_Entity_Id;
+
+ ---------------------------
+ -- Get_Referenced_Object --
+ ---------------------------
+
+ function Get_Referenced_Object (N : Node_Id) return Node_Id is
+ R : Node_Id := N;
+
+ begin
+ while Is_Entity_Name (R)
+ and then Present (Renamed_Object (Entity (R)))
+ loop
+ R := Renamed_Object (Entity (R));
+ end loop;
+
+ return R;
+ end Get_Referenced_Object;
+
+ -------------------------
+ -- Get_Subprogram_Body --
+ -------------------------
+
+ function Get_Subprogram_Body (E : Entity_Id) return Node_Id is
+ Decl : Node_Id;
+
+ begin
+ Decl := Unit_Declaration_Node (E);
+
+ if Nkind (Decl) = N_Subprogram_Body then
+ return Decl;
+
+ else -- Nkind (Decl) = N_Subprogram_Declaration
+
+ if Present (Corresponding_Body (Decl)) then
+ return Unit_Declaration_Node (Corresponding_Body (Decl));
+
+ else -- imported subprogram.
+ return Empty;
+ end if;
+ end if;
+ end Get_Subprogram_Body;
+
+ -----------------------------
+ -- Get_Task_Body_Procedure --
+ -----------------------------
+
+ function Get_Task_Body_Procedure (E : Entity_Id) return Node_Id is
+ begin
+ return Task_Body_Procedure (Declaration_Node (Root_Type (E)));
+ end Get_Task_Body_Procedure;
+
+ --------------------
+ -- Has_Infinities --
+ --------------------
+
+ function Has_Infinities (E : Entity_Id) return Boolean is
+ begin
+ return
+ Is_Floating_Point_Type (E)
+ and then Nkind (Scalar_Range (E)) = N_Range
+ and then Includes_Infinities (Scalar_Range (E));
+ end Has_Infinities;
+
+ ---------------------------
+ -- Has_Private_Component --
+ ---------------------------
+
+ function Has_Private_Component (Type_Id : Entity_Id) return Boolean is
+ Btype : Entity_Id := Base_Type (Type_Id);
+ Component : Entity_Id;
+
+ begin
+ if Error_Posted (Type_Id)
+ or else Error_Posted (Btype)
+ then
+ return False;
+ end if;
+
+ if Is_Class_Wide_Type (Btype) then
+ Btype := Root_Type (Btype);
+ end if;
+
+ if Is_Private_Type (Btype) then
+ declare
+ UT : constant Entity_Id := Underlying_Type (Btype);
+ begin
+ if No (UT) then
+
+ if No (Full_View (Btype)) then
+ return not Is_Generic_Type (Btype)
+ and then not Is_Generic_Type (Root_Type (Btype));
+
+ else
+ return not Is_Generic_Type (Root_Type (Full_View (Btype)));
+ end if;
+
+ else
+ return not Is_Frozen (UT) and then Has_Private_Component (UT);
+ end if;
+ end;
+ elsif Is_Array_Type (Btype) then
+ return Has_Private_Component (Component_Type (Btype));
+
+ elsif Is_Record_Type (Btype) then
+
+ Component := First_Component (Btype);
+ while Present (Component) loop
+
+ if Has_Private_Component (Etype (Component)) then
+ return True;
+ end if;
+
+ Next_Component (Component);
+ end loop;
+
+ return False;
+
+ elsif Is_Protected_Type (Btype)
+ and then Present (Corresponding_Record_Type (Btype))
+ then
+ return Has_Private_Component (Corresponding_Record_Type (Btype));
+
+ else
+ return False;
+ end if;
+ end Has_Private_Component;
+
+ --------------------------
+ -- Has_Tagged_Component --
+ --------------------------
+
+ function Has_Tagged_Component (Typ : Entity_Id) return Boolean is
+ Comp : Entity_Id;
+
+ begin
+ if Is_Private_Type (Typ)
+ and then Present (Underlying_Type (Typ))
+ then
+ return Has_Tagged_Component (Underlying_Type (Typ));
+
+ elsif Is_Array_Type (Typ) then
+ return Has_Tagged_Component (Component_Type (Typ));
+
+ elsif Is_Tagged_Type (Typ) then
+ return True;
+
+ elsif Is_Record_Type (Typ) then
+ Comp := First_Component (Typ);
+
+ while Present (Comp) loop
+ if Has_Tagged_Component (Etype (Comp)) then
+ return True;
+ end if;
+
+ Comp := Next_Component (Typ);
+ end loop;
+
+ return False;
+
+ else
+ return False;
+ end if;
+ end Has_Tagged_Component;
+
+ -----------------
+ -- In_Instance --
+ -----------------
+
+ function In_Instance return Boolean is
+ S : Entity_Id := Current_Scope;
+
+ begin
+ while Present (S)
+ and then S /= Standard_Standard
+ loop
+ if (Ekind (S) = E_Function
+ or else Ekind (S) = E_Package
+ or else Ekind (S) = E_Procedure)
+ and then Is_Generic_Instance (S)
+ then
+ return True;
+ end if;
+
+ S := Scope (S);
+ end loop;
+
+ return False;
+ end In_Instance;
+
+ ----------------------
+ -- In_Instance_Body --
+ ----------------------
+
+ function In_Instance_Body return Boolean is
+ S : Entity_Id := Current_Scope;
+
+ begin
+ while Present (S)
+ and then S /= Standard_Standard
+ loop
+ if (Ekind (S) = E_Function
+ or else Ekind (S) = E_Procedure)
+ and then Is_Generic_Instance (S)
+ then
+ return True;
+
+ elsif Ekind (S) = E_Package
+ and then In_Package_Body (S)
+ and then Is_Generic_Instance (S)
+ then
+ return True;
+ end if;
+
+ S := Scope (S);
+ end loop;
+
+ return False;
+ end In_Instance_Body;
+
+ -----------------------------
+ -- In_Instance_Not_Visible --
+ -----------------------------
+
+ function In_Instance_Not_Visible return Boolean is
+ S : Entity_Id := Current_Scope;
+
+ begin
+ while Present (S)
+ and then S /= Standard_Standard
+ loop
+ if (Ekind (S) = E_Function
+ or else Ekind (S) = E_Procedure)
+ and then Is_Generic_Instance (S)
+ then
+ return True;
+
+ elsif Ekind (S) = E_Package
+ and then (In_Package_Body (S) or else In_Private_Part (S))
+ and then Is_Generic_Instance (S)
+ then
+ return True;
+ end if;
+
+ S := Scope (S);
+ end loop;
+
+ return False;
+ end In_Instance_Not_Visible;
+
+ ------------------------------
+ -- In_Instance_Visible_Part --
+ ------------------------------
+
+ function In_Instance_Visible_Part return Boolean is
+ S : Entity_Id := Current_Scope;
+
+ begin
+ while Present (S)
+ and then S /= Standard_Standard
+ loop
+ if Ekind (S) = E_Package
+ and then Is_Generic_Instance (S)
+ and then not In_Package_Body (S)
+ and then not In_Private_Part (S)
+ then
+ return True;
+ end if;
+
+ S := Scope (S);
+ end loop;
+
+ return False;
+ end In_Instance_Visible_Part;
+
+ --------------------------------------
+ -- In_Subprogram_Or_Concurrent_Unit --
+ --------------------------------------
+
+ function In_Subprogram_Or_Concurrent_Unit return Boolean is
+ E : Entity_Id;
+ K : Entity_Kind;
+
+ begin
+ -- Use scope chain to check successively outer scopes
+
+ E := Current_Scope;
+ loop
+ K := Ekind (E);
+
+ if K in Subprogram_Kind
+ or else K in Concurrent_Kind
+ or else K = E_Generic_Procedure
+ or else K = E_Generic_Function
+ then
+ return True;
+
+ elsif E = Standard_Standard then
+ return False;
+ end if;
+
+ E := Scope (E);
+ end loop;
+
+ end In_Subprogram_Or_Concurrent_Unit;
+
+ ---------------------
+ -- In_Visible_Part --
+ ---------------------
+
+ function In_Visible_Part (Scope_Id : Entity_Id) return Boolean is
+ begin
+ return
+ Is_Package (Scope_Id)
+ and then In_Open_Scopes (Scope_Id)
+ and then not In_Package_Body (Scope_Id)
+ and then not In_Private_Part (Scope_Id);
+ end In_Visible_Part;
+
+ -------------------
+ -- Is_AAMP_Float --
+ -------------------
+
+ function Is_AAMP_Float (E : Entity_Id) return Boolean is
+ begin
+ pragma Assert (Is_Type (E));
+
+ return AAMP_On_Target
+ and then Is_Floating_Point_Type (E)
+ and then E = Base_Type (E);
+ end Is_AAMP_Float;
+
+ -------------------------
+ -- Is_Actual_Parameter --
+ -------------------------
+
+ function Is_Actual_Parameter (N : Node_Id) return Boolean is
+ PK : constant Node_Kind := Nkind (Parent (N));
+
+ begin
+ case PK is
+ when N_Parameter_Association =>
+ return N = Explicit_Actual_Parameter (Parent (N));
+
+ when N_Function_Call | N_Procedure_Call_Statement =>
+ return Is_List_Member (N)
+ and then
+ List_Containing (N) = Parameter_Associations (Parent (N));
+
+ when others =>
+ return False;
+ end case;
+ end Is_Actual_Parameter;
+
+ ---------------------
+ -- Is_Aliased_View --
+ ---------------------
+
+ function Is_Aliased_View (Obj : Node_Id) return Boolean is
+ E : Entity_Id;
+
+ begin
+ if Is_Entity_Name (Obj) then
+
+ -- Shouldn't we check that we really have an object here?
+ -- If we do, then a-caldel.adb blows up mysteriously ???
+
+ E := Entity (Obj);
+
+ return Is_Aliased (E)
+ or else (Present (Renamed_Object (E))
+ and then Is_Aliased_View (Renamed_Object (E)))
+
+ or else ((Is_Formal (E)
+ or else Ekind (E) = E_Generic_In_Out_Parameter
+ or else Ekind (E) = E_Generic_In_Parameter)
+ and then Is_Tagged_Type (Etype (E)))
+
+ or else ((Ekind (E) = E_Task_Type or else
+ Ekind (E) = E_Protected_Type)
+ and then In_Open_Scopes (E))
+
+ -- Current instance of type
+
+ or else (Is_Type (E) and then E = Current_Scope)
+ or else (Is_Incomplete_Or_Private_Type (E)
+ and then Full_View (E) = Current_Scope);
+
+ elsif Nkind (Obj) = N_Selected_Component then
+ return Is_Aliased (Entity (Selector_Name (Obj)));
+
+ elsif Nkind (Obj) = N_Indexed_Component then
+ return Has_Aliased_Components (Etype (Prefix (Obj)))
+ or else
+ (Is_Access_Type (Etype (Prefix (Obj)))
+ and then
+ Has_Aliased_Components
+ (Designated_Type (Etype (Prefix (Obj)))));
+
+ elsif Nkind (Obj) = N_Unchecked_Type_Conversion
+ or else Nkind (Obj) = N_Type_Conversion
+ then
+ return Is_Tagged_Type (Etype (Obj))
+ or else Is_Aliased_View (Expression (Obj));
+
+ elsif Nkind (Obj) = N_Explicit_Dereference then
+ return Nkind (Original_Node (Obj)) /= N_Function_Call;
+
+ else
+ return False;
+ end if;
+ end Is_Aliased_View;
+
+ ----------------------
+ -- Is_Atomic_Object --
+ ----------------------
+
+ function Is_Atomic_Object (N : Node_Id) return Boolean is
+
+ function Object_Has_Atomic_Components (N : Node_Id) return Boolean;
+ -- Determines if given object has atomic components
+
+ function Is_Atomic_Prefix (N : Node_Id) return Boolean;
+ -- If prefix is an implicit dereference, examine designated type.
+
+ function Is_Atomic_Prefix (N : Node_Id) return Boolean is
+ begin
+ if Is_Access_Type (Etype (N)) then
+ return
+ Has_Atomic_Components (Designated_Type (Etype (N)));
+ else
+ return Object_Has_Atomic_Components (N);
+ end if;
+ end Is_Atomic_Prefix;
+
+ function Object_Has_Atomic_Components (N : Node_Id) return Boolean is
+ begin
+ if Has_Atomic_Components (Etype (N))
+ or else Is_Atomic (Etype (N))
+ then
+ return True;
+
+ elsif Is_Entity_Name (N)
+ and then (Has_Atomic_Components (Entity (N))
+ or else Is_Atomic (Entity (N)))
+ then
+ return True;
+
+ elsif Nkind (N) = N_Indexed_Component
+ or else Nkind (N) = N_Selected_Component
+ then
+ return Is_Atomic_Prefix (Prefix (N));
+
+ else
+ return False;
+ end if;
+ end Object_Has_Atomic_Components;
+
+ -- Start of processing for Is_Atomic_Object
+
+ begin
+ if Is_Atomic (Etype (N))
+ or else (Is_Entity_Name (N) and then Is_Atomic (Entity (N)))
+ then
+ return True;
+
+ elsif Nkind (N) = N_Indexed_Component
+ or else Nkind (N) = N_Selected_Component
+ then
+ return Is_Atomic_Prefix (Prefix (N));
+
+ else
+ return False;
+ end if;
+ end Is_Atomic_Object;
+
+ ----------------------------------------------
+ -- Is_Dependent_Component_Of_Mutable_Object --
+ ----------------------------------------------
+
+ function Is_Dependent_Component_Of_Mutable_Object
+ (Object : Node_Id)
+ return Boolean
+ is
+ P : Node_Id;
+ Prefix_Type : Entity_Id;
+ P_Aliased : Boolean := False;
+ Comp : Entity_Id;
+
+ function Has_Dependent_Constraint (Comp : Entity_Id) return Boolean;
+ -- Returns True if and only if Comp has a constrained subtype
+ -- that depends on a discriminant.
+
+ function Is_Declared_Within_Variant (Comp : Entity_Id) return Boolean;
+ -- Returns True if and only if Comp is declared within a variant part.
+
+ ------------------------------
+ -- Has_Dependent_Constraint --
+ ------------------------------
+
+ function Has_Dependent_Constraint (Comp : Entity_Id) return Boolean is
+ Comp_Decl : constant Node_Id := Parent (Comp);
+ Subt_Indic : constant Node_Id := Subtype_Indication (Comp_Decl);
+ Constr : Node_Id;
+ Assn : Node_Id;
+
+ begin
+ if Nkind (Subt_Indic) = N_Subtype_Indication then
+ Constr := Constraint (Subt_Indic);
+
+ if Nkind (Constr) = N_Index_Or_Discriminant_Constraint then
+ Assn := First (Constraints (Constr));
+ while Present (Assn) loop
+ case Nkind (Assn) is
+ when N_Subtype_Indication |
+ N_Range |
+ N_Identifier
+ =>
+ if Depends_On_Discriminant (Assn) then
+ return True;
+ end if;
+
+ when N_Discriminant_Association =>
+ if Depends_On_Discriminant (Expression (Assn)) then
+ return True;
+ end if;
+
+ when others =>
+ null;
+
+ end case;
+
+ Next (Assn);
+ end loop;
+ end if;
+ end if;
+
+ return False;
+ end Has_Dependent_Constraint;
+
+ --------------------------------
+ -- Is_Declared_Within_Variant --
+ --------------------------------
+
+ function Is_Declared_Within_Variant (Comp : Entity_Id) return Boolean is
+ Comp_Decl : constant Node_Id := Parent (Comp);
+ Comp_List : constant Node_Id := Parent (Comp_Decl);
+
+ begin
+ return Nkind (Parent (Comp_List)) = N_Variant;
+ end Is_Declared_Within_Variant;
+
+ -- Start of processing for Is_Dependent_Component_Of_Mutable_Object
+
+ begin
+ if Is_Variable (Object) then
+
+ if Nkind (Object) = N_Selected_Component then
+ P := Prefix (Object);
+ Prefix_Type := Etype (P);
+
+ if Is_Entity_Name (P) then
+
+ if Ekind (Entity (P)) = E_Generic_In_Out_Parameter then
+ Prefix_Type := Base_Type (Prefix_Type);
+ end if;
+
+ if Is_Aliased (Entity (P)) then
+ P_Aliased := True;
+ end if;
+
+ else
+ -- Check for prefix being an aliased component ???
+ null;
+ end if;
+
+ if Is_Access_Type (Prefix_Type)
+ or else Nkind (P) = N_Explicit_Dereference
+ then
+ return False;
+ end if;
+
+ Comp :=
+ Original_Record_Component (Entity (Selector_Name (Object)));
+
+ if not Is_Constrained (Prefix_Type)
+ and then not Is_Indefinite_Subtype (Prefix_Type)
+ and then (Is_Declared_Within_Variant (Comp)
+ or else Has_Dependent_Constraint (Comp))
+ and then not P_Aliased
+ then
+ return True;
+
+ else
+ return
+ Is_Dependent_Component_Of_Mutable_Object (Prefix (Object));
+
+ end if;
+
+ elsif Nkind (Object) = N_Indexed_Component
+ or else Nkind (Object) = N_Slice
+ then
+ return Is_Dependent_Component_Of_Mutable_Object (Prefix (Object));
+ end if;
+ end if;
+
+ return False;
+ end Is_Dependent_Component_Of_Mutable_Object;
+
+ --------------
+ -- Is_False --
+ --------------
+
+ function Is_False (U : Uint) return Boolean is
+ begin
+ return (U = 0);
+ end Is_False;
+
+ ---------------------------
+ -- Is_Fixed_Model_Number --
+ ---------------------------
+
+ function Is_Fixed_Model_Number (U : Ureal; T : Entity_Id) return Boolean is
+ S : constant Ureal := Small_Value (T);
+ M : Urealp.Save_Mark;
+ R : Boolean;
+
+ begin
+ M := Urealp.Mark;
+ R := (U = UR_Trunc (U / S) * S);
+ Urealp.Release (M);
+ return R;
+ end Is_Fixed_Model_Number;
+
+ -------------------------------
+ -- Is_Fully_Initialized_Type --
+ -------------------------------
+
+ function Is_Fully_Initialized_Type (Typ : Entity_Id) return Boolean is
+ begin
+ if Is_Scalar_Type (Typ) then
+ return False;
+
+ elsif Is_Access_Type (Typ) then
+ return True;
+
+ elsif Is_Array_Type (Typ) then
+ if Is_Fully_Initialized_Type (Component_Type (Typ)) then
+ return True;
+ end if;
+
+ -- An interesting case, if we have a constrained type one of whose
+ -- bounds is known to be null, then there are no elements to be
+ -- initialized, so all the elements are initialized!
+
+ if Is_Constrained (Typ) then
+ declare
+ Indx : Node_Id;
+ Indx_Typ : Entity_Id;
+ Lbd, Hbd : Node_Id;
+
+ begin
+ Indx := First_Index (Typ);
+ while Present (Indx) loop
+
+ if Etype (Indx) = Any_Type then
+ return False;
+
+ -- If index is a range, use directly.
+
+ elsif Nkind (Indx) = N_Range then
+ Lbd := Low_Bound (Indx);
+ Hbd := High_Bound (Indx);
+
+ else
+ Indx_Typ := Etype (Indx);
+
+ if Is_Private_Type (Indx_Typ) then
+ Indx_Typ := Full_View (Indx_Typ);
+ end if;
+
+ if No (Indx_Typ) then
+ return False;
+ else
+ Lbd := Type_Low_Bound (Indx_Typ);
+ Hbd := Type_High_Bound (Indx_Typ);
+ end if;
+ end if;
+
+ if Compile_Time_Known_Value (Lbd)
+ and then Compile_Time_Known_Value (Hbd)
+ then
+ if Expr_Value (Hbd) < Expr_Value (Lbd) then
+ return True;
+ end if;
+ end if;
+
+ Next_Index (Indx);
+ end loop;
+ end;
+ end if;
+
+ return False;
+
+ elsif Is_Record_Type (Typ) then
+ declare
+ Ent : Entity_Id;
+
+ begin
+ Ent := First_Entity (Typ);
+
+ while Present (Ent) loop
+ if Ekind (Ent) = E_Component
+ and then (No (Parent (Ent))
+ or else No (Expression (Parent (Ent))))
+ and then not Is_Fully_Initialized_Type (Etype (Ent))
+ then
+ return False;
+ end if;
+
+ Next_Entity (Ent);
+ end loop;
+ end;
+
+ return True;
+
+ elsif Is_Concurrent_Type (Typ) then
+ return True;
+
+ elsif Is_Private_Type (Typ) then
+ declare
+ U : constant Entity_Id := Underlying_Type (Typ);
+
+ begin
+ if No (U) then
+ return False;
+ else
+ return Is_Fully_Initialized_Type (U);
+ end if;
+ end;
+
+ else
+ return False;
+ end if;
+ end Is_Fully_Initialized_Type;
+
+ ----------------------------
+ -- Is_Inherited_Operation --
+ ----------------------------
+
+ function Is_Inherited_Operation (E : Entity_Id) return Boolean is
+ Kind : constant Node_Kind := Nkind (Parent (E));
+
+ begin
+ pragma Assert (Is_Overloadable (E));
+ return Kind = N_Full_Type_Declaration
+ or else Kind = N_Private_Extension_Declaration
+ or else Kind = N_Subtype_Declaration
+ or else (Ekind (E) = E_Enumeration_Literal
+ and then Is_Derived_Type (Etype (E)));
+ end Is_Inherited_Operation;
+
+ -----------------------------
+ -- Is_Library_Level_Entity --
+ -----------------------------
+
+ function Is_Library_Level_Entity (E : Entity_Id) return Boolean is
+ begin
+ return Enclosing_Dynamic_Scope (E) = Standard_Standard;
+ end Is_Library_Level_Entity;
+
+ ---------------------------------
+ -- Is_Local_Variable_Reference --
+ ---------------------------------
+
+ function Is_Local_Variable_Reference (Expr : Node_Id) return Boolean is
+ begin
+ if not Is_Entity_Name (Expr) then
+ return False;
+
+ else
+ declare
+ Ent : constant Entity_Id := Entity (Expr);
+ Sub : constant Entity_Id := Enclosing_Subprogram (Ent);
+
+ begin
+ if Ekind (Ent) /= E_Variable
+ and then
+ Ekind (Ent) /= E_In_Out_Parameter
+ then
+ return False;
+
+ else
+ return Present (Sub) and then Sub = Current_Subprogram;
+ end if;
+ end;
+ end if;
+ end Is_Local_Variable_Reference;
+
+ -------------------------
+ -- Is_Object_Reference --
+ -------------------------
+
+ function Is_Object_Reference (N : Node_Id) return Boolean is
+ begin
+ if Is_Entity_Name (N) then
+ return Is_Object (Entity (N));
+
+ else
+ case Nkind (N) is
+ when N_Indexed_Component | N_Slice =>
+ return True;
+
+ -- In Ada95, a function call is a constant object.
+
+ when N_Function_Call =>
+ return True;
+
+ when N_Selected_Component =>
+ return Is_Object_Reference (Selector_Name (N));
+
+ when N_Explicit_Dereference =>
+ return True;
+
+ -- An unchecked type conversion is considered to be an object if
+ -- the operand is an object (this construction arises only as a
+ -- result of expansion activities).
+
+ when N_Unchecked_Type_Conversion =>
+ return True;
+
+ when others =>
+ return False;
+ end case;
+ end if;
+ end Is_Object_Reference;
+
+ -----------------------------------
+ -- Is_OK_Variable_For_Out_Formal --
+ -----------------------------------
+
+ function Is_OK_Variable_For_Out_Formal (AV : Node_Id) return Boolean is
+ begin
+ Note_Possible_Modification (AV);
+
+ -- We must reject parenthesized variable names. The check for
+ -- Comes_From_Source is present because there are currently
+ -- cases where the compiler violates this rule (e.g. passing
+ -- a task object to its controlled Initialize routine).
+
+ if Paren_Count (AV) > 0 and then Comes_From_Source (AV) then
+ return False;
+
+ -- A variable is always allowed
+
+ elsif Is_Variable (AV) then
+ return True;
+
+ -- Unchecked conversions are allowed only if they come from the
+ -- generated code, which sometimes uses unchecked conversions for
+ -- out parameters in cases where code generation is unaffected.
+ -- We tell source unchecked conversions by seeing if they are
+ -- rewrites of an original UC function call, or of an explicit
+ -- conversion of a function call.
+
+ elsif Nkind (AV) = N_Unchecked_Type_Conversion then
+ if Nkind (Original_Node (AV)) = N_Function_Call then
+ return False;
+
+ elsif Comes_From_Source (AV)
+ and then Nkind (Original_Node (Expression (AV))) = N_Function_Call
+ then
+ return False;
+
+ else
+ return True;
+ end if;
+
+ -- Normal type conversions are allowed if argument is a variable
+
+ elsif Nkind (AV) = N_Type_Conversion then
+ if Is_Variable (Expression (AV))
+ and then Paren_Count (Expression (AV)) = 0
+ then
+ Note_Possible_Modification (Expression (AV));
+ return True;
+
+ -- We also allow a non-parenthesized expression that raises
+ -- constraint error if it rewrites what used to be a variable
+
+ elsif Raises_Constraint_Error (Expression (AV))
+ and then Paren_Count (Expression (AV)) = 0
+ and then Is_Variable (Original_Node (Expression (AV)))
+ then
+ return True;
+
+ -- Type conversion of something other than a variable
+
+ else
+ return False;
+ end if;
+
+ -- If this node is rewritten, then test the original form, if that is
+ -- OK, then we consider the rewritten node OK (for example, if the
+ -- original node is a conversion, then Is_Variable will not be true
+ -- but we still want to allow the conversion if it converts a variable.
+
+ elsif Original_Node (AV) /= AV then
+ return Is_OK_Variable_For_Out_Formal (Original_Node (AV));
+
+ -- All other non-variables are rejected
+
+ else
+ return False;
+ end if;
+ end Is_OK_Variable_For_Out_Formal;
+
+ -----------------------------
+ -- Is_RCI_Pkg_Spec_Or_Body --
+ -----------------------------
+
+ function Is_RCI_Pkg_Spec_Or_Body (Cunit : Node_Id) return Boolean is
+
+ function Is_RCI_Pkg_Decl_Cunit (Cunit : Node_Id) return Boolean;
+ -- Return True if the unit of Cunit is an RCI package declaration
+
+ ---------------------------
+ -- Is_RCI_Pkg_Decl_Cunit --
+ ---------------------------
+
+ function Is_RCI_Pkg_Decl_Cunit (Cunit : Node_Id) return Boolean is
+ The_Unit : constant Node_Id := Unit (Cunit);
+
+ begin
+ if Nkind (The_Unit) /= N_Package_Declaration then
+ return False;
+ end if;
+ return Is_Remote_Call_Interface (Defining_Entity (The_Unit));
+ end Is_RCI_Pkg_Decl_Cunit;
+
+ -- Start of processing for Is_RCI_Pkg_Spec_Or_Body
+
+ begin
+ return Is_RCI_Pkg_Decl_Cunit (Cunit)
+ or else
+ (Nkind (Unit (Cunit)) = N_Package_Body
+ and then Is_RCI_Pkg_Decl_Cunit (Library_Unit (Cunit)));
+ end Is_RCI_Pkg_Spec_Or_Body;
+
+ -----------------------------------------
+ -- Is_Remote_Access_To_Class_Wide_Type --
+ -----------------------------------------
+
+ function Is_Remote_Access_To_Class_Wide_Type
+ (E : Entity_Id)
+ return Boolean
+ is
+ D : Entity_Id;
+
+ function Comes_From_Limited_Private_Type_Declaration
+ (E : Entity_Id)
+ return Boolean;
+ -- Check if the original declaration is a limited private one and
+ -- if all the derivations have been using private extensions.
+
+ -------------------------------------------------
+ -- Comes_From_Limited_Private_Type_Declaration --
+ -------------------------------------------------
+
+ function Comes_From_Limited_Private_Type_Declaration (E : in Entity_Id)
+ return Boolean
+ is
+ N : constant Node_Id := Declaration_Node (E);
+ begin
+ if Nkind (N) = N_Private_Type_Declaration
+ and then Limited_Present (N)
+ then
+ return True;
+ end if;
+
+ if Nkind (N) = N_Private_Extension_Declaration then
+ return Comes_From_Limited_Private_Type_Declaration (Etype (E));
+ end if;
+
+ return False;
+ end Comes_From_Limited_Private_Type_Declaration;
+
+ -- Start of processing for Is_Remote_Access_To_Class_Wide_Type
+
+ begin
+ if not (Is_Remote_Call_Interface (E)
+ or else Is_Remote_Types (E))
+ or else Ekind (E) /= E_General_Access_Type
+ then
+ return False;
+ end if;
+
+ D := Designated_Type (E);
+
+ if Ekind (D) /= E_Class_Wide_Type then
+ return False;
+ end if;
+
+ return Comes_From_Limited_Private_Type_Declaration
+ (Defining_Identifier (Parent (D)));
+ end Is_Remote_Access_To_Class_Wide_Type;
+
+ -----------------------------------------
+ -- Is_Remote_Access_To_Subprogram_Type --
+ -----------------------------------------
+
+ function Is_Remote_Access_To_Subprogram_Type
+ (E : Entity_Id)
+ return Boolean
+ is
+ begin
+ return (Ekind (E) = E_Access_Subprogram_Type
+ or else (Ekind (E) = E_Record_Type
+ and then Present (Corresponding_Remote_Type (E))))
+ and then (Is_Remote_Call_Interface (E)
+ or else Is_Remote_Types (E));
+ end Is_Remote_Access_To_Subprogram_Type;
+
+ --------------------
+ -- Is_Remote_Call --
+ --------------------
+
+ function Is_Remote_Call (N : Node_Id) return Boolean is
+ begin
+ if Nkind (N) /= N_Procedure_Call_Statement
+ and then Nkind (N) /= N_Function_Call
+ then
+ -- An entry call cannot be remote
+
+ return False;
+
+ elsif Nkind (Name (N)) in N_Has_Entity
+ and then Is_Remote_Call_Interface (Entity (Name (N)))
+ then
+ -- A subprogram declared in the spec of a RCI package is remote
+
+ return True;
+
+ elsif Nkind (Name (N)) = N_Explicit_Dereference
+ and then Is_Remote_Access_To_Subprogram_Type
+ (Etype (Prefix (Name (N))))
+ then
+ -- The dereference of a RAS is a remote call
+
+ return True;
+
+ elsif Present (Controlling_Argument (N))
+ and then Is_Remote_Access_To_Class_Wide_Type
+ (Etype (Controlling_Argument (N)))
+ then
+ -- Any primitive operation call with a controlling argument of
+ -- a RACW type is a remote call.
+
+ return True;
+ end if;
+
+ -- All other calls are local calls
+
+ return False;
+ end Is_Remote_Call;
+
+ ----------------------
+ -- Is_Selector_Name --
+ ----------------------
+
+ function Is_Selector_Name (N : Node_Id) return Boolean is
+
+ begin
+ if not Is_List_Member (N) then
+ declare
+ P : constant Node_Id := Parent (N);
+ K : constant Node_Kind := Nkind (P);
+
+ begin
+ return
+ (K = N_Expanded_Name or else
+ K = N_Generic_Association or else
+ K = N_Parameter_Association or else
+ K = N_Selected_Component)
+ and then Selector_Name (P) = N;
+ end;
+
+ else
+ declare
+ L : constant List_Id := List_Containing (N);
+ P : constant Node_Id := Parent (L);
+
+ begin
+ return (Nkind (P) = N_Discriminant_Association
+ and then Selector_Names (P) = L)
+ or else
+ (Nkind (P) = N_Component_Association
+ and then Choices (P) = L);
+ end;
+ end if;
+ end Is_Selector_Name;
+
+ ------------------
+ -- Is_Statement --
+ ------------------
+
+ function Is_Statement (N : Node_Id) return Boolean is
+ begin
+ return
+ Nkind (N) in N_Statement_Other_Than_Procedure_Call
+ or else Nkind (N) = N_Procedure_Call_Statement;
+ end Is_Statement;
+
+ -----------------
+ -- Is_Transfer --
+ -----------------
+
+ function Is_Transfer (N : Node_Id) return Boolean is
+ Kind : constant Node_Kind := Nkind (N);
+
+ begin
+ if Kind = N_Return_Statement
+ or else
+ Kind = N_Goto_Statement
+ or else
+ Kind = N_Raise_Statement
+ or else
+ Kind = N_Requeue_Statement
+ then
+ return True;
+
+ elsif (Kind = N_Exit_Statement or else Kind in N_Raise_xxx_Error)
+ and then No (Condition (N))
+ then
+ return True;
+
+ elsif Kind = N_Procedure_Call_Statement
+ and then Is_Entity_Name (Name (N))
+ and then Present (Entity (Name (N)))
+ and then No_Return (Entity (Name (N)))
+ then
+ return True;
+
+ elsif Nkind (Original_Node (N)) = N_Raise_Statement then
+ return True;
+
+ else
+ return False;
+ end if;
+ end Is_Transfer;
+
+ -------------
+ -- Is_True --
+ -------------
+
+ function Is_True (U : Uint) return Boolean is
+ begin
+ return (U /= 0);
+ end Is_True;
+
+ -----------------
+ -- Is_Variable --
+ -----------------
+
+ function Is_Variable (N : Node_Id) return Boolean is
+
+ Orig_Node : constant Node_Id := Original_Node (N);
+ -- We do the test on the original node, since this is basically a
+ -- test of syntactic categories, so it must not be disturbed by
+ -- whatever rewriting might have occurred. For example, an aggregate,
+ -- which is certainly NOT a variable, could be turned into a variable
+ -- by expansion.
+
+ function In_Protected_Function (E : Entity_Id) return Boolean;
+ -- Within a protected function, the private components of the
+ -- enclosing protected type are constants. A function nested within
+ -- a (protected) procedure is not itself protected.
+
+ function Is_Variable_Prefix (P : Node_Id) return Boolean;
+ -- Prefixes can involve implicit dereferences, in which case we
+ -- must test for the case of a reference of a constant access
+ -- type, which can never be a variable.
+
+ function In_Protected_Function (E : Entity_Id) return Boolean is
+ Prot : constant Entity_Id := Scope (E);
+ S : Entity_Id;
+
+ begin
+ if not Is_Protected_Type (Prot) then
+ return False;
+ else
+ S := Current_Scope;
+
+ while Present (S) and then S /= Prot loop
+
+ if Ekind (S) = E_Function
+ and then Scope (S) = Prot
+ then
+ return True;
+ end if;
+
+ S := Scope (S);
+ end loop;
+
+ return False;
+ end if;
+ end In_Protected_Function;
+
+ function Is_Variable_Prefix (P : Node_Id) return Boolean is
+ begin
+ if Is_Access_Type (Etype (P)) then
+ return not Is_Access_Constant (Root_Type (Etype (P)));
+ else
+ return Is_Variable (P);
+ end if;
+ end Is_Variable_Prefix;
+
+ -- Start of processing for Is_Variable
+
+ begin
+ -- Definitely OK if Assignment_OK is set. Since this is something that
+ -- only gets set for expanded nodes, the test is on N, not Orig_Node.
+
+ if Nkind (N) in N_Subexpr and then Assignment_OK (N) then
+ return True;
+
+ -- Normally we go to the original node, but there is one exception
+ -- where we use the rewritten node, namely when it is an explicit
+ -- dereference. The generated code may rewrite a prefix which is an
+ -- access type with an explicit dereference. The dereference is a
+ -- variable, even though the original node may not be (since it could
+ -- be a constant of the access type).
+
+ elsif Nkind (N) = N_Explicit_Dereference
+ and then Nkind (Orig_Node) /= N_Explicit_Dereference
+ and then Is_Access_Type (Etype (Orig_Node))
+ then
+ return Is_Variable_Prefix (Original_Node (Prefix (N)));
+
+ -- All remaining checks use the original node
+
+ elsif Is_Entity_Name (Orig_Node) then
+ declare
+ E : constant Entity_Id := Entity (Orig_Node);
+ K : constant Entity_Kind := Ekind (E);
+
+ begin
+ return (K = E_Variable
+ and then Nkind (Parent (E)) /= N_Exception_Handler)
+ or else (K = E_Component
+ and then not In_Protected_Function (E))
+ or else K = E_Out_Parameter
+ or else K = E_In_Out_Parameter
+ or else K = E_Generic_In_Out_Parameter
+
+ -- Current instance of type:
+
+ or else (Is_Type (E) and then In_Open_Scopes (E))
+ or else (Is_Incomplete_Or_Private_Type (E)
+ and then In_Open_Scopes (Full_View (E)));
+ end;
+
+ else
+ case Nkind (Orig_Node) is
+ when N_Indexed_Component | N_Slice =>
+ return Is_Variable_Prefix (Prefix (Orig_Node));
+
+ when N_Selected_Component =>
+ return Is_Variable_Prefix (Prefix (Orig_Node))
+ and then Is_Variable (Selector_Name (Orig_Node));
+
+ -- For an explicit dereference, we must check whether the type
+ -- is ACCESS CONSTANT, since if it is, then it is not a variable.
+
+ when N_Explicit_Dereference =>
+ return Is_Access_Type (Etype (Prefix (Orig_Node)))
+ and then not
+ Is_Access_Constant (Root_Type (Etype (Prefix (Orig_Node))));
+
+ -- The type conversion is the case where we do not deal with the
+ -- context dependent special case of an actual parameter. Thus
+ -- the type conversion is only considered a variable for the
+ -- purposes of this routine if the target type is tagged. However,
+ -- a type conversion is considered to be a variable if it does not
+ -- come from source (this deals for example with the conversions
+ -- of expressions to their actual subtypes).
+
+ when N_Type_Conversion =>
+ return Is_Variable (Expression (Orig_Node))
+ and then
+ (not Comes_From_Source (Orig_Node)
+ or else
+ (Is_Tagged_Type (Etype (Subtype_Mark (Orig_Node)))
+ and then
+ Is_Tagged_Type (Etype (Expression (Orig_Node)))));
+
+ -- GNAT allows an unchecked type conversion as a variable. This
+ -- only affects the generation of internal expanded code, since
+ -- calls to instantiations of Unchecked_Conversion are never
+ -- considered variables (since they are function calls).
+ -- This is also true for expression actions.
+
+ when N_Unchecked_Type_Conversion =>
+ return Is_Variable (Expression (Orig_Node));
+
+ when others =>
+ return False;
+ end case;
+ end if;
+ end Is_Variable;
+
+ ------------------------
+ -- Is_Volatile_Object --
+ ------------------------
+
+ function Is_Volatile_Object (N : Node_Id) return Boolean is
+
+ function Object_Has_Volatile_Components (N : Node_Id) return Boolean;
+ -- Determines if given object has volatile components
+
+ function Is_Volatile_Prefix (N : Node_Id) return Boolean;
+ -- If prefix is an implicit dereference, examine designated type.
+
+ function Is_Volatile_Prefix (N : Node_Id) return Boolean is
+ begin
+ if Is_Access_Type (Etype (N)) then
+ return Has_Volatile_Components (Designated_Type (Etype (N)));
+ else
+ return Object_Has_Volatile_Components (N);
+ end if;
+ end Is_Volatile_Prefix;
+
+ function Object_Has_Volatile_Components (N : Node_Id) return Boolean is
+ begin
+ if Is_Volatile (Etype (N))
+ or else Has_Volatile_Components (Etype (N))
+ then
+ return True;
+
+ elsif Is_Entity_Name (N)
+ and then (Has_Volatile_Components (Entity (N))
+ or else Is_Volatile (Entity (N)))
+ then
+ return True;
+
+ elsif Nkind (N) = N_Indexed_Component
+ or else Nkind (N) = N_Selected_Component
+ then
+ return Is_Volatile_Prefix (Prefix (N));
+
+ else
+ return False;
+ end if;
+ end Object_Has_Volatile_Components;
+
+ -- Start of processing for Is_Volatile_Object
+
+ begin
+ if Is_Volatile (Etype (N))
+ or else (Is_Entity_Name (N) and then Is_Volatile (Entity (N)))
+ then
+ return True;
+
+ elsif Nkind (N) = N_Indexed_Component
+ or else Nkind (N) = N_Selected_Component
+ then
+ return Is_Volatile_Prefix (Prefix (N));
+
+ else
+ return False;
+ end if;
+ end Is_Volatile_Object;
+
+ --------------------------
+ -- Kill_Size_Check_Code --
+ --------------------------
+
+ procedure Kill_Size_Check_Code (E : Entity_Id) is
+ begin
+ if (Ekind (E) = E_Constant or else Ekind (E) = E_Variable)
+ and then Present (Size_Check_Code (E))
+ then
+ Remove (Size_Check_Code (E));
+ Set_Size_Check_Code (E, Empty);
+ end if;
+ end Kill_Size_Check_Code;
+
+ -------------------------
+ -- New_External_Entity --
+ -------------------------
+
+ function New_External_Entity
+ (Kind : Entity_Kind;
+ Scope_Id : Entity_Id;
+ Sloc_Value : Source_Ptr;
+ Related_Id : Entity_Id;
+ Suffix : Character;
+ Suffix_Index : Nat := 0;
+ Prefix : Character := ' ')
+ return Entity_Id
+ is
+ N : constant Entity_Id :=
+ Make_Defining_Identifier (Sloc_Value,
+ New_External_Name
+ (Chars (Related_Id), Suffix, Suffix_Index, Prefix));
+
+ begin
+ Set_Ekind (N, Kind);
+ Set_Is_Internal (N, True);
+ Append_Entity (N, Scope_Id);
+ Set_Public_Status (N);
+
+ if Kind in Type_Kind then
+ Init_Size_Align (N);
+ end if;
+
+ return N;
+ end New_External_Entity;
+
+ -------------------------
+ -- New_Internal_Entity --
+ -------------------------
+
+ function New_Internal_Entity
+ (Kind : Entity_Kind;
+ Scope_Id : Entity_Id;
+ Sloc_Value : Source_Ptr;
+ Id_Char : Character)
+ return Entity_Id
+ is
+ N : constant Entity_Id :=
+ Make_Defining_Identifier (Sloc_Value, New_Internal_Name (Id_Char));
+
+ begin
+ Set_Ekind (N, Kind);
+ Set_Is_Internal (N, True);
+ Append_Entity (N, Scope_Id);
+
+ if Kind in Type_Kind then
+ Init_Size_Align (N);
+ end if;
+
+ return N;
+ end New_Internal_Entity;
+
+ -----------------
+ -- Next_Actual --
+ -----------------
+
+ function Next_Actual (Actual_Id : Node_Id) return Node_Id is
+ N : Node_Id;
+
+ begin
+ -- If we are pointing at a positional parameter, it is a member of
+ -- a node list (the list of parameters), and the next parameter
+ -- is the next node on the list, unless we hit a parameter
+ -- association, in which case we shift to using the chain whose
+ -- head is the First_Named_Actual in the parent, and then is
+ -- threaded using the Next_Named_Actual of the Parameter_Association.
+ -- All this fiddling is because the original node list is in the
+ -- textual call order, and what we need is the declaration order.
+
+ if Is_List_Member (Actual_Id) then
+ N := Next (Actual_Id);
+
+ if Nkind (N) = N_Parameter_Association then
+ return First_Named_Actual (Parent (Actual_Id));
+ else
+ return N;
+ end if;
+
+ else
+ return Next_Named_Actual (Parent (Actual_Id));
+ end if;
+ end Next_Actual;
+
+ procedure Next_Actual (Actual_Id : in out Node_Id) is
+ begin
+ Actual_Id := Next_Actual (Actual_Id);
+ end Next_Actual;
+
+ -----------------------
+ -- Normalize_Actuals --
+ -----------------------
+
+ -- Chain actuals according to formals of subprogram. If there are
+ -- no named associations, the chain is simply the list of Parameter
+ -- Associations, since the order is the same as the declaration order.
+ -- If there are named associations, then the First_Named_Actual field
+ -- in the N_Procedure_Call_Statement node or N_Function_Call node
+ -- points to the Parameter_Association node for the parameter that
+ -- comes first in declaration order. The remaining named parameters
+ -- are then chained in declaration order using Next_Named_Actual.
+
+ -- This routine also verifies that the number of actuals is compatible
+ -- with the number and default values of formals, but performs no type
+ -- checking (type checking is done by the caller).
+
+ -- If the matching succeeds, Success is set to True, and the caller
+ -- proceeds with type-checking. If the match is unsuccessful, then
+ -- Success is set to False, and the caller attempts a different
+ -- interpretation, if there is one.
+
+ -- If the flag Report is on, the call is not overloaded, and a failure
+ -- to match can be reported here, rather than in the caller.
+
+ procedure Normalize_Actuals
+ (N : Node_Id;
+ S : Entity_Id;
+ Report : Boolean;
+ Success : out Boolean)
+ is
+ Actuals : constant List_Id := Parameter_Associations (N);
+ Actual : Node_Id := Empty;
+ Formal : Entity_Id;
+ Last : Node_Id := Empty;
+ First_Named : Node_Id := Empty;
+ Found : Boolean;
+
+ Formals_To_Match : Integer := 0;
+ Actuals_To_Match : Integer := 0;
+
+ procedure Chain (A : Node_Id);
+ -- Add named actual at the proper place in the list, using the
+ -- Next_Named_Actual link.
+
+ function Reporting return Boolean;
+ -- Determines if an error is to be reported. To report an error, we
+ -- need Report to be True, and also we do not report errors caused
+ -- by calls to Init_Proc's that occur within other Init_Proc's. Such
+ -- errors must always be cascaded errors, since if all the types are
+ -- declared correctly, the compiler will certainly build decent calls!
+
+ procedure Chain (A : Node_Id) is
+ begin
+ if No (Last) then
+
+ -- Call node points to first actual in list.
+
+ Set_First_Named_Actual (N, Explicit_Actual_Parameter (A));
+
+ else
+ Set_Next_Named_Actual (Last, Explicit_Actual_Parameter (A));
+ end if;
+
+ Last := A;
+ Set_Next_Named_Actual (Last, Empty);
+ end Chain;
+
+ function Reporting return Boolean is
+ begin
+ if not Report then
+ return False;
+
+ elsif not Within_Init_Proc then
+ return True;
+
+ elsif Chars (Entity (Name (N))) = Name_uInit_Proc then
+ return False;
+
+ else
+ return True;
+ end if;
+ end Reporting;
+
+ -- Start of processing for Normalize_Actuals
+
+ begin
+ if Is_Access_Type (S) then
+
+ -- The name in the call is a function call that returns an access
+ -- to subprogram. The designated type has the list of formals.
+
+ Formal := First_Formal (Designated_Type (S));
+ else
+ Formal := First_Formal (S);
+ end if;
+
+ while Present (Formal) loop
+ Formals_To_Match := Formals_To_Match + 1;
+ Next_Formal (Formal);
+ end loop;
+
+ -- Find if there is a named association, and verify that no positional
+ -- associations appear after named ones.
+
+ if Present (Actuals) then
+ Actual := First (Actuals);
+ end if;
+
+ while Present (Actual)
+ and then Nkind (Actual) /= N_Parameter_Association
+ loop
+ Actuals_To_Match := Actuals_To_Match + 1;
+ Next (Actual);
+ end loop;
+
+ if No (Actual) and Actuals_To_Match = Formals_To_Match then
+
+ -- Most common case: positional notation, no defaults
+
+ Success := True;
+ return;
+
+ elsif Actuals_To_Match > Formals_To_Match then
+
+ -- Too many actuals: will not work.
+
+ if Reporting then
+ Error_Msg_N ("too many arguments in call", N);
+ end if;
+
+ Success := False;
+ return;
+ end if;
+
+ First_Named := Actual;
+
+ while Present (Actual) loop
+ if Nkind (Actual) /= N_Parameter_Association then
+ Error_Msg_N
+ ("positional parameters not allowed after named ones", Actual);
+ Success := False;
+ return;
+
+ else
+ Actuals_To_Match := Actuals_To_Match + 1;
+ end if;
+
+ Next (Actual);
+ end loop;
+
+ if Present (Actuals) then
+ Actual := First (Actuals);
+ end if;
+
+ Formal := First_Formal (S);
+
+ while Present (Formal) loop
+
+ -- Match the formals in order. If the corresponding actual
+ -- is positional, nothing to do. Else scan the list of named
+ -- actuals to find the one with the right name.
+
+ if Present (Actual)
+ and then Nkind (Actual) /= N_Parameter_Association
+ then
+ Next (Actual);
+ Actuals_To_Match := Actuals_To_Match - 1;
+ Formals_To_Match := Formals_To_Match - 1;
+
+ else
+ -- For named parameters, search the list of actuals to find
+ -- one that matches the next formal name.
+
+ Actual := First_Named;
+ Found := False;
+
+ while Present (Actual) loop
+ if Chars (Selector_Name (Actual)) = Chars (Formal) then
+ Found := True;
+ Chain (Actual);
+ Actuals_To_Match := Actuals_To_Match - 1;
+ Formals_To_Match := Formals_To_Match - 1;
+ exit;
+ end if;
+
+ Next (Actual);
+ end loop;
+
+ if not Found then
+ if Ekind (Formal) /= E_In_Parameter
+ or else No (Default_Value (Formal))
+ then
+ if Reporting then
+ if Comes_From_Source (S)
+ and then Is_Overloadable (S)
+ then
+ Error_Msg_Name_1 := Chars (S);
+ Error_Msg_Sloc := Sloc (S);
+ Error_Msg_NE
+ ("missing argument for parameter & " &
+ "in call to % declared #", N, Formal);
+ else
+ Error_Msg_NE
+ ("missing argument for parameter &", N, Formal);
+ end if;
+ end if;
+
+ Success := False;
+ return;
+
+ else
+ Formals_To_Match := Formals_To_Match - 1;
+ end if;
+ end if;
+ end if;
+
+ Next_Formal (Formal);
+ end loop;
+
+ if Formals_To_Match = 0 and then Actuals_To_Match = 0 then
+ Success := True;
+ return;
+
+ else
+ if Reporting then
+
+ -- Find some superfluous named actual that did not get
+ -- attached to the list of associations.
+
+ Actual := First (Actuals);
+
+ while Present (Actual) loop
+
+ if Nkind (Actual) = N_Parameter_Association
+ and then Actual /= Last
+ and then No (Next_Named_Actual (Actual))
+ then
+ Error_Msg_N ("Unmatched actual in call", Actual);
+ exit;
+ end if;
+
+ Next (Actual);
+ end loop;
+ end if;
+
+ Success := False;
+ return;
+ end if;
+ end Normalize_Actuals;
+
+ --------------------------------
+ -- Note_Possible_Modification --
+ --------------------------------
+
+ procedure Note_Possible_Modification (N : Node_Id) is
+ Ent : Entity_Id;
+ Exp : Node_Id;
+
+ procedure Set_Ref (E : Entity_Id; N : Node_Id);
+ -- Internal routine to note modification on entity E by node N
+
+ procedure Set_Ref (E : Entity_Id; N : Node_Id) is
+ begin
+ Set_Not_Source_Assigned (E, False);
+ Set_Is_True_Constant (E, False);
+ Generate_Reference (E, N, 'm');
+ end Set_Ref;
+
+ -- Start of processing for Note_Possible_Modification
+
+ begin
+ -- Loop to find referenced entity, if there is one
+
+ Exp := N;
+ loop
+ -- Test for node rewritten as dereference (e.g. accept parameter)
+
+ if Nkind (Exp) = N_Explicit_Dereference
+ and then Is_Entity_Name (Original_Node (Exp))
+ then
+ Set_Ref (Entity (Original_Node (Exp)), Original_Node (Exp));
+ return;
+
+ elsif Is_Entity_Name (Exp) then
+ Ent := Entity (Exp);
+
+ if (Ekind (Ent) = E_Variable or else Ekind (Ent) = E_Constant)
+ and then Present (Renamed_Object (Ent))
+ then
+ Exp := Renamed_Object (Ent);
+
+ else
+ Set_Ref (Ent, Exp);
+ return;
+ end if;
+
+ elsif Nkind (Exp) = N_Type_Conversion
+ or else Nkind (Exp) = N_Unchecked_Type_Conversion
+ then
+ Exp := Expression (Exp);
+
+ elsif Nkind (Exp) = N_Slice
+ or else Nkind (Exp) = N_Indexed_Component
+ or else Nkind (Exp) = N_Selected_Component
+ then
+ Exp := Prefix (Exp);
+
+ else
+ return;
+ end if;
+ end loop;
+ end Note_Possible_Modification;
+
+ -------------------------
+ -- Object_Access_Level --
+ -------------------------
+
+ function Object_Access_Level (Obj : Node_Id) return Uint is
+ E : Entity_Id;
+
+ -- Returns the static accessibility level of the view denoted
+ -- by Obj. Note that the value returned is the result of a
+ -- call to Scope_Depth. Only scope depths associated with
+ -- dynamic scopes can actually be returned. Since only
+ -- relative levels matter for accessibility checking, the fact
+ -- that the distance between successive levels of accessibility
+ -- is not always one is immaterial (invariant: if level(E2) is
+ -- deeper than level(E1), then Scope_Depth(E1) < Scope_Depth(E2)).
+
+ begin
+ if Is_Entity_Name (Obj) then
+ E := Entity (Obj);
+
+ -- If E is a type then it denotes a current instance.
+ -- For this case we add one to the normal accessibility
+ -- level of the type to ensure that current instances
+ -- are treated as always being deeper than than the level
+ -- of any visible named access type (see 3.10.2(21)).
+
+ if Is_Type (E) then
+ return Type_Access_Level (E) + 1;
+
+ elsif Present (Renamed_Object (E)) then
+ return Object_Access_Level (Renamed_Object (E));
+
+ -- Similarly, if E is a component of the current instance of a
+ -- protected type, any instance of it is assumed to be at a deeper
+ -- level than the type. For a protected object (whose type is an
+ -- anonymous protected type) its components are at the same level
+ -- as the type itself.
+
+ elsif not Is_Overloadable (E)
+ and then Ekind (Scope (E)) = E_Protected_Type
+ and then Comes_From_Source (Scope (E))
+ then
+ return Type_Access_Level (Scope (E)) + 1;
+
+ else
+ return Scope_Depth (Enclosing_Dynamic_Scope (E));
+ end if;
+
+ elsif Nkind (Obj) = N_Selected_Component then
+ if Is_Access_Type (Etype (Prefix (Obj))) then
+ return Type_Access_Level (Etype (Prefix (Obj)));
+ else
+ return Object_Access_Level (Prefix (Obj));
+ end if;
+
+ elsif Nkind (Obj) = N_Indexed_Component then
+ if Is_Access_Type (Etype (Prefix (Obj))) then
+ return Type_Access_Level (Etype (Prefix (Obj)));
+ else
+ return Object_Access_Level (Prefix (Obj));
+ end if;
+
+ elsif Nkind (Obj) = N_Explicit_Dereference then
+
+ -- If the prefix is a selected access discriminant then
+ -- we make a recursive call on the prefix, which will
+ -- in turn check the level of the prefix object of
+ -- the selected discriminant.
+
+ if Nkind (Prefix (Obj)) = N_Selected_Component
+ and then Ekind (Etype (Prefix (Obj))) = E_Anonymous_Access_Type
+ and then
+ Ekind (Entity (Selector_Name (Prefix (Obj)))) = E_Discriminant
+ then
+ return Object_Access_Level (Prefix (Obj));
+ else
+ return Type_Access_Level (Etype (Prefix (Obj)));
+ end if;
+
+ elsif Nkind (Obj) = N_Type_Conversion then
+ return Object_Access_Level (Expression (Obj));
+
+ -- Function results are objects, so we get either the access level
+ -- of the function or, in the case of an indirect call, the level of
+ -- of the access-to-subprogram type.
+
+ elsif Nkind (Obj) = N_Function_Call then
+ if Is_Entity_Name (Name (Obj)) then
+ return Subprogram_Access_Level (Entity (Name (Obj)));
+ else
+ return Type_Access_Level (Etype (Prefix (Name (Obj))));
+ end if;
+
+ -- For convenience we handle qualified expressions, even though
+ -- they aren't technically object names.
+
+ elsif Nkind (Obj) = N_Qualified_Expression then
+ return Object_Access_Level (Expression (Obj));
+
+ -- Otherwise return the scope level of Standard.
+ -- (If there are cases that fall through
+ -- to this point they will be treated as
+ -- having global accessibility for now. ???)
+
+ else
+ return Scope_Depth (Standard_Standard);
+ end if;
+ end Object_Access_Level;
+
+ -----------------------
+ -- Private_Component --
+ -----------------------
+
+ function Private_Component (Type_Id : Entity_Id) return Entity_Id is
+ Ancestor : constant Entity_Id := Base_Type (Type_Id);
+
+ function Trace_Components
+ (T : Entity_Id;
+ Check : Boolean)
+ return Entity_Id;
+ -- Recursive function that does the work, and checks against circular
+ -- definition for each subcomponent type.
+
+ ----------------------
+ -- Trace_Components --
+ ----------------------
+
+ function Trace_Components
+ (T : Entity_Id;
+ Check : Boolean) return Entity_Id
+ is
+ Btype : constant Entity_Id := Base_Type (T);
+ Component : Entity_Id;
+ P : Entity_Id;
+ Candidate : Entity_Id := Empty;
+
+ begin
+ if Check and then Btype = Ancestor then
+ Error_Msg_N ("circular type definition", Type_Id);
+ return Any_Type;
+ end if;
+
+ if Is_Private_Type (Btype)
+ and then not Is_Generic_Type (Btype)
+ then
+ return Btype;
+
+ elsif Is_Array_Type (Btype) then
+ return Trace_Components (Component_Type (Btype), True);
+
+ elsif Is_Record_Type (Btype) then
+ Component := First_Entity (Btype);
+ while Present (Component) loop
+
+ -- skip anonymous types generated by constrained components.
+
+ if not Is_Type (Component) then
+ P := Trace_Components (Etype (Component), True);
+
+ if Present (P) then
+ if P = Any_Type then
+ return P;
+ else
+ Candidate := P;
+ end if;
+ end if;
+ end if;
+
+ Next_Entity (Component);
+ end loop;
+
+ return Candidate;
+
+ else
+ return Empty;
+ end if;
+ end Trace_Components;
+
+ -- Start of processing for Private_Component
+
+ begin
+ return Trace_Components (Type_Id, False);
+ end Private_Component;
+
+ -----------------------
+ -- Process_End_Label --
+ -----------------------
+
+ procedure Process_End_Label (N : Node_Id; Typ : Character) is
+ Loc : Source_Ptr;
+ Nam : Node_Id;
+ Ctyp : Entity_Id;
+
+ Label_Ref : Boolean;
+ -- Set True if reference to end label itself is required
+
+ Endl : Node_Id;
+ -- Gets set to the operator symbol or identifier that references
+ -- the entity Ent. For the child unit case, this is the identifier
+ -- from the designator. For other cases, this is simply Endl.
+
+ Ent : Entity_Id;
+ -- This is the entity for the construct to which the End_Label applies
+
+ procedure Generate_Parent_Ref (N : Node_Id);
+ -- N is an identifier node that appears as a parent unit reference
+ -- in the case where Ent is a child unit. This procedure generates
+ -- an appropriate cross-reference entry.
+
+ procedure Generate_Parent_Ref (N : Node_Id) is
+ Parent_Ent : Entity_Id;
+
+ begin
+ -- Search up scope stack. The reason we do this is that normal
+ -- visibility analysis would not work for two reasons. First in
+ -- some subunit cases, the entry for the parent unit may not be
+ -- visible, and in any case there can be a local entity that
+ -- hides the scope entity.
+
+ Parent_Ent := Current_Scope;
+ while Present (Parent_Ent) loop
+ if Chars (Parent_Ent) = Chars (N) then
+
+ -- Generate the reference. We do NOT consider this as a
+ -- reference for unreferenced symbol purposes, but we do
+ -- force a cross-reference even if the end line does not
+ -- come from source (the caller already generated the
+ -- appropriate Typ for this situation).
+
+ Generate_Reference
+ (Parent_Ent, N, 'r', Set_Ref => False, Force => True);
+ Style.Check_Identifier (N, Parent_Ent);
+ return;
+ end if;
+
+ Parent_Ent := Scope (Parent_Ent);
+ end loop;
+
+ -- Fall through means entity was not found -- that's odd, but
+ -- the appropriate thing is simply to ignore and not generate
+ -- any cross-reference for this entry.
+
+ return;
+ end Generate_Parent_Ref;
+
+ -- Start of processing for Process_End_Label
+
+ begin
+ -- If no node, ignore. This happens in some error situations,
+ -- and also for some internally generated structures where no
+ -- end label references are required in any case.
+
+ if No (N) then
+ return;
+ end if;
+
+ -- Nothing to do if no End_Label, happens for internally generated
+ -- constructs where we don't want an end label reference anyway.
+
+ Endl := End_Label (N);
+
+ if No (Endl) then
+ return;
+ end if;
+
+ -- Reference node is not in extended main source unit
+
+ if not In_Extended_Main_Source_Unit (N) then
+
+ -- Generally we do not collect references except for the
+ -- extended main source unit. The one exception is the 'e'
+ -- entry for a package spec, where it is useful for a client
+ -- to have the ending information to define scopes.
+
+ if Typ /= 'e' then
+ return;
+
+ else
+ Label_Ref := False;
+
+ -- For this case, we can ignore any parent references,
+ -- but we need the package name itself for the 'e' entry.
+
+ if Nkind (Endl) = N_Designator then
+ Endl := Identifier (Endl);
+ end if;
+ end if;
+
+ -- Reference is in extended main source unit
+
+ else
+ Label_Ref := True;
+
+ -- For designator, generate references for the parent entries
+
+ if Nkind (Endl) = N_Designator then
+
+ -- Generate references for the prefix if the END line comes
+ -- from source (otherwise we do not need these references)
+
+ if Comes_From_Source (Endl) then
+ Nam := Name (Endl);
+ while Nkind (Nam) = N_Selected_Component loop
+ Generate_Parent_Ref (Selector_Name (Nam));
+ Nam := Prefix (Nam);
+ end loop;
+
+ Generate_Parent_Ref (Nam);
+ end if;
+
+ Endl := Identifier (Endl);
+ end if;
+ end if;
+
+ -- Locate the entity to which the end label applies. Most of the
+ -- time this is simply the current scope containing the construct.
+
+ Ent := Current_Scope;
+
+ if Chars (Ent) = Chars (Endl) then
+ null;
+
+ -- But in the case of single tasks and single protected objects,
+ -- the current scope is the anonymous task or protected type and
+ -- what we want is the object. There is no direct link so what we
+ -- do is search ahead in the entity chain for the object with the
+ -- matching type and name. In practice it is almost certain to be
+ -- the very next entity on the chain, so this is not inefficient.
+
+ else
+ Ctyp := Etype (Ent);
+ loop
+ Next_Entity (Ent);
+
+ -- If we don't find the entry we are looking for, that's
+ -- odd, perhaps results from some error condition? Anyway
+ -- the appropriate thing is just to abandon the attempt.
+
+ if No (Ent) then
+ return;
+
+ -- Exit if we find the entity we are looking for
+
+ elsif Etype (Ent) = Ctyp
+ and then Chars (Ent) = Chars (Endl)
+ then
+ exit;
+ end if;
+ end loop;
+ end if;
+
+ -- If label was really there, then generate a normal reference
+ -- and then adjust the location in the end label to point past
+ -- the name (which should almost always be the semicolon).
+
+ Loc := Sloc (Endl);
+
+ if Comes_From_Source (Endl) then
+
+ -- If a label reference is required, then do the style check
+ -- and generate a normal cross-reference entry for the label
+
+ if Label_Ref then
+ Style.Check_Identifier (Endl, Ent);
+ Generate_Reference (Ent, Endl, 'r', Set_Ref => False);
+ end if;
+
+ -- Set the location to point past the label (normally this will
+ -- mean the semicolon immediately following the label). This is
+ -- done for the sake of the 'e' or 't' entry generated below.
+
+ Get_Decoded_Name_String (Chars (Endl));
+ Set_Sloc (Endl, Sloc (Endl) + Source_Ptr (Name_Len));
+ end if;
+
+ -- Now generate the e/t reference
+
+ Generate_Reference (Ent, Endl, Typ, Set_Ref => False, Force => True);
+
+ -- Restore Sloc, in case modified above, since we have an identifier
+ -- and the normal Sloc should be left set in the tree.
+
+ Set_Sloc (Endl, Loc);
+ end Process_End_Label;
+
+ ------------------
+ -- Real_Convert --
+ ------------------
+
+ -- We do the conversion to get the value of the real string by using
+ -- the scanner, see Sinput for details on use of the internal source
+ -- buffer for scanning internal strings.
+
+ function Real_Convert (S : String) return Node_Id is
+ Save_Src : constant Source_Buffer_Ptr := Source;
+ Negative : Boolean;
+
+ begin
+ Source := Internal_Source_Ptr;
+ Scan_Ptr := 1;
+
+ for J in S'Range loop
+ Source (Source_Ptr (J)) := S (J);
+ end loop;
+
+ Source (S'Length + 1) := EOF;
+
+ if Source (Scan_Ptr) = '-' then
+ Negative := True;
+ Scan_Ptr := Scan_Ptr + 1;
+ else
+ Negative := False;
+ end if;
+
+ Scan;
+
+ if Negative then
+ Set_Realval (Token_Node, UR_Negate (Realval (Token_Node)));
+ end if;
+
+ Source := Save_Src;
+ return Token_Node;
+ end Real_Convert;
+
+ ------------------------------
+ -- Requires_Transient_Scope --
+ ------------------------------
+
+ -- A transient scope is required when variable-sized temporaries are
+ -- allocated in the primary or secondary stack, or when finalization
+ -- actions must be generated before the next instruction
+
+ function Requires_Transient_Scope (Id : Entity_Id) return Boolean is
+ Typ : constant Entity_Id := Underlying_Type (Id);
+
+ begin
+ -- This is a private type which is not completed yet. This can only
+ -- happen in a default expression (of a formal parameter or of a
+ -- record component). Do not expand transient scope in this case
+
+ if No (Typ) then
+ return False;
+
+ elsif Typ = Standard_Void_Type then
+ return False;
+
+ -- The back-end has trouble allocating variable-size temporaries so
+ -- we generate them in the front-end and need a transient scope to
+ -- reclaim them properly
+
+ elsif not Size_Known_At_Compile_Time (Typ) then
+ return True;
+
+ -- Unconstrained discriminated records always require a variable
+ -- length temporary, since the length may depend on the variant.
+
+ elsif Is_Record_Type (Typ)
+ and then Has_Discriminants (Typ)
+ and then not Is_Constrained (Typ)
+ then
+ return True;
+
+ -- Functions returning tagged types may dispatch on result so their
+ -- returned value is allocated on the secondary stack. Controlled
+ -- type temporaries need finalization.
+
+ elsif Is_Tagged_Type (Typ)
+ or else Has_Controlled_Component (Typ)
+ then
+ return True;
+
+ -- Unconstrained array types are returned on the secondary stack
+
+ elsif Is_Array_Type (Typ) then
+ return not Is_Constrained (Typ);
+ end if;
+
+ return False;
+ end Requires_Transient_Scope;
+
+ --------------------------
+ -- Reset_Analyzed_Flags --
+ --------------------------
+
+ procedure Reset_Analyzed_Flags (N : Node_Id) is
+
+ function Clear_Analyzed
+ (N : Node_Id)
+ return Traverse_Result;
+ -- Function used to reset Analyzed flags in tree. Note that we do
+ -- not reset Analyzed flags in entities, since there is no need to
+ -- renalalyze entities, and indeed, it is wrong to do so, since it
+ -- can result in generating auxiliary stuff more than once.
+
+ function Clear_Analyzed
+ (N : Node_Id)
+ return Traverse_Result
+ is
+ begin
+ if not Has_Extension (N) then
+ Set_Analyzed (N, False);
+ end if;
+
+ return OK;
+ end Clear_Analyzed;
+
+ function Reset_Analyzed is
+ new Traverse_Func (Clear_Analyzed);
+
+ Discard : Traverse_Result;
+
+ -- Start of processing for Reset_Analyzed_Flags
+
+ begin
+ Discard := Reset_Analyzed (N);
+ end Reset_Analyzed_Flags;
+
+ ---------------
+ -- Same_Name --
+ ---------------
+
+ function Same_Name (N1, N2 : Node_Id) return Boolean is
+ K1 : constant Node_Kind := Nkind (N1);
+ K2 : constant Node_Kind := Nkind (N2);
+
+ begin
+ if (K1 = N_Identifier or else K1 = N_Defining_Identifier)
+ and then (K2 = N_Identifier or else K2 = N_Defining_Identifier)
+ then
+ return Chars (N1) = Chars (N2);
+
+ elsif (K1 = N_Selected_Component or else K1 = N_Expanded_Name)
+ and then (K2 = N_Selected_Component or else K2 = N_Expanded_Name)
+ then
+ return Same_Name (Selector_Name (N1), Selector_Name (N2))
+ and then Same_Name (Prefix (N1), Prefix (N2));
+
+ else
+ return False;
+ end if;
+ end Same_Name;
+
+ ---------------
+ -- Same_Type --
+ ---------------
+
+ function Same_Type (T1, T2 : Entity_Id) return Boolean is
+ begin
+ if T1 = T2 then
+ return True;
+
+ elsif not Is_Constrained (T1)
+ and then not Is_Constrained (T2)
+ and then Base_Type (T1) = Base_Type (T2)
+ then
+ return True;
+
+ -- For now don't bother with case of identical constraints, to be
+ -- fiddled with later on perhaps (this is only used for optimization
+ -- purposes, so it is not critical to do a best possible job)
+
+ else
+ return False;
+ end if;
+ end Same_Type;
+
+ ------------------------
+ -- Scope_Is_Transient --
+ ------------------------
+
+ function Scope_Is_Transient return Boolean is
+ begin
+ return Scope_Stack.Table (Scope_Stack.Last).Is_Transient;
+ end Scope_Is_Transient;
+
+ ------------------
+ -- Scope_Within --
+ ------------------
+
+ function Scope_Within (Scope1, Scope2 : Entity_Id) return Boolean is
+ Scop : Entity_Id;
+
+ begin
+ Scop := Scope1;
+ while Scop /= Standard_Standard loop
+ Scop := Scope (Scop);
+
+ if Scop = Scope2 then
+ return True;
+ end if;
+ end loop;
+
+ return False;
+ end Scope_Within;
+
+ --------------------------
+ -- Scope_Within_Or_Same --
+ --------------------------
+
+ function Scope_Within_Or_Same (Scope1, Scope2 : Entity_Id) return Boolean is
+ Scop : Entity_Id;
+
+ begin
+ Scop := Scope1;
+ while Scop /= Standard_Standard loop
+ if Scop = Scope2 then
+ return True;
+ else
+ Scop := Scope (Scop);
+ end if;
+ end loop;
+
+ return False;
+ end Scope_Within_Or_Same;
+
+ ------------------------
+ -- Set_Current_Entity --
+ ------------------------
+
+ -- The given entity is to be set as the currently visible definition
+ -- of its associated name (i.e. the Node_Id associated with its name).
+ -- All we have to do is to get the name from the identifier, and
+ -- then set the associated Node_Id to point to the given entity.
+
+ procedure Set_Current_Entity (E : Entity_Id) is
+ begin
+ Set_Name_Entity_Id (Chars (E), E);
+ end Set_Current_Entity;
+
+ ---------------------------------
+ -- Set_Entity_With_Style_Check --
+ ---------------------------------
+
+ procedure Set_Entity_With_Style_Check (N : Node_Id; Val : Entity_Id) is
+ Val_Actual : Entity_Id;
+ Nod : Node_Id;
+
+ begin
+ Set_Entity (N, Val);
+
+ if Style_Check
+ and then not Suppress_Style_Checks (Val)
+ and then not In_Instance
+ then
+ if Nkind (N) = N_Identifier then
+ Nod := N;
+
+ elsif Nkind (N) = N_Expanded_Name then
+ Nod := Selector_Name (N);
+
+ else
+ return;
+ end if;
+
+ Val_Actual := Val;
+
+ -- A special situation arises for derived operations, where we want
+ -- to do the check against the parent (since the Sloc of the derived
+ -- operation points to the derived type declaration itself).
+
+ while not Comes_From_Source (Val_Actual)
+ and then Nkind (Val_Actual) in N_Entity
+ and then (Ekind (Val_Actual) = E_Enumeration_Literal
+ or else Ekind (Val_Actual) = E_Function
+ or else Ekind (Val_Actual) = E_Generic_Function
+ or else Ekind (Val_Actual) = E_Procedure
+ or else Ekind (Val_Actual) = E_Generic_Procedure)
+ and then Present (Alias (Val_Actual))
+ loop
+ Val_Actual := Alias (Val_Actual);
+ end loop;
+
+ -- Renaming declarations for generic actuals do not come from source,
+ -- and have a different name from that of the entity they rename, so
+ -- there is no style check to perform here.
+
+ if Chars (Nod) = Chars (Val_Actual) then
+ Style.Check_Identifier (Nod, Val_Actual);
+ end if;
+
+ end if;
+
+ Set_Entity (N, Val);
+ end Set_Entity_With_Style_Check;
+
+ ------------------------
+ -- Set_Name_Entity_Id --
+ ------------------------
+
+ procedure Set_Name_Entity_Id (Id : Name_Id; Val : Entity_Id) is
+ begin
+ Set_Name_Table_Info (Id, Int (Val));
+ end Set_Name_Entity_Id;
+
+ ---------------------
+ -- Set_Next_Actual --
+ ---------------------
+
+ procedure Set_Next_Actual (Ass1_Id : Node_Id; Ass2_Id : Node_Id) is
+ begin
+ if Nkind (Parent (Ass1_Id)) = N_Parameter_Association then
+ Set_First_Named_Actual (Parent (Ass1_Id), Ass2_Id);
+ end if;
+ end Set_Next_Actual;
+
+ -----------------------
+ -- Set_Public_Status --
+ -----------------------
+
+ procedure Set_Public_Status (Id : Entity_Id) is
+ S : constant Entity_Id := Current_Scope;
+
+ begin
+ if S = Standard_Standard
+ or else (Is_Public (S)
+ and then (Ekind (S) = E_Package
+ or else Is_Record_Type (S)
+ or else Ekind (S) = E_Void))
+ then
+ Set_Is_Public (Id);
+
+ -- The bounds of an entry family declaration can generate object
+ -- declarations that are visible to the back-end, e.g. in the
+ -- the declaration of a composite type that contains tasks.
+
+ elsif Is_Public (S)
+ and then Is_Concurrent_Type (S)
+ and then not Has_Completion (S)
+ and then Nkind (Parent (Id)) = N_Object_Declaration
+ then
+ Set_Is_Public (Id);
+ end if;
+ end Set_Public_Status;
+
+ ----------------------------
+ -- Set_Scope_Is_Transient --
+ ----------------------------
+
+ procedure Set_Scope_Is_Transient (V : Boolean := True) is
+ begin
+ Scope_Stack.Table (Scope_Stack.Last).Is_Transient := V;
+ end Set_Scope_Is_Transient;
+
+ -------------------
+ -- Set_Size_Info --
+ -------------------
+
+ procedure Set_Size_Info (T1, T2 : Entity_Id) is
+ begin
+ -- We copy Esize, but not RM_Size, since in general RM_Size is
+ -- subtype specific and does not get inherited by all subtypes.
+
+ Set_Esize (T1, Esize (T2));
+ Set_Has_Biased_Representation (T1, Has_Biased_Representation (T2));
+
+ if Is_Discrete_Or_Fixed_Point_Type (T1)
+ and then
+ Is_Discrete_Or_Fixed_Point_Type (T2)
+ then
+ Set_Is_Unsigned_Type (T1, Is_Unsigned_Type (T2));
+ end if;
+
+ Set_Alignment (T1, Alignment (T2));
+ end Set_Size_Info;
+
+ --------------------
+ -- Static_Integer --
+ --------------------
+
+ function Static_Integer (N : Node_Id) return Uint is
+ begin
+ Analyze_And_Resolve (N, Any_Integer);
+
+ if N = Error
+ or else Error_Posted (N)
+ or else Etype (N) = Any_Type
+ then
+ return No_Uint;
+ end if;
+
+ if Is_Static_Expression (N) then
+ if not Raises_Constraint_Error (N) then
+ return Expr_Value (N);
+ else
+ return No_Uint;
+ end if;
+
+ elsif Etype (N) = Any_Type then
+ return No_Uint;
+
+ else
+ Error_Msg_N ("static integer expression required here", N);
+ return No_Uint;
+ end if;
+ end Static_Integer;
+
+ --------------------------
+ -- Statically_Different --
+ --------------------------
+
+ function Statically_Different (E1, E2 : Node_Id) return Boolean is
+ R1 : constant Node_Id := Get_Referenced_Object (E1);
+ R2 : constant Node_Id := Get_Referenced_Object (E2);
+
+ begin
+ return Is_Entity_Name (R1)
+ and then Is_Entity_Name (R2)
+ and then Entity (R1) /= Entity (R2)
+ and then not Is_Formal (Entity (R1))
+ and then not Is_Formal (Entity (R2));
+ end Statically_Different;
+
+ -----------------------------
+ -- Subprogram_Access_Level --
+ -----------------------------
+
+ function Subprogram_Access_Level (Subp : Entity_Id) return Uint is
+ begin
+ if Present (Alias (Subp)) then
+ return Subprogram_Access_Level (Alias (Subp));
+ else
+ return Scope_Depth (Enclosing_Dynamic_Scope (Subp));
+ end if;
+ end Subprogram_Access_Level;
+
+ -----------------
+ -- Trace_Scope --
+ -----------------
+
+ procedure Trace_Scope (N : Node_Id; E : Entity_Id; Msg : String) is
+ begin
+ if Debug_Flag_W then
+ for J in 0 .. Scope_Stack.Last loop
+ Write_Str (" ");
+ end loop;
+
+ Write_Str (Msg);
+ Write_Name (Chars (E));
+ Write_Str (" line ");
+ Write_Int (Int (Get_Logical_Line_Number (Sloc (N))));
+ Write_Eol;
+ end if;
+ end Trace_Scope;
+
+ -----------------------
+ -- Transfer_Entities --
+ -----------------------
+
+ procedure Transfer_Entities (From : Entity_Id; To : Entity_Id) is
+ Ent : Entity_Id := First_Entity (From);
+
+ begin
+ if No (Ent) then
+ return;
+ end if;
+
+ if (Last_Entity (To)) = Empty then
+ Set_First_Entity (To, Ent);
+ else
+ Set_Next_Entity (Last_Entity (To), Ent);
+ end if;
+
+ Set_Last_Entity (To, Last_Entity (From));
+
+ while Present (Ent) loop
+ Set_Scope (Ent, To);
+
+ if not Is_Public (Ent) then
+ Set_Public_Status (Ent);
+
+ if Is_Public (Ent)
+ and then Ekind (Ent) = E_Record_Subtype
+
+ then
+ -- The components of the propagated Itype must be public
+ -- as well.
+
+ declare
+ Comp : Entity_Id;
+
+ begin
+ Comp := First_Entity (Ent);
+
+ while Present (Comp) loop
+ Set_Is_Public (Comp);
+ Next_Entity (Comp);
+ end loop;
+ end;
+ end if;
+ end if;
+
+ Next_Entity (Ent);
+ end loop;
+
+ Set_First_Entity (From, Empty);
+ Set_Last_Entity (From, Empty);
+ end Transfer_Entities;
+
+ -----------------------
+ -- Type_Access_Level --
+ -----------------------
+
+ function Type_Access_Level (Typ : Entity_Id) return Uint is
+ Btyp : Entity_Id := Base_Type (Typ);
+
+ begin
+ -- If the type is an anonymous access type we treat it as being
+ -- declared at the library level to ensure that names such as
+ -- X.all'access don't fail static accessibility checks.
+
+ if Ekind (Btyp) in Access_Kind then
+ if Ekind (Btyp) = E_Anonymous_Access_Type then
+ return Scope_Depth (Standard_Standard);
+ end if;
+
+ Btyp := Root_Type (Btyp);
+ end if;
+
+ return Scope_Depth (Enclosing_Dynamic_Scope (Btyp));
+ end Type_Access_Level;
+
+ --------------------------
+ -- Unit_Declaration_Node --
+ --------------------------
+
+ function Unit_Declaration_Node (Unit_Id : Entity_Id) return Node_Id is
+ N : Node_Id := Parent (Unit_Id);
+
+ begin
+ -- Predefined operators do not have a full function declaration.
+
+ if Ekind (Unit_Id) = E_Operator then
+ return N;
+ end if;
+
+ while Nkind (N) /= N_Abstract_Subprogram_Declaration
+ and then Nkind (N) /= N_Formal_Package_Declaration
+ and then Nkind (N) /= N_Formal_Subprogram_Declaration
+ and then Nkind (N) /= N_Function_Instantiation
+ and then Nkind (N) /= N_Generic_Package_Declaration
+ and then Nkind (N) /= N_Generic_Subprogram_Declaration
+ and then Nkind (N) /= N_Package_Declaration
+ and then Nkind (N) /= N_Package_Body
+ and then Nkind (N) /= N_Package_Instantiation
+ and then Nkind (N) /= N_Package_Renaming_Declaration
+ and then Nkind (N) /= N_Procedure_Instantiation
+ and then Nkind (N) /= N_Subprogram_Declaration
+ and then Nkind (N) /= N_Subprogram_Body
+ and then Nkind (N) /= N_Subprogram_Body_Stub
+ and then Nkind (N) /= N_Subprogram_Renaming_Declaration
+ and then Nkind (N) /= N_Task_Body
+ and then Nkind (N) /= N_Task_Type_Declaration
+ and then Nkind (N) not in N_Generic_Renaming_Declaration
+ loop
+ N := Parent (N);
+ pragma Assert (Present (N));
+ end loop;
+
+ return N;
+ end Unit_Declaration_Node;
+
+ ----------------------
+ -- Within_Init_Proc --
+ ----------------------
+
+ function Within_Init_Proc return Boolean is
+ S : Entity_Id;
+
+ begin
+ S := Current_Scope;
+ while not Is_Overloadable (S) loop
+ if S = Standard_Standard then
+ return False;
+ else
+ S := Scope (S);
+ end if;
+ end loop;
+
+ return Chars (S) = Name_uInit_Proc;
+ end Within_Init_Proc;
+
+ ----------------
+ -- Wrong_Type --
+ ----------------
+
+ procedure Wrong_Type (Expr : Node_Id; Expected_Type : Entity_Id) is
+ Found_Type : constant Entity_Id := First_Subtype (Etype (Expr));
+ Expec_Type : constant Entity_Id := First_Subtype (Expected_Type);
+
+ function Has_One_Matching_Field return Boolean;
+ -- Determines whether Expec_Type is a record type with a single
+ -- component or discriminant whose type matches the found type or
+ -- is a one dimensional array whose component type matches the
+ -- found type.
+
+ function Has_One_Matching_Field return Boolean is
+ E : Entity_Id;
+
+ begin
+ if Is_Array_Type (Expec_Type)
+ and then Number_Dimensions (Expec_Type) = 1
+ and then
+ Covers (Etype (Component_Type (Expec_Type)), Found_Type)
+ then
+ return True;
+
+ elsif not Is_Record_Type (Expec_Type) then
+ return False;
+
+ else
+ E := First_Entity (Expec_Type);
+
+ loop
+ if No (E) then
+ return False;
+
+ elsif (Ekind (E) /= E_Discriminant
+ and then Ekind (E) /= E_Component)
+ or else (Chars (E) = Name_uTag
+ or else Chars (E) = Name_uParent)
+ then
+ Next_Entity (E);
+
+ else
+ exit;
+ end if;
+ end loop;
+
+ if not Covers (Etype (E), Found_Type) then
+ return False;
+
+ elsif Present (Next_Entity (E)) then
+ return False;
+
+ else
+ return True;
+ end if;
+ end if;
+ end Has_One_Matching_Field;
+
+ -- Start of processing for Wrong_Type
+
+ begin
+ -- Don't output message if either type is Any_Type, or if a message
+ -- has already been posted for this node. We need to do the latter
+ -- check explicitly (it is ordinarily done in Errout), because we
+ -- are using ! to force the output of the error messages.
+
+ if Expec_Type = Any_Type
+ or else Found_Type = Any_Type
+ or else Error_Posted (Expr)
+ then
+ return;
+
+ -- In an instance, there is an ongoing problem with completion of
+ -- type derived from private types. Their structure is what Gigi
+ -- expects, but the Etype is the parent type rather than the
+ -- derived private type itself. Do not flag error in this case. The
+ -- private completion is an entity without a parent, like an Itype.
+ -- Similarly, full and partial views may be incorrect in the instance.
+ -- There is no simple way to insure that it is consistent ???
+
+ elsif In_Instance then
+
+ if Etype (Etype (Expr)) = Etype (Expected_Type)
+ and then No (Parent (Expected_Type))
+ then
+ return;
+ end if;
+ end if;
+
+ -- An interesting special check. If the expression is parenthesized
+ -- and its type corresponds to the type of the sole component of the
+ -- expected record type, or to the component type of the expected one
+ -- dimensional array type, then assume we have a bad aggregate attempt.
+
+ if Nkind (Expr) in N_Subexpr
+ and then Paren_Count (Expr) /= 0
+ and then Has_One_Matching_Field
+ then
+ Error_Msg_N ("positional aggregate cannot have one component", Expr);
+
+ -- Another special check, if we are looking for a pool-specific access
+ -- type and we found an E_Access_Attribute_Type, then we have the case
+ -- of an Access attribute being used in a context which needs a pool-
+ -- specific type, which is never allowed. The one extra check we make
+ -- is that the expected designated type covers the Found_Type.
+
+ elsif Is_Access_Type (Expec_Type)
+ and then Ekind (Found_Type) = E_Access_Attribute_Type
+ and then Ekind (Base_Type (Expec_Type)) /= E_General_Access_Type
+ and then Ekind (Base_Type (Expec_Type)) /= E_Anonymous_Access_Type
+ and then Covers
+ (Designated_Type (Expec_Type), Designated_Type (Found_Type))
+ then
+ Error_Msg_N ("result must be general access type!", Expr);
+ Error_Msg_NE ("add ALL to }!", Expr, Expec_Type);
+
+ -- If the expected type is an anonymous access type, as for access
+ -- parameters and discriminants, the error is on the designated types.
+
+ elsif Ekind (Expec_Type) = E_Anonymous_Access_Type then
+ if Comes_From_Source (Expec_Type) then
+ Error_Msg_NE ("expected}!", Expr, Expec_Type);
+ else
+ Error_Msg_NE
+ ("expected an access type with designated}",
+ Expr, Designated_Type (Expec_Type));
+ end if;
+
+ if Is_Access_Type (Found_Type)
+ and then not Comes_From_Source (Found_Type)
+ then
+ Error_Msg_NE
+ ("found an access type with designated}!",
+ Expr, Designated_Type (Found_Type));
+ else
+ if From_With_Type (Found_Type) then
+ Error_Msg_NE ("found incomplete}!", Expr, Found_Type);
+ Error_Msg_NE
+ ("\possibly missing with_clause on&", Expr,
+ Scope (Found_Type));
+ else
+ Error_Msg_NE ("found}!", Expr, Found_Type);
+ end if;
+ end if;
+
+ -- Normal case of one type found, some other type expected
+
+ else
+ -- If the names of the two types are the same, see if some
+ -- number of levels of qualification will help. Don't try
+ -- more than three levels, and if we get to standard, it's
+ -- no use (and probably represents an error in the compiler)
+ -- Also do not bother with internal scope names.
+
+ declare
+ Expec_Scope : Entity_Id;
+ Found_Scope : Entity_Id;
+
+ begin
+ Expec_Scope := Expec_Type;
+ Found_Scope := Found_Type;
+
+ for Levels in Int range 0 .. 3 loop
+ if Chars (Expec_Scope) /= Chars (Found_Scope) then
+ Error_Msg_Qual_Level := Levels;
+ exit;
+ end if;
+
+ Expec_Scope := Scope (Expec_Scope);
+ Found_Scope := Scope (Found_Scope);
+
+ exit when Expec_Scope = Standard_Standard
+ or else
+ Found_Scope = Standard_Standard
+ or else
+ not Comes_From_Source (Expec_Scope)
+ or else
+ not Comes_From_Source (Found_Scope);
+ end loop;
+ end;
+
+ Error_Msg_NE ("expected}!", Expr, Expec_Type);
+
+ if Is_Entity_Name (Expr)
+ and then Is_Package (Entity (Expr))
+ then
+ Error_Msg_N ("found package name!", Expr);
+
+ elsif Is_Entity_Name (Expr)
+ and then
+ (Ekind (Entity (Expr)) = E_Procedure
+ or else
+ Ekind (Entity (Expr)) = E_Generic_Procedure)
+ then
+ Error_Msg_N ("found procedure name instead of function!", Expr);
+
+ -- catch common error: a prefix or infix operator which is not
+ -- directly visible because the type isn't.
+
+ elsif Nkind (Expr) in N_Op
+ and then Is_Overloaded (Expr)
+ and then not Is_Immediately_Visible (Expec_Type)
+ and then not Is_Potentially_Use_Visible (Expec_Type)
+ and then not In_Use (Expec_Type)
+ and then Has_Compatible_Type (Right_Opnd (Expr), Expec_Type)
+ then
+ Error_Msg_N (
+ "operator of the type is not directly visible!", Expr);
+
+ else
+ Error_Msg_NE ("found}!", Expr, Found_Type);
+ end if;
+
+ Error_Msg_Qual_Level := 0;
+ end if;
+ end Wrong_Type;
+
+end Sem_Util;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S E M _ U T I L --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.225 $
+-- --
+-- 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). --
+-- --
+------------------------------------------------------------------------------
+
+-- Package containing utility procedures used throughout the semantics
+
+with Einfo; use Einfo;
+with Types; use Types;
+with Uintp; use Uintp;
+with Urealp; use Urealp;
+
+package Sem_Util is
+
+ procedure Add_Access_Type_To_Process (E : Entity_Id; A : Entity_Id);
+ -- Add A to the list of access types to process when expanding the
+ -- freeze node of E.
+
+ function Alignment_In_Bits (E : Entity_Id) return Uint;
+ -- If the alignment of the type or object E is currently known to the
+ -- compiler, then this function returns the alignment value in bits.
+ -- Otherwise Uint_0 is returned, indicating that the alignment of the
+ -- entity is not yet known to the compiler.
+
+ procedure Apply_Compile_Time_Constraint_Error
+ (N : Node_Id;
+ Msg : String;
+ Ent : Entity_Id := Empty;
+ Typ : Entity_Id := Empty;
+ Loc : Source_Ptr := No_Location;
+ Rep : Boolean := True);
+ -- N is a subexpression which will raise constraint error when evaluated
+ -- at runtime. Msg is a message that explains the reason for raising the
+ -- exception. The last character is ? if the message is always a
+ -- warning, even in Ada 95, and is not a ? if the message represents an
+ -- illegality (because of violation of static expression rules) in Ada 95
+ -- (but not in Ada 83). Typically this routine posts all messages at
+ -- the Sloc of node N. However, if Loc /= No_Location, Loc is the Sloc
+ -- used to output the message. After posting the appropriate message,
+ -- and if the flag Rep is set, this routine replaces the expression
+ -- with an N_Raise_Constraint_Error node. This node is then marked as
+ -- being static if the original node is static, but sets the flag
+ -- Raises_Constraint_Error, preventing further evaluation.
+ -- The error message may contain a } or & insertion character.
+ -- This normally references Etype (N), unless the Ent argument is given
+ -- explicitly, in which case it is used instead. The type of the raise
+ -- node that is built is normally Etype (N), but if the Typ parameter
+ -- is present, this is used instead.
+
+ function Build_Actual_Subtype
+ (T : Entity_Id;
+ N : Node_Or_Entity_Id)
+ return Node_Id;
+ -- Build an anonymous subtype for an entity or expression, using the
+ -- bounds of the entity or the discriminants of the enclosing record.
+ -- T is the type for which the actual subtype is required, and N is either
+ -- a defining identifier, or any subexpression.
+
+ function Build_Actual_Subtype_Of_Component
+ (T : Entity_Id;
+ N : Node_Id)
+ return Node_Id;
+ -- Determine whether a selected component has a type that depends on
+ -- discriminants, and build actual subtype for it if so.
+
+ function Build_Discriminal_Subtype_Of_Component
+ (T : Entity_Id)
+ return Node_Id;
+ -- Determine whether a record component has a type that depends on
+ -- discriminants, and build actual subtype for it if so.
+
+ procedure Build_Elaboration_Entity (N : Node_Id; Spec_Id : Entity_Id);
+ -- Given a compilation unit node N, allocate an elaboration boolean for
+ -- the compilation unit, and install it in the Elaboration_Entity field
+ -- of Spec_Id, the entity for the compilation unit.
+
+ procedure Check_Fully_Declared (T : Entity_Id; N : Node_Id);
+ -- Verify that the full declaration of type T has been seen. If not,
+ -- place error message on node N. Used in object declarations, type
+ -- conversions, qualified expressions.
+
+ procedure Check_Potentially_Blocking_Operation (N : Node_Id);
+ -- N is one of the statement forms that is a potentially blocking
+ -- operation. If it appears within a protected action, emit warning
+ -- and raise Program_Error.
+
+ procedure Check_VMS (Construct : Node_Id);
+ -- Check that this the target is OpenVMS, and if so, return with
+ -- no effect, otherwise post an error noting this can only be used
+ -- with OpenVMS ports. The argument is the construct in question
+ -- and is used to post the error message.
+
+ function Collect_Primitive_Operations (T : Entity_Id) return Elist_Id;
+ -- Called upon type derivation and extension. We scan the declarative
+ -- part in which the type appears, and collect subprograms that have
+ -- one subsidiary subtype of the type. These subprograms can only
+ -- appear after the type itself.
+
+ function Compile_Time_Constraint_Error
+ (N : Node_Id;
+ Msg : String;
+ Ent : Entity_Id := Empty;
+ Loc : Source_Ptr := No_Location)
+ return Node_Id;
+ -- Subsidiary to Apply_Compile_Time_Constraint_Error and Checks routines.
+ -- Does not modify any nodes, but generates a warning (or error) message.
+ -- For convenience, the function always returns its first argument.
+
+ procedure Conditional_Delay (New_Ent, Old_Ent : Entity_Id);
+ -- Sets the Has_Delayed_Freeze flag of New if the Delayed_Freeze flag
+ -- of Old is set and Old has no yet been Frozen (i.e. Is_Frozen is false);
+
+ function Current_Entity (N : Node_Id) return Entity_Id;
+ -- Find the currently visible definition for a given identifier, that is to
+ -- say the first entry in the visibility chain for the Chars of N.
+
+ function Current_Entity_In_Scope (N : Node_Id) return Entity_Id;
+ -- Find whether there is a previous definition for identifier N in the
+ -- current scope. Because declarations for a scope are not necessarily
+ -- contiguous (e.g. for packages) the first entry on the visibility chain
+ -- for N is not necessarily in the current scope.
+
+ function Current_Scope return Entity_Id;
+ -- Get entity representing current scope
+
+ function Current_Subprogram return Entity_Id;
+ -- Returns current enclosing subprogram. If Current_Scope is a subprogram,
+ -- then that is what is returned, otherwise the Enclosing_Subprogram of
+ -- the Current_Scope is returned. The returned value is Empty if this
+ -- is called from a library package which is not within any subprogram.
+
+ function Defining_Entity (N : Node_Id) return Entity_Id;
+ -- Given a declaration N, returns the associated defining entity. If
+ -- the declaration has a specification, the entity is obtained from
+ -- the specification. If the declaration has a defining unit name,
+ -- then the defining entity is obtained from the defining unit name
+ -- ignoring any child unit prefixes.
+
+ function Denotes_Discriminant (N : Node_Id) return Boolean;
+ -- Returns True if node N is an N_Identifier node for a discriminant.
+ -- Returns False for any other kind of node, or for an N_Identifier
+ -- node that does not denote a discriminant.
+
+ function Depends_On_Discriminant (N : Node_Id) return Boolean;
+ -- Returns True if N denotes a discriminant or if N is a range, a subtype
+ -- indication or a scalar subtype where one of the bounds is a
+ -- discriminant.
+
+ function Designate_Same_Unit
+ (Name1 : Node_Id;
+ Name2 : Node_Id)
+ return Boolean;
+ -- Return true if Name1 and Name2 designate the same unit name;
+ -- each of these names is supposed to be a selected component name,
+ -- an expanded name, a defining program unit name or an identifier
+
+ function Enclosing_Generic_Body
+ (E : Entity_Id)
+ return Node_Id;
+ -- Returns the Node_Id associated with the innermost enclosing
+ -- generic body, if any. If none, then returns Empty.
+
+ function Enclosing_Lib_Unit_Entity return Entity_Id;
+ -- Returns the entity of enclosing N_Compilation_Unit Node which is the
+ -- root of the current scope (which must not be Standard_Standard, and
+ -- the caller is responsible for ensuring this condition).
+
+ function Enclosing_Lib_Unit_Node (N : Node_Id) return Node_Id;
+ -- Returns the enclosing N_Compilation_Unit Node that is the root
+ -- of a subtree containing N.
+
+ function Enclosing_Subprogram (E : Entity_Id) return Entity_Id;
+ -- Utility function to return the Ada entity of the subprogram enclosing
+ -- the entity E, if any. Returns Empty if no enclosing subprogram.
+
+ procedure Ensure_Freeze_Node (E : Entity_Id);
+ -- Make sure a freeze node is allocated for entity E. If necessary,
+ -- build and initialize a new freeze node and set Has_Delayed_Freeze
+ -- true for entity E.
+
+ procedure Enter_Name (Def_Id : Node_Id);
+ -- Insert new name in symbol table of current scope with check for
+ -- duplications (error message is issued if a conflict is found)
+ -- Note: Enter_Name is not used for overloadable entities, instead
+ -- these are entered using Sem_Ch6.Enter_Overloadable_Entity.
+
+ function Find_Corresponding_Discriminant
+ (Id : Node_Id;
+ Typ : Entity_Id)
+ return Entity_Id;
+ -- Because discriminants may have different names in a generic unit
+ -- and in an instance, they are resolved positionally when possible.
+ -- A reference to a discriminant carries the discriminant that it
+ -- denotes when analyzed. Subsequent uses of this id on a different
+ -- type denote the discriminant at the same position in this new type.
+
+ function First_Actual (Node : Node_Id) return Node_Id;
+ -- Node is an N_Function_Call or N_Procedure_Call_Statement node. The
+ -- result returned is the first actual parameter in declaration order
+ -- (not the order of parameters as they appeared in the source, which
+ -- can be quite different as a result of the use of named parameters).
+ -- Empty is returned for a call with no parameters. The procedure for
+ -- iterating through the actuals in declaration order is to use this
+ -- function to find the first actual, and then use Next_Actual to obtain
+ -- the next actual in declaration order. Note that the value returned
+ -- is always the expression (not the N_Parameter_Association nodes
+ -- even if named association is used).
+
+ function Full_Qualified_Name (E : Entity_Id) return String_Id;
+ -- Generates the string literal corresponding to the E's full qualified
+ -- name in upper case. An ASCII.NUL is appended as the last character
+
+ procedure Gather_Components
+ (Typ : Entity_Id;
+ Comp_List : Node_Id;
+ Governed_By : List_Id;
+ Into : Elist_Id;
+ Report_Errors : out Boolean);
+ -- The purpose of this procedure is to gather the valid components
+ -- in a record type according to the values of its discriminants, in order
+ -- to validate the components of a record aggregate.
+ --
+ -- Typ is the type of the aggregate when its constrained discriminants
+ -- need to be collected, otherwise it is Empty.
+ --
+ -- Comp_List is an N_Component_List node.
+ --
+ -- Governed_By is a list of N_Component_Association nodes,
+ -- where each choice list contains the name of a discriminant and
+ -- the expression field gives its value. The values of the
+ -- discriminants governing the (possibly nested) variant parts in
+ -- Comp_List are found in this Component_Association List.
+ --
+ -- Into is the list where the valid components are appended.
+ -- Note that Into need not be an Empty list. If it's not, components
+ -- are attached to its tail.
+ --
+ -- Report_Errors is set to True if the values of the discriminants
+ -- are non-static.
+
+ -- This procedure is also used when building a record subtype. If the
+ -- discriminant constraint of the subtype is static, the components of the
+ -- subtype are only those of the variants selected by the values of the
+ -- discriminants. Otherwise all components of the parent must be included
+ -- in the subtype for semantic analysis.
+
+ function Get_Actual_Subtype (N : Node_Id) return Entity_Id;
+ -- Given a node for an expression, obtain the actual subtype of the
+ -- expression. In the case of a parameter where the formal is an
+ -- unconstrained array or discriminated type, this will be the
+ -- previously constructed subtype of the actual. Note that this is
+ -- not quite the "Actual Subtype" of the RM, since it is always
+ -- a constrained type, i.e. it is the subtype of the value of the
+ -- actual. The actual subtype is also returned in other cases where
+ -- it has already been constructed for an object. Otherwise the
+ -- expression type is returned unchanged, except for the case of an
+ -- unconstrained array type, where an actual subtype is created, using
+ -- Insert_Actions if necessary to insert any associated actions.
+
+ function Get_Actual_Subtype_If_Available (N : Node_Id) return Entity_Id;
+ -- This is like Get_Actual_Subtype, except that it never constructs an
+ -- actual subtype. If an actual subtype is already available, i.e. the
+ -- Actual_Subtype field of the corresponding entity is set, then it is
+ -- returned. Otherwise the Etype of the node is returned.
+
+ function Get_Default_External_Name (E : Node_Or_Entity_Id) return Node_Id;
+ -- This is used to construct the string literal node representing a
+ -- default external name, i.e. one that is constructed from the name
+ -- of an entity, or (in the case of extended DEC import/export pragmas,
+ -- an identifier provided as the external name. Letters in the name are
+ -- according to the setting of Opt.External_Name_Default_Casing.
+
+ procedure Get_Index_Bounds (N : Node_Id; L, H : out Node_Id);
+ -- This procedure assigns to L and H respectively the values of the
+ -- low and high bounds of node N, which must be a range, subtype
+ -- indication, or the name of a scalar subtype. The result in L, H
+ -- may be set to Error if there was an earlier error in the range.
+
+ function Get_Enum_Lit_From_Pos
+ (T : Entity_Id;
+ Pos : Uint;
+ Loc : Source_Ptr)
+ return Entity_Id;
+ -- This function obtains the E_Enumeration_Literal entity for the
+ -- specified value from the enumneration type or subtype T. The
+ -- second argument is the Pos value, which is assumed to be in range.
+ -- The third argument supplies a source location for constructed
+ -- nodes returned by this function.
+
+ function Get_Name_Entity_Id (Id : Name_Id) return Entity_Id;
+ -- An entity value is associated with each name in the name table. The
+ -- Get_Name_Entity_Id function fetches the Entity_Id of this entity,
+ -- which is the innermost visible entity with the given name. See the
+ -- body of Sem_Ch8 for further details on handling of entity visibility.
+
+ function Get_Referenced_Object (N : Node_Id) return Node_Id;
+ -- Given a node, return the renamed object if the node represents
+ -- a renamed object, otherwise return the node unchanged. The node
+ -- may represent an arbitrary expression.
+
+ function Get_Subprogram_Body (E : Entity_Id) return Node_Id;
+ -- Given the entity for a subprogram (E_Function or E_Procedure),
+ -- return the corresponding N_Subprogram_Body node. If the corresponding
+ -- body of the declaration is missing (as for an imported subprogram)
+ -- return Empty.
+
+ function Get_Task_Body_Procedure (E : Entity_Id) return Node_Id;
+ pragma Inline (Get_Task_Body_Procedure);
+ -- Given an entity for a task type or subtype, retrieves the
+ -- Task_Body_Procedure field from the corresponding task type
+ -- declaration.
+
+ function Has_Infinities (E : Entity_Id) return Boolean;
+ -- Determines if the range of the floating-point type E includes
+ -- infinities. Returns False if E is not a floating-point type.
+
+ function Has_Private_Component (Type_Id : Entity_Id) return Boolean;
+ -- Check if a type has a (sub)component of a private type that has not
+ -- yet received a full declaration.
+
+ function Has_Tagged_Component (Typ : Entity_Id) return Boolean;
+ -- Typ must be a composite type (array or record). This function is used
+ -- to check if '=' has to be expanded into a bunch component comparaisons.
+
+ function In_Instance return Boolean;
+ -- Returns True if the current scope is within a generic instance.
+
+ function In_Instance_Body return Boolean;
+ -- Returns True if current scope is within the body of an instance, where
+ -- several semantic checks (e.g. accessibility checks) are relaxed.
+
+ function In_Instance_Not_Visible return Boolean;
+ -- Returns True if current scope is with the private part or the body of
+ -- an instance. Other semantic checks are suppressed in this context.
+
+ function In_Instance_Visible_Part return Boolean;
+ -- Returns True if current scope is within the visible part of a package
+ -- instance, where several additional semantic checks apply.
+
+ function In_Subprogram_Or_Concurrent_Unit return Boolean;
+ -- Determines if the current scope is within a subprogram compilation
+ -- unit (inside a subprogram declaration, subprogram body, or generic
+ -- subprogram declaration) or within a task or protected body. The test
+ -- is for appearing anywhere within such a construct (that is it does not
+ -- need to be directly within).
+
+ function In_Visible_Part (Scope_Id : Entity_Id) return Boolean;
+ -- Determine whether a declaration occurs within the visible part of a
+ -- package specification. The package must be on the scope stack, and the
+ -- corresponding private part must not.
+
+ function Is_AAMP_Float (E : Entity_Id) return Boolean;
+ -- Defined for all type entities. Returns True only for the base type
+ -- of float types with AAMP format. The particular format is determined
+ -- by the Digits_Value value which is 6 for the 32-bit floating point type,
+ -- or 9 for the 48-bit type. This is not an attribute function (like
+ -- VAX_Float) in order to not use up an extra flag and to prevent
+ -- the dependency of Einfo on Targparm which would be required for a
+ -- synthesized attribute.
+
+ function Is_Dependent_Component_Of_Mutable_Object
+ (Object : Node_Id)
+ return Boolean;
+ -- Returns True if Object is the name of a subcomponent that
+ -- depends on discriminants of a variable whose nominal subtype
+ -- is unconstrained and not indefinite, and the variable is
+ -- not aliased. Otherwise returns False. The nodes passed
+ -- to this function are assumed to denote objects.
+
+ function Is_Actual_Parameter (N : Node_Id) return Boolean;
+ -- Determines if N is an actual parameter in a subprogram call.
+
+ function Is_Aliased_View (Obj : Node_Id) return Boolean;
+ -- Determine if Obj is an aliased view, i.e. the name of an
+ -- object to which 'Access or 'Unchecked_Access can apply.
+
+ function Is_Atomic_Object (N : Node_Id) return Boolean;
+ -- Determines if the given node denotes an atomic object in the sense
+ -- of the legality checks described in RM C.6(12).
+
+ function Is_False (U : Uint) return Boolean;
+ -- The argument is a Uint value which is the Boolean'Pos value of a
+ -- Boolean operand (i.e. is either 0 for False, or 1 for True). This
+ -- function simply tests if it is False (i.e. zero)
+
+ function Is_Fixed_Model_Number (U : Ureal; T : Entity_Id) return Boolean;
+ -- Returns True iff the number U is a model number of the fixed-
+ -- point type T, i.e. if it is an exact multiple of Small.
+
+ function Is_Fully_Initialized_Type (Typ : Entity_Id) return Boolean;
+ -- Typ is a type entity. This function returns true if this type is
+ -- fully initialized, meaning that an object of the type is fully
+ -- initialized. Note that initialization resulting from the use of
+ -- pragma Normalized_Scalars does not count.
+
+ function Is_Inherited_Operation (E : Entity_Id) return Boolean;
+ -- E is a subprogram. Return True is E is an implicit operation inherited
+ -- by a derived type declarations.
+
+ function Is_Library_Level_Entity (E : Entity_Id) return Boolean;
+ -- A library-level declaration is one that is accessible from Standard,
+ -- i.e. a library unit or an entity declared in a library package.
+
+ function Is_Local_Variable_Reference (Expr : Node_Id) return Boolean;
+ -- Determines whether Expr is a refeference to a variable or IN OUT
+ -- mode parameter of the current enclosing subprogram.
+
+ function Is_Object_Reference (N : Node_Id) return Boolean;
+ -- Determines if the tree referenced by N represents an object. Both
+ -- variable and constant objects return True (compare Is_Variable).
+
+ function Is_OK_Variable_For_Out_Formal (AV : Node_Id) return Boolean;
+ -- Used to test if AV is an acceptable formal for an OUT or IN OUT
+ -- formal. Note that the Is_Variable function is not quite the right
+ -- test because this is a case in which conversions whose expression
+ -- is a variable (in the Is_Variable sense) with a non-tagged type
+ -- target are considered view conversions and hence variables.
+
+ function Is_RCI_Pkg_Spec_Or_Body (Cunit : Node_Id) return Boolean;
+ -- Return True if a compilation unit is the specification or the
+ -- body of a remote call interface package.
+
+ function Is_Remote_Access_To_Class_Wide_Type (E : Entity_Id) return Boolean;
+ -- Return True if E is a remote access-to-class-wide-limited_private type
+
+ function Is_Remote_Access_To_Subprogram_Type (E : Entity_Id) return Boolean;
+ -- Return True if E is a remote access to subprogram type.
+
+ function Is_Remote_Call (N : Node_Id) return Boolean;
+ -- Return True if N denotes a potentially remote call
+
+ function Is_Selector_Name (N : Node_Id) return Boolean;
+ -- Given an N_Identifier node N, determines if it is a Selector_Name.
+ -- As described in Sinfo, Selector_Names are special because they
+ -- represent use of the N_Identifier node for a true identifer, when
+ -- normally such nodes represent a direct name.
+
+ function Is_Statement (N : Node_Id) return Boolean;
+ -- Check if the node N is a statement node. Note that this includes
+ -- the case of procedure call statements (unlike the direct use of
+ -- the N_Statement_Other_Than_Procedure_Call subtype from Sinfo)
+
+ function Is_Transfer (N : Node_Id) return Boolean;
+ -- Returns True if the node N is a statement which is known to cause
+ -- an unconditional transfer of control at runtime, i.e. the following
+ -- statement definitely will not be executed.
+
+ function Is_True (U : Uint) return Boolean;
+ -- The argument is a Uint value which is the Boolean'Pos value of a
+ -- Boolean operand (i.e. is either 0 for False, or 1 for True). This
+ -- function simply tests if it is True (i.e. non-zero)
+
+ function Is_Variable (N : Node_Id) return Boolean;
+ -- Determines if the tree referenced by N represents a variable, i.e.
+ -- can appear on the left side of an assignment. There is one situation,
+ -- namely formal parameters, in which non-tagged type conversions are
+ -- also considered variables, but Is_Variable returns False for such
+ -- cases, since it has no knowledge of the context. Note that this is
+ -- the point at which Assignment_OK is checked, and True is returned
+ -- for any tree thus marked.
+
+ function Is_Volatile_Object (N : Node_Id) return Boolean;
+ -- Determines if the given node denotes an volatile object in the sense
+ -- of the legality checks described in RM C.6(12).
+
+ procedure Kill_Size_Check_Code (E : Entity_Id);
+ -- Called when an address clause or pragma Import is applied to an
+ -- entity. If the entity is a variable or a constant, and size check
+ -- code is present, this size check code is killed, since the object
+ -- will not be allocated by the program.
+
+ function New_External_Entity
+ (Kind : Entity_Kind;
+ Scope_Id : Entity_Id;
+ Sloc_Value : Source_Ptr;
+ Related_Id : Entity_Id;
+ Suffix : Character;
+ Suffix_Index : Nat := 0;
+ Prefix : Character := ' ')
+ return Entity_Id;
+ -- This function creates an N_Defining_Identifier node for an internal
+ -- created entity, such as an implicit type or subtype, or a record
+ -- initialization procedure. The entity name is constructed with a call
+ -- to New_External_Name (Related_Id, Suffix, Suffix_Index, Prefix), so
+ -- that the generated name may be referenced as a public entry, and the
+ -- Is_Public flag is set if needed (using Set_Public_Status). If the
+ -- entity is for a type or subtype, the size/align fields are initialized
+ -- to unknown (Uint_0).
+
+ function New_Internal_Entity
+ (Kind : Entity_Kind;
+ Scope_Id : Entity_Id;
+ Sloc_Value : Source_Ptr;
+ Id_Char : Character)
+ return Entity_Id;
+ -- This function is similar to New_External_Entity, except that the
+ -- name is constructed by New_Internal_Name (Id_Char). This is used
+ -- when the resulting entity does not have to be referenced as a
+ -- public entity (and in this case Is_Public is not set).
+
+ procedure Next_Actual (Actual_Id : in out Node_Id);
+ pragma Inline (Next_Actual);
+ -- Next_Actual (N) is equivalent to N := Next_Actual (N)
+
+ function Next_Actual (Actual_Id : Node_Id) return Node_Id;
+ -- Find next actual parameter in declaration order. As described for
+ -- First_Actual, this is the next actual in the declaration order, not
+ -- the call order, so this does not correspond to simply taking the
+ -- next entry of the Parameter_Associations list. The argument is an
+ -- actual previously returned by a call to First_Actual or Next_Actual.
+ -- Note tha the result produced is always an expression, not a parameter
+ -- assciation node, even if named notation was used.
+
+ procedure Normalize_Actuals
+ (N : Node_Id;
+ S : Entity_Id;
+ Report : Boolean;
+ Success : out Boolean);
+ -- Reorders lists of actuals according to names of formals, value returned
+ -- in Success indicates sucess of reordering. For more details, see body.
+ -- Errors are reported only if Report is set to True.
+
+ procedure Note_Possible_Modification (N : Node_Id);
+ -- This routine is called if the sub-expression N maybe the target of
+ -- an assignment (e.g. it is the left side of an assignment, used as
+ -- an out parameters, or used as prefixes of access attributes). It
+ -- sets May_Be_Modified in the associated entity if there is one,
+ -- taking into account the rule that in the case of renamed objects,
+ -- it is the flag in the renamed object that must be set.
+
+ function Object_Access_Level (Obj : Node_Id) return Uint;
+ -- Return the accessibility level of the view of the object Obj.
+ -- For convenience, qualified expressions applied to object names
+ -- are also allowed as actuals for this function.
+
+ function Private_Component (Type_Id : Entity_Id) return Entity_Id;
+ -- Returns some private component (if any) of the given Type_Id.
+ -- Used to enforce the rules on visibility of operations on composite
+ -- types, that depend on the full view of the component type. For a
+ -- record type there may be several such components, we just return
+ -- the first one.
+
+ procedure Process_End_Label (N : Node_Id; Typ : Character);
+ -- N is a node whose End_Label is to be processed, generating all
+ -- appropriate cross-reference entries, and performing style checks
+ -- for any identifier references in the end label. Typ is either
+ -- 'e' or 't indicating the type of the cross-reference entity
+ -- (e for spec, t for body, see Lib.Xref spec for details).
+
+ function Real_Convert (S : String) return Node_Id;
+ -- S is a possibly signed syntactically valid real literal. The result
+ -- returned is an N_Real_Literal node representing the literal value.
+
+ function Requires_Transient_Scope (Id : Entity_Id) return Boolean;
+ -- E is a type entity. The result is True when temporaries of this
+ -- type need to be wrapped in a transient scope to be reclaimed
+ -- properly when a secondary stack is in use. Examples of types
+ -- requiring such wrapping are controlled types and variable-sized
+ -- types including unconstrained arrays
+
+ procedure Reset_Analyzed_Flags (N : Node_Id);
+ -- Reset the Analyzed flags in all nodes of the tree whose root is N
+
+ function Same_Name (N1, N2 : Node_Id) return Boolean;
+ -- Determine if two (possibly expanded) names are the same name
+
+ function Same_Type (T1, T2 : Entity_Id) return Boolean;
+ -- Determines if T1 and T2 represent exactly the same type. Two types
+ -- are the same if they are identical, or if one is an unconstrained
+ -- subtype of the other, or they are both common subtypes of the same
+ -- type with identical contraints. The result returned is conservative.
+ -- It is True if the types are known to be the same, but a result of
+ -- False is indecisive (e.g. the compiler may not be able to tell that
+ -- two constraints are identical).
+
+ function Scope_Within_Or_Same (Scope1, Scope2 : Entity_Id) return Boolean;
+ -- Determines if the entity Scope1 is the same as Scope2, or if it is
+ -- inside it, where both entities represent scopes. Note that scopes
+ -- are only partially ordered, so Scope_Within_Or_Same (A,B) and
+ -- Scope_Within_Or_Same (B,A) can both be False for a given pair A,B.
+
+ function Scope_Within (Scope1, Scope2 : Entity_Id) return Boolean;
+ -- Like Scope_Within_Or_Same, except that this function returns
+ -- False in the case where Scope1 and Scope2 are the same scope.
+
+ procedure Set_Current_Entity (E : Entity_Id);
+ -- Establish the entity E as the currently visible definition of its
+ -- associated name (i.e. the Node_Id associated with its name)
+
+ procedure Set_Entity_With_Style_Check (N : Node_Id; Val : Entity_Id);
+ -- This procedure has the same calling sequence as Set_Entity, but
+ -- if Style_Check is set, then it calls a style checking routine which
+ -- can check identifier spelling style.
+
+ procedure Set_Name_Entity_Id (Id : Name_Id; Val : Entity_Id);
+ -- Sets the Entity_Id value associated with the given name, which is the
+ -- Id of the innermost visible entity with the given name. See the body
+ -- of package Sem_Ch8 for further details on the handling of visibility.
+
+ procedure Set_Next_Actual (Ass1_Id : Node_Id; Ass2_Id : Node_Id);
+ -- The arguments may be parameter associations, whose descendants
+ -- are the optional formal name and the actual parameter. Positional
+ -- parameters are already members of a list, and do not need to be
+ -- chained separately. See also First_Actual and Next_Actual.
+
+ procedure Set_Public_Status (Id : Entity_Id);
+ -- If an entity (visible or otherwise) is defined in a library
+ -- package, or a package that is itself public, then this subprogram
+ -- labels the entity public as well.
+
+ procedure Set_Scope_Is_Transient (V : Boolean := True);
+ -- Set the flag Is_Transient of the current scope
+
+ procedure Set_Size_Info (T1, T2 : Entity_Id);
+ -- Copies the Esize field and Has_Biased_Representation flag from
+ -- (sub)type entity T2 to (sub)type entity T1. Also copies the
+ -- Is_Unsigned_Type flag in the fixed-point and discrete cases,
+ -- and also copies the alignment value from T2 to T1. It does NOT
+ -- copy the RM_Size field, which must be separately set if this
+ -- is required to be copied also.
+
+ function Scope_Is_Transient return Boolean;
+ -- True if the current scope is transient.
+
+ function Static_Integer (N : Node_Id) return Uint;
+ -- This function analyzes the given expression node and then resolves it
+ -- as any integer type. If the result is static, then the value of the
+ -- universal expression is returned, otherwise an error message is output
+ -- and a value of No_Uint is returned.
+
+ function Statically_Different (E1, E2 : Node_Id) return Boolean;
+ -- Return True if it can be statically determined that the Expressions
+ -- E1 and E2 refer to different objects
+
+ function Subprogram_Access_Level (Subp : Entity_Id) return Uint;
+ -- Return the accessibility level of the view denoted by Subp.
+
+ procedure Trace_Scope (N : Node_Id; E : Entity_Id; Msg : String);
+ -- Print debugging information on entry to each unit being analyzed.
+
+ procedure Transfer_Entities (From : Entity_Id; To : Entity_Id);
+ -- Move a list of entities from one scope to another, and recompute
+ -- Is_Public based upon the new scope.
+
+ function Type_Access_Level (Typ : Entity_Id) return Uint;
+ -- Return the accessibility level of Typ.
+
+ function Unit_Declaration_Node (Unit_Id : Entity_Id) return Node_Id;
+ -- Unit_Id is the simple name of a program unit, this function returns
+ -- the corresponding xxx_Declaration node for the entity. Also applies
+ -- to the body entities for subprograms in tasks, in which case it
+ -- returns the subprogram or task body node for it. The unit may be
+ -- a child unit with any number of ancestors.
+
+ function Within_Init_Proc return Boolean;
+ -- Determines if Current_Scope is within an Init_Proc
+
+ procedure Wrong_Type (Expr : Node_Id; Expected_Type : Entity_Id);
+ -- Output error message for incorrectly typed expression. Expr is the
+ -- node for the incorrectly typed construct (Etype (Expr) is the type
+ -- found), and Expected_Type is the entity for the expected type. Note
+ -- that Expr does not have to be a subexpression, anything with an
+ -- Etype field may be used.
+
+private
+ pragma Inline (Current_Entity);
+ pragma Inline (Get_Name_Entity_Id);
+ pragma Inline (Is_False);
+ pragma Inline (Is_Statement);
+ pragma Inline (Is_True);
+ pragma Inline (Set_Current_Entity);
+ pragma Inline (Set_Name_Entity_Id);
+ pragma Inline (Set_Size_Info);
+
+end Sem_Util;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S E M _ V F P T --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.10 $
+-- --
+-- Copyright (C) 1997-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 CStand; use CStand;
+with Einfo; use Einfo;
+with Opt; use Opt;
+with Stand; use Stand;
+with Targparm; use Targparm;
+with Ttypef; use Ttypef;
+with Uintp; use Uintp;
+
+pragma Elaborate_All (Uintp);
+
+package body Sem_VFpt is
+
+ T_Digits : constant Uint := UI_From_Int (IEEEL_Digits);
+ -- Digits for IEEE formats
+
+ -----------------
+ -- Set_D_Float --
+ -----------------
+
+ procedure Set_D_Float (E : Entity_Id) is
+ begin
+ Init_Size (Base_Type (E), 64);
+ Init_Alignment (Base_Type (E));
+ Init_Digits_Value (Base_Type (E), VAXDF_Digits);
+ Set_Vax_Float (Base_Type (E), True);
+ Set_Float_Bounds (Base_Type (E));
+
+ Init_Size (E, 64);
+ Init_Alignment (E);
+ Init_Digits_Value (E, VAXDF_Digits);
+ Set_Scalar_Range (E, Scalar_Range (Base_Type (E)));
+ end Set_D_Float;
+
+ -----------------
+ -- Set_F_Float --
+ -----------------
+
+ procedure Set_F_Float (E : Entity_Id) is
+ begin
+ Init_Size (Base_Type (E), 32);
+ Init_Alignment (Base_Type (E));
+ Init_Digits_Value (Base_Type (E), VAXFF_Digits);
+ Set_Vax_Float (Base_Type (E), True);
+ Set_Float_Bounds (Base_Type (E));
+
+ Init_Size (E, 32);
+ Init_Alignment (E);
+ Init_Digits_Value (E, VAXFF_Digits);
+ Set_Scalar_Range (E, Scalar_Range (Base_Type (E)));
+ end Set_F_Float;
+
+ -----------------
+ -- Set_G_Float --
+ -----------------
+
+ procedure Set_G_Float (E : Entity_Id) is
+ begin
+ Init_Size (Base_Type (E), 64);
+ Init_Alignment (Base_Type (E));
+ Init_Digits_Value (Base_Type (E), VAXGF_Digits);
+ Set_Vax_Float (Base_Type (E), True);
+ Set_Float_Bounds (Base_Type (E));
+
+ Init_Size (E, 64);
+ Init_Alignment (E);
+ Init_Digits_Value (E, VAXGF_Digits);
+ Set_Scalar_Range (E, Scalar_Range (Base_Type (E)));
+ end Set_G_Float;
+
+ -------------------
+ -- Set_IEEE_Long --
+ -------------------
+
+ procedure Set_IEEE_Long (E : Entity_Id) is
+ begin
+ Init_Size (Base_Type (E), 64);
+ Init_Alignment (Base_Type (E));
+ Init_Digits_Value (Base_Type (E), IEEEL_Digits);
+ Set_Vax_Float (Base_Type (E), False);
+ Set_Float_Bounds (Base_Type (E));
+
+ Init_Size (E, 64);
+ Init_Alignment (E);
+ Init_Digits_Value (E, IEEEL_Digits);
+ Set_Scalar_Range (E, Scalar_Range (Base_Type (E)));
+ end Set_IEEE_Long;
+
+ --------------------
+ -- Set_IEEE_Short --
+ --------------------
+
+ procedure Set_IEEE_Short (E : Entity_Id) is
+ begin
+ Init_Size (Base_Type (E), 32);
+ Init_Alignment (Base_Type (E));
+ Init_Digits_Value (Base_Type (E), IEEES_Digits);
+ Set_Vax_Float (Base_Type (E), False);
+ Set_Float_Bounds (Base_Type (E));
+
+ Init_Size (E, 32);
+ Init_Alignment (E);
+ Init_Digits_Value (E, IEEES_Digits);
+ Set_Scalar_Range (E, Scalar_Range (Base_Type (E)));
+ end Set_IEEE_Short;
+
+ ------------------------------
+ -- Set_Standard_Fpt_Formats --
+ ------------------------------
+
+ procedure Set_Standard_Fpt_Formats is
+ begin
+ -- IEEE case
+
+ if Opt.Float_Format = 'I' then
+ Set_IEEE_Short (Standard_Float);
+ Set_IEEE_Long (Standard_Long_Float);
+ Set_IEEE_Long (Standard_Long_Long_Float);
+
+ -- Vax float case
+
+ else
+ Set_F_Float (Standard_Float);
+
+ if Opt.Float_Format_Long = 'D' then
+ Set_D_Float (Standard_Long_Float);
+ else
+ Set_G_Float (Standard_Long_Float);
+ end if;
+
+ -- Note: Long_Long_Float gets set only in the real VMS case,
+ -- because this gives better results for testing out the use
+ -- of VAX float on non-VMS environments with the -gnatdm switch.
+
+ if OpenVMS_On_Target then
+ Set_G_Float (Standard_Long_Long_Float);
+ end if;
+ end if;
+ end Set_Standard_Fpt_Formats;
+
+end Sem_VFpt;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S E M _ V F P T --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.1 $ --
+-- --
+-- Copyright (C) 1997 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 contains specialized routines for handling the Alpha
+-- floating point formats. It is used only in Alpha implementations.
+-- Note that this means that the caller can assume that we are on an
+-- Alpha implementation, and that Vax floating-point formats are valid.
+
+with Types; use Types;
+
+package Sem_VFpt is
+
+ procedure Set_D_Float (E : Entity_Id);
+ -- Sets the given floating-point entity to have Vax D_Float format
+
+ procedure Set_F_Float (E : Entity_Id);
+ -- Sets the given floating-point entity to have Vax F_Float format
+
+ procedure Set_G_Float (E : Entity_Id);
+ -- Sets the given floating-point entity to have Vax G_Float format
+
+ procedure Set_IEEE_Short (E : Entity_Id);
+ -- Sets the given floating-point entity to have IEEE Short format
+
+ procedure Set_IEEE_Long (E : Entity_Id);
+ -- Sets the given floating-point entity to have IEEE Long format
+
+ procedure Set_Standard_Fpt_Formats;
+ -- This procedure sets the appropriate formats for the standard
+ -- floating-point types in Standard, based on the setting of
+ -- the flags Opt.Float_Format and Opt.Float_Format_Long
+
+end Sem_VFpt;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S E M _ W A R N --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.24 $
+-- --
+-- 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. --
+-- --
+-- 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 Alloc;
+with Atree; use Atree;
+with Einfo; use Einfo;
+with Errout; use Errout;
+with Fname; use Fname;
+with Lib; use Lib;
+with Nlists; use Nlists;
+with Opt; use Opt;
+with Sem; use Sem;
+with Sem_Util; use Sem_Util;
+with Sinfo; use Sinfo;
+with Sinput; use Sinput;
+with Snames; use Snames;
+with Stand; use Stand;
+with Table;
+
+package body Sem_Warn is
+
+ -- The following table collects Id's of entities that are potentially
+ -- unreferenced. See Check_Unset_Reference for further details.
+
+ package Unreferenced_Entities is new Table.Table (
+ Table_Component_Type => Entity_Id,
+ Table_Index_Type => Nat,
+ Table_Low_Bound => 1,
+ Table_Initial => Alloc.Unreferenced_Entities_Initial,
+ Table_Increment => Alloc.Unreferenced_Entities_Increment,
+ Table_Name => "Unreferenced_Entities");
+
+ -- One entry is made in the following table for each branch of
+ -- a conditional, e.g. an if-then-elsif-else-endif structure
+ -- creates three entries in this table.
+
+ type Branch_Entry is record
+ Sloc : Source_Ptr;
+ -- Location for warnings associated with this branch
+
+ Defs : Elist_Id;
+ -- List of entities defined for the first time in this branch. On
+ -- exit from a conditional structure, any entity that is in the
+ -- list of all branches is removed (and the entity flagged as
+ -- defined by the conditional as a whole). Thus after processing
+ -- a conditional, Defs contains a list of entities defined in this
+ -- branch for the first time, but not defined at all in some other
+ -- branch of the same conditional. A value of No_Elist is used to
+ -- represent the initial empty list.
+
+ Next : Nat;
+ -- Index of next branch for this conditional, zero = last branch
+ end record;
+
+ package Branch_Table is new Table.Table (
+ Table_Component_Type => Branch_Entry,
+ Table_Index_Type => Nat,
+ Table_Low_Bound => 1,
+ Table_Initial => Alloc.Branches_Initial,
+ Table_Increment => Alloc.Branches_Increment,
+ Table_Name => "Branches");
+
+ -- The following table is used to represent conditionals, there is
+ -- one entry in this table for each conditional structure.
+
+ type Conditional_Entry is record
+ If_Stmt : Boolean;
+ -- True for IF statement, False for CASE statement
+
+ First_Branch : Nat;
+ -- Index in Branch table of first branch, zero = none yet
+
+ Current_Branch : Nat;
+ -- Index in Branch table of current branch, zero = none yet
+ end record;
+
+ package Conditional_Table is new Table.Table (
+ Table_Component_Type => Conditional_Entry,
+ Table_Index_Type => Nat,
+ Table_Low_Bound => 1,
+ Table_Initial => Alloc.Conditionals_Initial,
+ Table_Increment => Alloc.Conditionals_Increment,
+ Table_Name => "Conditionals");
+
+ -- The following table is a stack that keeps track of the current
+ -- conditional. The Last entry is the top of the stack. An Empty
+ -- entry represents the start of a compilation unit. Non-zero
+ -- entries in the stack are indexes into the conditional table.
+
+ package Conditional_Stack is new Table.Table (
+ Table_Component_Type => Nat,
+ Table_Index_Type => Nat,
+ Table_Low_Bound => 1,
+ Table_Initial => Alloc.Conditional_Stack_Initial,
+ Table_Increment => Alloc.Conditional_Stack_Increment,
+ Table_Name => "Conditional_Stack");
+
+ Current_Entity_List : Elist_Id := No_Elist;
+ -- This is a copy of the Defs list of the current branch of the current
+ -- conditional. It could be accessed by taking the top element of the
+ -- Conditional_Stack, and going to te Current_Branch entry of this
+ -- conditional, but we keep it precomputed for rapid access.
+
+ ----------------------
+ -- Check_References --
+ ----------------------
+
+ procedure Check_References (E : Entity_Id; Anod : Node_Id := Empty) is
+ E1 : Entity_Id;
+ UR : Node_Id;
+ PU : Node_Id;
+
+ procedure Output_Reference_Error (M : String);
+ -- Used to output an error message. Deals with posting the error on
+ -- the body formal in the accept case.
+
+ function Publicly_Referenceable (Ent : Entity_Id) return Boolean;
+ -- This is true if the entity in question is potentially referenceable
+ -- from another unit. This is true for entities in packages that are
+ -- at the library level, or for entities in tasks or protected objects
+ -- that are themselves publicly visible.
+
+ ----------------------------
+ -- Output_Reference_Error --
+ ----------------------------
+
+ procedure Output_Reference_Error (M : String) is
+ begin
+ -- Other than accept case, post error on defining identifier
+
+ if No (Anod) then
+ Error_Msg_N (M, E1);
+
+ -- Accept case, find body formal to post the message
+
+ else
+ declare
+ Parm : Node_Id;
+ Enod : Node_Id;
+ Defid : Entity_Id;
+
+ begin
+ Enod := Anod;
+
+ if Present (Parameter_Specifications (Anod)) then
+ Parm := First (Parameter_Specifications (Anod));
+
+ while Present (Parm) loop
+ Defid := Defining_Identifier (Parm);
+
+ if Chars (E1) = Chars (Defid) then
+ Enod := Defid;
+ exit;
+ end if;
+
+ Next (Parm);
+ end loop;
+ end if;
+
+ Error_Msg_NE (M, Enod, E1);
+ end;
+ end if;
+ end Output_Reference_Error;
+
+ ----------------------------
+ -- Publicly_Referenceable --
+ ----------------------------
+
+ function Publicly_Referenceable (Ent : Entity_Id) return Boolean is
+ S : Entity_Id;
+
+ begin
+ -- Any entity in a generic package is considered to be publicly
+ -- referenceable, since it could be referenced in an instantiation
+
+ if Ekind (E) = E_Generic_Package then
+ return True;
+ end if;
+
+ -- Otherwise look up the scope stack
+
+ S := Scope (Ent);
+ loop
+ if Is_Package (S) then
+ return Is_Library_Level_Entity (S);
+
+ elsif Ekind (S) = E_Task_Type
+ or else Ekind (S) = E_Protected_Type
+ or else Ekind (S) = E_Entry
+ then
+ S := Scope (S);
+
+ else
+ return False;
+ end if;
+ end loop;
+ end Publicly_Referenceable;
+
+ -- Start of processing for Check_References
+
+ begin
+ -- No messages if warnings are suppressed, or if we have detected
+ -- any real errors so far (this last check avoids junk messages
+ -- resulting from errors, e.g. a subunit that is not loaded).
+
+ -- We also skip the messages if any subunits were not loaded (see
+ -- comment in Sem_Ch10 to understand how this is set, and why it is
+ -- necessary to suppress the warnings in this case).
+
+ if Warning_Mode = Suppress
+ or else Errors_Detected /= 0
+ or else Unloaded_Subunits
+ then
+ return;
+ end if;
+
+ -- Otherwise loop through entities, looking for suspicious stuff
+
+ E1 := First_Entity (E);
+ while Present (E1) loop
+
+ -- We only look at source entities with warning flag off
+
+ if Comes_From_Source (E1) and then not Warnings_Off (E1) then
+
+ -- We are interested in variables and out parameters, but we
+ -- exclude protected types, too complicated to worry about.
+
+ if Ekind (E1) = E_Variable
+ or else
+ (Ekind (E1) = E_Out_Parameter
+ and then not Is_Protected_Type (Current_Scope))
+ then
+ -- Post warning if this object not assigned. Note that we
+ -- do not consider the implicit initialization of an access
+ -- type to be the assignment of a value for this purpose.
+ -- If the entity is an out parameter of the current subprogram
+ -- body, check the warning status of the parameter in the spec.
+
+ if Ekind (E1) = E_Out_Parameter
+ and then Present (Spec_Entity (E1))
+ and then Warnings_Off (Spec_Entity (E1))
+ then
+ null;
+
+ elsif Not_Source_Assigned (E1) then
+ Output_Reference_Error ("& is never assigned a value?");
+
+ -- Deal with special case where this variable is hidden
+ -- by a loop variable
+
+ if Ekind (E1) = E_Variable
+ and then Present (Hiding_Loop_Variable (E1))
+ then
+ Error_Msg_Sloc := Sloc (E1);
+ Error_Msg_N
+ ("declaration hides &#?",
+ Hiding_Loop_Variable (E1));
+ Error_Msg_N
+ ("for loop implicitly declares loop variable?",
+ Hiding_Loop_Variable (E1));
+ end if;
+
+ goto Continue;
+ end if;
+
+ -- Check for unset reference, note that we exclude access
+ -- types from this check, since access types do always have
+ -- a null value, and that seems legitimate in this case.
+
+ UR := Unset_Reference (E1);
+ if Present (UR) then
+
+ -- For access types, the only time we complain is when
+ -- we have a dereference (of a null value)
+
+ if Is_Access_Type (Etype (E1)) then
+ PU := Parent (UR);
+
+ if (Nkind (PU) = N_Selected_Component
+ or else
+ Nkind (PU) = N_Explicit_Dereference
+ or else
+ Nkind (PU) = N_Indexed_Component)
+ and then
+ Prefix (PU) = UR
+ then
+ Error_Msg_N ("& may be null?", UR);
+ goto Continue;
+ end if;
+
+ -- For other than access type, go back to original node
+ -- to deal with case where original unset reference
+ -- has been rewritten during expansion.
+
+ else
+ UR := Original_Node (UR);
+
+ -- In some cases, the original node may be a type
+ -- conversion or qualification, and in this case
+ -- we want the object entity inside.
+
+ while Nkind (UR) = N_Type_Conversion
+ or else Nkind (UR) = N_Qualified_Expression
+ loop
+ UR := Expression (UR);
+ end loop;
+
+ Error_Msg_N
+ ("& may be referenced before it has a value?", UR);
+ goto Continue;
+ end if;
+ end if;
+ end if;
+
+ -- Then check for unreferenced variables
+
+ if Check_Unreferenced
+
+ -- Check entity is flagged as not referenced and that
+ -- warnings are not suppressed for this entity
+
+ and then not Referenced (E1)
+ and then not Warnings_Off (E1)
+
+ -- Warnings are placed on objects, types, subprograms,
+ -- labels, and enumeration literals.
+
+ and then (Is_Object (E1)
+ or else
+ Is_Type (E1)
+ or else
+ Ekind (E1) = E_Label
+ or else
+ Ekind (E1) = E_Named_Integer
+ or else
+ Ekind (E1) = E_Named_Real
+ or else
+ Is_Overloadable (E1))
+
+ -- We only place warnings for the main unit
+
+ and then In_Extended_Main_Source_Unit (E1)
+
+ -- Exclude instantiations, since there is no reason why
+ -- every entity in an instantiation should be referenced.
+
+ and then Instantiation_Location (Sloc (E1)) = No_Location
+
+ -- Exclude formal parameters from bodies (in the case
+ -- where there is a separate spec, it is the spec formals
+ -- that are of interest).
+
+ and then (not Is_Formal (E1)
+ or else
+ Ekind (Scope (E1)) /= E_Subprogram_Body)
+
+ -- Consider private type referenced if full view is
+ -- referenced.
+
+ and then not (Is_Private_Type (E1)
+ and then
+ Referenced (Full_View (E1)))
+
+ -- Don't worry about full view, only about private type
+
+ and then not Has_Private_Declaration (E1)
+
+ -- Eliminate dispatching operations from consideration, we
+ -- cannot tell if these are referenced or not in any easy
+ -- manner (note this also catches Adjust/Finalize/Initialize)
+
+ and then not Is_Dispatching_Operation (E1)
+
+ -- Check entity that can be publicly referenced (we do not
+ -- give messages for such entities, since there could be
+ -- other units, not involved in this compilation, that
+ -- contain relevant references.
+
+ and then not Publicly_Referenceable (E1)
+
+ -- Class wide types are marked as source entities, but
+ -- they are not really source entities, and are always
+ -- created, so we do not care if they are not referenced.
+
+ and then Ekind (E1) /= E_Class_Wide_Type
+
+ -- Objects other than parameters of task types are allowed
+ -- to be non-referenced, since they start up tasks!
+
+ and then ((Ekind (E1) /= E_Variable
+ and then Ekind (E1) /= E_Constant
+ and then Ekind (E1) /= E_Component)
+ or else not Is_Task_Type (Etype (E1)))
+ then
+ -- Suppress warnings in internal units if not in -gnatg
+ -- mode (these would be junk warnings for an applications
+ -- program, since they refer to problems in internal units)
+
+ if GNAT_Mode
+ or else not
+ Is_Internal_File_Name
+ (Unit_File_Name (Get_Source_Unit (E1)))
+ then
+ -- We do not immediately flag the error. This is because
+ -- we have not expanded generic bodies yet, and they may
+ -- have the missing reference. So instead we park the
+ -- entity on a list, for later processing. However, for
+ -- the accept case, post the error right here, since we
+ -- have the information now in this case.
+
+ if Present (Anod) then
+ Output_Reference_Error ("& is not referenced?");
+
+ else
+ Unreferenced_Entities.Increment_Last;
+ Unreferenced_Entities.Table
+ (Unreferenced_Entities.Last) := E1;
+ end if;
+ end if;
+ end if;
+ end if;
+
+ -- Recurse into nested package or block
+
+ <<Continue>>
+ if (Ekind (E1) = E_Package
+ and then Nkind (Parent (E1)) = N_Package_Specification)
+ or else Ekind (E1) = E_Block
+ then
+ Check_References (E1);
+ end if;
+
+ Next_Entity (E1);
+ end loop;
+ end Check_References;
+
+ ---------------------------
+ -- Check_Unset_Reference --
+ ---------------------------
+
+ procedure Check_Unset_Reference (N : Node_Id) is
+ begin
+ -- Nothing to do if warnings suppressed
+
+ if Warning_Mode = Suppress then
+ return;
+ end if;
+
+ -- Otherwise see what kind of node we have. If the entity already
+ -- has an unset reference, it is not necessarily the earliest in
+ -- the text, because resolution of the prefix of selected components
+ -- is completed before the resolution of the selected component itself.
+ -- as a result, given (R /= null and then R.X > 0), the occurrences
+ -- of R are examined in right-to-left order. If there is already an
+ -- unset reference, we check whether N is earlier before proceeding.
+
+ case Nkind (N) is
+
+ when N_Identifier | N_Expanded_Name =>
+ declare
+ E : constant Entity_Id := Entity (N);
+
+ begin
+ if (Ekind (E) = E_Variable
+ or else Ekind (E) = E_Out_Parameter)
+ and then Not_Source_Assigned (E)
+ and then (No (Unset_Reference (E))
+ or else Earlier_In_Extended_Unit
+ (Sloc (N), Sloc (Unset_Reference (E))))
+ and then not Warnings_Off (E)
+ then
+ -- Here we have a potential unset reference. But before we
+ -- get worried about it, we have to make sure that the
+ -- entity declaration is in the same procedure as the
+ -- reference, since if they are in separate procedures,
+ -- then we have no idea about sequential execution.
+
+ -- The tests in the loop below catch all such cases, but
+ -- do allow the reference to appear in a loop, block, or
+ -- package spec that is nested within the declaring scope.
+ -- As always, it is possible to construct cases where the
+ -- warning is wrong, that is why it is a warning!
+
+ -- If the entity is an out_parameter, it is ok to read its
+ -- its discriminants (that was true in Ada83) so suppress
+ -- the message in that case as well.
+
+ if Ekind (E) = E_Out_Parameter
+ and then Nkind (Parent (N)) = N_Selected_Component
+ and then Ekind (Entity (Selector_Name (Parent (N))))
+ = E_Discriminant
+ then
+ return;
+ end if;
+
+ declare
+ SR : Entity_Id;
+ SE : constant Entity_Id := Scope (E);
+
+ begin
+ SR := Current_Scope;
+ while SR /= SE loop
+ if SR = Standard_Standard
+ or else Is_Subprogram (SR)
+ or else Is_Concurrent_Body (SR)
+ or else Is_Concurrent_Type (SR)
+ then
+ return;
+ end if;
+
+ SR := Scope (SR);
+ end loop;
+
+ if Nkind (N) = N_Identifier then
+ Set_Unset_Reference (E, N);
+ else
+ Set_Unset_Reference (E, Selector_Name (N));
+ end if;
+ end;
+ end if;
+ end;
+
+ when N_Indexed_Component | N_Selected_Component | N_Slice =>
+ Check_Unset_Reference (Prefix (N));
+ return;
+
+ when N_Type_Conversion | N_Qualified_Expression =>
+ Check_Unset_Reference (Expression (N));
+
+ when others =>
+ null;
+
+ end case;
+ end Check_Unset_Reference;
+
+ ------------------------
+ -- Check_Unused_Withs --
+ ------------------------
+
+ procedure Check_Unused_Withs (Spec_Unit : Unit_Number_Type := No_Unit) is
+ Cnode : Node_Id;
+ Item : Node_Id;
+ Lunit : Node_Id;
+ Ent : Entity_Id;
+
+ Munite : constant Entity_Id := Cunit_Entity (Main_Unit);
+ -- This is needed for checking the special renaming case
+
+ procedure Check_One_Unit (Unit : Unit_Number_Type);
+ -- Subsidiary procedure, performs checks for specified unit
+
+ --------------------
+ -- Check_One_Unit --
+ --------------------
+
+ procedure Check_One_Unit (Unit : Unit_Number_Type) is
+ Is_Visible_Renaming : Boolean := False;
+ Pack : Entity_Id;
+
+ function Find_Package_Renaming
+ (P : Entity_Id;
+ L : Entity_Id) return Entity_Id;
+ -- The only reference to a context unit may be in a renaming
+ -- declaration. If this renaming declares a visible entity, do
+ -- not warn that the context clause could be moved to the body,
+ -- because the renaming may be intented to re-export the unit.
+
+ ---------------------------
+ -- Find_Package_Renaming --
+ ---------------------------
+
+ function Find_Package_Renaming
+ (P : Entity_Id;
+ L : Entity_Id) return Entity_Id
+ is
+ E1 : Entity_Id;
+ R : Entity_Id;
+
+ begin
+ Is_Visible_Renaming := False;
+ E1 := First_Entity (P);
+
+ while Present (E1) loop
+ if Ekind (E1) = E_Package
+ and then Renamed_Object (E1) = L
+ then
+ Is_Visible_Renaming := not Is_Hidden (E1);
+ return E1;
+
+ elsif Ekind (E1) = E_Package
+ and then No (Renamed_Object (E1))
+ and then not Is_Generic_Instance (E1)
+ then
+ R := Find_Package_Renaming (E1, L);
+
+ if Present (R) then
+ Is_Visible_Renaming := not Is_Hidden (R);
+ return R;
+ end if;
+ end if;
+
+ Next_Entity (E1);
+ end loop;
+
+ return Empty;
+ end Find_Package_Renaming;
+
+ -- Start of processing for Check_One_Unit
+
+ begin
+ Cnode := Cunit (Unit);
+
+ -- Only do check in units that are part of the extended main
+ -- unit. This is actually a necessary restriction, because in
+ -- the case of subprogram acting as its own specification,
+ -- there can be with's in subunits that we will not see.
+
+ if not In_Extended_Main_Source_Unit (Cnode) then
+ return;
+ end if;
+
+ -- Loop through context items in this unit
+
+ Item := First (Context_Items (Cnode));
+ while Present (Item) loop
+
+ if Nkind (Item) = N_With_Clause
+ and then not Implicit_With (Item)
+ and then In_Extended_Main_Source_Unit (Item)
+ then
+ Lunit := Entity (Name (Item));
+
+ -- Check if this unit is referenced
+
+ if not Referenced (Lunit) then
+
+ -- Suppress warnings in internal units if not in -gnatg
+ -- mode (these would be junk warnings for an applications
+ -- program, since they refer to problems in internal units)
+
+ if GNAT_Mode
+ or else not Is_Internal_File_Name (Unit_File_Name (Unit))
+ then
+ -- Here we definitely have a non-referenced unit. If
+ -- it is the special call for a spec unit, then just
+ -- set the flag to be read later.
+
+ if Unit = Spec_Unit then
+ Set_Unreferenced_In_Spec (Item);
+
+ -- Otherwise simple unreferenced message
+
+ else
+ Error_Msg_N
+ ("unit& is not referenced?", Name (Item));
+ end if;
+ end if;
+
+ -- If main unit is a renaming of this unit, then we consider
+ -- the with to be OK (obviously it is needed in this case!)
+
+ elsif Present (Renamed_Entity (Munite))
+ and then Renamed_Entity (Munite) = Lunit
+ then
+ null;
+
+ -- If this unit is referenced, and it is a package, we
+ -- do another test, to see if any of the entities in the
+ -- package are referenced. If none of the entities are
+ -- referenced, we still post a warning. This occurs if
+ -- the only use of the package is in a use clause, or
+ -- in a package renaming declaration.
+
+ elsif Ekind (Lunit) = E_Package then
+
+ -- If Is_Instantiated is set, it means that the package
+ -- is implicitly instantiated (this is the case of a
+ -- parent instance or an actual for a generic package
+ -- formal), and this counts as a reference.
+
+ if Is_Instantiated (Lunit) then
+ null;
+
+ -- If no entities in package, and there is a pragma
+ -- Elaborate_Body present, then assume that this with
+ -- is done for purposes of this elaboration.
+
+ elsif No (First_Entity (Lunit))
+ and then Has_Pragma_Elaborate_Body (Lunit)
+ then
+ null;
+
+ -- Otherwise see if any entities have been referenced
+
+ else
+ Ent := First_Entity (Lunit);
+
+ loop
+ -- No more entities, and we did not find one
+ -- that was referenced. Means we have a definite
+ -- case of a with none of whose entities was
+ -- referenced.
+
+ if No (Ent) then
+
+ -- If in spec, just set the flag
+
+ if Unit = Spec_Unit then
+ Set_No_Entities_Ref_In_Spec (Item);
+
+ -- Else give the warning
+
+ else
+ Error_Msg_N
+ ("no entities of & are referenced?",
+ Name (Item));
+
+ -- Look for renamings of this package, and
+ -- flag them as well. If the original package
+ -- has warnings off, we suppress the warning
+ -- on the renaming as well.
+
+ Pack := Find_Package_Renaming (Munite, Lunit);
+
+ if Present (Pack)
+ and then not Warnings_Off (Lunit)
+ then
+ Error_Msg_NE
+ ("no entities of & are referenced?",
+ Unit_Declaration_Node (Pack),
+ Pack);
+ end if;
+ end if;
+
+ exit;
+
+ -- Case of next entity is referenced
+
+ elsif Referenced (Ent) then
+
+ -- This means that the with is indeed fine, in
+ -- that it is definitely needed somewhere, and
+ -- we can quite worrying about this one.
+
+ -- Except for one little detail, if either of
+ -- the flags was set during spec processing,
+ -- this is where we complain that the with
+ -- could be moved from the spec. If the spec
+ -- contains a visible renaming of the package,
+ -- inhibit warning to move with_clause to body.
+
+ if Ekind (Munite) = E_Package_Body then
+ Pack :=
+ Find_Package_Renaming
+ (Spec_Entity (Munite), Lunit);
+ end if;
+
+ if Unreferenced_In_Spec (Item) then
+ Error_Msg_N
+ ("unit& is not referenced in spec?",
+ Name (Item));
+
+ elsif No_Entities_Ref_In_Spec (Item) then
+ Error_Msg_N
+ ("no entities of & are referenced in spec?",
+ Name (Item));
+
+ else
+ exit;
+ end if;
+
+ if not Is_Visible_Renaming then
+ Error_Msg_N
+ ("\with clause might be moved to body?",
+ Name (Item));
+ end if;
+
+ exit;
+
+ -- Move to next entity to continue search
+
+ else
+ Next_Entity (Ent);
+ end if;
+ end loop;
+ end if;
+
+ -- For a generic package, the only interesting kind of
+ -- reference is an instantiation, since entities cannot
+ -- be referenced directly.
+
+ elsif Is_Generic_Unit (Lunit) then
+
+ -- Unit was never instantiated, set flag for case of spec
+ -- call, or give warning for normal call.
+
+ if not Is_Instantiated (Lunit) then
+ if Unit = Spec_Unit then
+ Set_Unreferenced_In_Spec (Item);
+ else
+ Error_Msg_N
+ ("unit& is never instantiated?", Name (Item));
+ end if;
+
+ -- If unit was indeed instantiated, make sure that
+ -- flag is not set showing it was uninstantiated in
+ -- the spec, and if so, give warning.
+
+ elsif Unreferenced_In_Spec (Item) then
+ Error_Msg_N
+ ("unit& is not instantiated in spec?", Name (Item));
+ Error_Msg_N
+ ("\with clause can be moved to body?", Name (Item));
+ end if;
+ end if;
+ end if;
+
+ Next (Item);
+ end loop;
+
+ end Check_One_Unit;
+
+ -- Start of processing for Check_Unused_Withs
+
+ begin
+ if not Opt.Check_Withs
+ or else Operating_Mode = Check_Syntax
+ then
+ return;
+ end if;
+
+ -- Flag any unused with clauses, but skip this step if we are
+ -- compiling a subunit on its own, since we do not have enough
+ -- information to determine whether with's are used. We will get
+ -- the relevant warnings when we compile the parent. This is the
+ -- normal style of GNAT compilation in any case.
+
+ if Nkind (Unit (Cunit (Main_Unit))) = N_Subunit then
+ return;
+ end if;
+
+ -- Process specified units
+
+ if Spec_Unit = No_Unit then
+
+ -- For main call, check all units
+
+ for Unit in Main_Unit .. Last_Unit loop
+ Check_One_Unit (Unit);
+ end loop;
+
+ else
+ -- For call for spec, check only the spec
+
+ Check_One_Unit (Spec_Unit);
+ end if;
+ end Check_Unused_Withs;
+
+ ---------------------
+ -- End_Conditional --
+ ---------------------
+
+ procedure End_Conditional is
+ begin
+ null;
+ end End_Conditional;
+
+ --------------
+ -- End_Unit --
+ --------------
+
+ procedure End_Unit is
+ begin
+ null;
+ end End_Unit;
+
+ ----------------------------------
+ -- Output_Unreferenced_Messages --
+ ----------------------------------
+
+ procedure Output_Unreferenced_Messages is
+ E : Entity_Id;
+
+ begin
+ for J in Unreferenced_Entities.First ..
+ Unreferenced_Entities.Last
+ loop
+ E := Unreferenced_Entities.Table (J);
+
+ if not Referenced (E) and then not Warnings_Off (E) then
+
+ case Ekind (E) is
+ when E_Variable =>
+ if Present (Renamed_Object (E))
+ and then Comes_From_Source (Renamed_Object (E))
+ then
+ Error_Msg_N ("renamed variable & is not referenced?", E);
+ else
+ Error_Msg_N ("variable & is not referenced?", E);
+ end if;
+
+ when E_Constant =>
+ if Present (Renamed_Object (E)) then
+ Error_Msg_N ("renamed constant & is not referenced?", E);
+ else
+ Error_Msg_N ("constant & is not referenced?", E);
+ end if;
+
+ when E_In_Parameter |
+ E_Out_Parameter |
+ E_In_Out_Parameter =>
+
+ -- Do not emit message for formals of a renaming, because
+ -- they are never referenced explicitly.
+
+ if Nkind (Original_Node (Unit_Declaration_Node (Scope (E))))
+ /= N_Subprogram_Renaming_Declaration
+ then
+ Error_Msg_N ("formal parameter & is not referenced?", E);
+ end if;
+
+ when E_Named_Integer |
+ E_Named_Real =>
+ Error_Msg_N ("named number & is not referenced?", E);
+
+ when E_Enumeration_Literal =>
+ Error_Msg_N ("literal & is not referenced?", E);
+
+ when E_Function =>
+ Error_Msg_N ("function & is not referenced?", E);
+
+ when E_Procedure =>
+ Error_Msg_N ("procedure & is not referenced?", E);
+
+ when Type_Kind =>
+ Error_Msg_N ("type & is not referenced?", E);
+
+ when others =>
+ Error_Msg_N ("& is not referenced?", E);
+ end case;
+
+ Set_Warnings_Off (E);
+ end if;
+ end loop;
+ end Output_Unreferenced_Messages;
+
+ ------------------
+ -- Start_Branch --
+ ------------------
+
+ procedure Start_Branch (Loc : Source_Ptr) is
+ begin
+ null;
+ end Start_Branch;
+
+ -----------------------
+ -- Start_Conditional --
+ -----------------------
+
+ procedure Start_Conditional (If_Stmt : Boolean) is
+ begin
+ null;
+ end Start_Conditional;
+
+ ----------------
+ -- Start_Unit --
+ ----------------
+
+ procedure Start_Unit is
+ begin
+ null;
+ end Start_Unit;
+
+ -----------------------------
+ -- Warn_On_Known_Condition --
+ -----------------------------
+
+ procedure Warn_On_Known_Condition (C : Node_Id) is
+ P : Node_Id;
+
+ begin
+ if Constant_Condition_Warnings
+ and then Nkind (C) = N_Identifier
+ and then
+ (Entity (C) = Standard_False or else Entity (C) = Standard_True)
+ and then Comes_From_Source (Original_Node (C))
+ and then not In_Instance
+ then
+ -- See if this is in a statement or a declaration
+
+ P := Parent (C);
+ loop
+ -- If tree is not attached, do not issue warning (this is very
+ -- peculiar, and probably arises from some other error condition)
+
+ if No (P) then
+ return;
+
+ -- If we are in a declaration, then no warning, since in practice
+ -- conditionals in declarations are used for intended tests which
+ -- may be known at compile time, e.g. things like
+
+ -- x : constant Integer := 2 + (Word'Size = 32);
+
+ -- And a warning is annoying in such cases
+
+ elsif Nkind (P) in N_Declaration
+ or else
+ Nkind (P) in N_Later_Decl_Item
+ then
+ return;
+
+ -- Don't warn in assert pragma, since presumably tests in such
+ -- a context are very definitely intended, and might well be
+ -- known at compile time. Note that we have to test the original
+ -- node, since assert pragmas get rewritten at analysis time.
+
+ elsif Nkind (Original_Node (P)) = N_Pragma
+ and then Chars (Original_Node (P)) = Name_Assert
+ then
+ return;
+ end if;
+
+ exit when Is_Statement (P);
+ P := Parent (P);
+ end loop;
+
+ if Entity (C) = Standard_True then
+ Error_Msg_N ("condition is always True?", C);
+ else
+ Error_Msg_N ("condition is always False?", C);
+ end if;
+ end if;
+ end Warn_On_Known_Condition;
+
+end Sem_Warn;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S E M _ W A R N --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.3 $
+-- --
+-- Copyright (C) 1999-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). --
+-- --
+------------------------------------------------------------------------------
+
+-- This package contains the routines used to deal with issuing warnings
+-- about uses of uninitialized variables and unused with's. It also has
+-- some unrelated routines related to the generation of warnings.
+
+with Types; use Types;
+
+package Sem_Warn is
+
+ ------------------------------------------
+ -- Routines to Handle Unused References --
+ ------------------------------------------
+
+ procedure Check_References (E : Entity_Id; Anod : Node_Id := Empty);
+ -- Called at the end of processing a declarative region. The entity E
+ -- is the entity for the scope. All entities declared in the region,
+ -- as indicated by First_Entity and the entity chain, are checked to
+ -- see if they are variables for which warnings need to be posted for
+ -- either no assignments, or a use before an assignment or no references
+ -- at all. The Anod node is present for the case of an accept statement,
+ -- and references the accept statement. This is used to place the warning
+ -- messages in the right place.
+
+ procedure Check_Unset_Reference (N : Node_Id);
+ -- N is the node for an expression which occurs in a reference position,
+ -- e.g. as the right side of an assignment. This procedure checks to see
+ -- if the node is a reference to a variable entity where the entity has
+ -- Not_Assigned set. If so, the Unset_Reference field is set if it is not
+ -- the first occurrence. No warning is posted, instead warnings will be
+ -- posted later by Check_References. The reason we do things that
+ -- way is that if there are no assignments anywhere, we prefer to flag
+ -- the entity, rather than a reference to it. Note that for the purposes
+ -- of this routine, a type conversion or qualified expression whose
+ -- expression is an entity is also processed. The reason that we do not
+ -- process these at the point of occurrence is that both these constructs
+ -- can occur in non-reference positions (e.g. as out parameters).
+
+ procedure Check_Unused_Withs (Spec_Unit : Unit_Number_Type := No_Unit);
+ -- This routine performs two kinds of checks. It checks that all with'ed
+ -- units are referenced, and that at least one entity of each with'ed
+ -- unit is referenced (the latter check catches units that are only
+ -- referenced in a use or package renaming statement). Appropriate
+ -- warning messages are generated if either of these situations is
+ -- detected.
+ --
+ -- A special case arises when a package body or a subprogram body with
+ -- a separate spec is being compiled. In this case, a with may appear
+ -- on the spec, but be needed only by the body. This still generates
+ -- a warning, but the text is different (the with is not redundant,
+ -- it is misplaced).
+ --
+ -- This special case is implemented by making an initial call to this
+ -- procedure with Spec_Unit set to the unit number of the separate spec.
+ -- This call does not generate any warning messages, but instead may
+ -- result in flags being set in the N_With_Clause node that record that
+ -- there was no use in the spec.
+ --
+ -- The main call (made after all units have been analyzed, with Spec_Unit
+ -- set to the default value of No_Unit) generates the required warnings
+ -- using the flags set by the initial call where appropriate to specialize
+ -- the text of the warning messages.
+
+ ----------------------------------------
+ -- Routines to Deal with Conditionals --
+ ----------------------------------------
+
+ -- These routines provide the necessary interfacing information to
+ -- correctly handle references in conditional structures (if/then/end-if,
+ -- or case/when/end-case). The issue here is that if a variable is only
+ -- set in some but not all branches of a conditional, then it is not
+ -- considered as being set by the conditional as a whole.
+
+ procedure Start_Unit;
+ -- Mark start of new unit to be analyzed, deals with fact that a call to
+ -- Rtsfind may cause new unit to be analyzed in middle of conditional.
+
+ procedure End_Unit;
+ -- Mark end of unit corresponding to previous call to Start_Unit
+
+ procedure Start_Conditional (If_Stmt : Boolean);
+ -- Mark start of a new conditional structure (an if-elsif-else-endif
+ -- or a case-when-end-case structure). If_Stmt is True for the IF
+ -- statement case, and False for the CASE statement case.
+
+ procedure Start_Branch (Loc : Source_Ptr);
+ -- Start processing of one branch of conditional previously marked by
+ -- a call to Start_Conditional (i.e. start of then/elsif/else statements
+ -- or set of statements after a when condition). The Loc value is the
+ -- source pointer to be used in warning messages concerning variables
+ -- not properly initialized in this branch. A branch is terminated by
+ -- either another Start_Branch or End_Conditional call.
+
+ procedure End_Conditional;
+ -- Terminate conditional started by previous Start_Conditional statement.
+
+ ---------------------
+ -- Output Routines --
+ ---------------------
+
+ procedure Output_Unreferenced_Messages;
+ -- Warnings about unreferenced entities are collected till the end of
+ -- the compilation process (see Check_Unset_Reference for further
+ -- details). This procedure outputs waiting warnings, if any.
+
+ ----------------------------
+ -- Other Warning Routines --
+ ----------------------------
+
+ procedure Warn_On_Known_Condition (C : Node_Id);
+ -- C is a node for a boolean expression resluting from a relational
+ -- or membership operation. If the expression has a compile time known
+ -- value, then a warning is output if all the following conditions hold:
+ --
+ -- 1. Original expression comes from source. We don't want to generate
+ -- warnings for internally generated conditionals.
+ --
+ -- 2. As noted above, the expression is a relational or membership
+ -- test, we don't want to generate warnings for boolean variables
+ -- since this is typical of conditional compilation in Ada.
+ --
+ -- 3. The expression appears in a statement, rather than a declaration.
+ -- In practice, most occurrences in declarations are legitimate
+ -- conditionalizations, but occurrences in statements are often
+ -- errors for which the warning is useful.
+ --
+ -- 4. The expression does not occur within an instantiation. A non-
+ -- static expression in a generic may become constant because of
+ -- the attributes of the actuals, and we do not want to warn on
+ -- these legitimate constant foldings.
+ --
+ -- If all these conditions are met, the warning is issued noting that
+ -- the result of the test is always false or always true as appropriate.
+
+end Sem_Warn;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S E Q U E N T I A L _ I O --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.8 $ --
+-- --
+-- This specification is adapted from the Ada Reference Manual for use with --
+-- GNAT. In accordance with the copyright of that document, you can freely --
+-- copy and modify this specification, provided that if you redistribute a --
+-- modified version, any changes that you have made are clearly indicated. --
+-- --
+------------------------------------------------------------------------------
+
+pragma Ada_95;
+with Ada.Sequential_IO;
+
+generic package Sequential_IO renames Ada.Sequential_IO;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S F N _ S C A N --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.6 $
+-- --
+-- 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. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception 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). --
+-- --
+------------------------------------------------------------------------------
+
+with Ada.Exceptions; use Ada.Exceptions;
+
+package body SFN_Scan is
+
+ use ASCII;
+ -- Allow easy access to control character definitions
+
+ type String_Ptr is access String;
+
+ S : String_Ptr;
+ -- Points to the gnat.adc input file
+
+ P : Natural;
+ -- Subscript of next character to process in S
+
+ Line_Num : Natural;
+ -- Current line number
+
+ Start_Of_Line : Natural;
+ -- Subscript of first character at start of current line
+
+ ----------------------
+ -- Local Procedures --
+ ----------------------
+
+ function Acquire_String (B : Natural; E : Natural) return String;
+ -- This function takes a string scanned out by Scan_String, strips
+ -- the enclosing quote characters and any internal doubled quote
+ -- characters, and returns the result as a String. The arguments
+ -- B and E are as returned from a call to Scan_String. The lower
+ -- bound of the string returned is always 1.
+
+ function Acquire_Unit_Name return String;
+ -- Skips white space, and then scans and returns a unit name. The
+ -- unit name is cased exactly as it appears in the source file.
+ -- The terminating character must be white space, or a comma or
+ -- a right parenthesis or end of file.
+
+ function At_EOF return Boolean;
+ pragma Inline (At_EOF);
+ -- Returns True if at end of file, False if not. Note that this
+ -- function does NOT skip white space, so P is always unchanged.
+
+ procedure Check_Not_At_EOF;
+ pragma Inline (Check_Not_At_EOF);
+ -- Skips past white space if any, and then raises Error if at
+ -- end of file. Otherwise returns with P skipped past whitespace.
+
+ function Check_File_Type return Character;
+ -- Skips white space if any, and then looks for any of the tokens
+ -- Spec_File_Name, Body_File_Name, or Subunit_File_Name. If one
+ -- of these is found then the value returned is 's', 'b' or 'u'
+ -- respectively, and P is bumped past the token. If none of
+ -- these tokens is found, then P is unchanged (except for
+ -- possible skip of white space), and a space is returned.
+
+ function Check_Token (T : String) return Boolean;
+ -- Skips white space if any, and then checks if the string at the
+ -- current location matches the given string T, and the character
+ -- immediately following is non-alphabetic, non-numeric. If so,
+ -- P is stepped past the token, and True is returned. If not,
+ -- P is unchanged (except for possibly skipping past whitespace),
+ -- and False is returned. S may contain only lower-case letters
+ -- ('a' .. 'z').
+
+ procedure Error (Err : String);
+ -- Called if an error is detected. Raises Syntax_Error_In_GNAT_ADC
+ -- with a message of the form gnat.adc:line:col: xxx, where xxx is
+ -- the string Err passed as a parameter.
+
+ procedure Require_Token (T : String);
+ -- Skips white space if any, and then requires the given string
+ -- to be present. If it is, the P is stepped past it, otherwise
+ -- Error is raised, since this is a syntax error. Require_Token
+ -- is used only for sequences of special characters, so there
+ -- is no issue of terminators, or casing of letters.
+
+ procedure Scan_String (B : out Natural; E : out Natural);
+ -- Skips white space if any, then requires that a double quote
+ -- or percent be present (start of string). Raises error if
+ -- neither of these two characters is found. Otherwise scans
+ -- out the string, and returns with P pointing past the
+ -- closing quote and S (B .. E) contains the characters of the
+ -- string (including the enclosing quotes, with internal quotes
+ -- still doubled). Raises Error if the string is malformed.
+
+ procedure Skip_WS;
+ -- Skips P past any white space characters (end of line
+ -- characters, spaces, comments, horizontal tab characters).
+
+ --------------------
+ -- Acquire_String --
+ --------------------
+
+ function Acquire_String (B : Natural; E : Natural) return String is
+ Str : String (1 .. E - B - 1);
+ Q : constant Character := S (B);
+ J : Natural;
+ Ptr : Natural;
+
+ begin
+ Ptr := B + 1;
+ J := 0;
+ while Ptr < E loop
+ J := J + 1;
+ Str (J) := S (Ptr);
+
+ if S (Ptr) = Q and then S (Ptr + 1) = Q then
+ Ptr := Ptr + 2;
+ else
+ Ptr := Ptr + 1;
+ end if;
+ end loop;
+
+ return Str (1 .. J);
+ end Acquire_String;
+
+ -----------------------
+ -- Acquire_Unit_Name --
+ -----------------------
+
+ function Acquire_Unit_Name return String is
+ B : Natural;
+
+ begin
+ Check_Not_At_EOF;
+ B := P;
+
+ while not At_EOF loop
+ exit when S (P) not in '0' .. '9'
+ and then S (P) /= '.'
+ and then S (P) /= '_'
+ and then not (S (P) = '[' and then S (P + 1) = '"')
+ and then not (S (P) = '"' and then S (P - 1) = '[')
+ and then not (S (P) = '"' and then S (P + 1) = ']')
+ and then not (S (P) = ']' and then S (P - 1) = '"')
+ and then S (P) < 'A';
+ P := P + 1;
+ end loop;
+
+ if P = B then
+ Error ("null unit name");
+ end if;
+
+ return S (B .. P - 1);
+ end Acquire_Unit_Name;
+
+ ------------
+ -- At_EOF --
+ ------------
+
+ function At_EOF return Boolean is
+ begin
+ return P > S'Last;
+ end At_EOF;
+
+ ---------------------
+ -- Check_File_Type --
+ ---------------------
+
+ function Check_File_Type return Character is
+ begin
+ if Check_Token ("spec_file_name") then
+ return 's';
+ elsif Check_Token ("body_file_name") then
+ return 'b';
+ elsif Check_Token ("subunit_file_name") then
+ return 'u';
+ else
+ return ' ';
+ end if;
+ end Check_File_Type;
+
+ ----------------------
+ -- Check_Not_At_EOF --
+ ----------------------
+
+ procedure Check_Not_At_EOF is
+ begin
+ Skip_WS;
+
+ if At_EOF then
+ Error ("unexpected end of file");
+ end if;
+
+ return;
+ end Check_Not_At_EOF;
+
+ -----------------
+ -- Check_Token --
+ -----------------
+
+ function Check_Token (T : String) return Boolean is
+ Save_P : Natural;
+ C : Character;
+
+ begin
+ Skip_WS;
+ Save_P := P;
+
+ for K in T'Range loop
+ if At_EOF then
+ P := Save_P;
+ return False;
+ end if;
+
+ C := S (P);
+
+ if C in 'A' .. 'Z' then
+ C := Character'Val (Character'Pos (C) +
+ (Character'Pos ('a') - Character'Pos ('A')));
+ end if;
+
+ if C /= T (K) then
+ P := Save_P;
+ return False;
+ end if;
+
+ P := P + 1;
+ end loop;
+
+ if At_EOF then
+ return True;
+ end if;
+
+ C := S (P);
+
+ if C in '0' .. '9'
+ or else C in 'a' .. 'z'
+ or else C in 'A' .. 'Z'
+ or else C > Character'Val (127)
+ then
+ P := Save_P;
+ return False;
+
+ else
+ return True;
+ end if;
+ end Check_Token;
+
+ -----------
+ -- Error --
+ -----------
+
+ procedure Error (Err : String) is
+ C : Natural := 0;
+ -- Column number
+
+ M : String (1 .. 80);
+ -- Buffer used to build resulting error msg
+
+ LM : Natural := 0;
+ -- Pointer to last set location in M
+
+ procedure Add_Nat (N : Natural);
+ -- Add chars of integer to error msg buffer
+
+ procedure Add_Nat (N : Natural) is
+ begin
+ if N > 9 then
+ Add_Nat (N / 10);
+ end if;
+
+ LM := LM + 1;
+ M (LM) := Character'Val (N mod 10 + Character'Pos ('0'));
+ end Add_Nat;
+
+ -- Start of processing for Error
+
+ begin
+ M (1 .. 9) := "gnat.adc:";
+ LM := 9;
+ Add_Nat (Line_Num);
+ LM := LM + 1;
+ M (LM) := ':';
+
+ -- Determine column number
+
+ for X in Start_Of_Line .. P loop
+ C := C + 1;
+
+ if S (X) = HT then
+ C := (C + 7) / 8 * 8;
+ end if;
+ end loop;
+
+ Add_Nat (C);
+ M (LM + 1) := ':';
+ LM := LM + 1;
+ M (LM + 1) := ' ';
+ LM := LM + 1;
+
+ M (LM + 1 .. LM + Err'Length) := Err;
+ LM := LM + Err'Length;
+
+ Raise_Exception (Syntax_Error_In_GNAT_ADC'Identity, M (1 .. LM));
+ end Error;
+
+ -------------------
+ -- Require_Token --
+ -------------------
+
+ procedure Require_Token (T : String) is
+ SaveP : Natural;
+
+ begin
+ Skip_WS;
+ SaveP := P;
+
+ for J in T'Range loop
+
+ if At_EOF or else S (P) /= T (J) then
+ declare
+ S : String (1 .. T'Length + 10);
+
+ begin
+ S (1 .. 9) := "missing """;
+ S (10 .. T'Length + 9) := T;
+ S (T'Length + 10) := '"';
+ P := SaveP;
+ Error (S);
+ end;
+
+ else
+ P := P + 1;
+ end if;
+ end loop;
+ end Require_Token;
+
+ ----------------------
+ -- Scan_SFN_Pragmas --
+ ----------------------
+
+ procedure Scan_SFN_Pragmas
+ (Source : String;
+ SFN_Ptr : Set_File_Name_Ptr;
+ SFNP_Ptr : Set_File_Name_Pattern_Ptr)
+ is
+ B, E : Natural;
+ Typ : Character;
+ Cas : Character;
+
+ begin
+ Line_Num := 1;
+ S := Source'Unrestricted_Access;
+ P := Source'First;
+ Start_Of_Line := P;
+
+ -- Loop through pragmas in file
+
+ Main_Scan_Loop : loop
+ Skip_WS;
+ exit Main_Scan_Loop when At_EOF;
+
+ -- Error if something other than pragma
+
+ if not Check_Token ("pragma") then
+ Error ("non pragma encountered");
+ end if;
+
+ -- Source_File_Name pragma case
+
+ if Check_Token ("source_file_name") then
+ Require_Token ("(");
+
+ Typ := Check_File_Type;
+
+ -- First format, with unit name first
+
+ if Typ = ' ' then
+ if Check_Token ("unit_name") then
+ Require_Token ("=>");
+ end if;
+
+ declare
+ U : constant String := Acquire_Unit_Name;
+
+ begin
+ Require_Token (",");
+ Typ := Check_File_Type;
+
+ if Typ /= 's' and then Typ /= 'b' then
+ Error ("bad pragma");
+ end if;
+
+ Require_Token ("=>");
+ Scan_String (B, E);
+
+ declare
+ F : constant String := Acquire_String (B, E);
+
+ begin
+ Require_Token (")");
+ Require_Token (";");
+ SFN_Ptr.all (Typ, U, F);
+ end;
+ end;
+
+ -- Second format with pattern string
+
+ else
+ Require_Token ("=>");
+ Scan_String (B, E);
+
+ declare
+ Pat : constant String := Acquire_String (B, E);
+ Nas : Natural := 0;
+
+ begin
+ -- Check exactly one asterisk
+
+ for J in Pat'Range loop
+ if Pat (J) = '*' then
+ Nas := Nas + 1;
+ end if;
+ end loop;
+
+ if Nas /= 1 then
+ Error ("** not allowed");
+ end if;
+
+ B := 0;
+ E := 0;
+ Cas := ' ';
+
+ -- Loop to scan out Casing or Dot_Replacement parameters
+
+ loop
+ Check_Not_At_EOF;
+ exit when S (P) = ')';
+ Require_Token (",");
+
+ if Check_Token ("casing") then
+ Require_Token ("=>");
+
+ if Cas /= ' ' then
+ Error ("duplicate casing argument");
+ elsif Check_Token ("lowercase") then
+ Cas := 'l';
+ elsif Check_Token ("uppercase") then
+ Cas := 'u';
+ elsif Check_Token ("mixedcase") then
+ Cas := 'm';
+ else
+ Error ("invalid casing argument");
+ end if;
+
+ elsif Check_Token ("dot_replacement") then
+ Require_Token ("=>");
+
+ if E /= 0 then
+ Error ("duplicate dot_replacement");
+ else
+ Scan_String (B, E);
+ end if;
+
+ else
+ Error ("invalid argument");
+ end if;
+ end loop;
+
+ Require_Token (")");
+ Require_Token (";");
+
+ if Cas = ' ' then
+ Cas := 'l';
+ end if;
+
+ if E = 0 then
+ SFNP_Ptr.all (Pat, Typ, ".", Cas);
+
+ else
+ declare
+ Dot : constant String := Acquire_String (B, E);
+
+ begin
+ SFNP_Ptr.all (Pat, Typ, Dot, Cas);
+ end;
+ end if;
+ end;
+ end if;
+
+ -- Some other pragma, scan to semicolon at end of pragma
+
+ else
+ Skip_Loop : loop
+ exit Main_Scan_Loop when At_EOF;
+ exit Skip_Loop when S (P) = ';';
+
+ if S (P) = '"' or else S (P) = '%' then
+ Scan_String (B, E);
+ else
+ P := P + 1;
+ end if;
+ end loop Skip_Loop;
+
+ -- We successfuly skipped to semicolon, so skip past it
+
+ P := P + 1;
+ end if;
+ end loop Main_Scan_Loop;
+
+ exception
+ when others =>
+ Cursor := P - S'First + 1;
+ raise;
+ end Scan_SFN_Pragmas;
+
+ -----------------
+ -- Scan_String --
+ -----------------
+
+ procedure Scan_String (B : out Natural; E : out Natural) is
+ Q : Character;
+
+ begin
+ Check_Not_At_EOF;
+
+ if S (P) = '"' then
+ Q := '"';
+ elsif S (P) = '%' then
+ Q := '%';
+ else
+ Error ("bad string");
+ Q := '"';
+ end if;
+
+ -- Scan out the string, B points to first char
+
+ B := P;
+ P := P + 1;
+
+ loop
+ if At_EOF or else S (P) = LF or else S (P) = CR then
+ Error ("missing string quote");
+
+ elsif S (P) = HT then
+ Error ("tab character in string");
+
+ elsif S (P) /= Q then
+ P := P + 1;
+
+ -- We have a quote
+
+ else
+ P := P + 1;
+
+ -- Check for doubled quote
+
+ if not At_EOF and then S (P) = Q then
+ P := P + 1;
+
+ -- Otherwise this is the terminating quote
+
+ else
+ E := P - 1;
+ return;
+ end if;
+ end if;
+ end loop;
+ end Scan_String;
+
+ -------------
+ -- Skip_WS --
+ -------------
+
+ procedure Skip_WS is
+ begin
+ WS_Scan : while not At_EOF loop
+ case S (P) is
+
+ -- End of physical line
+
+ when CR | LF =>
+ Line_Num := Line_Num + 1;
+ P := P + 1;
+
+ while not At_EOF
+ and then (S (P) = CR or else S (P) = LF)
+ loop
+ Line_Num := Line_Num + 1;
+ P := P + 1;
+ end loop;
+
+ Start_Of_Line := P;
+
+ -- All other cases of white space characters
+
+ when ' ' | FF | VT | HT =>
+ P := P + 1;
+
+ -- Comment
+
+ when '-' =>
+ P := P + 1;
+
+ if At_EOF then
+ Error ("bad comment");
+
+ elsif S (P) = '-' then
+ P := P + 1;
+
+ while not At_EOF loop
+ case S (P) is
+ when CR | LF | FF | VT =>
+ exit;
+ when others =>
+ P := P + 1;
+ end case;
+ end loop;
+
+ else
+ P := P - 1;
+ exit WS_Scan;
+ end if;
+
+ when others =>
+ exit WS_Scan;
+
+ end case;
+ end loop WS_Scan;
+ end Skip_WS;
+
+end SFN_Scan;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S F N _ S C A N --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.2 $
+-- --
+-- 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). --
+-- --
+------------------------------------------------------------------------------
+
+-- This package provides a stand alone capability for scanning a gnat.adc
+-- file for Source_File_Name pragmas. This is for use in tools other than
+-- the compiler, which want to scan source file name pragmas without the
+-- overhead of the full compiler scanner and parser.
+
+-- Note that neither the package spec, nor the package body, of this
+-- unit contains any with statements at all. This is a compeltely
+-- independent package, suitable for incorporation into tools that do
+-- not access any other units in the GNAT compiler or tools sources.
+
+-- This package is NOT task safe, so multiple tasks that may call the
+-- Scan_SFN_Pragmas procedure at the same time are responsibible for
+-- avoiding such multiple calls by appropriate synchronization.
+
+package SFN_Scan is
+
+ -- The call to SFN_Scan passes pointers to two procedures that are
+ -- used to store the results of scanning any Source_File_Name pragmas
+ -- that are encountered. The following access types define the form
+ -- of these procedures:
+
+ type Set_File_Name_Ptr is access
+ procedure (Typ : Character; U : String; F : String);
+ -- The procedure with this profile is called when a Source_File_Name
+ -- pragma of the form having a unit name parameter. Typ is 'b' for
+ -- a body file name, and 's' for a spec file name. U is a string that
+ -- contains the unit name, exactly as it appeared in the source file,
+ -- and F is the file taken from the second parameter.
+
+ type Set_File_Name_Pattern_Ptr is access
+ procedure (Pat : String; Typ : Character; Dot : String; Cas : Character);
+ -- This is called to process a Source_File_Name pragma whose first
+ -- argument is a file pattern. Pat is this pattern string, which
+ -- contains an asterisk to correspond to the unit. Typ is one of
+ -- ('b'/'s'/'u') for body/spec/subunit, Dot is the separator string
+ -- for child/subunit names (default is "."), and Cas is one of
+ -- ('l'/'u'/'m') indicating the required case for the file name.
+ -- The default setting for Cas is 'l' if no parameter is present.
+
+ Cursor : Natural;
+ -- Used to record the cursor value if a syntax error is found
+
+ Syntax_Error_In_GNAT_ADC : exception;
+ -- Exception raised if a syntax error is found
+
+ procedure Scan_SFN_Pragmas
+ (Source : String;
+ SFN_Ptr : Set_File_Name_Ptr;
+ SFNP_Ptr : Set_File_Name_Pattern_Ptr);
+ -- This is the procedure called to scan a gnat.adc file. The Source
+ -- parameter points to the full text of the file, with normal line end
+ -- characters, in the format normally read by the compiler. The two
+ -- parameters SFN_Ptr and SFNP_Ptr point to procedures that will be
+ -- called to register Source_File_Name pragmas as they are found.
+ --
+ -- If a syntax error is found, then Syntax_Error_In_GNAT_ADC is raised,
+ -- and the location SFN_Scan.Cursor contains the approximate index of
+ -- the error in the source string.
+ --
+ -- The scan assumes that it is dealing with a valid gnat.adc file,
+ -- that includes only pragmas and comments. It does not do a full
+ -- syntax correctness scan by any means, but if it does find anything
+ -- that it can tell is wrong it will immediately raise the exception
+ -- to indicate the aproximate location of the error
+
+end SFN_Scan;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S I N F O . C N --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.7 $
+-- --
+-- 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 child package of Sinfo contains some routines that permit in place
+-- alteration of existing tree nodes by changing the value in the Nkind
+-- field. Since Nkind functions logically in a manner similart to a variant
+-- record discriminant part, such alterations cannot be permitted in a
+-- general manner, but in some specific cases, the fields of related nodes
+-- have been deliberately layed out in a manner that permits such alteration.
+-- that determin
+
+with Atree; use Atree;
+
+package body Sinfo.CN is
+
+ use Atree.Unchecked_Access;
+ -- This package is one of the few packages which is allowed to make direct
+ -- references to tree nodes (since it is in the business of providing a
+ -- higher level of tree access which other clients are expected to use and
+ -- which implements checks).
+
+ ------------------------------------------------------------
+ -- Change_Character_Literal_To_Defining_Character_Literal --
+ ------------------------------------------------------------
+
+ procedure Change_Character_Literal_To_Defining_Character_Literal
+ (N : in out Node_Id)
+ is
+ begin
+ Set_Nkind (N, N_Defining_Character_Literal);
+ N := Extend_Node (N);
+ end Change_Character_Literal_To_Defining_Character_Literal;
+
+ ------------------------------------
+ -- Change_Conversion_To_Unchecked --
+ ------------------------------------
+
+ procedure Change_Conversion_To_Unchecked (N : Node_Id) is
+ begin
+ Set_Do_Overflow_Check (N, False);
+ Set_Do_Tag_Check (N, False);
+ Set_Do_Length_Check (N, False);
+ Set_Nkind (N, N_Unchecked_Type_Conversion);
+ end Change_Conversion_To_Unchecked;
+
+ ----------------------------------------------
+ -- Change_Identifier_To_Defining_Identifier --
+ ----------------------------------------------
+
+ procedure Change_Identifier_To_Defining_Identifier (N : in out Node_Id) is
+ begin
+ Set_Nkind (N, N_Defining_Identifier);
+ N := Extend_Node (N);
+ end Change_Identifier_To_Defining_Identifier;
+
+ --------------------------------------------------------
+ -- Change_Operator_Symbol_To_Defining_Operator_Symbol --
+ --------------------------------------------------------
+
+ procedure Change_Operator_Symbol_To_Defining_Operator_Symbol
+ (N : in out Node_Id)
+ is
+ begin
+ Set_Nkind (N, N_Defining_Operator_Symbol);
+ Set_Node2 (N, Empty); -- Clear unused Str2 field
+ N := Extend_Node (N);
+ end Change_Operator_Symbol_To_Defining_Operator_Symbol;
+
+ ----------------------------------------------
+ -- Change_Operator_Symbol_To_String_Literal --
+ ----------------------------------------------
+
+ procedure Change_Operator_Symbol_To_String_Literal (N : Node_Id) is
+ begin
+ Set_Nkind (N, N_String_Literal);
+ Set_Node1 (N, Empty); -- clear Name1 field
+ end Change_Operator_Symbol_To_String_Literal;
+
+ ------------------------------------------------
+ -- Change_Selected_Component_To_Expanded_Name --
+ ------------------------------------------------
+
+ procedure Change_Selected_Component_To_Expanded_Name (N : Node_Id) is
+ begin
+ Set_Nkind (N, N_Expanded_Name);
+ Set_Chars (N, Chars (Selector_Name (N)));
+ end Change_Selected_Component_To_Expanded_Name;
+
+end Sinfo.CN;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S I N F O . C N --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.9 $
+-- --
+-- 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 child package of Sinfo contains some routines that permit in place
+-- alteration of existing tree nodes by changing the value in the Nkind
+-- field. Since Nkind functions logically in a manner similar to a variant
+-- record discriminant part, such alterations cannot be permitted in a
+-- general manner, but in some specific cases, the fields of related nodes
+-- have been deliberately laid out in a manner that permits such alteration.
+
+package Sinfo.CN is
+
+ procedure Change_Identifier_To_Defining_Identifier (N : in out Node_Id);
+ -- N must refer to a node of type N_Identifier. This node is modified to
+ -- be of type N_Defining_Identifier. The scanner always returns identifiers
+ -- as N_Identifier. The parser then uses this routine to change the node
+ -- to be a defining identifier where the context demands it. This routine
+ -- also allocates the necessary extension node. Note that this procedure
+ -- may (but is not required to) change the Id of the node in question.
+
+ procedure Change_Character_Literal_To_Defining_Character_Literal
+ (N : in out Node_Id);
+ -- Similar processing for a character literal
+
+ procedure Change_Operator_Symbol_To_Defining_Operator_Symbol
+ (N : in out Node_Id);
+ -- Similar processing for an operator symbol
+
+ procedure Change_Conversion_To_Unchecked (N : Node_Id);
+ -- Change checked conversion node to unchecked conversion node, clearing
+ -- irrelevant check flags (other fields in the two nodes are identical)
+
+ procedure Change_Operator_Symbol_To_String_Literal (N : Node_Id);
+ -- The scanner returns any string that looks like an operator symbol as
+ -- a N_Operator_Symbol node. The parser then uses this procedure to change
+ -- the node to a normal N_String_Literal node if the context is not one
+ -- in which an operator symbol is required. There are some cases where the
+ -- parser cannot tell, in which case this transformation happens later on.
+
+ procedure Change_Selected_Component_To_Expanded_Name (N : Node_Id);
+ -- The parser always generates Selected_Component nodes. The semantics
+ -- modifies these to Expanded_Name nodes where appropriate. Note that
+ -- on return the Chars field is set to a copy of the contents of the
+ -- Chars field of the Selector_Name field.
+
+end Sinfo.CN;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S I N F O --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.314 $
+-- --
+-- 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 other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception 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). --
+-- --
+------------------------------------------------------------------------------
+
+pragma Style_Checks (All_Checks);
+-- No subprogram ordering check, due to logical grouping
+
+with Atree; use Atree;
+
+package body Sinfo is
+
+ use Atree.Unchecked_Access;
+ -- This package is one of the few packages which is allowed to make direct
+ -- references to tree nodes (since it is in the business of providing a
+ -- higher level of tree access which other clients are expected to use and
+ -- which implements checks).
+
+ use Atree_Private_Part;
+ -- The only reason that we ask for direct access to the private part of
+ -- the tree package is so that we can directly reference the Nkind field
+ -- of nodes table entries. We do this since it helps the efficiency of
+ -- the Sinfo debugging checks considerably (note that when we are checking
+ -- Nkind values, we don't need to check for a valid node reference, because
+ -- we will check that anyway when we reference the field).
+
+ NT : Nodes.Table_Ptr renames Nodes.Table;
+ -- A short hand abbreviation, useful for the debugging checks
+
+ ----------------------------
+ -- Field Access Functions --
+ ----------------------------
+
+ function ABE_Is_Certain
+ (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Formal_Package_Declaration
+ or else NT (N).Nkind = N_Function_Call
+ or else NT (N).Nkind = N_Function_Instantiation
+ or else NT (N).Nkind = N_Package_Instantiation
+ or else NT (N).Nkind = N_Procedure_Call_Statement
+ or else NT (N).Nkind = N_Procedure_Instantiation);
+ return Flag18 (N);
+ end ABE_Is_Certain;
+
+ function Abort_Present
+ (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Requeue_Statement);
+ return Flag15 (N);
+ end Abort_Present;
+
+ function Abortable_Part
+ (N : Node_Id) return Node_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Asynchronous_Select);
+ return Node2 (N);
+ end Abortable_Part;
+
+ function Abstract_Present
+ (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Derived_Type_Definition
+ or else NT (N).Nkind = N_Formal_Derived_Type_Definition
+ or else NT (N).Nkind = N_Formal_Private_Type_Definition
+ or else NT (N).Nkind = N_Private_Extension_Declaration
+ or else NT (N).Nkind = N_Private_Type_Declaration
+ or else NT (N).Nkind = N_Record_Definition);
+ return Flag4 (N);
+ end Abstract_Present;
+
+ function Accept_Handler_Records
+ (N : Node_Id) return List_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Accept_Alternative);
+ return List5 (N);
+ end Accept_Handler_Records;
+
+ function Accept_Statement
+ (N : Node_Id) return Node_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Accept_Alternative);
+ return Node2 (N);
+ end Accept_Statement;
+
+ function Access_Types_To_Process
+ (N : Node_Id) return Elist_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Freeze_Entity);
+ return Elist2 (N);
+ end Access_Types_To_Process;
+
+ function Actions
+ (N : Node_Id) return List_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_And_Then
+ or else NT (N).Nkind = N_Compilation_Unit_Aux
+ or else NT (N).Nkind = N_Freeze_Entity
+ or else NT (N).Nkind = N_Or_Else);
+ return List1 (N);
+ end Actions;
+
+ function Activation_Chain_Entity
+ (N : Node_Id) return Node_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Block_Statement
+ or else NT (N).Nkind = N_Entry_Body
+ or else NT (N).Nkind = N_Generic_Package_Declaration
+ or else NT (N).Nkind = N_Package_Declaration
+ or else NT (N).Nkind = N_Subprogram_Body
+ or else NT (N).Nkind = N_Task_Body);
+ return Node3 (N);
+ end Activation_Chain_Entity;
+
+ function Acts_As_Spec
+ (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Compilation_Unit
+ or else NT (N).Nkind = N_Subprogram_Body);
+ return Flag4 (N);
+ end Acts_As_Spec;
+
+ function Aggregate_Bounds
+ (N : Node_Id) return Node_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Aggregate);
+ return Node3 (N);
+ end Aggregate_Bounds;
+
+ function Aliased_Present
+ (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Component_Declaration
+ or else NT (N).Nkind = N_Constrained_Array_Definition
+ or else NT (N).Nkind = N_Object_Declaration
+ or else NT (N).Nkind = N_Unconstrained_Array_Definition);
+ return Flag4 (N);
+ end Aliased_Present;
+
+ function All_Others
+ (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Others_Choice);
+ return Flag11 (N);
+ end All_Others;
+
+ function All_Present
+ (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Access_To_Object_Definition);
+ return Flag15 (N);
+ end All_Present;
+
+ function Alternatives
+ (N : Node_Id) return List_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Case_Statement);
+ return List4 (N);
+ end Alternatives;
+
+ function Ancestor_Part
+ (N : Node_Id) return Node_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Extension_Aggregate);
+ return Node3 (N);
+ end Ancestor_Part;
+
+ function Array_Aggregate
+ (N : Node_Id) return Node_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Enumeration_Representation_Clause);
+ return Node3 (N);
+ end Array_Aggregate;
+
+ function Assignment_OK
+ (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Object_Declaration
+ or else NT (N).Nkind in N_Subexpr);
+ return Flag15 (N);
+ end Assignment_OK;
+
+ function At_End_Proc
+ (N : Node_Id) return Node_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Handled_Sequence_Of_Statements);
+ return Node1 (N);
+ end At_End_Proc;
+
+ function Attribute_Name
+ (N : Node_Id) return Name_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Attribute_Reference);
+ return Name2 (N);
+ end Attribute_Name;
+
+ function Aux_Decls_Node
+ (N : Node_Id) return Node_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Compilation_Unit);
+ return Node5 (N);
+ end Aux_Decls_Node;
+
+ function Backwards_OK
+ (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Assignment_Statement);
+ return Flag6 (N);
+ end Backwards_OK;
+
+ function Bad_Is_Detected
+ (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Subprogram_Body);
+ return Flag15 (N);
+ end Bad_Is_Detected;
+
+ function Body_Required
+ (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Compilation_Unit);
+ return Flag13 (N);
+ end Body_Required;
+
+ function Body_To_Inline
+ (N : Node_Id) return Node_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Subprogram_Declaration);
+ return Node3 (N);
+ end Body_To_Inline;
+
+ function Box_Present
+ (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Formal_Package_Declaration
+ or else NT (N).Nkind = N_Formal_Subprogram_Declaration);
+ return Flag15 (N);
+ end Box_Present;
+
+ function By_Ref
+ (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Return_Statement);
+ return Flag5 (N);
+ end By_Ref;
+
+ function Char_Literal_Value
+ (N : Node_Id) return Char_Code is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Character_Literal);
+ return Char_Code2 (N);
+ end Char_Literal_Value;
+
+ function Chars
+ (N : Node_Id) return Name_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind in N_Has_Chars);
+ return Name1 (N);
+ end Chars;
+
+ function Choice_Parameter
+ (N : Node_Id) return Node_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Exception_Handler);
+ return Node2 (N);
+ end Choice_Parameter;
+
+ function Choices
+ (N : Node_Id) return List_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Component_Association);
+ return List1 (N);
+ end Choices;
+
+ function Compile_Time_Known_Aggregate
+ (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Aggregate);
+ return Flag18 (N);
+ end Compile_Time_Known_Aggregate;
+
+ function Component_Associations
+ (N : Node_Id) return List_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Aggregate
+ or else NT (N).Nkind = N_Extension_Aggregate);
+ return List2 (N);
+ end Component_Associations;
+
+ function Component_Clauses
+ (N : Node_Id) return List_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Record_Representation_Clause);
+ return List3 (N);
+ end Component_Clauses;
+
+ function Component_Items
+ (N : Node_Id) return List_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Component_List);
+ return List3 (N);
+ end Component_Items;
+
+ function Component_List
+ (N : Node_Id) return Node_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Record_Definition
+ or else NT (N).Nkind = N_Variant);
+ return Node1 (N);
+ end Component_List;
+
+ function Component_Name
+ (N : Node_Id) return Node_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Component_Clause);
+ return Node1 (N);
+ end Component_Name;
+
+ function Condition
+ (N : Node_Id) return Node_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Accept_Alternative
+ or else NT (N).Nkind = N_Delay_Alternative
+ or else NT (N).Nkind = N_Elsif_Part
+ or else NT (N).Nkind = N_Entry_Body_Formal_Part
+ or else NT (N).Nkind = N_Exit_Statement
+ or else NT (N).Nkind = N_If_Statement
+ or else NT (N).Nkind = N_Iteration_Scheme
+ or else NT (N).Nkind = N_Raise_Constraint_Error
+ or else NT (N).Nkind = N_Raise_Program_Error
+ or else NT (N).Nkind = N_Raise_Storage_Error
+ or else NT (N).Nkind = N_Terminate_Alternative);
+ return Node1 (N);
+ end Condition;
+
+ function Condition_Actions
+ (N : Node_Id) return List_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Elsif_Part
+ or else NT (N).Nkind = N_Iteration_Scheme);
+ return List3 (N);
+ end Condition_Actions;
+
+ function Constant_Present
+ (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Access_To_Object_Definition
+ or else NT (N).Nkind = N_Object_Declaration);
+ return Flag17 (N);
+ end Constant_Present;
+
+ function Constraint
+ (N : Node_Id) return Node_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Subtype_Indication);
+ return Node3 (N);
+ end Constraint;
+
+ function Constraints
+ (N : Node_Id) return List_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Index_Or_Discriminant_Constraint);
+ return List1 (N);
+ end Constraints;
+
+ function Context_Installed
+ (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_With_Clause);
+ return Flag13 (N);
+ end Context_Installed;
+
+ function Context_Items
+ (N : Node_Id) return List_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Compilation_Unit);
+ return List1 (N);
+ end Context_Items;
+
+ function Controlling_Argument
+ (N : Node_Id) return Node_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Function_Call
+ or else NT (N).Nkind = N_Procedure_Call_Statement);
+ return Node1 (N);
+ end Controlling_Argument;
+
+ function Conversion_OK
+ (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Type_Conversion);
+ return Flag14 (N);
+ end Conversion_OK;
+
+ function Corresponding_Body
+ (N : Node_Id) return Node_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Generic_Package_Declaration
+ or else NT (N).Nkind = N_Generic_Subprogram_Declaration
+ or else NT (N).Nkind = N_Package_Body_Stub
+ or else NT (N).Nkind = N_Package_Declaration
+ or else NT (N).Nkind = N_Protected_Body_Stub
+ or else NT (N).Nkind = N_Protected_Type_Declaration
+ or else NT (N).Nkind = N_Subprogram_Body_Stub
+ or else NT (N).Nkind = N_Subprogram_Declaration
+ or else NT (N).Nkind = N_Task_Body_Stub
+ or else NT (N).Nkind = N_Task_Type_Declaration);
+ return Node5 (N);
+ end Corresponding_Body;
+
+ function Corresponding_Generic_Association
+ (N : Node_Id) return Node_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Object_Declaration
+ or else NT (N).Nkind = N_Object_Renaming_Declaration);
+ return Node5 (N);
+ end Corresponding_Generic_Association;
+
+ function Corresponding_Integer_Value
+ (N : Node_Id) return Uint is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Real_Literal);
+ return Uint4 (N);
+ end Corresponding_Integer_Value;
+
+ function Corresponding_Spec
+ (N : Node_Id) return Node_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Package_Body
+ or else NT (N).Nkind = N_Protected_Body
+ or else NT (N).Nkind = N_Subprogram_Body
+ or else NT (N).Nkind = N_Subprogram_Renaming_Declaration
+ or else NT (N).Nkind = N_Task_Body
+ or else NT (N).Nkind = N_With_Clause);
+ return Node5 (N);
+ end Corresponding_Spec;
+
+ function Corresponding_Stub
+ (N : Node_Id) return Node_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Subunit);
+ return Node3 (N);
+ end Corresponding_Stub;
+
+ function Dcheck_Function
+ (N : Node_Id) return Entity_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Variant);
+ return Node5 (N);
+ end Dcheck_Function;
+
+ function Debug_Statement
+ (N : Node_Id) return Node_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Pragma);
+ return Node3 (N);
+ end Debug_Statement;
+
+ function Declarations
+ (N : Node_Id) return List_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Accept_Statement
+ or else NT (N).Nkind = N_Block_Statement
+ or else NT (N).Nkind = N_Compilation_Unit_Aux
+ or else NT (N).Nkind = N_Entry_Body
+ or else NT (N).Nkind = N_Package_Body
+ or else NT (N).Nkind = N_Protected_Body
+ or else NT (N).Nkind = N_Subprogram_Body
+ or else NT (N).Nkind = N_Task_Body);
+ return List2 (N);
+ end Declarations;
+
+ function Default_Expression
+ (N : Node_Id) return Node_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Parameter_Specification);
+ return Node5 (N);
+ end Default_Expression;
+
+ function Default_Name
+ (N : Node_Id) return Node_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Formal_Subprogram_Declaration);
+ return Node2 (N);
+ end Default_Name;
+
+ function Defining_Identifier
+ (N : Node_Id) return Entity_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Component_Declaration
+ or else NT (N).Nkind = N_Defining_Program_Unit_Name
+ or else NT (N).Nkind = N_Discriminant_Specification
+ or else NT (N).Nkind = N_Entry_Body
+ or else NT (N).Nkind = N_Entry_Declaration
+ or else NT (N).Nkind = N_Entry_Index_Specification
+ or else NT (N).Nkind = N_Exception_Declaration
+ or else NT (N).Nkind = N_Exception_Renaming_Declaration
+ or else NT (N).Nkind = N_Formal_Object_Declaration
+ or else NT (N).Nkind = N_Formal_Package_Declaration
+ or else NT (N).Nkind = N_Formal_Type_Declaration
+ or else NT (N).Nkind = N_Full_Type_Declaration
+ or else NT (N).Nkind = N_Implicit_Label_Declaration
+ or else NT (N).Nkind = N_Incomplete_Type_Declaration
+ or else NT (N).Nkind = N_Loop_Parameter_Specification
+ or else NT (N).Nkind = N_Number_Declaration
+ or else NT (N).Nkind = N_Object_Declaration
+ or else NT (N).Nkind = N_Object_Renaming_Declaration
+ or else NT (N).Nkind = N_Package_Body_Stub
+ or else NT (N).Nkind = N_Parameter_Specification
+ or else NT (N).Nkind = N_Private_Extension_Declaration
+ or else NT (N).Nkind = N_Private_Type_Declaration
+ or else NT (N).Nkind = N_Protected_Body
+ or else NT (N).Nkind = N_Protected_Body_Stub
+ or else NT (N).Nkind = N_Protected_Type_Declaration
+ or else NT (N).Nkind = N_Single_Protected_Declaration
+ or else NT (N).Nkind = N_Single_Task_Declaration
+ or else NT (N).Nkind = N_Subtype_Declaration
+ or else NT (N).Nkind = N_Task_Body
+ or else NT (N).Nkind = N_Task_Body_Stub
+ or else NT (N).Nkind = N_Task_Type_Declaration);
+ return Node1 (N);
+ end Defining_Identifier;
+
+ function Defining_Unit_Name
+ (N : Node_Id) return Node_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Function_Instantiation
+ or else NT (N).Nkind = N_Function_Specification
+ or else NT (N).Nkind = N_Generic_Function_Renaming_Declaration
+ or else NT (N).Nkind = N_Generic_Package_Renaming_Declaration
+ or else NT (N).Nkind = N_Generic_Procedure_Renaming_Declaration
+ or else NT (N).Nkind = N_Package_Body
+ or else NT (N).Nkind = N_Package_Instantiation
+ or else NT (N).Nkind = N_Package_Renaming_Declaration
+ or else NT (N).Nkind = N_Package_Specification
+ or else NT (N).Nkind = N_Procedure_Instantiation
+ or else NT (N).Nkind = N_Procedure_Specification);
+ return Node1 (N);
+ end Defining_Unit_Name;
+
+ function Delay_Alternative
+ (N : Node_Id) return Node_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Timed_Entry_Call);
+ return Node4 (N);
+ end Delay_Alternative;
+
+ function Delay_Finalize_Attach
+ (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Object_Declaration);
+ return Flag14 (N);
+ end Delay_Finalize_Attach;
+
+ function Delay_Statement
+ (N : Node_Id) return Node_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Delay_Alternative);
+ return Node2 (N);
+ end Delay_Statement;
+
+ function Delta_Expression
+ (N : Node_Id) return Node_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Decimal_Fixed_Point_Definition
+ or else NT (N).Nkind = N_Delta_Constraint
+ or else NT (N).Nkind = N_Ordinary_Fixed_Point_Definition);
+ return Node3 (N);
+ end Delta_Expression;
+
+ function Digits_Expression
+ (N : Node_Id) return Node_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Decimal_Fixed_Point_Definition
+ or else NT (N).Nkind = N_Digits_Constraint
+ or else NT (N).Nkind = N_Floating_Point_Definition);
+ return Node2 (N);
+ end Digits_Expression;
+
+ function Discr_Check_Funcs_Built
+ (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Full_Type_Declaration);
+ return Flag11 (N);
+ end Discr_Check_Funcs_Built;
+
+ function Discrete_Choices
+ (N : Node_Id) return List_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Case_Statement_Alternative
+ or else NT (N).Nkind = N_Variant);
+ return List4 (N);
+ end Discrete_Choices;
+
+ function Discrete_Range
+ (N : Node_Id) return Node_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Slice);
+ return Node4 (N);
+ end Discrete_Range;
+
+ function Discrete_Subtype_Definition
+ (N : Node_Id) return Node_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Entry_Declaration
+ or else NT (N).Nkind = N_Entry_Index_Specification
+ or else NT (N).Nkind = N_Loop_Parameter_Specification);
+ return Node4 (N);
+ end Discrete_Subtype_Definition;
+
+ function Discrete_Subtype_Definitions
+ (N : Node_Id) return List_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Constrained_Array_Definition);
+ return List2 (N);
+ end Discrete_Subtype_Definitions;
+
+ function Discriminant_Specifications
+ (N : Node_Id) return List_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Formal_Type_Declaration
+ or else NT (N).Nkind = N_Full_Type_Declaration
+ or else NT (N).Nkind = N_Incomplete_Type_Declaration
+ or else NT (N).Nkind = N_Private_Extension_Declaration
+ or else NT (N).Nkind = N_Private_Type_Declaration
+ or else NT (N).Nkind = N_Protected_Type_Declaration
+ or else NT (N).Nkind = N_Task_Type_Declaration);
+ return List4 (N);
+ end Discriminant_Specifications;
+
+ function Discriminant_Type
+ (N : Node_Id) return Node_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Discriminant_Specification);
+ return Node5 (N);
+ end Discriminant_Type;
+
+ function Do_Access_Check
+ (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Attribute_Reference
+ or else NT (N).Nkind = N_Explicit_Dereference
+ or else NT (N).Nkind = N_Indexed_Component
+ or else NT (N).Nkind = N_Selected_Component
+ or else NT (N).Nkind = N_Slice);
+ return Flag11 (N);
+ end Do_Access_Check;
+
+ function Do_Accessibility_Check
+ (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Parameter_Specification);
+ return Flag13 (N);
+ end Do_Accessibility_Check;
+
+ function Do_Discriminant_Check
+ (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Selected_Component);
+ return Flag13 (N);
+ end Do_Discriminant_Check;
+
+ function Do_Division_Check
+ (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Op_Divide
+ or else NT (N).Nkind = N_Op_Mod
+ or else NT (N).Nkind = N_Op_Rem);
+ return Flag13 (N);
+ end Do_Division_Check;
+
+ function Do_Length_Check
+ (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Assignment_Statement
+ or else NT (N).Nkind = N_Op_And
+ or else NT (N).Nkind = N_Op_Or
+ or else NT (N).Nkind = N_Op_Xor
+ or else NT (N).Nkind = N_Type_Conversion);
+ return Flag4 (N);
+ end Do_Length_Check;
+
+ function Do_Overflow_Check
+ (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind in N_Op
+ or else NT (N).Nkind = N_Attribute_Reference
+ or else NT (N).Nkind = N_Type_Conversion);
+ return Flag17 (N);
+ end Do_Overflow_Check;
+
+ function Do_Range_Check
+ (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind in N_Subexpr);
+ return Flag9 (N);
+ end Do_Range_Check;
+
+ function Do_Storage_Check
+ (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Allocator
+ or else NT (N).Nkind = N_Subprogram_Body);
+ return Flag17 (N);
+ end Do_Storage_Check;
+
+ function Do_Tag_Check
+ (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Assignment_Statement
+ or else NT (N).Nkind = N_Function_Call
+ or else NT (N).Nkind = N_Procedure_Call_Statement
+ or else NT (N).Nkind = N_Return_Statement
+ or else NT (N).Nkind = N_Type_Conversion);
+ return Flag13 (N);
+ end Do_Tag_Check;
+
+ function Elaborate_All_Present
+ (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_With_Clause);
+ return Flag15 (N);
+ end Elaborate_All_Present;
+
+ function Elaborate_Present
+ (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_With_Clause);
+ return Flag4 (N);
+ end Elaborate_Present;
+
+ function Elaboration_Boolean
+ (N : Node_Id) return Node_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Function_Specification
+ or else NT (N).Nkind = N_Procedure_Specification);
+ return Node2 (N);
+ end Elaboration_Boolean;
+
+ function Else_Actions
+ (N : Node_Id) return List_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Conditional_Expression);
+ return List3 (N);
+ end Else_Actions;
+
+ function Else_Statements
+ (N : Node_Id) return List_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Conditional_Entry_Call
+ or else NT (N).Nkind = N_If_Statement
+ or else NT (N).Nkind = N_Selective_Accept);
+ return List4 (N);
+ end Else_Statements;
+
+ function Elsif_Parts
+ (N : Node_Id) return List_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_If_Statement);
+ return List3 (N);
+ end Elsif_Parts;
+
+ function Enclosing_Variant
+ (N : Node_Id) return Node_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Variant);
+ return Node2 (N);
+ end Enclosing_Variant;
+
+ function End_Label
+ (N : Node_Id) return Node_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Handled_Sequence_Of_Statements
+ or else NT (N).Nkind = N_Loop_Statement
+ or else NT (N).Nkind = N_Package_Specification
+ or else NT (N).Nkind = N_Protected_Body
+ or else NT (N).Nkind = N_Protected_Definition
+ or else NT (N).Nkind = N_Record_Definition
+ or else NT (N).Nkind = N_Task_Definition);
+ return Node4 (N);
+ end End_Label;
+
+ function End_Span
+ (N : Node_Id) return Uint is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Case_Statement
+ or else NT (N).Nkind = N_If_Statement);
+ return Uint5 (N);
+ end End_Span;
+
+ function Entity
+ (N : Node_Id) return Node_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind in N_Has_Entity
+ or else NT (N).Nkind = N_Freeze_Entity);
+ return Node4 (N);
+ end Entity;
+
+ function Entry_Body_Formal_Part
+ (N : Node_Id) return Node_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Entry_Body);
+ return Node5 (N);
+ end Entry_Body_Formal_Part;
+
+ function Entry_Call_Alternative
+ (N : Node_Id) return Node_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Conditional_Entry_Call
+ or else NT (N).Nkind = N_Timed_Entry_Call);
+ return Node1 (N);
+ end Entry_Call_Alternative;
+
+ function Entry_Call_Statement
+ (N : Node_Id) return Node_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Entry_Call_Alternative);
+ return Node1 (N);
+ end Entry_Call_Statement;
+
+ function Entry_Direct_Name
+ (N : Node_Id) return Node_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Accept_Statement);
+ return Node1 (N);
+ end Entry_Direct_Name;
+
+ function Entry_Index
+ (N : Node_Id) return Node_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Accept_Statement);
+ return Node5 (N);
+ end Entry_Index;
+
+ function Entry_Index_Specification
+ (N : Node_Id) return Node_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Entry_Body_Formal_Part);
+ return Node4 (N);
+ end Entry_Index_Specification;
+
+ function Etype
+ (N : Node_Id) return Node_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind in N_Has_Etype);
+ return Node5 (N);
+ end Etype;
+
+ function Exception_Choices
+ (N : Node_Id) return List_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Exception_Handler);
+ return List4 (N);
+ end Exception_Choices;
+
+ function Exception_Handlers
+ (N : Node_Id) return List_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Handled_Sequence_Of_Statements);
+ return List5 (N);
+ end Exception_Handlers;
+
+ function Exception_Junk
+ (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Goto_Statement
+ or else NT (N).Nkind = N_Label
+ or else NT (N).Nkind = N_Object_Declaration
+ or else NT (N).Nkind = N_Subtype_Declaration);
+ return Flag11 (N);
+ end Exception_Junk;
+
+ function Expansion_Delayed
+ (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Aggregate
+ or else NT (N).Nkind = N_Extension_Aggregate);
+ return Flag11 (N);
+ end Expansion_Delayed;
+
+ function Explicit_Actual_Parameter
+ (N : Node_Id) return Node_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Parameter_Association);
+ return Node3 (N);
+ end Explicit_Actual_Parameter;
+
+ function Explicit_Generic_Actual_Parameter
+ (N : Node_Id) return Node_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Generic_Association);
+ return Node1 (N);
+ end Explicit_Generic_Actual_Parameter;
+
+ function Expression
+ (N : Node_Id) return Node_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Allocator
+ or else NT (N).Nkind = N_Assignment_Statement
+ or else NT (N).Nkind = N_At_Clause
+ or else NT (N).Nkind = N_Attribute_Definition_Clause
+ or else NT (N).Nkind = N_Case_Statement
+ or else NT (N).Nkind = N_Code_Statement
+ or else NT (N).Nkind = N_Component_Association
+ or else NT (N).Nkind = N_Component_Declaration
+ or else NT (N).Nkind = N_Delay_Relative_Statement
+ or else NT (N).Nkind = N_Delay_Until_Statement
+ or else NT (N).Nkind = N_Discriminant_Association
+ or else NT (N).Nkind = N_Discriminant_Specification
+ or else NT (N).Nkind = N_Exception_Declaration
+ or else NT (N).Nkind = N_Formal_Object_Declaration
+ or else NT (N).Nkind = N_Free_Statement
+ or else NT (N).Nkind = N_Mod_Clause
+ or else NT (N).Nkind = N_Modular_Type_Definition
+ or else NT (N).Nkind = N_Number_Declaration
+ or else NT (N).Nkind = N_Object_Declaration
+ or else NT (N).Nkind = N_Parameter_Specification
+ or else NT (N).Nkind = N_Pragma_Argument_Association
+ or else NT (N).Nkind = N_Qualified_Expression
+ or else NT (N).Nkind = N_Return_Statement
+ or else NT (N).Nkind = N_Type_Conversion
+ or else NT (N).Nkind = N_Unchecked_Expression
+ or else NT (N).Nkind = N_Unchecked_Type_Conversion);
+ return Node3 (N);
+ end Expression;
+
+ function Expressions
+ (N : Node_Id) return List_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Aggregate
+ or else NT (N).Nkind = N_Attribute_Reference
+ or else NT (N).Nkind = N_Conditional_Expression
+ or else NT (N).Nkind = N_Extension_Aggregate
+ or else NT (N).Nkind = N_Indexed_Component);
+ return List1 (N);
+ end Expressions;
+
+ function First_Bit
+ (N : Node_Id) return Node_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Component_Clause);
+ return Node3 (N);
+ end First_Bit;
+
+ function First_Inlined_Subprogram
+ (N : Node_Id) return Entity_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Compilation_Unit);
+ return Node3 (N);
+ end First_Inlined_Subprogram;
+
+ function First_Name
+ (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_With_Clause);
+ return Flag5 (N);
+ end First_Name;
+
+ function First_Named_Actual
+ (N : Node_Id) return Node_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Entry_Call_Statement
+ or else NT (N).Nkind = N_Function_Call
+ or else NT (N).Nkind = N_Procedure_Call_Statement);
+ return Node4 (N);
+ end First_Named_Actual;
+
+ function First_Real_Statement
+ (N : Node_Id) return Node_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Handled_Sequence_Of_Statements);
+ return Node2 (N);
+ end First_Real_Statement;
+
+ function First_Subtype_Link
+ (N : Node_Id) return Entity_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Freeze_Entity);
+ return Node5 (N);
+ end First_Subtype_Link;
+
+ function Float_Truncate
+ (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Type_Conversion);
+ return Flag11 (N);
+ end Float_Truncate;
+
+ function Formal_Type_Definition
+ (N : Node_Id) return Node_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Formal_Type_Declaration);
+ return Node3 (N);
+ end Formal_Type_Definition;
+
+ function Forwards_OK
+ (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Assignment_Statement);
+ return Flag5 (N);
+ end Forwards_OK;
+
+ function From_At_Mod
+ (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Attribute_Definition_Clause);
+ return Flag4 (N);
+ end From_At_Mod;
+
+ function Generic_Associations
+ (N : Node_Id) return List_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Formal_Package_Declaration
+ or else NT (N).Nkind = N_Function_Instantiation
+ or else NT (N).Nkind = N_Package_Instantiation
+ or else NT (N).Nkind = N_Procedure_Instantiation);
+ return List3 (N);
+ end Generic_Associations;
+
+ function Generic_Formal_Declarations
+ (N : Node_Id) return List_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Generic_Package_Declaration
+ or else NT (N).Nkind = N_Generic_Subprogram_Declaration);
+ return List2 (N);
+ end Generic_Formal_Declarations;
+
+ function Generic_Parent
+ (N : Node_Id) return Node_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Function_Specification
+ or else NT (N).Nkind = N_Package_Specification
+ or else NT (N).Nkind = N_Procedure_Specification);
+ return Node5 (N);
+ end Generic_Parent;
+
+ function Generic_Parent_Type
+ (N : Node_Id) return Node_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Subtype_Declaration);
+ return Node4 (N);
+ end Generic_Parent_Type;
+
+ function Handled_Statement_Sequence
+ (N : Node_Id) return Node_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Accept_Statement
+ or else NT (N).Nkind = N_Block_Statement
+ or else NT (N).Nkind = N_Entry_Body
+ or else NT (N).Nkind = N_Package_Body
+ or else NT (N).Nkind = N_Subprogram_Body
+ or else NT (N).Nkind = N_Task_Body);
+ return Node4 (N);
+ end Handled_Statement_Sequence;
+
+ function Handler_List_Entry
+ (N : Node_Id) return Node_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Object_Declaration);
+ return Node2 (N);
+ end Handler_List_Entry;
+
+ function Has_Created_Identifier
+ (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Block_Statement
+ or else NT (N).Nkind = N_Loop_Statement);
+ return Flag15 (N);
+ end Has_Created_Identifier;
+
+ function Has_Dynamic_Length_Check
+ (N : Node_Id) return Boolean is
+ begin
+ return Flag10 (N);
+ end Has_Dynamic_Length_Check;
+
+ function Has_Dynamic_Range_Check
+ (N : Node_Id) return Boolean is
+ begin
+ return Flag12 (N);
+ end Has_Dynamic_Range_Check;
+
+ function Has_No_Elaboration_Code
+ (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Compilation_Unit);
+ return Flag17 (N);
+ end Has_No_Elaboration_Code;
+
+ function Has_Priority_Pragma
+ (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Protected_Definition
+ or else NT (N).Nkind = N_Subprogram_Body
+ or else NT (N).Nkind = N_Task_Definition);
+ return Flag6 (N);
+ end Has_Priority_Pragma;
+
+ function Has_Private_View
+ (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind in N_Op
+ or else NT (N).Nkind = N_Character_Literal
+ or else NT (N).Nkind = N_Expanded_Name
+ or else NT (N).Nkind = N_Identifier
+ or else NT (N).Nkind = N_Operator_Symbol);
+ return Flag11 (N);
+ end Has_Private_View;
+
+ function Has_Storage_Size_Pragma
+ (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Task_Definition);
+ return Flag5 (N);
+ end Has_Storage_Size_Pragma;
+
+ function Has_Task_Info_Pragma
+ (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Task_Definition);
+ return Flag7 (N);
+ end Has_Task_Info_Pragma;
+
+ function Has_Task_Name_Pragma
+ (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Task_Definition);
+ return Flag8 (N);
+ end Has_Task_Name_Pragma;
+
+ function Has_Wide_Character
+ (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_String_Literal);
+ return Flag11 (N);
+ end Has_Wide_Character;
+
+ function Hidden_By_Use_Clause
+ (N : Node_Id) return Elist_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Use_Package_Clause
+ or else NT (N).Nkind = N_Use_Type_Clause);
+ return Elist4 (N);
+ end Hidden_By_Use_Clause;
+
+ function High_Bound
+ (N : Node_Id) return Node_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Range
+ or else NT (N).Nkind = N_Real_Range_Specification
+ or else NT (N).Nkind = N_Signed_Integer_Type_Definition);
+ return Node2 (N);
+ end High_Bound;
+
+ function Identifier
+ (N : Node_Id) return Node_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_At_Clause
+ or else NT (N).Nkind = N_Block_Statement
+ or else NT (N).Nkind = N_Designator
+ or else NT (N).Nkind = N_Enumeration_Representation_Clause
+ or else NT (N).Nkind = N_Label
+ or else NT (N).Nkind = N_Loop_Statement
+ or else NT (N).Nkind = N_Record_Representation_Clause
+ or else NT (N).Nkind = N_Subprogram_Info);
+ return Node1 (N);
+ end Identifier;
+
+ function Implicit_With
+ (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_With_Clause);
+ return Flag17 (N);
+ end Implicit_With;
+
+ function In_Present
+ (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Formal_Object_Declaration
+ or else NT (N).Nkind = N_Parameter_Specification);
+ return Flag15 (N);
+ end In_Present;
+
+ function Includes_Infinities
+ (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Range);
+ return Flag11 (N);
+ end Includes_Infinities;
+
+ function Instance_Spec
+ (N : Node_Id) return Node_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Formal_Package_Declaration
+ or else NT (N).Nkind = N_Function_Instantiation
+ or else NT (N).Nkind = N_Package_Instantiation
+ or else NT (N).Nkind = N_Procedure_Instantiation);
+ return Node5 (N);
+ end Instance_Spec;
+
+ function Intval
+ (N : Node_Id) return Uint is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Integer_Literal);
+ return Uint3 (N);
+ end Intval;
+
+ function Is_Asynchronous_Call_Block
+ (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Block_Statement);
+ return Flag7 (N);
+ end Is_Asynchronous_Call_Block;
+
+ function Is_Component_Left_Opnd
+ (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Op_Concat);
+ return Flag13 (N);
+ end Is_Component_Left_Opnd;
+
+ function Is_Component_Right_Opnd
+ (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Op_Concat);
+ return Flag14 (N);
+ end Is_Component_Right_Opnd;
+
+ function Is_Controlling_Actual
+ (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind in N_Subexpr);
+ return Flag16 (N);
+ end Is_Controlling_Actual;
+
+ function Is_Machine_Number
+ (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Real_Literal);
+ return Flag11 (N);
+ end Is_Machine_Number;
+
+ function Is_Overloaded
+ (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind in N_Subexpr);
+ return Flag5 (N);
+ end Is_Overloaded;
+
+ function Is_Power_Of_2_For_Shift
+ (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Op_Expon);
+ return Flag13 (N);
+ end Is_Power_Of_2_For_Shift;
+
+ function Is_Protected_Subprogram_Body
+ (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Subprogram_Body);
+ return Flag7 (N);
+ end Is_Protected_Subprogram_Body;
+
+ function Is_Static_Expression
+ (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind in N_Subexpr);
+ return Flag6 (N);
+ end Is_Static_Expression;
+
+ function Is_Subprogram_Descriptor
+ (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Object_Declaration);
+ return Flag16 (N);
+ end Is_Subprogram_Descriptor;
+
+ function Is_Task_Allocation_Block
+ (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Block_Statement);
+ return Flag6 (N);
+ end Is_Task_Allocation_Block;
+
+ function Is_Task_Master
+ (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Block_Statement
+ or else NT (N).Nkind = N_Subprogram_Body
+ or else NT (N).Nkind = N_Task_Body);
+ return Flag5 (N);
+ end Is_Task_Master;
+
+ function Iteration_Scheme
+ (N : Node_Id) return Node_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Loop_Statement);
+ return Node2 (N);
+ end Iteration_Scheme;
+
+ function Itype
+ (N : Node_Id) return Node_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Itype_Reference);
+ return Node1 (N);
+ end Itype;
+
+ function Kill_Range_Check
+ (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Unchecked_Type_Conversion);
+ return Flag11 (N);
+ end Kill_Range_Check;
+
+ function Label_Construct
+ (N : Node_Id) return Node_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Implicit_Label_Declaration);
+ return Node2 (N);
+ end Label_Construct;
+
+ function Last_Bit
+ (N : Node_Id) return Node_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Component_Clause);
+ return Node4 (N);
+ end Last_Bit;
+
+ function Last_Name
+ (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_With_Clause);
+ return Flag6 (N);
+ end Last_Name;
+
+ function Left_Opnd
+ (N : Node_Id) return Node_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_And_Then
+ or else NT (N).Nkind = N_In
+ or else NT (N).Nkind = N_Not_In
+ or else NT (N).Nkind = N_Or_Else
+ or else NT (N).Nkind in N_Binary_Op);
+ return Node2 (N);
+ end Left_Opnd;
+
+ function Library_Unit
+ (N : Node_Id) return Node_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Compilation_Unit
+ or else NT (N).Nkind = N_Package_Body_Stub
+ or else NT (N).Nkind = N_Protected_Body_Stub
+ or else NT (N).Nkind = N_Subprogram_Body_Stub
+ or else NT (N).Nkind = N_Task_Body_Stub
+ or else NT (N).Nkind = N_With_Clause);
+ return Node4 (N);
+ end Library_Unit;
+
+ function Limited_Present
+ (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Formal_Private_Type_Definition
+ or else NT (N).Nkind = N_Private_Type_Declaration
+ or else NT (N).Nkind = N_Record_Definition);
+ return Flag17 (N);
+ end Limited_Present;
+
+ function Literals
+ (N : Node_Id) return List_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Enumeration_Type_Definition);
+ return List1 (N);
+ end Literals;
+
+ function Loop_Actions
+ (N : Node_Id) return List_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Component_Association);
+ return List2 (N);
+ end Loop_Actions;
+
+ function Loop_Parameter_Specification
+ (N : Node_Id) return Node_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Iteration_Scheme);
+ return Node4 (N);
+ end Loop_Parameter_Specification;
+
+ function Low_Bound
+ (N : Node_Id) return Node_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Range
+ or else NT (N).Nkind = N_Real_Range_Specification
+ or else NT (N).Nkind = N_Signed_Integer_Type_Definition);
+ return Node1 (N);
+ end Low_Bound;
+
+ function Mod_Clause
+ (N : Node_Id) return Node_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Record_Representation_Clause);
+ return Node2 (N);
+ end Mod_Clause;
+
+ function More_Ids
+ (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Component_Declaration
+ or else NT (N).Nkind = N_Discriminant_Specification
+ or else NT (N).Nkind = N_Exception_Declaration
+ or else NT (N).Nkind = N_Formal_Object_Declaration
+ or else NT (N).Nkind = N_Number_Declaration
+ or else NT (N).Nkind = N_Object_Declaration
+ or else NT (N).Nkind = N_Parameter_Specification);
+ return Flag5 (N);
+ end More_Ids;
+
+ function Must_Not_Freeze
+ (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Subtype_Indication
+ or else NT (N).Nkind in N_Subexpr);
+ return Flag8 (N);
+ end Must_Not_Freeze;
+
+ function Name
+ (N : Node_Id) return Node_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Assignment_Statement
+ or else NT (N).Nkind = N_Attribute_Definition_Clause
+ or else NT (N).Nkind = N_Defining_Program_Unit_Name
+ or else NT (N).Nkind = N_Designator
+ or else NT (N).Nkind = N_Entry_Call_Statement
+ or else NT (N).Nkind = N_Exception_Renaming_Declaration
+ or else NT (N).Nkind = N_Exit_Statement
+ or else NT (N).Nkind = N_Formal_Package_Declaration
+ or else NT (N).Nkind = N_Function_Call
+ or else NT (N).Nkind = N_Function_Instantiation
+ or else NT (N).Nkind = N_Generic_Function_Renaming_Declaration
+ or else NT (N).Nkind = N_Generic_Package_Renaming_Declaration
+ or else NT (N).Nkind = N_Generic_Procedure_Renaming_Declaration
+ or else NT (N).Nkind = N_Goto_Statement
+ or else NT (N).Nkind = N_Object_Renaming_Declaration
+ or else NT (N).Nkind = N_Package_Instantiation
+ or else NT (N).Nkind = N_Package_Renaming_Declaration
+ or else NT (N).Nkind = N_Procedure_Call_Statement
+ or else NT (N).Nkind = N_Procedure_Instantiation
+ or else NT (N).Nkind = N_Raise_Statement
+ or else NT (N).Nkind = N_Requeue_Statement
+ or else NT (N).Nkind = N_Subprogram_Renaming_Declaration
+ or else NT (N).Nkind = N_Subunit
+ or else NT (N).Nkind = N_Variant_Part
+ or else NT (N).Nkind = N_With_Clause
+ or else NT (N).Nkind = N_With_Type_Clause);
+ return Node2 (N);
+ end Name;
+
+ function Names
+ (N : Node_Id) return List_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Abort_Statement
+ or else NT (N).Nkind = N_Use_Package_Clause);
+ return List2 (N);
+ end Names;
+
+ function Next_Entity
+ (N : Node_Id) return Node_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Defining_Character_Literal
+ or else NT (N).Nkind = N_Defining_Identifier
+ or else NT (N).Nkind = N_Defining_Operator_Symbol);
+ return Node2 (N);
+ end Next_Entity;
+
+ function Next_Named_Actual
+ (N : Node_Id) return Node_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Parameter_Association);
+ return Node4 (N);
+ end Next_Named_Actual;
+
+ function Next_Rep_Item
+ (N : Node_Id) return Node_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Attribute_Definition_Clause
+ or else NT (N).Nkind = N_Enumeration_Representation_Clause
+ or else NT (N).Nkind = N_Pragma
+ or else NT (N).Nkind = N_Record_Representation_Clause);
+ return Node4 (N);
+ end Next_Rep_Item;
+
+ function Next_Use_Clause
+ (N : Node_Id) return Node_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Use_Package_Clause
+ or else NT (N).Nkind = N_Use_Type_Clause);
+ return Node3 (N);
+ end Next_Use_Clause;
+
+ function No_Ctrl_Actions
+ (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Assignment_Statement);
+ return Flag7 (N);
+ end No_Ctrl_Actions;
+
+ function No_Entities_Ref_In_Spec
+ (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_With_Clause);
+ return Flag8 (N);
+ end No_Entities_Ref_In_Spec;
+
+ function No_Initialization
+ (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Allocator
+ or else NT (N).Nkind = N_Object_Declaration);
+ return Flag13 (N);
+ end No_Initialization;
+
+ function Null_Present
+ (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Component_List
+ or else NT (N).Nkind = N_Record_Definition);
+ return Flag13 (N);
+ end Null_Present;
+
+ function Null_Record_Present
+ (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Aggregate
+ or else NT (N).Nkind = N_Extension_Aggregate);
+ return Flag17 (N);
+ end Null_Record_Present;
+
+ function Object_Definition
+ (N : Node_Id) return Node_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Object_Declaration);
+ return Node4 (N);
+ end Object_Definition;
+
+ function OK_For_Stream
+ (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Attribute_Reference);
+ return Flag4 (N);
+ end OK_For_Stream;
+
+ function Original_Discriminant
+ (N : Node_Id) return Node_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Identifier);
+ return Node2 (N);
+ end Original_Discriminant;
+
+ function Others_Discrete_Choices
+ (N : Node_Id) return List_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Others_Choice);
+ return List1 (N);
+ end Others_Discrete_Choices;
+
+ function Out_Present
+ (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Formal_Object_Declaration
+ or else NT (N).Nkind = N_Parameter_Specification);
+ return Flag17 (N);
+ end Out_Present;
+
+ function Parameter_Associations
+ (N : Node_Id) return List_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Entry_Call_Statement
+ or else NT (N).Nkind = N_Function_Call
+ or else NT (N).Nkind = N_Procedure_Call_Statement);
+ return List3 (N);
+ end Parameter_Associations;
+
+ function Parameter_List_Truncated
+ (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Function_Call
+ or else NT (N).Nkind = N_Procedure_Call_Statement);
+ return Flag17 (N);
+ end Parameter_List_Truncated;
+
+ function Parameter_Specifications
+ (N : Node_Id) return List_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Accept_Statement
+ or else NT (N).Nkind = N_Access_Function_Definition
+ or else NT (N).Nkind = N_Access_Procedure_Definition
+ or else NT (N).Nkind = N_Entry_Body_Formal_Part
+ or else NT (N).Nkind = N_Entry_Declaration
+ or else NT (N).Nkind = N_Function_Specification
+ or else NT (N).Nkind = N_Procedure_Specification);
+ return List3 (N);
+ end Parameter_Specifications;
+
+ function Parameter_Type
+ (N : Node_Id) return Node_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Parameter_Specification);
+ return Node2 (N);
+ end Parameter_Type;
+
+ function Parent_Spec
+ (N : Node_Id) return Node_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Function_Instantiation
+ or else NT (N).Nkind = N_Generic_Function_Renaming_Declaration
+ or else NT (N).Nkind = N_Generic_Package_Declaration
+ or else NT (N).Nkind = N_Generic_Package_Renaming_Declaration
+ or else NT (N).Nkind = N_Generic_Procedure_Renaming_Declaration
+ or else NT (N).Nkind = N_Generic_Subprogram_Declaration
+ or else NT (N).Nkind = N_Package_Declaration
+ or else NT (N).Nkind = N_Package_Instantiation
+ or else NT (N).Nkind = N_Package_Renaming_Declaration
+ or else NT (N).Nkind = N_Procedure_Instantiation
+ or else NT (N).Nkind = N_Subprogram_Declaration
+ or else NT (N).Nkind = N_Subprogram_Renaming_Declaration);
+ return Node4 (N);
+ end Parent_Spec;
+
+ function Position
+ (N : Node_Id) return Node_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Component_Clause);
+ return Node2 (N);
+ end Position;
+
+ function Pragma_Argument_Associations
+ (N : Node_Id) return List_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Pragma);
+ return List2 (N);
+ end Pragma_Argument_Associations;
+
+ function Pragmas_After
+ (N : Node_Id) return List_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Compilation_Unit_Aux
+ or else NT (N).Nkind = N_Terminate_Alternative);
+ return List5 (N);
+ end Pragmas_After;
+
+ function Pragmas_Before
+ (N : Node_Id) return List_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Accept_Alternative
+ or else NT (N).Nkind = N_Delay_Alternative
+ or else NT (N).Nkind = N_Entry_Call_Alternative
+ or else NT (N).Nkind = N_Mod_Clause
+ or else NT (N).Nkind = N_Terminate_Alternative
+ or else NT (N).Nkind = N_Triggering_Alternative);
+ return List4 (N);
+ end Pragmas_Before;
+
+ function Prefix
+ (N : Node_Id) return Node_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Attribute_Reference
+ or else NT (N).Nkind = N_Expanded_Name
+ or else NT (N).Nkind = N_Explicit_Dereference
+ or else NT (N).Nkind = N_Indexed_Component
+ or else NT (N).Nkind = N_Reference
+ or else NT (N).Nkind = N_Selected_Component
+ or else NT (N).Nkind = N_Slice);
+ return Node3 (N);
+ end Prefix;
+
+ function Present_Expr
+ (N : Node_Id) return Uint is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Variant);
+ return Uint3 (N);
+ end Present_Expr;
+
+ function Prev_Ids
+ (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Component_Declaration
+ or else NT (N).Nkind = N_Discriminant_Specification
+ or else NT (N).Nkind = N_Exception_Declaration
+ or else NT (N).Nkind = N_Formal_Object_Declaration
+ or else NT (N).Nkind = N_Number_Declaration
+ or else NT (N).Nkind = N_Object_Declaration
+ or else NT (N).Nkind = N_Parameter_Specification);
+ return Flag6 (N);
+ end Prev_Ids;
+
+ function Print_In_Hex
+ (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Integer_Literal);
+ return Flag13 (N);
+ end Print_In_Hex;
+
+ function Private_Declarations
+ (N : Node_Id) return List_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Package_Specification
+ or else NT (N).Nkind = N_Protected_Definition
+ or else NT (N).Nkind = N_Task_Definition);
+ return List3 (N);
+ end Private_Declarations;
+
+ function Private_Present
+ (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Compilation_Unit
+ or else NT (N).Nkind = N_Formal_Derived_Type_Definition);
+ return Flag15 (N);
+ end Private_Present;
+
+ function Procedure_To_Call
+ (N : Node_Id) return Node_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Allocator
+ or else NT (N).Nkind = N_Free_Statement
+ or else NT (N).Nkind = N_Return_Statement);
+ return Node4 (N);
+ end Procedure_To_Call;
+
+ function Proper_Body
+ (N : Node_Id) return Node_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Subunit);
+ return Node1 (N);
+ end Proper_Body;
+
+ function Protected_Definition
+ (N : Node_Id) return Node_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Protected_Type_Declaration
+ or else NT (N).Nkind = N_Single_Protected_Declaration);
+ return Node3 (N);
+ end Protected_Definition;
+
+ function Protected_Present
+ (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Access_Function_Definition
+ or else NT (N).Nkind = N_Access_Procedure_Definition);
+ return Flag15 (N);
+ end Protected_Present;
+
+ function Raises_Constraint_Error
+ (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind in N_Subexpr);
+ return Flag7 (N);
+ end Raises_Constraint_Error;
+
+ function Range_Constraint
+ (N : Node_Id) return Node_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Delta_Constraint
+ or else NT (N).Nkind = N_Digits_Constraint);
+ return Node4 (N);
+ end Range_Constraint;
+
+ function Range_Expression
+ (N : Node_Id) return Node_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Range_Constraint);
+ return Node4 (N);
+ end Range_Expression;
+
+ function Real_Range_Specification
+ (N : Node_Id) return Node_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Decimal_Fixed_Point_Definition
+ or else NT (N).Nkind = N_Floating_Point_Definition
+ or else NT (N).Nkind = N_Ordinary_Fixed_Point_Definition);
+ return Node4 (N);
+ end Real_Range_Specification;
+
+ function Realval
+ (N : Node_Id) return Ureal is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Real_Literal);
+ return Ureal3 (N);
+ end Realval;
+
+ function Record_Extension_Part
+ (N : Node_Id) return Node_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Derived_Type_Definition);
+ return Node3 (N);
+ end Record_Extension_Part;
+
+ function Redundant_Use
+ (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Attribute_Reference
+ or else NT (N).Nkind = N_Expanded_Name
+ or else NT (N).Nkind = N_Identifier);
+ return Flag13 (N);
+ end Redundant_Use;
+
+ function Return_Type
+ (N : Node_Id) return Node_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Return_Statement);
+ return Node2 (N);
+ end Return_Type;
+
+ function Reverse_Present
+ (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Loop_Parameter_Specification);
+ return Flag15 (N);
+ end Reverse_Present;
+
+ function Right_Opnd
+ (N : Node_Id) return Node_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind in N_Op
+ or else NT (N).Nkind = N_And_Then
+ or else NT (N).Nkind = N_In
+ or else NT (N).Nkind = N_Not_In
+ or else NT (N).Nkind = N_Or_Else);
+ return Node3 (N);
+ end Right_Opnd;
+
+ function Rounded_Result
+ (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Op_Divide
+ or else NT (N).Nkind = N_Op_Multiply
+ or else NT (N).Nkind = N_Type_Conversion);
+ return Flag18 (N);
+ end Rounded_Result;
+
+ function Scope
+ (N : Node_Id) return Node_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Defining_Character_Literal
+ or else NT (N).Nkind = N_Defining_Identifier
+ or else NT (N).Nkind = N_Defining_Operator_Symbol);
+ return Node3 (N);
+ end Scope;
+
+ function Select_Alternatives
+ (N : Node_Id) return List_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Selective_Accept);
+ return List1 (N);
+ end Select_Alternatives;
+
+ function Selector_Name
+ (N : Node_Id) return Node_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Expanded_Name
+ or else NT (N).Nkind = N_Generic_Association
+ or else NT (N).Nkind = N_Parameter_Association
+ or else NT (N).Nkind = N_Selected_Component);
+ return Node2 (N);
+ end Selector_Name;
+
+ function Selector_Names
+ (N : Node_Id) return List_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Discriminant_Association);
+ return List1 (N);
+ end Selector_Names;
+
+ function Shift_Count_OK
+ (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Op_Rotate_Left
+ or else NT (N).Nkind = N_Op_Rotate_Right
+ or else NT (N).Nkind = N_Op_Shift_Left
+ or else NT (N).Nkind = N_Op_Shift_Right
+ or else NT (N).Nkind = N_Op_Shift_Right_Arithmetic);
+ return Flag4 (N);
+ end Shift_Count_OK;
+
+ function Source_Type
+ (N : Node_Id) return Entity_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Validate_Unchecked_Conversion);
+ return Node1 (N);
+ end Source_Type;
+
+ function Specification
+ (N : Node_Id) return Node_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Abstract_Subprogram_Declaration
+ or else NT (N).Nkind = N_Formal_Subprogram_Declaration
+ or else NT (N).Nkind = N_Generic_Package_Declaration
+ or else NT (N).Nkind = N_Generic_Subprogram_Declaration
+ or else NT (N).Nkind = N_Package_Declaration
+ or else NT (N).Nkind = N_Subprogram_Body
+ or else NT (N).Nkind = N_Subprogram_Body_Stub
+ or else NT (N).Nkind = N_Subprogram_Declaration
+ or else NT (N).Nkind = N_Subprogram_Renaming_Declaration);
+ return Node1 (N);
+ end Specification;
+
+ function Statements
+ (N : Node_Id) return List_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Abortable_Part
+ or else NT (N).Nkind = N_Accept_Alternative
+ or else NT (N).Nkind = N_Case_Statement_Alternative
+ or else NT (N).Nkind = N_Delay_Alternative
+ or else NT (N).Nkind = N_Entry_Call_Alternative
+ or else NT (N).Nkind = N_Exception_Handler
+ or else NT (N).Nkind = N_Handled_Sequence_Of_Statements
+ or else NT (N).Nkind = N_Loop_Statement
+ or else NT (N).Nkind = N_Triggering_Alternative);
+ return List3 (N);
+ end Statements;
+
+ function Static_Processing_OK
+ (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Aggregate);
+ return Flag4 (N);
+ end Static_Processing_OK;
+
+ function Storage_Pool
+ (N : Node_Id) return Node_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Allocator
+ or else NT (N).Nkind = N_Free_Statement
+ or else NT (N).Nkind = N_Return_Statement);
+ return Node1 (N);
+ end Storage_Pool;
+
+ function Strval
+ (N : Node_Id) return String_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Operator_Symbol
+ or else NT (N).Nkind = N_String_Literal);
+ return Str3 (N);
+ end Strval;
+
+ function Subtype_Indication
+ (N : Node_Id) return Node_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Access_To_Object_Definition
+ or else NT (N).Nkind = N_Component_Declaration
+ or else NT (N).Nkind = N_Constrained_Array_Definition
+ or else NT (N).Nkind = N_Derived_Type_Definition
+ or else NT (N).Nkind = N_Private_Extension_Declaration
+ or else NT (N).Nkind = N_Subtype_Declaration
+ or else NT (N).Nkind = N_Unconstrained_Array_Definition);
+ return Node5 (N);
+ end Subtype_Indication;
+
+ function Subtype_Mark
+ (N : Node_Id) return Node_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Access_Definition
+ or else NT (N).Nkind = N_Access_Function_Definition
+ or else NT (N).Nkind = N_Formal_Derived_Type_Definition
+ or else NT (N).Nkind = N_Formal_Object_Declaration
+ or else NT (N).Nkind = N_Function_Specification
+ or else NT (N).Nkind = N_Object_Renaming_Declaration
+ or else NT (N).Nkind = N_Qualified_Expression
+ or else NT (N).Nkind = N_Subtype_Indication
+ or else NT (N).Nkind = N_Type_Conversion
+ or else NT (N).Nkind = N_Unchecked_Type_Conversion);
+ return Node4 (N);
+ end Subtype_Mark;
+
+ function Subtype_Marks
+ (N : Node_Id) return List_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Unconstrained_Array_Definition
+ or else NT (N).Nkind = N_Use_Type_Clause);
+ return List2 (N);
+ end Subtype_Marks;
+
+ function Tagged_Present
+ (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Formal_Private_Type_Definition
+ or else NT (N).Nkind = N_Private_Type_Declaration
+ or else NT (N).Nkind = N_Record_Definition
+ or else NT (N).Nkind = N_With_Type_Clause);
+ return Flag15 (N);
+ end Tagged_Present;
+
+ function Target_Type
+ (N : Node_Id) return Entity_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Validate_Unchecked_Conversion);
+ return Node2 (N);
+ end Target_Type;
+
+ function Task_Body_Procedure
+ (N : Node_Id) return Entity_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Task_Type_Declaration);
+ return Node2 (N);
+ end Task_Body_Procedure;
+
+ function Task_Definition
+ (N : Node_Id) return Node_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Single_Task_Declaration
+ or else NT (N).Nkind = N_Task_Type_Declaration);
+ return Node3 (N);
+ end Task_Definition;
+
+ function Then_Actions
+ (N : Node_Id) return List_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Conditional_Expression);
+ return List2 (N);
+ end Then_Actions;
+
+ function Then_Statements
+ (N : Node_Id) return List_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Elsif_Part
+ or else NT (N).Nkind = N_If_Statement);
+ return List2 (N);
+ end Then_Statements;
+
+ function Treat_Fixed_As_Integer
+ (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Op_Divide
+ or else NT (N).Nkind = N_Op_Mod
+ or else NT (N).Nkind = N_Op_Multiply
+ or else NT (N).Nkind = N_Op_Rem);
+ return Flag14 (N);
+ end Treat_Fixed_As_Integer;
+
+ function Triggering_Alternative
+ (N : Node_Id) return Node_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Asynchronous_Select);
+ return Node1 (N);
+ end Triggering_Alternative;
+
+ function Triggering_Statement
+ (N : Node_Id) return Node_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Triggering_Alternative);
+ return Node1 (N);
+ end Triggering_Statement;
+
+ function TSS_Elist
+ (N : Node_Id) return Elist_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Freeze_Entity);
+ return Elist3 (N);
+ end TSS_Elist;
+
+ function Type_Definition
+ (N : Node_Id) return Node_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Full_Type_Declaration);
+ return Node3 (N);
+ end Type_Definition;
+
+ function Unit
+ (N : Node_Id) return Node_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Compilation_Unit);
+ return Node2 (N);
+ end Unit;
+
+ function Unknown_Discriminants_Present
+ (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Formal_Type_Declaration
+ or else NT (N).Nkind = N_Incomplete_Type_Declaration
+ or else NT (N).Nkind = N_Private_Extension_Declaration
+ or else NT (N).Nkind = N_Private_Type_Declaration);
+ return Flag13 (N);
+ end Unknown_Discriminants_Present;
+
+ function Unreferenced_In_Spec
+ (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_With_Clause);
+ return Flag7 (N);
+ end Unreferenced_In_Spec;
+
+ function Variant_Part
+ (N : Node_Id) return Node_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Component_List);
+ return Node4 (N);
+ end Variant_Part;
+
+ function Variants
+ (N : Node_Id) return List_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Variant_Part);
+ return List1 (N);
+ end Variants;
+
+ function Visible_Declarations
+ (N : Node_Id) return List_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Package_Specification
+ or else NT (N).Nkind = N_Protected_Definition
+ or else NT (N).Nkind = N_Task_Definition);
+ return List2 (N);
+ end Visible_Declarations;
+
+ function Was_Originally_Stub
+ (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Package_Body
+ or else NT (N).Nkind = N_Protected_Body
+ or else NT (N).Nkind = N_Subprogram_Body
+ or else NT (N).Nkind = N_Task_Body);
+ return Flag13 (N);
+ end Was_Originally_Stub;
+
+ function Zero_Cost_Handling
+ (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Exception_Handler
+ or else NT (N).Nkind = N_Handled_Sequence_Of_Statements);
+ return Flag5 (N);
+ end Zero_Cost_Handling;
+
+ --------------------------
+ -- Field Set Procedures --
+ --------------------------
+
+ procedure Set_ABE_Is_Certain
+ (N : Node_Id; Val : Boolean := True) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Formal_Package_Declaration
+ or else NT (N).Nkind = N_Function_Call
+ or else NT (N).Nkind = N_Function_Instantiation
+ or else NT (N).Nkind = N_Package_Instantiation
+ or else NT (N).Nkind = N_Procedure_Call_Statement
+ or else NT (N).Nkind = N_Procedure_Instantiation);
+ Set_Flag18 (N, Val);
+ end Set_ABE_Is_Certain;
+
+ procedure Set_Abort_Present
+ (N : Node_Id; Val : Boolean := True) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Requeue_Statement);
+ Set_Flag15 (N, Val);
+ end Set_Abort_Present;
+
+ procedure Set_Abortable_Part
+ (N : Node_Id; Val : Node_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Asynchronous_Select);
+ Set_Node2_With_Parent (N, Val);
+ end Set_Abortable_Part;
+
+ procedure Set_Abstract_Present
+ (N : Node_Id; Val : Boolean := True) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Derived_Type_Definition
+ or else NT (N).Nkind = N_Formal_Derived_Type_Definition
+ or else NT (N).Nkind = N_Formal_Private_Type_Definition
+ or else NT (N).Nkind = N_Private_Extension_Declaration
+ or else NT (N).Nkind = N_Private_Type_Declaration
+ or else NT (N).Nkind = N_Record_Definition);
+ Set_Flag4 (N, Val);
+ end Set_Abstract_Present;
+
+ procedure Set_Accept_Handler_Records
+ (N : Node_Id; Val : List_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Accept_Alternative);
+ Set_List5 (N, Val); -- semantic field, no parent set
+ end Set_Accept_Handler_Records;
+
+ procedure Set_Accept_Statement
+ (N : Node_Id; Val : Node_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Accept_Alternative);
+ Set_Node2_With_Parent (N, Val);
+ end Set_Accept_Statement;
+
+ procedure Set_Access_Types_To_Process
+ (N : Node_Id; Val : Elist_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Freeze_Entity);
+ Set_Elist2 (N, Val); -- semantic field, no parent set
+ end Set_Access_Types_To_Process;
+
+ procedure Set_Actions
+ (N : Node_Id; Val : List_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_And_Then
+ or else NT (N).Nkind = N_Compilation_Unit_Aux
+ or else NT (N).Nkind = N_Freeze_Entity
+ or else NT (N).Nkind = N_Or_Else);
+ Set_List1_With_Parent (N, Val);
+ end Set_Actions;
+
+ procedure Set_Activation_Chain_Entity
+ (N : Node_Id; Val : Node_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Block_Statement
+ or else NT (N).Nkind = N_Entry_Body
+ or else NT (N).Nkind = N_Generic_Package_Declaration
+ or else NT (N).Nkind = N_Package_Declaration
+ or else NT (N).Nkind = N_Subprogram_Body
+ or else NT (N).Nkind = N_Task_Body);
+ Set_Node3 (N, Val); -- semantic field, no parent set
+ end Set_Activation_Chain_Entity;
+
+ procedure Set_Acts_As_Spec
+ (N : Node_Id; Val : Boolean := True) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Compilation_Unit
+ or else NT (N).Nkind = N_Subprogram_Body);
+ Set_Flag4 (N, Val);
+ end Set_Acts_As_Spec;
+
+ procedure Set_Aggregate_Bounds
+ (N : Node_Id; Val : Node_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Aggregate);
+ Set_Node3 (N, Val); -- semantic field, no parent set
+ end Set_Aggregate_Bounds;
+
+ procedure Set_Aliased_Present
+ (N : Node_Id; Val : Boolean := True) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Component_Declaration
+ or else NT (N).Nkind = N_Constrained_Array_Definition
+ or else NT (N).Nkind = N_Object_Declaration
+ or else NT (N).Nkind = N_Unconstrained_Array_Definition);
+ Set_Flag4 (N, Val);
+ end Set_Aliased_Present;
+
+ procedure Set_All_Others
+ (N : Node_Id; Val : Boolean := True) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Others_Choice);
+ Set_Flag11 (N, Val);
+ end Set_All_Others;
+
+ procedure Set_All_Present
+ (N : Node_Id; Val : Boolean := True) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Access_To_Object_Definition);
+ Set_Flag15 (N, Val);
+ end Set_All_Present;
+
+ procedure Set_Alternatives
+ (N : Node_Id; Val : List_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Case_Statement);
+ Set_List4_With_Parent (N, Val);
+ end Set_Alternatives;
+
+ procedure Set_Ancestor_Part
+ (N : Node_Id; Val : Node_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Extension_Aggregate);
+ Set_Node3_With_Parent (N, Val);
+ end Set_Ancestor_Part;
+
+ procedure Set_Array_Aggregate
+ (N : Node_Id; Val : Node_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Enumeration_Representation_Clause);
+ Set_Node3_With_Parent (N, Val);
+ end Set_Array_Aggregate;
+
+ procedure Set_Assignment_OK
+ (N : Node_Id; Val : Boolean := True) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Object_Declaration
+ or else NT (N).Nkind in N_Subexpr);
+ Set_Flag15 (N, Val);
+ end Set_Assignment_OK;
+
+ procedure Set_At_End_Proc
+ (N : Node_Id; Val : Node_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Handled_Sequence_Of_Statements);
+ Set_Node1 (N, Val);
+ end Set_At_End_Proc;
+
+ procedure Set_Attribute_Name
+ (N : Node_Id; Val : Name_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Attribute_Reference);
+ Set_Name2 (N, Val);
+ end Set_Attribute_Name;
+
+ procedure Set_Aux_Decls_Node
+ (N : Node_Id; Val : Node_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Compilation_Unit);
+ Set_Node5_With_Parent (N, Val);
+ end Set_Aux_Decls_Node;
+
+ procedure Set_Backwards_OK
+ (N : Node_Id; Val : Boolean := True) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Assignment_Statement);
+ Set_Flag6 (N, Val);
+ end Set_Backwards_OK;
+
+ procedure Set_Bad_Is_Detected
+ (N : Node_Id; Val : Boolean := True) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Subprogram_Body);
+ Set_Flag15 (N, Val);
+ end Set_Bad_Is_Detected;
+
+ procedure Set_Body_Required
+ (N : Node_Id; Val : Boolean := True) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Compilation_Unit);
+ Set_Flag13 (N, Val);
+ end Set_Body_Required;
+
+ procedure Set_Body_To_Inline
+ (N : Node_Id; Val : Node_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Subprogram_Declaration);
+ Set_Node3 (N, Val);
+ end Set_Body_To_Inline;
+
+ procedure Set_Box_Present
+ (N : Node_Id; Val : Boolean := True) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Formal_Package_Declaration
+ or else NT (N).Nkind = N_Formal_Subprogram_Declaration);
+ Set_Flag15 (N, Val);
+ end Set_Box_Present;
+
+ procedure Set_By_Ref
+ (N : Node_Id; Val : Boolean := True) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Return_Statement);
+ Set_Flag5 (N, Val);
+ end Set_By_Ref;
+
+ procedure Set_Char_Literal_Value
+ (N : Node_Id; Val : Char_Code) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Character_Literal);
+ Set_Char_Code2 (N, Val);
+ end Set_Char_Literal_Value;
+
+ procedure Set_Chars
+ (N : Node_Id; Val : Name_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind in N_Has_Chars);
+ Set_Name1 (N, Val);
+ end Set_Chars;
+
+ procedure Set_Choice_Parameter
+ (N : Node_Id; Val : Node_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Exception_Handler);
+ Set_Node2_With_Parent (N, Val);
+ end Set_Choice_Parameter;
+
+ procedure Set_Choices
+ (N : Node_Id; Val : List_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Component_Association);
+ Set_List1_With_Parent (N, Val);
+ end Set_Choices;
+
+ procedure Set_Compile_Time_Known_Aggregate
+ (N : Node_Id; Val : Boolean := True) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Aggregate);
+ Set_Flag18 (N, Val);
+ end Set_Compile_Time_Known_Aggregate;
+
+ procedure Set_Component_Associations
+ (N : Node_Id; Val : List_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Aggregate
+ or else NT (N).Nkind = N_Extension_Aggregate);
+ Set_List2_With_Parent (N, Val);
+ end Set_Component_Associations;
+
+ procedure Set_Component_Clauses
+ (N : Node_Id; Val : List_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Record_Representation_Clause);
+ Set_List3_With_Parent (N, Val);
+ end Set_Component_Clauses;
+
+ procedure Set_Component_Items
+ (N : Node_Id; Val : List_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Component_List);
+ Set_List3_With_Parent (N, Val);
+ end Set_Component_Items;
+
+ procedure Set_Component_List
+ (N : Node_Id; Val : Node_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Record_Definition
+ or else NT (N).Nkind = N_Variant);
+ Set_Node1_With_Parent (N, Val);
+ end Set_Component_List;
+
+ procedure Set_Component_Name
+ (N : Node_Id; Val : Node_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Component_Clause);
+ Set_Node1_With_Parent (N, Val);
+ end Set_Component_Name;
+
+ procedure Set_Condition
+ (N : Node_Id; Val : Node_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Accept_Alternative
+ or else NT (N).Nkind = N_Delay_Alternative
+ or else NT (N).Nkind = N_Elsif_Part
+ or else NT (N).Nkind = N_Entry_Body_Formal_Part
+ or else NT (N).Nkind = N_Exit_Statement
+ or else NT (N).Nkind = N_If_Statement
+ or else NT (N).Nkind = N_Iteration_Scheme
+ or else NT (N).Nkind = N_Raise_Constraint_Error
+ or else NT (N).Nkind = N_Raise_Program_Error
+ or else NT (N).Nkind = N_Raise_Storage_Error
+ or else NT (N).Nkind = N_Terminate_Alternative);
+ Set_Node1_With_Parent (N, Val);
+ end Set_Condition;
+
+ procedure Set_Condition_Actions
+ (N : Node_Id; Val : List_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Elsif_Part
+ or else NT (N).Nkind = N_Iteration_Scheme);
+ Set_List3 (N, Val); -- semantic field, no parent set
+ end Set_Condition_Actions;
+
+ procedure Set_Constant_Present
+ (N : Node_Id; Val : Boolean := True) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Access_To_Object_Definition
+ or else NT (N).Nkind = N_Object_Declaration);
+ Set_Flag17 (N, Val);
+ end Set_Constant_Present;
+
+ procedure Set_Constraint
+ (N : Node_Id; Val : Node_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Subtype_Indication);
+ Set_Node3_With_Parent (N, Val);
+ end Set_Constraint;
+
+ procedure Set_Constraints
+ (N : Node_Id; Val : List_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Index_Or_Discriminant_Constraint);
+ Set_List1_With_Parent (N, Val);
+ end Set_Constraints;
+
+ procedure Set_Context_Installed
+ (N : Node_Id; Val : Boolean := True) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_With_Clause);
+ Set_Flag13 (N, Val);
+ end Set_Context_Installed;
+
+ procedure Set_Context_Items
+ (N : Node_Id; Val : List_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Compilation_Unit);
+ Set_List1_With_Parent (N, Val);
+ end Set_Context_Items;
+
+ procedure Set_Controlling_Argument
+ (N : Node_Id; Val : Node_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Function_Call
+ or else NT (N).Nkind = N_Procedure_Call_Statement);
+ Set_Node1 (N, Val); -- semantic field, no parent set
+ end Set_Controlling_Argument;
+
+ procedure Set_Conversion_OK
+ (N : Node_Id; Val : Boolean := True) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Type_Conversion);
+ Set_Flag14 (N, Val);
+ end Set_Conversion_OK;
+
+ procedure Set_Corresponding_Body
+ (N : Node_Id; Val : Node_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Generic_Package_Declaration
+ or else NT (N).Nkind = N_Generic_Subprogram_Declaration
+ or else NT (N).Nkind = N_Package_Body_Stub
+ or else NT (N).Nkind = N_Package_Declaration
+ or else NT (N).Nkind = N_Protected_Body_Stub
+ or else NT (N).Nkind = N_Protected_Type_Declaration
+ or else NT (N).Nkind = N_Subprogram_Body_Stub
+ or else NT (N).Nkind = N_Subprogram_Declaration
+ or else NT (N).Nkind = N_Task_Body_Stub
+ or else NT (N).Nkind = N_Task_Type_Declaration);
+ Set_Node5 (N, Val); -- semantic field, no parent set
+ end Set_Corresponding_Body;
+
+ procedure Set_Corresponding_Generic_Association
+ (N : Node_Id; Val : Node_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Object_Declaration
+ or else NT (N).Nkind = N_Object_Renaming_Declaration);
+ Set_Node5 (N, Val); -- semantic field, no parent set
+ end Set_Corresponding_Generic_Association;
+ procedure Set_Corresponding_Integer_Value
+ (N : Node_Id; Val : Uint) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Real_Literal);
+ Set_Uint4 (N, Val); -- semantic field, no parent set
+ end Set_Corresponding_Integer_Value;
+
+ procedure Set_Corresponding_Spec
+ (N : Node_Id; Val : Node_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Package_Body
+ or else NT (N).Nkind = N_Protected_Body
+ or else NT (N).Nkind = N_Subprogram_Body
+ or else NT (N).Nkind = N_Subprogram_Renaming_Declaration
+ or else NT (N).Nkind = N_Task_Body
+ or else NT (N).Nkind = N_With_Clause);
+ Set_Node5 (N, Val); -- semantic field, no parent set
+ end Set_Corresponding_Spec;
+
+ procedure Set_Corresponding_Stub
+ (N : Node_Id; Val : Node_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Subunit);
+ Set_Node3 (N, Val);
+ end Set_Corresponding_Stub;
+
+ procedure Set_Dcheck_Function
+ (N : Node_Id; Val : Entity_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Variant);
+ Set_Node5 (N, Val); -- semantic field, no parent set
+ end Set_Dcheck_Function;
+
+ procedure Set_Debug_Statement
+ (N : Node_Id; Val : Node_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Pragma);
+ Set_Node3_With_Parent (N, Val);
+ end Set_Debug_Statement;
+
+ procedure Set_Declarations
+ (N : Node_Id; Val : List_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Accept_Statement
+ or else NT (N).Nkind = N_Block_Statement
+ or else NT (N).Nkind = N_Compilation_Unit_Aux
+ or else NT (N).Nkind = N_Entry_Body
+ or else NT (N).Nkind = N_Package_Body
+ or else NT (N).Nkind = N_Protected_Body
+ or else NT (N).Nkind = N_Subprogram_Body
+ or else NT (N).Nkind = N_Task_Body);
+ Set_List2_With_Parent (N, Val);
+ end Set_Declarations;
+
+ procedure Set_Default_Expression
+ (N : Node_Id; Val : Node_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Parameter_Specification);
+ Set_Node5 (N, Val); -- semantic field, no parent set
+ end Set_Default_Expression;
+
+ procedure Set_Default_Name
+ (N : Node_Id; Val : Node_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Formal_Subprogram_Declaration);
+ Set_Node2_With_Parent (N, Val);
+ end Set_Default_Name;
+
+ procedure Set_Defining_Identifier
+ (N : Node_Id; Val : Entity_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Component_Declaration
+ or else NT (N).Nkind = N_Defining_Program_Unit_Name
+ or else NT (N).Nkind = N_Discriminant_Specification
+ or else NT (N).Nkind = N_Entry_Body
+ or else NT (N).Nkind = N_Entry_Declaration
+ or else NT (N).Nkind = N_Entry_Index_Specification
+ or else NT (N).Nkind = N_Exception_Declaration
+ or else NT (N).Nkind = N_Exception_Renaming_Declaration
+ or else NT (N).Nkind = N_Formal_Object_Declaration
+ or else NT (N).Nkind = N_Formal_Package_Declaration
+ or else NT (N).Nkind = N_Formal_Type_Declaration
+ or else NT (N).Nkind = N_Full_Type_Declaration
+ or else NT (N).Nkind = N_Implicit_Label_Declaration
+ or else NT (N).Nkind = N_Incomplete_Type_Declaration
+ or else NT (N).Nkind = N_Loop_Parameter_Specification
+ or else NT (N).Nkind = N_Number_Declaration
+ or else NT (N).Nkind = N_Object_Declaration
+ or else NT (N).Nkind = N_Object_Renaming_Declaration
+ or else NT (N).Nkind = N_Package_Body_Stub
+ or else NT (N).Nkind = N_Parameter_Specification
+ or else NT (N).Nkind = N_Private_Extension_Declaration
+ or else NT (N).Nkind = N_Private_Type_Declaration
+ or else NT (N).Nkind = N_Protected_Body
+ or else NT (N).Nkind = N_Protected_Body_Stub
+ or else NT (N).Nkind = N_Protected_Type_Declaration
+ or else NT (N).Nkind = N_Single_Protected_Declaration
+ or else NT (N).Nkind = N_Single_Task_Declaration
+ or else NT (N).Nkind = N_Subtype_Declaration
+ or else NT (N).Nkind = N_Task_Body
+ or else NT (N).Nkind = N_Task_Body_Stub
+ or else NT (N).Nkind = N_Task_Type_Declaration);
+ Set_Node1_With_Parent (N, Val);
+ end Set_Defining_Identifier;
+
+ procedure Set_Defining_Unit_Name
+ (N : Node_Id; Val : Node_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Function_Instantiation
+ or else NT (N).Nkind = N_Function_Specification
+ or else NT (N).Nkind = N_Generic_Function_Renaming_Declaration
+ or else NT (N).Nkind = N_Generic_Package_Renaming_Declaration
+ or else NT (N).Nkind = N_Generic_Procedure_Renaming_Declaration
+ or else NT (N).Nkind = N_Package_Body
+ or else NT (N).Nkind = N_Package_Instantiation
+ or else NT (N).Nkind = N_Package_Renaming_Declaration
+ or else NT (N).Nkind = N_Package_Specification
+ or else NT (N).Nkind = N_Procedure_Instantiation
+ or else NT (N).Nkind = N_Procedure_Specification);
+ Set_Node1_With_Parent (N, Val);
+ end Set_Defining_Unit_Name;
+
+ procedure Set_Delay_Alternative
+ (N : Node_Id; Val : Node_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Timed_Entry_Call);
+ Set_Node4_With_Parent (N, Val);
+ end Set_Delay_Alternative;
+
+ procedure Set_Delay_Finalize_Attach
+ (N : Node_Id; Val : Boolean := True) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Object_Declaration);
+ Set_Flag14 (N, Val);
+ end Set_Delay_Finalize_Attach;
+
+ procedure Set_Delay_Statement
+ (N : Node_Id; Val : Node_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Delay_Alternative);
+ Set_Node2_With_Parent (N, Val);
+ end Set_Delay_Statement;
+
+ procedure Set_Delta_Expression
+ (N : Node_Id; Val : Node_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Decimal_Fixed_Point_Definition
+ or else NT (N).Nkind = N_Delta_Constraint
+ or else NT (N).Nkind = N_Ordinary_Fixed_Point_Definition);
+ Set_Node3_With_Parent (N, Val);
+ end Set_Delta_Expression;
+
+ procedure Set_Digits_Expression
+ (N : Node_Id; Val : Node_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Decimal_Fixed_Point_Definition
+ or else NT (N).Nkind = N_Digits_Constraint
+ or else NT (N).Nkind = N_Floating_Point_Definition);
+ Set_Node2_With_Parent (N, Val);
+ end Set_Digits_Expression;
+
+ procedure Set_Discr_Check_Funcs_Built
+ (N : Node_Id; Val : Boolean := True) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Full_Type_Declaration);
+ Set_Flag11 (N, Val);
+ end Set_Discr_Check_Funcs_Built;
+
+ procedure Set_Discrete_Choices
+ (N : Node_Id; Val : List_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Case_Statement_Alternative
+ or else NT (N).Nkind = N_Variant);
+ Set_List4_With_Parent (N, Val);
+ end Set_Discrete_Choices;
+
+ procedure Set_Discrete_Range
+ (N : Node_Id; Val : Node_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Slice);
+ Set_Node4_With_Parent (N, Val);
+ end Set_Discrete_Range;
+
+ procedure Set_Discrete_Subtype_Definition
+ (N : Node_Id; Val : Node_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Entry_Declaration
+ or else NT (N).Nkind = N_Entry_Index_Specification
+ or else NT (N).Nkind = N_Loop_Parameter_Specification);
+ Set_Node4_With_Parent (N, Val);
+ end Set_Discrete_Subtype_Definition;
+
+ procedure Set_Discrete_Subtype_Definitions
+ (N : Node_Id; Val : List_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Constrained_Array_Definition);
+ Set_List2_With_Parent (N, Val);
+ end Set_Discrete_Subtype_Definitions;
+
+ procedure Set_Discriminant_Specifications
+ (N : Node_Id; Val : List_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Formal_Type_Declaration
+ or else NT (N).Nkind = N_Full_Type_Declaration
+ or else NT (N).Nkind = N_Incomplete_Type_Declaration
+ or else NT (N).Nkind = N_Private_Extension_Declaration
+ or else NT (N).Nkind = N_Private_Type_Declaration
+ or else NT (N).Nkind = N_Protected_Type_Declaration
+ or else NT (N).Nkind = N_Task_Type_Declaration);
+ Set_List4_With_Parent (N, Val);
+ end Set_Discriminant_Specifications;
+
+ procedure Set_Discriminant_Type
+ (N : Node_Id; Val : Node_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Discriminant_Specification);
+ Set_Node5_With_Parent (N, Val);
+ end Set_Discriminant_Type;
+
+ procedure Set_Do_Access_Check
+ (N : Node_Id; Val : Boolean := True) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Attribute_Reference
+ or else NT (N).Nkind = N_Explicit_Dereference
+ or else NT (N).Nkind = N_Indexed_Component
+ or else NT (N).Nkind = N_Selected_Component
+ or else NT (N).Nkind = N_Slice);
+ Set_Flag11 (N, Val);
+ end Set_Do_Access_Check;
+
+ procedure Set_Do_Accessibility_Check
+ (N : Node_Id; Val : Boolean := True) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Parameter_Specification);
+ Set_Flag13 (N, Val);
+ end Set_Do_Accessibility_Check;
+
+ procedure Set_Do_Discriminant_Check
+ (N : Node_Id; Val : Boolean := True) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Selected_Component);
+ Set_Flag13 (N, Val);
+ end Set_Do_Discriminant_Check;
+
+ procedure Set_Do_Division_Check
+ (N : Node_Id; Val : Boolean := True) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Op_Divide
+ or else NT (N).Nkind = N_Op_Mod
+ or else NT (N).Nkind = N_Op_Rem);
+ Set_Flag13 (N, Val);
+ end Set_Do_Division_Check;
+
+ procedure Set_Do_Length_Check
+ (N : Node_Id; Val : Boolean := True) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Assignment_Statement
+ or else NT (N).Nkind = N_Op_And
+ or else NT (N).Nkind = N_Op_Or
+ or else NT (N).Nkind = N_Op_Xor
+ or else NT (N).Nkind = N_Type_Conversion);
+ Set_Flag4 (N, Val);
+ end Set_Do_Length_Check;
+
+ procedure Set_Do_Overflow_Check
+ (N : Node_Id; Val : Boolean := True) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind in N_Op
+ or else NT (N).Nkind = N_Attribute_Reference
+ or else NT (N).Nkind = N_Type_Conversion);
+ Set_Flag17 (N, Val);
+ end Set_Do_Overflow_Check;
+
+ procedure Set_Do_Range_Check
+ (N : Node_Id; Val : Boolean := True) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind in N_Subexpr);
+ Set_Flag9 (N, Val);
+ end Set_Do_Range_Check;
+
+ procedure Set_Do_Storage_Check
+ (N : Node_Id; Val : Boolean := True) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Allocator
+ or else NT (N).Nkind = N_Subprogram_Body);
+ Set_Flag17 (N, Val);
+ end Set_Do_Storage_Check;
+
+ procedure Set_Do_Tag_Check
+ (N : Node_Id; Val : Boolean := True) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Assignment_Statement
+ or else NT (N).Nkind = N_Function_Call
+ or else NT (N).Nkind = N_Procedure_Call_Statement
+ or else NT (N).Nkind = N_Return_Statement
+ or else NT (N).Nkind = N_Type_Conversion);
+ Set_Flag13 (N, Val);
+ end Set_Do_Tag_Check;
+
+ procedure Set_Elaborate_All_Present
+ (N : Node_Id; Val : Boolean := True) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_With_Clause);
+ Set_Flag15 (N, Val);
+ end Set_Elaborate_All_Present;
+
+ procedure Set_Elaborate_Present
+ (N : Node_Id; Val : Boolean := True) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_With_Clause);
+ Set_Flag4 (N, Val);
+ end Set_Elaborate_Present;
+
+ procedure Set_Elaboration_Boolean
+ (N : Node_Id; Val : Node_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Function_Specification
+ or else NT (N).Nkind = N_Procedure_Specification);
+ Set_Node2 (N, Val);
+ end Set_Elaboration_Boolean;
+
+ procedure Set_Else_Actions
+ (N : Node_Id; Val : List_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Conditional_Expression);
+ Set_List3 (N, Val); -- semantic field, no parent set
+ end Set_Else_Actions;
+
+ procedure Set_Else_Statements
+ (N : Node_Id; Val : List_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Conditional_Entry_Call
+ or else NT (N).Nkind = N_If_Statement
+ or else NT (N).Nkind = N_Selective_Accept);
+ Set_List4_With_Parent (N, Val);
+ end Set_Else_Statements;
+
+ procedure Set_Elsif_Parts
+ (N : Node_Id; Val : List_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_If_Statement);
+ Set_List3_With_Parent (N, Val);
+ end Set_Elsif_Parts;
+
+ procedure Set_Enclosing_Variant
+ (N : Node_Id; Val : Node_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Variant);
+ Set_Node2 (N, Val); -- semantic field, no parent set
+ end Set_Enclosing_Variant;
+
+ procedure Set_End_Label
+ (N : Node_Id; Val : Node_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Handled_Sequence_Of_Statements
+ or else NT (N).Nkind = N_Loop_Statement
+ or else NT (N).Nkind = N_Package_Specification
+ or else NT (N).Nkind = N_Protected_Body
+ or else NT (N).Nkind = N_Protected_Definition
+ or else NT (N).Nkind = N_Record_Definition
+ or else NT (N).Nkind = N_Task_Definition);
+ Set_Node4_With_Parent (N, Val);
+ end Set_End_Label;
+
+ procedure Set_End_Span
+ (N : Node_Id; Val : Uint) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Case_Statement
+ or else NT (N).Nkind = N_If_Statement);
+ Set_Uint5 (N, Val);
+ end Set_End_Span;
+
+ procedure Set_Entity
+ (N : Node_Id; Val : Node_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind in N_Has_Entity
+ or else NT (N).Nkind = N_Freeze_Entity);
+ Set_Node4 (N, Val); -- semantic field, no parent set
+ end Set_Entity;
+
+ procedure Set_Entry_Body_Formal_Part
+ (N : Node_Id; Val : Node_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Entry_Body);
+ Set_Node5_With_Parent (N, Val);
+ end Set_Entry_Body_Formal_Part;
+
+ procedure Set_Entry_Call_Alternative
+ (N : Node_Id; Val : Node_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Conditional_Entry_Call
+ or else NT (N).Nkind = N_Timed_Entry_Call);
+ Set_Node1_With_Parent (N, Val);
+ end Set_Entry_Call_Alternative;
+
+ procedure Set_Entry_Call_Statement
+ (N : Node_Id; Val : Node_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Entry_Call_Alternative);
+ Set_Node1_With_Parent (N, Val);
+ end Set_Entry_Call_Statement;
+
+ procedure Set_Entry_Direct_Name
+ (N : Node_Id; Val : Node_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Accept_Statement);
+ Set_Node1_With_Parent (N, Val);
+ end Set_Entry_Direct_Name;
+
+ procedure Set_Entry_Index
+ (N : Node_Id; Val : Node_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Accept_Statement);
+ Set_Node5_With_Parent (N, Val);
+ end Set_Entry_Index;
+
+ procedure Set_Entry_Index_Specification
+ (N : Node_Id; Val : Node_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Entry_Body_Formal_Part);
+ Set_Node4_With_Parent (N, Val);
+ end Set_Entry_Index_Specification;
+
+ procedure Set_Etype
+ (N : Node_Id; Val : Node_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind in N_Has_Etype);
+ Set_Node5 (N, Val); -- semantic field, no parent set
+ end Set_Etype;
+
+ procedure Set_Exception_Choices
+ (N : Node_Id; Val : List_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Exception_Handler);
+ Set_List4_With_Parent (N, Val);
+ end Set_Exception_Choices;
+
+ procedure Set_Exception_Handlers
+ (N : Node_Id; Val : List_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Handled_Sequence_Of_Statements);
+ Set_List5_With_Parent (N, Val);
+ end Set_Exception_Handlers;
+
+ procedure Set_Exception_Junk
+ (N : Node_Id; Val : Boolean := True) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Goto_Statement
+ or else NT (N).Nkind = N_Label
+ or else NT (N).Nkind = N_Object_Declaration
+ or else NT (N).Nkind = N_Subtype_Declaration);
+ Set_Flag11 (N, Val);
+ end Set_Exception_Junk;
+
+ procedure Set_Expansion_Delayed
+ (N : Node_Id; Val : Boolean := True) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Aggregate
+ or else NT (N).Nkind = N_Extension_Aggregate);
+ Set_Flag11 (N, Val);
+ end Set_Expansion_Delayed;
+
+ procedure Set_Explicit_Actual_Parameter
+ (N : Node_Id; Val : Node_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Parameter_Association);
+ Set_Node3_With_Parent (N, Val);
+ end Set_Explicit_Actual_Parameter;
+
+ procedure Set_Explicit_Generic_Actual_Parameter
+ (N : Node_Id; Val : Node_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Generic_Association);
+ Set_Node1_With_Parent (N, Val);
+ end Set_Explicit_Generic_Actual_Parameter;
+
+ procedure Set_Expression
+ (N : Node_Id; Val : Node_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Allocator
+ or else NT (N).Nkind = N_Assignment_Statement
+ or else NT (N).Nkind = N_At_Clause
+ or else NT (N).Nkind = N_Attribute_Definition_Clause
+ or else NT (N).Nkind = N_Case_Statement
+ or else NT (N).Nkind = N_Code_Statement
+ or else NT (N).Nkind = N_Component_Association
+ or else NT (N).Nkind = N_Component_Declaration
+ or else NT (N).Nkind = N_Delay_Relative_Statement
+ or else NT (N).Nkind = N_Delay_Until_Statement
+ or else NT (N).Nkind = N_Discriminant_Association
+ or else NT (N).Nkind = N_Discriminant_Specification
+ or else NT (N).Nkind = N_Exception_Declaration
+ or else NT (N).Nkind = N_Formal_Object_Declaration
+ or else NT (N).Nkind = N_Free_Statement
+ or else NT (N).Nkind = N_Mod_Clause
+ or else NT (N).Nkind = N_Modular_Type_Definition
+ or else NT (N).Nkind = N_Number_Declaration
+ or else NT (N).Nkind = N_Object_Declaration
+ or else NT (N).Nkind = N_Parameter_Specification
+ or else NT (N).Nkind = N_Pragma_Argument_Association
+ or else NT (N).Nkind = N_Qualified_Expression
+ or else NT (N).Nkind = N_Return_Statement
+ or else NT (N).Nkind = N_Type_Conversion
+ or else NT (N).Nkind = N_Unchecked_Expression
+ or else NT (N).Nkind = N_Unchecked_Type_Conversion);
+ Set_Node3_With_Parent (N, Val);
+ end Set_Expression;
+
+ procedure Set_Expressions
+ (N : Node_Id; Val : List_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Aggregate
+ or else NT (N).Nkind = N_Attribute_Reference
+ or else NT (N).Nkind = N_Conditional_Expression
+ or else NT (N).Nkind = N_Extension_Aggregate
+ or else NT (N).Nkind = N_Indexed_Component);
+ Set_List1_With_Parent (N, Val);
+ end Set_Expressions;
+
+ procedure Set_First_Bit
+ (N : Node_Id; Val : Node_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Component_Clause);
+ Set_Node3_With_Parent (N, Val);
+ end Set_First_Bit;
+
+ procedure Set_First_Inlined_Subprogram
+ (N : Node_Id; Val : Entity_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Compilation_Unit);
+ Set_Node3 (N, Val); -- semantic field, no parent set
+ end Set_First_Inlined_Subprogram;
+
+ procedure Set_First_Name
+ (N : Node_Id; Val : Boolean := True) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_With_Clause);
+ Set_Flag5 (N, Val);
+ end Set_First_Name;
+
+ procedure Set_First_Named_Actual
+ (N : Node_Id; Val : Node_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Entry_Call_Statement
+ or else NT (N).Nkind = N_Function_Call
+ or else NT (N).Nkind = N_Procedure_Call_Statement);
+ Set_Node4 (N, Val); -- semantic field, no parent set
+ end Set_First_Named_Actual;
+
+ procedure Set_First_Real_Statement
+ (N : Node_Id; Val : Node_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Handled_Sequence_Of_Statements);
+ Set_Node2 (N, Val); -- semantic field, no parent set
+ end Set_First_Real_Statement;
+
+ procedure Set_First_Subtype_Link
+ (N : Node_Id; Val : Entity_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Freeze_Entity);
+ Set_Node5 (N, Val); -- semantic field, no parent set
+ end Set_First_Subtype_Link;
+
+ procedure Set_Float_Truncate
+ (N : Node_Id; Val : Boolean := True) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Type_Conversion);
+ Set_Flag11 (N, Val);
+ end Set_Float_Truncate;
+
+ procedure Set_Formal_Type_Definition
+ (N : Node_Id; Val : Node_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Formal_Type_Declaration);
+ Set_Node3_With_Parent (N, Val);
+ end Set_Formal_Type_Definition;
+
+ procedure Set_Forwards_OK
+ (N : Node_Id; Val : Boolean := True) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Assignment_Statement);
+ Set_Flag5 (N, Val);
+ end Set_Forwards_OK;
+
+ procedure Set_From_At_Mod
+ (N : Node_Id; Val : Boolean := True) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Attribute_Definition_Clause);
+ Set_Flag4 (N, Val);
+ end Set_From_At_Mod;
+
+ procedure Set_Generic_Associations
+ (N : Node_Id; Val : List_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Formal_Package_Declaration
+ or else NT (N).Nkind = N_Function_Instantiation
+ or else NT (N).Nkind = N_Package_Instantiation
+ or else NT (N).Nkind = N_Procedure_Instantiation);
+ Set_List3_With_Parent (N, Val);
+ end Set_Generic_Associations;
+
+ procedure Set_Generic_Formal_Declarations
+ (N : Node_Id; Val : List_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Generic_Package_Declaration
+ or else NT (N).Nkind = N_Generic_Subprogram_Declaration);
+ Set_List2_With_Parent (N, Val);
+ end Set_Generic_Formal_Declarations;
+
+ procedure Set_Generic_Parent
+ (N : Node_Id; Val : Node_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Function_Specification
+ or else NT (N).Nkind = N_Package_Specification
+ or else NT (N).Nkind = N_Procedure_Specification);
+ Set_Node5 (N, Val);
+ end Set_Generic_Parent;
+
+ procedure Set_Generic_Parent_Type
+ (N : Node_Id; Val : Node_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Subtype_Declaration);
+ Set_Node4 (N, Val);
+ end Set_Generic_Parent_Type;
+
+ procedure Set_Handled_Statement_Sequence
+ (N : Node_Id; Val : Node_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Accept_Statement
+ or else NT (N).Nkind = N_Block_Statement
+ or else NT (N).Nkind = N_Entry_Body
+ or else NT (N).Nkind = N_Package_Body
+ or else NT (N).Nkind = N_Subprogram_Body
+ or else NT (N).Nkind = N_Task_Body);
+ Set_Node4_With_Parent (N, Val);
+ end Set_Handled_Statement_Sequence;
+
+ procedure Set_Handler_List_Entry
+ (N : Node_Id; Val : Node_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Object_Declaration);
+ Set_Node2 (N, Val);
+ end Set_Handler_List_Entry;
+
+ procedure Set_Has_Created_Identifier
+ (N : Node_Id; Val : Boolean := True) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Block_Statement
+ or else NT (N).Nkind = N_Loop_Statement);
+ Set_Flag15 (N, Val);
+ end Set_Has_Created_Identifier;
+
+ procedure Set_Has_Dynamic_Length_Check
+ (N : Node_Id; Val : Boolean := True) is
+ begin
+ Set_Flag10 (N, Val);
+ end Set_Has_Dynamic_Length_Check;
+
+ procedure Set_Has_Dynamic_Range_Check
+ (N : Node_Id; Val : Boolean := True) is
+ begin
+ Set_Flag12 (N, Val);
+ end Set_Has_Dynamic_Range_Check;
+
+ procedure Set_Has_No_Elaboration_Code
+ (N : Node_Id; Val : Boolean := True) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Compilation_Unit);
+ Set_Flag17 (N, Val);
+ end Set_Has_No_Elaboration_Code;
+
+ procedure Set_Has_Priority_Pragma
+ (N : Node_Id; Val : Boolean := True) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Protected_Definition
+ or else NT (N).Nkind = N_Subprogram_Body
+ or else NT (N).Nkind = N_Task_Definition);
+ Set_Flag6 (N, Val);
+ end Set_Has_Priority_Pragma;
+
+ procedure Set_Has_Private_View
+ (N : Node_Id; Val : Boolean := True) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind in N_Op
+ or else NT (N).Nkind = N_Character_Literal
+ or else NT (N).Nkind = N_Expanded_Name
+ or else NT (N).Nkind = N_Identifier
+ or else NT (N).Nkind = N_Operator_Symbol);
+ Set_Flag11 (N, Val);
+ end Set_Has_Private_View;
+
+ procedure Set_Has_Storage_Size_Pragma
+ (N : Node_Id; Val : Boolean := True) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Task_Definition);
+ Set_Flag5 (N, Val);
+ end Set_Has_Storage_Size_Pragma;
+
+ procedure Set_Has_Task_Info_Pragma
+ (N : Node_Id; Val : Boolean := True) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Task_Definition);
+ Set_Flag7 (N, Val);
+ end Set_Has_Task_Info_Pragma;
+
+ procedure Set_Has_Task_Name_Pragma
+ (N : Node_Id; Val : Boolean := True) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Task_Definition);
+ Set_Flag8 (N, Val);
+ end Set_Has_Task_Name_Pragma;
+
+ procedure Set_Has_Wide_Character
+ (N : Node_Id; Val : Boolean := True) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_String_Literal);
+ Set_Flag11 (N, Val);
+ end Set_Has_Wide_Character;
+
+ procedure Set_Hidden_By_Use_Clause
+ (N : Node_Id; Val : Elist_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Use_Package_Clause
+ or else NT (N).Nkind = N_Use_Type_Clause);
+ Set_Elist4 (N, Val);
+ end Set_Hidden_By_Use_Clause;
+
+ procedure Set_High_Bound
+ (N : Node_Id; Val : Node_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Range
+ or else NT (N).Nkind = N_Real_Range_Specification
+ or else NT (N).Nkind = N_Signed_Integer_Type_Definition);
+ Set_Node2_With_Parent (N, Val);
+ end Set_High_Bound;
+
+ procedure Set_Identifier
+ (N : Node_Id; Val : Node_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_At_Clause
+ or else NT (N).Nkind = N_Block_Statement
+ or else NT (N).Nkind = N_Designator
+ or else NT (N).Nkind = N_Enumeration_Representation_Clause
+ or else NT (N).Nkind = N_Label
+ or else NT (N).Nkind = N_Loop_Statement
+ or else NT (N).Nkind = N_Record_Representation_Clause
+ or else NT (N).Nkind = N_Subprogram_Info);
+ Set_Node1_With_Parent (N, Val);
+ end Set_Identifier;
+
+ procedure Set_Implicit_With
+ (N : Node_Id; Val : Boolean := True) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_With_Clause);
+ Set_Flag17 (N, Val);
+ end Set_Implicit_With;
+
+ procedure Set_In_Present
+ (N : Node_Id; Val : Boolean := True) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Formal_Object_Declaration
+ or else NT (N).Nkind = N_Parameter_Specification);
+ Set_Flag15 (N, Val);
+ end Set_In_Present;
+
+ procedure Set_Includes_Infinities
+ (N : Node_Id; Val : Boolean := True) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Range);
+ Set_Flag11 (N, Val);
+ end Set_Includes_Infinities;
+
+ procedure Set_Instance_Spec
+ (N : Node_Id; Val : Node_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Formal_Package_Declaration
+ or else NT (N).Nkind = N_Function_Instantiation
+ or else NT (N).Nkind = N_Package_Instantiation
+ or else NT (N).Nkind = N_Procedure_Instantiation);
+ Set_Node5 (N, Val); -- semantic field, no Parent set
+ end Set_Instance_Spec;
+
+ procedure Set_Intval
+ (N : Node_Id; Val : Uint) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Integer_Literal);
+ Set_Uint3 (N, Val);
+ end Set_Intval;
+
+ procedure Set_Is_Asynchronous_Call_Block
+ (N : Node_Id; Val : Boolean := True) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Block_Statement);
+ Set_Flag7 (N, Val);
+ end Set_Is_Asynchronous_Call_Block;
+
+ procedure Set_Is_Component_Left_Opnd
+ (N : Node_Id; Val : Boolean := True) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Op_Concat);
+ Set_Flag13 (N, Val);
+ end Set_Is_Component_Left_Opnd;
+
+ procedure Set_Is_Component_Right_Opnd
+ (N : Node_Id; Val : Boolean := True) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Op_Concat);
+ Set_Flag14 (N, Val);
+ end Set_Is_Component_Right_Opnd;
+
+ procedure Set_Is_Controlling_Actual
+ (N : Node_Id; Val : Boolean := True) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind in N_Subexpr);
+ Set_Flag16 (N, Val);
+ end Set_Is_Controlling_Actual;
+
+ procedure Set_Is_Machine_Number
+ (N : Node_Id; Val : Boolean := True) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Real_Literal);
+ Set_Flag11 (N, Val);
+ end Set_Is_Machine_Number;
+
+ procedure Set_Is_Overloaded
+ (N : Node_Id; Val : Boolean := True) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind in N_Subexpr);
+ Set_Flag5 (N, Val);
+ end Set_Is_Overloaded;
+
+ procedure Set_Is_Power_Of_2_For_Shift
+ (N : Node_Id; Val : Boolean := True) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Op_Expon);
+ Set_Flag13 (N, Val);
+ end Set_Is_Power_Of_2_For_Shift;
+
+ procedure Set_Is_Protected_Subprogram_Body
+ (N : Node_Id; Val : Boolean := True) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Subprogram_Body);
+ Set_Flag7 (N, Val);
+ end Set_Is_Protected_Subprogram_Body;
+
+ procedure Set_Is_Static_Expression
+ (N : Node_Id; Val : Boolean := True) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind in N_Subexpr);
+ Set_Flag6 (N, Val);
+ end Set_Is_Static_Expression;
+
+ procedure Set_Is_Subprogram_Descriptor
+ (N : Node_Id; Val : Boolean := True) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Object_Declaration);
+ Set_Flag16 (N, Val);
+ end Set_Is_Subprogram_Descriptor;
+
+ procedure Set_Is_Task_Allocation_Block
+ (N : Node_Id; Val : Boolean := True) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Block_Statement);
+ Set_Flag6 (N, Val);
+ end Set_Is_Task_Allocation_Block;
+
+ procedure Set_Is_Task_Master
+ (N : Node_Id; Val : Boolean := True) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Block_Statement
+ or else NT (N).Nkind = N_Subprogram_Body
+ or else NT (N).Nkind = N_Task_Body);
+ Set_Flag5 (N, Val);
+ end Set_Is_Task_Master;
+
+ procedure Set_Iteration_Scheme
+ (N : Node_Id; Val : Node_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Loop_Statement);
+ Set_Node2_With_Parent (N, Val);
+ end Set_Iteration_Scheme;
+
+ procedure Set_Itype
+ (N : Node_Id; Val : Entity_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Itype_Reference);
+ Set_Node1 (N, Val); -- no parent, semantic field
+ end Set_Itype;
+
+ procedure Set_Kill_Range_Check
+ (N : Node_Id; Val : Boolean := True) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Unchecked_Type_Conversion);
+ Set_Flag11 (N, Val);
+ end Set_Kill_Range_Check;
+
+ procedure Set_Label_Construct
+ (N : Node_Id; Val : Node_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Implicit_Label_Declaration);
+ Set_Node2 (N, Val); -- semantic field, no parent set
+ end Set_Label_Construct;
+
+ procedure Set_Last_Bit
+ (N : Node_Id; Val : Node_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Component_Clause);
+ Set_Node4_With_Parent (N, Val);
+ end Set_Last_Bit;
+
+ procedure Set_Last_Name
+ (N : Node_Id; Val : Boolean := True) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_With_Clause);
+ Set_Flag6 (N, Val);
+ end Set_Last_Name;
+
+ procedure Set_Left_Opnd
+ (N : Node_Id; Val : Node_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_And_Then
+ or else NT (N).Nkind = N_In
+ or else NT (N).Nkind = N_Not_In
+ or else NT (N).Nkind = N_Or_Else
+ or else NT (N).Nkind in N_Binary_Op);
+ Set_Node2_With_Parent (N, Val);
+ end Set_Left_Opnd;
+
+ procedure Set_Library_Unit
+ (N : Node_Id; Val : Node_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Compilation_Unit
+ or else NT (N).Nkind = N_Package_Body_Stub
+ or else NT (N).Nkind = N_Protected_Body_Stub
+ or else NT (N).Nkind = N_Subprogram_Body_Stub
+ or else NT (N).Nkind = N_Task_Body_Stub
+ or else NT (N).Nkind = N_With_Clause);
+ Set_Node4 (N, Val); -- semantic field, no parent set
+ end Set_Library_Unit;
+
+ procedure Set_Limited_Present
+ (N : Node_Id; Val : Boolean := True) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Formal_Private_Type_Definition
+ or else NT (N).Nkind = N_Private_Type_Declaration
+ or else NT (N).Nkind = N_Record_Definition);
+ Set_Flag17 (N, Val);
+ end Set_Limited_Present;
+
+ procedure Set_Literals
+ (N : Node_Id; Val : List_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Enumeration_Type_Definition);
+ Set_List1_With_Parent (N, Val);
+ end Set_Literals;
+
+ procedure Set_Loop_Actions
+ (N : Node_Id; Val : List_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Component_Association);
+ Set_List2 (N, Val); -- semantic field, no parent set
+ end Set_Loop_Actions;
+
+ procedure Set_Loop_Parameter_Specification
+ (N : Node_Id; Val : Node_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Iteration_Scheme);
+ Set_Node4_With_Parent (N, Val);
+ end Set_Loop_Parameter_Specification;
+
+ procedure Set_Low_Bound
+ (N : Node_Id; Val : Node_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Range
+ or else NT (N).Nkind = N_Real_Range_Specification
+ or else NT (N).Nkind = N_Signed_Integer_Type_Definition);
+ Set_Node1_With_Parent (N, Val);
+ end Set_Low_Bound;
+
+ procedure Set_Mod_Clause
+ (N : Node_Id; Val : Node_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Record_Representation_Clause);
+ Set_Node2_With_Parent (N, Val);
+ end Set_Mod_Clause;
+
+ procedure Set_More_Ids
+ (N : Node_Id; Val : Boolean := True) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Component_Declaration
+ or else NT (N).Nkind = N_Discriminant_Specification
+ or else NT (N).Nkind = N_Exception_Declaration
+ or else NT (N).Nkind = N_Formal_Object_Declaration
+ or else NT (N).Nkind = N_Number_Declaration
+ or else NT (N).Nkind = N_Object_Declaration
+ or else NT (N).Nkind = N_Parameter_Specification);
+ Set_Flag5 (N, Val);
+ end Set_More_Ids;
+
+ procedure Set_Must_Not_Freeze
+ (N : Node_Id; Val : Boolean := True) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Subtype_Indication
+ or else NT (N).Nkind in N_Subexpr);
+ Set_Flag8 (N, Val);
+ end Set_Must_Not_Freeze;
+
+ procedure Set_Name
+ (N : Node_Id; Val : Node_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Assignment_Statement
+ or else NT (N).Nkind = N_Attribute_Definition_Clause
+ or else NT (N).Nkind = N_Defining_Program_Unit_Name
+ or else NT (N).Nkind = N_Designator
+ or else NT (N).Nkind = N_Entry_Call_Statement
+ or else NT (N).Nkind = N_Exception_Renaming_Declaration
+ or else NT (N).Nkind = N_Exit_Statement
+ or else NT (N).Nkind = N_Formal_Package_Declaration
+ or else NT (N).Nkind = N_Function_Call
+ or else NT (N).Nkind = N_Function_Instantiation
+ or else NT (N).Nkind = N_Generic_Function_Renaming_Declaration
+ or else NT (N).Nkind = N_Generic_Package_Renaming_Declaration
+ or else NT (N).Nkind = N_Generic_Procedure_Renaming_Declaration
+ or else NT (N).Nkind = N_Goto_Statement
+ or else NT (N).Nkind = N_Object_Renaming_Declaration
+ or else NT (N).Nkind = N_Package_Instantiation
+ or else NT (N).Nkind = N_Package_Renaming_Declaration
+ or else NT (N).Nkind = N_Procedure_Call_Statement
+ or else NT (N).Nkind = N_Procedure_Instantiation
+ or else NT (N).Nkind = N_Raise_Statement
+ or else NT (N).Nkind = N_Requeue_Statement
+ or else NT (N).Nkind = N_Subprogram_Renaming_Declaration
+ or else NT (N).Nkind = N_Subunit
+ or else NT (N).Nkind = N_Variant_Part
+ or else NT (N).Nkind = N_With_Clause
+ or else NT (N).Nkind = N_With_Type_Clause);
+ Set_Node2_With_Parent (N, Val);
+ end Set_Name;
+
+ procedure Set_Names
+ (N : Node_Id; Val : List_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Abort_Statement
+ or else NT (N).Nkind = N_Use_Package_Clause);
+ Set_List2_With_Parent (N, Val);
+ end Set_Names;
+
+ procedure Set_Next_Entity
+ (N : Node_Id; Val : Node_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Defining_Character_Literal
+ or else NT (N).Nkind = N_Defining_Identifier
+ or else NT (N).Nkind = N_Defining_Operator_Symbol);
+ Set_Node2 (N, Val); -- semantic field, no parent set
+ end Set_Next_Entity;
+
+ procedure Set_Next_Named_Actual
+ (N : Node_Id; Val : Node_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Parameter_Association);
+ Set_Node4 (N, Val); -- semantic field, no parent set
+ end Set_Next_Named_Actual;
+
+ procedure Set_Next_Rep_Item
+ (N : Node_Id; Val : Node_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Attribute_Definition_Clause
+ or else NT (N).Nkind = N_Enumeration_Representation_Clause
+ or else NT (N).Nkind = N_Pragma
+ or else NT (N).Nkind = N_Record_Representation_Clause);
+ Set_Node4 (N, Val); -- semantic field, no parent set
+ end Set_Next_Rep_Item;
+
+ procedure Set_Next_Use_Clause
+ (N : Node_Id; Val : Node_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Use_Package_Clause
+ or else NT (N).Nkind = N_Use_Type_Clause);
+ Set_Node3 (N, Val); -- semantic field, no parent set
+ end Set_Next_Use_Clause;
+
+ procedure Set_No_Ctrl_Actions
+ (N : Node_Id; Val : Boolean := True) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Assignment_Statement);
+ Set_Flag7 (N, Val);
+ end Set_No_Ctrl_Actions;
+
+ procedure Set_No_Entities_Ref_In_Spec
+ (N : Node_Id; Val : Boolean := True) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_With_Clause);
+ Set_Flag8 (N, Val);
+ end Set_No_Entities_Ref_In_Spec;
+
+ procedure Set_No_Initialization
+ (N : Node_Id; Val : Boolean := True) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Allocator
+ or else NT (N).Nkind = N_Object_Declaration);
+ Set_Flag13 (N, Val);
+ end Set_No_Initialization;
+
+ procedure Set_Null_Present
+ (N : Node_Id; Val : Boolean := True) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Component_List
+ or else NT (N).Nkind = N_Record_Definition);
+ Set_Flag13 (N, Val);
+ end Set_Null_Present;
+
+ procedure Set_Null_Record_Present
+ (N : Node_Id; Val : Boolean := True) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Aggregate
+ or else NT (N).Nkind = N_Extension_Aggregate);
+ Set_Flag17 (N, Val);
+ end Set_Null_Record_Present;
+
+ procedure Set_Object_Definition
+ (N : Node_Id; Val : Node_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Object_Declaration);
+ Set_Node4_With_Parent (N, Val);
+ end Set_Object_Definition;
+
+ procedure Set_OK_For_Stream
+ (N : Node_Id; Val : Boolean := True) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Attribute_Reference);
+ Set_Flag4 (N, Val);
+ end Set_OK_For_Stream;
+
+ procedure Set_Original_Discriminant
+ (N : Node_Id; Val : Node_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Identifier);
+ Set_Node2 (N, Val); -- semantic field, no parent set
+ end Set_Original_Discriminant;
+
+ procedure Set_Others_Discrete_Choices
+ (N : Node_Id; Val : List_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Others_Choice);
+ Set_List1_With_Parent (N, Val);
+ end Set_Others_Discrete_Choices;
+
+ procedure Set_Out_Present
+ (N : Node_Id; Val : Boolean := True) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Formal_Object_Declaration
+ or else NT (N).Nkind = N_Parameter_Specification);
+ Set_Flag17 (N, Val);
+ end Set_Out_Present;
+
+ procedure Set_Parameter_Associations
+ (N : Node_Id; Val : List_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Entry_Call_Statement
+ or else NT (N).Nkind = N_Function_Call
+ or else NT (N).Nkind = N_Procedure_Call_Statement);
+ Set_List3_With_Parent (N, Val);
+ end Set_Parameter_Associations;
+
+ procedure Set_Parameter_List_Truncated
+ (N : Node_Id; Val : Boolean := True) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Function_Call
+ or else NT (N).Nkind = N_Procedure_Call_Statement);
+ Set_Flag17 (N, Val);
+ end Set_Parameter_List_Truncated;
+
+ procedure Set_Parameter_Specifications
+ (N : Node_Id; Val : List_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Accept_Statement
+ or else NT (N).Nkind = N_Access_Function_Definition
+ or else NT (N).Nkind = N_Access_Procedure_Definition
+ or else NT (N).Nkind = N_Entry_Body_Formal_Part
+ or else NT (N).Nkind = N_Entry_Declaration
+ or else NT (N).Nkind = N_Function_Specification
+ or else NT (N).Nkind = N_Procedure_Specification);
+ Set_List3_With_Parent (N, Val);
+ end Set_Parameter_Specifications;
+
+ procedure Set_Parameter_Type
+ (N : Node_Id; Val : Node_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Parameter_Specification);
+ Set_Node2_With_Parent (N, Val);
+ end Set_Parameter_Type;
+
+ procedure Set_Parent_Spec
+ (N : Node_Id; Val : Node_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Function_Instantiation
+ or else NT (N).Nkind = N_Generic_Function_Renaming_Declaration
+ or else NT (N).Nkind = N_Generic_Package_Declaration
+ or else NT (N).Nkind = N_Generic_Package_Renaming_Declaration
+ or else NT (N).Nkind = N_Generic_Procedure_Renaming_Declaration
+ or else NT (N).Nkind = N_Generic_Subprogram_Declaration
+ or else NT (N).Nkind = N_Package_Declaration
+ or else NT (N).Nkind = N_Package_Instantiation
+ or else NT (N).Nkind = N_Package_Renaming_Declaration
+ or else NT (N).Nkind = N_Procedure_Instantiation
+ or else NT (N).Nkind = N_Subprogram_Declaration
+ or else NT (N).Nkind = N_Subprogram_Renaming_Declaration);
+ Set_Node4 (N, Val); -- semantic field, no parent set
+ end Set_Parent_Spec;
+
+ procedure Set_Position
+ (N : Node_Id; Val : Node_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Component_Clause);
+ Set_Node2_With_Parent (N, Val);
+ end Set_Position;
+
+ procedure Set_Pragma_Argument_Associations
+ (N : Node_Id; Val : List_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Pragma);
+ Set_List2_With_Parent (N, Val);
+ end Set_Pragma_Argument_Associations;
+
+ procedure Set_Pragmas_After
+ (N : Node_Id; Val : List_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Compilation_Unit_Aux
+ or else NT (N).Nkind = N_Terminate_Alternative);
+ Set_List5_With_Parent (N, Val);
+ end Set_Pragmas_After;
+
+ procedure Set_Pragmas_Before
+ (N : Node_Id; Val : List_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Accept_Alternative
+ or else NT (N).Nkind = N_Delay_Alternative
+ or else NT (N).Nkind = N_Entry_Call_Alternative
+ or else NT (N).Nkind = N_Mod_Clause
+ or else NT (N).Nkind = N_Terminate_Alternative
+ or else NT (N).Nkind = N_Triggering_Alternative);
+ Set_List4_With_Parent (N, Val);
+ end Set_Pragmas_Before;
+
+ procedure Set_Prefix
+ (N : Node_Id; Val : Node_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Attribute_Reference
+ or else NT (N).Nkind = N_Expanded_Name
+ or else NT (N).Nkind = N_Explicit_Dereference
+ or else NT (N).Nkind = N_Indexed_Component
+ or else NT (N).Nkind = N_Reference
+ or else NT (N).Nkind = N_Selected_Component
+ or else NT (N).Nkind = N_Slice);
+ Set_Node3_With_Parent (N, Val);
+ end Set_Prefix;
+
+ procedure Set_Present_Expr
+ (N : Node_Id; Val : Uint) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Variant);
+ Set_Uint3 (N, Val);
+ end Set_Present_Expr;
+
+ procedure Set_Prev_Ids
+ (N : Node_Id; Val : Boolean := True) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Component_Declaration
+ or else NT (N).Nkind = N_Discriminant_Specification
+ or else NT (N).Nkind = N_Exception_Declaration
+ or else NT (N).Nkind = N_Formal_Object_Declaration
+ or else NT (N).Nkind = N_Number_Declaration
+ or else NT (N).Nkind = N_Object_Declaration
+ or else NT (N).Nkind = N_Parameter_Specification);
+ Set_Flag6 (N, Val);
+ end Set_Prev_Ids;
+
+ procedure Set_Print_In_Hex
+ (N : Node_Id; Val : Boolean := True) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Integer_Literal);
+ Set_Flag13 (N, Val);
+ end Set_Print_In_Hex;
+
+ procedure Set_Private_Declarations
+ (N : Node_Id; Val : List_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Package_Specification
+ or else NT (N).Nkind = N_Protected_Definition
+ or else NT (N).Nkind = N_Task_Definition);
+ Set_List3_With_Parent (N, Val);
+ end Set_Private_Declarations;
+
+ procedure Set_Private_Present
+ (N : Node_Id; Val : Boolean := True) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Compilation_Unit
+ or else NT (N).Nkind = N_Formal_Derived_Type_Definition);
+ Set_Flag15 (N, Val);
+ end Set_Private_Present;
+
+ procedure Set_Procedure_To_Call
+ (N : Node_Id; Val : Node_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Allocator
+ or else NT (N).Nkind = N_Free_Statement
+ or else NT (N).Nkind = N_Return_Statement);
+ Set_Node4 (N, Val); -- semantic field, no parent set
+ end Set_Procedure_To_Call;
+
+ procedure Set_Proper_Body
+ (N : Node_Id; Val : Node_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Subunit);
+ Set_Node1_With_Parent (N, Val);
+ end Set_Proper_Body;
+
+ procedure Set_Protected_Definition
+ (N : Node_Id; Val : Node_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Protected_Type_Declaration
+ or else NT (N).Nkind = N_Single_Protected_Declaration);
+ Set_Node3_With_Parent (N, Val);
+ end Set_Protected_Definition;
+
+ procedure Set_Protected_Present
+ (N : Node_Id; Val : Boolean := True) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Access_Function_Definition
+ or else NT (N).Nkind = N_Access_Procedure_Definition);
+ Set_Flag15 (N, Val);
+ end Set_Protected_Present;
+
+ procedure Set_Raises_Constraint_Error
+ (N : Node_Id; Val : Boolean := True) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind in N_Subexpr);
+ Set_Flag7 (N, Val);
+ end Set_Raises_Constraint_Error;
+
+ procedure Set_Range_Constraint
+ (N : Node_Id; Val : Node_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Delta_Constraint
+ or else NT (N).Nkind = N_Digits_Constraint);
+ Set_Node4_With_Parent (N, Val);
+ end Set_Range_Constraint;
+
+ procedure Set_Range_Expression
+ (N : Node_Id; Val : Node_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Range_Constraint);
+ Set_Node4_With_Parent (N, Val);
+ end Set_Range_Expression;
+
+ procedure Set_Real_Range_Specification
+ (N : Node_Id; Val : Node_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Decimal_Fixed_Point_Definition
+ or else NT (N).Nkind = N_Floating_Point_Definition
+ or else NT (N).Nkind = N_Ordinary_Fixed_Point_Definition);
+ Set_Node4_With_Parent (N, Val);
+ end Set_Real_Range_Specification;
+
+ procedure Set_Realval
+ (N : Node_Id; Val : Ureal) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Real_Literal);
+ Set_Ureal3 (N, Val);
+ end Set_Realval;
+
+ procedure Set_Record_Extension_Part
+ (N : Node_Id; Val : Node_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Derived_Type_Definition);
+ Set_Node3_With_Parent (N, Val);
+ end Set_Record_Extension_Part;
+
+ procedure Set_Redundant_Use
+ (N : Node_Id; Val : Boolean := True) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Attribute_Reference
+ or else NT (N).Nkind = N_Expanded_Name
+ or else NT (N).Nkind = N_Identifier);
+ Set_Flag13 (N, Val);
+ end Set_Redundant_Use;
+
+ procedure Set_Return_Type
+ (N : Node_Id; Val : Node_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Return_Statement);
+ Set_Node2 (N, Val); -- semantic field, no parent set
+ end Set_Return_Type;
+
+ procedure Set_Reverse_Present
+ (N : Node_Id; Val : Boolean := True) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Loop_Parameter_Specification);
+ Set_Flag15 (N, Val);
+ end Set_Reverse_Present;
+
+ procedure Set_Right_Opnd
+ (N : Node_Id; Val : Node_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind in N_Op
+ or else NT (N).Nkind = N_And_Then
+ or else NT (N).Nkind = N_In
+ or else NT (N).Nkind = N_Not_In
+ or else NT (N).Nkind = N_Or_Else);
+ Set_Node3_With_Parent (N, Val);
+ end Set_Right_Opnd;
+
+ procedure Set_Rounded_Result
+ (N : Node_Id; Val : Boolean := True) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Op_Divide
+ or else NT (N).Nkind = N_Op_Multiply
+ or else NT (N).Nkind = N_Type_Conversion);
+ Set_Flag18 (N, Val);
+ end Set_Rounded_Result;
+
+ procedure Set_Scope
+ (N : Node_Id; Val : Node_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Defining_Character_Literal
+ or else NT (N).Nkind = N_Defining_Identifier
+ or else NT (N).Nkind = N_Defining_Operator_Symbol);
+ Set_Node3 (N, Val); -- semantic field, no parent set
+ end Set_Scope;
+
+ procedure Set_Select_Alternatives
+ (N : Node_Id; Val : List_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Selective_Accept);
+ Set_List1_With_Parent (N, Val);
+ end Set_Select_Alternatives;
+
+ procedure Set_Selector_Name
+ (N : Node_Id; Val : Node_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Expanded_Name
+ or else NT (N).Nkind = N_Generic_Association
+ or else NT (N).Nkind = N_Parameter_Association
+ or else NT (N).Nkind = N_Selected_Component);
+ Set_Node2_With_Parent (N, Val);
+ end Set_Selector_Name;
+
+ procedure Set_Selector_Names
+ (N : Node_Id; Val : List_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Discriminant_Association);
+ Set_List1_With_Parent (N, Val);
+ end Set_Selector_Names;
+
+ procedure Set_Shift_Count_OK
+ (N : Node_Id; Val : Boolean := True) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Op_Rotate_Left
+ or else NT (N).Nkind = N_Op_Rotate_Right
+ or else NT (N).Nkind = N_Op_Shift_Left
+ or else NT (N).Nkind = N_Op_Shift_Right
+ or else NT (N).Nkind = N_Op_Shift_Right_Arithmetic);
+ Set_Flag4 (N, Val);
+ end Set_Shift_Count_OK;
+
+ procedure Set_Source_Type
+ (N : Node_Id; Val : Entity_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Validate_Unchecked_Conversion);
+ Set_Node1 (N, Val); -- semantic field, no parent set
+ end Set_Source_Type;
+
+ procedure Set_Specification
+ (N : Node_Id; Val : Node_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Abstract_Subprogram_Declaration
+ or else NT (N).Nkind = N_Formal_Subprogram_Declaration
+ or else NT (N).Nkind = N_Generic_Package_Declaration
+ or else NT (N).Nkind = N_Generic_Subprogram_Declaration
+ or else NT (N).Nkind = N_Package_Declaration
+ or else NT (N).Nkind = N_Subprogram_Body
+ or else NT (N).Nkind = N_Subprogram_Body_Stub
+ or else NT (N).Nkind = N_Subprogram_Declaration
+ or else NT (N).Nkind = N_Subprogram_Renaming_Declaration);
+ Set_Node1_With_Parent (N, Val);
+ end Set_Specification;
+
+ procedure Set_Statements
+ (N : Node_Id; Val : List_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Abortable_Part
+ or else NT (N).Nkind = N_Accept_Alternative
+ or else NT (N).Nkind = N_Case_Statement_Alternative
+ or else NT (N).Nkind = N_Delay_Alternative
+ or else NT (N).Nkind = N_Entry_Call_Alternative
+ or else NT (N).Nkind = N_Exception_Handler
+ or else NT (N).Nkind = N_Handled_Sequence_Of_Statements
+ or else NT (N).Nkind = N_Loop_Statement
+ or else NT (N).Nkind = N_Triggering_Alternative);
+ Set_List3_With_Parent (N, Val);
+ end Set_Statements;
+
+ procedure Set_Static_Processing_OK
+ (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Aggregate);
+ Set_Flag4 (N, Val);
+ end Set_Static_Processing_OK;
+
+ procedure Set_Storage_Pool
+ (N : Node_Id; Val : Node_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Allocator
+ or else NT (N).Nkind = N_Free_Statement
+ or else NT (N).Nkind = N_Return_Statement);
+ Set_Node1 (N, Val); -- semantic field, no parent set
+ end Set_Storage_Pool;
+
+ procedure Set_Strval
+ (N : Node_Id; Val : String_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Operator_Symbol
+ or else NT (N).Nkind = N_String_Literal);
+ Set_Str3 (N, Val);
+ end Set_Strval;
+
+ procedure Set_Subtype_Indication
+ (N : Node_Id; Val : Node_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Access_To_Object_Definition
+ or else NT (N).Nkind = N_Component_Declaration
+ or else NT (N).Nkind = N_Constrained_Array_Definition
+ or else NT (N).Nkind = N_Derived_Type_Definition
+ or else NT (N).Nkind = N_Private_Extension_Declaration
+ or else NT (N).Nkind = N_Subtype_Declaration
+ or else NT (N).Nkind = N_Unconstrained_Array_Definition);
+ Set_Node5_With_Parent (N, Val);
+ end Set_Subtype_Indication;
+
+ procedure Set_Subtype_Mark
+ (N : Node_Id; Val : Node_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Access_Definition
+ or else NT (N).Nkind = N_Access_Function_Definition
+ or else NT (N).Nkind = N_Formal_Derived_Type_Definition
+ or else NT (N).Nkind = N_Formal_Object_Declaration
+ or else NT (N).Nkind = N_Function_Specification
+ or else NT (N).Nkind = N_Object_Renaming_Declaration
+ or else NT (N).Nkind = N_Qualified_Expression
+ or else NT (N).Nkind = N_Subtype_Indication
+ or else NT (N).Nkind = N_Type_Conversion
+ or else NT (N).Nkind = N_Unchecked_Type_Conversion);
+ Set_Node4_With_Parent (N, Val);
+ end Set_Subtype_Mark;
+
+ procedure Set_Subtype_Marks
+ (N : Node_Id; Val : List_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Unconstrained_Array_Definition
+ or else NT (N).Nkind = N_Use_Type_Clause);
+ Set_List2_With_Parent (N, Val);
+ end Set_Subtype_Marks;
+
+ procedure Set_Tagged_Present
+ (N : Node_Id; Val : Boolean := True) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Formal_Private_Type_Definition
+ or else NT (N).Nkind = N_Private_Type_Declaration
+ or else NT (N).Nkind = N_Record_Definition
+ or else NT (N).Nkind = N_With_Type_Clause);
+ Set_Flag15 (N, Val);
+ end Set_Tagged_Present;
+
+ procedure Set_Target_Type
+ (N : Node_Id; Val : Entity_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Validate_Unchecked_Conversion);
+ Set_Node2 (N, Val); -- semantic field, no parent set
+ end Set_Target_Type;
+
+ procedure Set_Task_Body_Procedure
+ (N : Node_Id; Val : Entity_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Task_Type_Declaration);
+ Set_Node2 (N, Val); -- semantic field, no parent set
+ end Set_Task_Body_Procedure;
+
+ procedure Set_Task_Definition
+ (N : Node_Id; Val : Node_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Single_Task_Declaration
+ or else NT (N).Nkind = N_Task_Type_Declaration);
+ Set_Node3_With_Parent (N, Val);
+ end Set_Task_Definition;
+
+ procedure Set_Then_Actions
+ (N : Node_Id; Val : List_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Conditional_Expression);
+ Set_List2 (N, Val); -- semantic field, no parent set
+ end Set_Then_Actions;
+
+ procedure Set_Then_Statements
+ (N : Node_Id; Val : List_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Elsif_Part
+ or else NT (N).Nkind = N_If_Statement);
+ Set_List2_With_Parent (N, Val);
+ end Set_Then_Statements;
+
+ procedure Set_Treat_Fixed_As_Integer
+ (N : Node_Id; Val : Boolean := True) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Op_Divide
+ or else NT (N).Nkind = N_Op_Mod
+ or else NT (N).Nkind = N_Op_Multiply
+ or else NT (N).Nkind = N_Op_Rem);
+ Set_Flag14 (N, Val);
+ end Set_Treat_Fixed_As_Integer;
+
+ procedure Set_Triggering_Alternative
+ (N : Node_Id; Val : Node_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Asynchronous_Select);
+ Set_Node1_With_Parent (N, Val);
+ end Set_Triggering_Alternative;
+
+ procedure Set_Triggering_Statement
+ (N : Node_Id; Val : Node_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Triggering_Alternative);
+ Set_Node1_With_Parent (N, Val);
+ end Set_Triggering_Statement;
+
+ procedure Set_TSS_Elist
+ (N : Node_Id; Val : Elist_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Freeze_Entity);
+ Set_Elist3 (N, Val); -- semantic field, no parent set
+ end Set_TSS_Elist;
+
+ procedure Set_Type_Definition
+ (N : Node_Id; Val : Node_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Full_Type_Declaration);
+ Set_Node3_With_Parent (N, Val);
+ end Set_Type_Definition;
+
+ procedure Set_Unit
+ (N : Node_Id; Val : Node_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Compilation_Unit);
+ Set_Node2_With_Parent (N, Val);
+ end Set_Unit;
+
+ procedure Set_Unknown_Discriminants_Present
+ (N : Node_Id; Val : Boolean := True) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Formal_Type_Declaration
+ or else NT (N).Nkind = N_Incomplete_Type_Declaration
+ or else NT (N).Nkind = N_Private_Extension_Declaration
+ or else NT (N).Nkind = N_Private_Type_Declaration);
+ Set_Flag13 (N, Val);
+ end Set_Unknown_Discriminants_Present;
+
+ procedure Set_Unreferenced_In_Spec
+ (N : Node_Id; Val : Boolean := True) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_With_Clause);
+ Set_Flag7 (N, Val);
+ end Set_Unreferenced_In_Spec;
+
+ procedure Set_Variant_Part
+ (N : Node_Id; Val : Node_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Component_List);
+ Set_Node4_With_Parent (N, Val);
+ end Set_Variant_Part;
+
+ procedure Set_Variants
+ (N : Node_Id; Val : List_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Variant_Part);
+ Set_List1_With_Parent (N, Val);
+ end Set_Variants;
+
+ procedure Set_Visible_Declarations
+ (N : Node_Id; Val : List_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Package_Specification
+ or else NT (N).Nkind = N_Protected_Definition
+ or else NT (N).Nkind = N_Task_Definition);
+ Set_List2_With_Parent (N, Val);
+ end Set_Visible_Declarations;
+
+ procedure Set_Was_Originally_Stub
+ (N : Node_Id; Val : Boolean := True) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Package_Body
+ or else NT (N).Nkind = N_Protected_Body
+ or else NT (N).Nkind = N_Subprogram_Body
+ or else NT (N).Nkind = N_Task_Body);
+ Set_Flag13 (N, Val);
+ end Set_Was_Originally_Stub;
+
+ procedure Set_Zero_Cost_Handling
+ (N : Node_Id; Val : Boolean := True) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Exception_Handler
+ or else NT (N).Nkind = N_Handled_Sequence_Of_Statements);
+ Set_Flag5 (N, Val);
+ end Set_Zero_Cost_Handling;
+
+ -------------------------
+ -- Iterator Procedures --
+ -------------------------
+
+ procedure Next_Entity (N : in out Node_Id) is
+ begin
+ N := Next_Entity (N);
+ end Next_Entity;
+
+ procedure Next_Named_Actual (N : in out Node_Id) is
+ begin
+ N := Next_Named_Actual (N);
+ end Next_Named_Actual;
+
+ procedure Next_Rep_Item (N : in out Node_Id) is
+ begin
+ N := Next_Rep_Item (N);
+ end Next_Rep_Item;
+
+ procedure Next_Use_Clause (N : in out Node_Id) is
+ begin
+ N := Next_Use_Clause (N);
+ end Next_Use_Clause;
+
+ ------------------
+ -- End_Location --
+ ------------------
+
+ function End_Location (N : Node_Id) return Source_Ptr is
+ L : constant Uint := End_Span (N);
+
+ begin
+ if L = No_Uint then
+ return No_Location;
+ else
+ return Source_Ptr (Int (Sloc (N)) + UI_To_Int (L));
+ end if;
+ end End_Location;
+
+ ----------------------
+ -- Set_End_Location --
+ ----------------------
+
+ procedure Set_End_Location (N : Node_Id; S : Source_Ptr) is
+ begin
+ Set_End_Span (N,
+ UI_From_Int (Int (S) - Int (Sloc (N))));
+ end Set_End_Location;
+
+end Sinfo;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S I N F O --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.430 $
+-- --
+-- 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 other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception 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 package defines the structure of the abstract syntax tree. The Tree
+-- package provides a basic tree structure. Sinfo describes how this
+-- structure is used to represent the syntax of an Ada program.
+
+-- Note: the grammar used here is taken from Version 5.95 of the RM, dated
+-- November 1994. The grammar in the RM is followed very closely in the tree
+-- design, and is repeated as part of this source file.
+
+-- The tree contains not only the full syntactic representation of the
+-- program, but also the results of semantic analysis. In particular, the
+-- nodes for defining identifiers, defining character literals and defining
+-- operator symbols, collectively referred to as entities, represent what
+-- would normally be regarded as the symbol table information. In addition
+-- a number of the tree nodes contain semantic information.
+
+-- WARNING: There is a C version of this package. Any changes to this
+-- source file must be properly reflected in this C header file sinfo.h
+-- which is created automatically from sinfo.ads using xsinfo.spt.
+
+with Types; use Types;
+with Uintp; use Uintp;
+with Urealp; use Urealp;
+
+package Sinfo is
+
+ ---------------------------------
+ -- Making Changes to This File --
+ ---------------------------------
+
+ -- If changes are made to this file, a number of related steps must be
+ -- carried out to ensure consistency. First, if a field access function
+ -- is added, it appears in seven places:
+
+ -- The documentation associated with the node
+ -- The spec of the access function in sinfo.ads
+ -- The body of the access function in sinfo.adb
+ -- The pragma Inline at the end of sinfo.ads for the access function
+ -- The spec of the set procedure in sinfo.ads
+ -- The body of the set procedure in sinfo.adb
+ -- The pragma Inline at the end of sinfo.ads for the set procedure
+
+ -- The field chosen must be consistent in all places, and, for a node
+ -- that is a subexpression, must not overlap any of the standard
+ -- expression fields. In the body, the calls to the Dcheck_Node debug
+ -- procedure will need cross-references adding in alphabetical order.
+
+ -- In addition, if any of the standard expression fields is changed, then
+ -- the utiliy program which creates the Treeprs spec (in file treeprs.ads)
+ -- must be updated appropriately, since it special cases expression fields.
+
+ -- If a new tree node is added, then the following changes are made
+
+ -- Add it to the documentation in the appropriate place
+ -- Add its fields to this documentation section
+ -- Define it in the appropriate classification in Node_Kind
+ -- In the body (sinfo), add entries to the Dcheck calls for all
+ -- its fields (except standard expression fields) to include
+ -- the new node in the debug cross-reference list
+ -- Add an appropriate section to the case statement in sprint.adb
+ -- Add an appropriate section to the case statement in sem.adb
+ -- Add an appropraite section to the case statement in exp_util.adb
+ -- (Insert_Actions procedure)
+ -- For a subexpression, add an appropriate sections to the case
+ -- statement in sem_eval.adb
+ -- For a subexpression, add an appropriate sections to the case
+ -- statement in sem_res.adb
+
+ -- Finally, four utility programs must be run:
+
+ -- Run CSinfo to check that you have made the changes consistently.
+ -- It checks most of the rules given above, with clear error messages.
+ -- This utility reads sinfo.ads and sinfo.adb and generates a report
+ -- to standard output.
+
+ -- Run XSinfo to create a-sinfo.h, the corresponding C header. This
+ -- utility reads sinfo.ads and generates a-sinfo.h. Note that it
+ -- does not need to read sinfo.adb, since the contents of the body
+ -- are algorithmically determinable from the spec.
+
+ -- Run XTreeprs to create treeprs.ads, an updated version of
+ -- the module that is used to drive the tree print routine. This
+ -- utility reads (but does not modify) treeprs.adt, the template
+ -- that provides the basic structure of the file, and then fills
+ -- in the data from the comments in sinfo.ads.
+
+ -- Run XNmake to create nmake.ads and nmake.adb, the package body
+ -- and spec of the Nmake package which contains functions for
+ -- constructing nodes.
+
+ -- Note: sometime we could write a utility that actually generated the
+ -- body of sinfo from the spec instead of simply checking it, since, as
+ -- noted above, the contents of the body can be determined from the spec.
+
+ --------------------------------
+ -- Implicit Nodes in the Tree --
+ --------------------------------
+
+ -- Generally the structure of the tree very closely follows the grammar
+ -- as defined in the RM. However, certain nodes are omitted to save
+ -- space and simplify semantic processing. Two general classes of such
+ -- omitted nodes are as follows:
+
+ -- If the only possibilities for a non-terminal are one or more other
+ -- non terminals (i.e. the rule is a "skinny" rule), then usually the
+ -- corresponding node is omitted from the tree, and the target construct
+ -- appears directly. For example, a real type definition is either a
+ -- floating point definition or a fixed point definition. No explicit
+ -- node appears for real type definition. Instead either the floating
+ -- point definition or fixed point definition appears directly.
+
+ -- If a non-terminal corresponds to a list of some other non-terminal
+ -- (possibly with separating punctuation), then usually it is omitted
+ -- from the tree, and a list of components appears instead. For
+ -- example, sequence of statements does not appear explicitly in the
+ -- tree. Instead a list of statements appears directly.
+
+ -- Some additional cases of omitted nodes occur and are documented
+ -- individually. In particular, many nodes are omitted in the tree
+ -- generated for an expression.
+
+ -------------------------------------------
+ -- Handling of Defining Identifier Lists --
+ -------------------------------------------
+
+ -- In several declarative forms in the syntax, lists of defining
+ -- identifiers appear (object declarations, component declarations,
+ -- number declarations etc.)
+
+ -- The semantics of such statements are equivalent to a series of
+ -- identical declarations of single defining identifiers (except that
+ -- conformance checks require the same grouping of identifiers in the
+ -- parameter case).
+
+ -- To simplify semantic processing, the parser breaks down such multiple
+ -- declaration cases into sequences of single declarations, duplicating
+ -- type and initialization information as required. The flags More_Ids
+ -- and Prev_Ids are used to record the original form of the source in
+ -- the case where the original source used a list of names, More_Ids
+ -- being set on all but the last name and Prev_Ids being set on all
+ -- but the first name. These flags are used to reconstruct the original
+ -- source (e.g. in the Sprint package), and also are included in the
+ -- conformance checks, but otherwise have no semantic significance.
+
+ -- Note: the reason that we use More_Ids and Prev_Ids rather than
+ -- First_Name and Last_Name flags is so that the flags are off in the
+ -- normal one identifier case, which minimizes tree print output.
+
+ -----------------------
+ -- Use of Node Lists --
+ -----------------------
+
+ -- With a few exceptions, if a construction of the form {non-terminal}
+ -- appears in the tree, lists are used in the corresponding tree node
+ -- (see package Nlists for handling of node lists). In this case a field
+ -- of the parent node points to a list of nodes for the non-terminal. The
+ -- field name for such fields has a plural name which always ends in "s".
+ -- For example, a case statement has a field Alternatives pointing to a
+ -- list of case statement alternative nodes.
+
+ -- Only fields pointing to lists have names ending in "s", so generally
+ -- the structure is strongly typed, fields not ending in s point to
+ -- single nodes, and fields ending in s point to lists.
+
+ -- The following example shows how a traversal of a list is written. We
+ -- suppose here that Stmt points to a N_Case_Statement node which has
+ -- a list field called Alternatives:
+
+ -- Alt := First (Alternatives (Stmt));
+ -- while Present (Alt) loop
+ -- ..
+ -- -- processing for case statement alternative Alt
+ -- ..
+ -- Alt := Next (Alt);
+ -- end loop;
+
+ -- The Present function tests for Empty, which in this case signals the
+ -- end of the list. First returns Empty immediately if the list is empty.
+ -- Present is defined in Atree, First and Next are defined in Nlists.
+
+ -- The exceptions to this rule occur with {DEFINING_IDENTIFIERS} in all
+ -- contexts, which is handled as described in the previous section, and
+ -- with {,library_unit_NAME} in the N_With_Clause mode, which is handled
+ -- using the First_Name and Last_Name flags, as further detailed in the
+ -- description of the N_With_Clause node.
+
+ -------------
+ -- Pragmas --
+ -------------
+
+ -- Pragmas can appear in many different context, but are not included
+ -- in the grammar. Still they must appear in the tree, so they can be
+ -- properly processed.
+
+ -- Two approaches are used. In some cases, an extra field is defined
+ -- in an appropriate node that contains a list of pragmas appearing
+ -- in the expected context. For example pragmas can appear before an
+ -- Accept_Alternative in a Selective_Accept_Statement, and these pragmas
+ -- appear in the Pragmas_Before field of the N_Accept_Alternative node.
+
+ -- The other approach is to simply allow pragmas to appear in syntactic
+ -- lists where the grammar (of course) does not include the possibility.
+ -- For example, the Variants field of an N_Variant_Part node points to
+ -- a list that can contain both N_Pragma and N_Variant nodes.
+
+ -- To make processing easier in the latter case, the Nlists package
+ -- provides a set of routines (First_Non_Pragma, Last_Non_Pragma,
+ -- Next_Non_Pragma, Prev_Non_Pragma) that allow such lists to be
+ -- handled ignoring all pragmas.
+
+ -- In the case of the variants list, we can either write:
+
+ -- Variant := First (Variants (N));
+ -- while Present (Variant) loop
+ -- ...
+ -- Alt := Next (Alt);
+ -- end loop;
+
+ -- or
+
+ -- Variant := First_Non_Pragma (Variants (N));
+ -- while Present (Variant) loop
+ -- ...
+ -- Alt := Next_Non_Pragma (Alt);
+ -- end loop;
+
+ -- In the first form of the loop, Variant can either be an N_Pragma or
+ -- an N_Variant node. In the second form, Variant can only be N_Variant
+ -- since all pragmas are skipped.
+
+ ---------------------
+ -- Optional Fields --
+ ---------------------
+
+ -- Fields which correspond to a section of the syntax enclosed in square
+ -- brackets are generally omitted (and the corresponding field set to
+ -- Empty for a node, or No_List for a list). The documentation of such
+ -- fields notes these cases. One exception to this rule occurs in the
+ -- case of possibly empty statement sequences (such as the sequence of
+ -- statements in an entry call alternative). Such cases appear in the
+ -- syntax rules as [SEQUENCE_OF_STATEMENTS] and the fields corresponding
+ -- to such optional statement sequences always contain an empty list (not
+ -- No_List) if no statements are present.
+
+ -- Note: the utility program that constructs the body and spec of the
+ -- Nmake package relies on the format of the comments to determine if
+ -- a field should have a default value in the corresponding make routine.
+ -- The rule is that if the first line of the description of the field
+ -- contains the string "(set to xxx if", then a default value of xxx is
+ -- provided for this field in the corresponding Make_yyy routine.
+
+ -----------------------------------
+ -- Note on Body/Spec Terminology --
+ -----------------------------------
+
+ -- In informal discussions about Ada, it is customary to refer to package
+ -- and subprogram specs and bodies. However, this is not technically
+ -- correct, what is normally referred to as a spec or specification is in
+ -- fact a package declaration or subprogram declaration. We are careful
+ -- in GNAT to use the correct terminology and in particular, the full
+ -- word specification is never used as an incorrect substitute for
+ -- declaration. The structure and terminology used in the tree also
+ -- reflects the grammar and thus uses declaration and specification in
+ -- the technically correct manner.
+
+ -- However, there are contexts in which the informal terminology is
+ -- useful. We have the word "body" to refer to the Interp_Etype declared by
+ -- the declaration of a unit body, and in some contexts we need a
+ -- similar term to refer to the entity declared by the package or
+ -- subprogram declaration, and simply using declaration can be confusing
+ -- since the body also has a declaration.
+
+ -- An example of such a context is the link between the package body
+ -- and its declaration. With_Declaration is confusing, since
+ -- the package body itself is a declaration.
+
+ -- To deal with this problem, we reserve the informal term Spec, i.e.
+ -- the popular abbreviation used in this context, to refer to the entity
+ -- declared by the package or subprogram declaration. So in the above
+ -- example case, the field in the body is called With_Spec.
+
+ -- Another important context for the use of the word Spec is in error
+ -- messages, where a hyper-correct use of declaration would be confusing
+ -- to a typical Ada programmer, and even for an expert programmer can
+ -- cause confusion since the body has a declaration as well.
+
+ -- So, to summarize:
+
+ -- Declaration always refers to the syntactic entity that is called
+ -- a declaration. In particular, subprogram declaration
+ -- and package declaration are used to describe the
+ -- syntactic entity that includes the semicolon.
+
+ -- Specification always refers to the syntactic entity that is called
+ -- a specification. In particular, the terms procedure
+ -- specification, function specification, package
+ -- specification, subprogram specification always refer
+ -- to the syntactic entity that has no semicolon.
+
+ -- Spec is an informal term, used to refer to the entity
+ -- that is declared by a task declaration, protected
+ -- declaration, generic declaration, subprogram
+ -- declaration or package declaration.
+
+ -- This convention is followed throughout the GNAT documentation
+ -- both internal and external, and in all error message text.
+
+ ------------------------
+ -- Internal Use Nodes --
+ ------------------------
+
+ -- These are Node_Kind settings used in the internal implementation
+ -- which are not logically part of the specification.
+
+ -- N_Unused_At_Start
+ -- Completely unused entry at the start of the enumeration type. This
+ -- is inserted so that no legitimate value is zero, which helps to get
+ -- better debugging behavior, since zero is a likely uninitialized value).
+
+ -- N_Unused_At_End
+ -- Completely unused entry at the end of the enumeration type. This is
+ -- handy so that arrays with Node_Kind as the index type have an extra
+ -- entry at the end (see for example the use of the Pchar_Pos_Array in
+ -- Treepr, where the extra entry provides the limit value when dealing
+ -- with the last used entry in the array).
+
+ -----------------------------------------
+ -- Note on the settings of Sloc fields --
+ -----------------------------------------
+
+ -- The Sloc field of nodes that come from the source is set by the
+ -- parser. For internal nodes, and nodes generated during expansion
+ -- the Sloc is usually set in the call to the constructor for the node.
+ -- In general the Sloc value chosen for an internal node is the Sloc of
+ -- the source node whose processing is responsible for the expansion. For
+ -- example, the Sloc of an inherited primitive operation is the Sloc of
+ -- the corresponding derived type declaration.
+
+ -- For the nodes of a generic instantiation, the Sloc value is encoded
+ -- to represent both the original Sloc in the generic unit, and the Sloc
+ -- of the instantiation itself. See Sinput.ads for details.
+
+ -- Subprogram instances create two callable entities: one is the visible
+ -- subprogram instance, and the other is an anonymous subprogram nested
+ -- within a wrapper package that contains the renamings for the actuals.
+ -- Both of these entities have the Sloc of the defining entity in the
+ -- instantiation node. This simplifies some ASIS queries.
+
+ -----------------------
+ -- Field Definitions --
+ -----------------------
+
+ -- In the following node definitions, all fields, both syntactic and
+ -- semantic, are documented. The one exception is in the case of entities
+ -- (defining indentifiers, character literals and operator symbols),
+ -- where the usage of the fields depends on the entity kind. Entity
+ -- fields are fully documented in the separate package Einfo.
+
+ -- In the node definitions, three common sets of fields are abbreviated
+ -- to save both space in the documentation, and also space in the string
+ -- (defined in Tree_Print_Strings) used to print trees. The following
+ -- abbreviations are used:
+
+ -- Note: the utility program that creates the Treeprs spec (in the file
+ -- treeprs.ads) knows about the special fields here, so it must be
+ -- modified if any change is made to these fields.
+
+ -- "plus fields for binary operator"
+ -- Chars (Name1) Name_Id for the operator
+ -- Left_Opnd (Node2) left operand expression
+ -- Right_Opnd (Node3) right operand expression
+ -- Entity (Node4-Sem) defining entity for operator
+ -- Do_Overflow_Check (Flag17-Sem) set if overflow check needed
+ -- Has_Private_View (Flag11-Sem) set in generic units.
+
+ -- "plus fields for unary operator"
+ -- Chars (Name1) Name_Id for the operator
+ -- Right_Opnd (Node3) right operand expression
+ -- Entity (Node4-Sem) defining entity for operator
+ -- Do_Overflow_Check (Flag17-Sem) set if overflow check needed
+ -- Has_Private_View (Flag11-Sem) set in generic units.
+
+ -- "plus fields for expression"
+ -- Paren_Count number of parentheses levels
+ -- Etype (Node5-Sem) type of the expression
+ -- Is_Overloaded (Flag5-Sem) >1 type interpretation exists
+ -- Is_Static_Expression (Flag6-Sem) set for static expression
+ -- Raises_Constraint_Error (Flag7-Sem) evaluation raises CE
+ -- Must_Not_Freeze (Flag8-Sem) set if must not freeze
+ -- Do_Range_Check (Flag9-Sem) set if a range check needed
+ -- Assignment_OK (Flag15-Sem) set if modification is OK
+ -- Is_Controlling_Actual (Flag16-Sem) set for controlling argument
+
+ -- Note: see under (EXPRESSION) for further details on the use of
+ -- the Paren_Count field to record the number of parentheses levels.
+
+ -- Node_Kind is the type used in the Nkind field to indicate the node
+ -- kind. The actual definition of this type is given later (the reason
+ -- for this is that we want the descriptions ordered by logical chapter
+ -- in the RM, but the type definition is reordered to facilitate the
+ -- definition of some subtype ranges. The individual descriptions of
+ -- the nodes show how the various fields are used in each node kind,
+ -- as well as providing logical names for the fields. Functions and
+ -- procedures are provided for accessing and setting these fields
+ -- using these logical names.
+
+ -----------------------
+ -- Gigi Restrictions --
+ -----------------------
+
+ -- The tree passed to Gigi is more restricted than the general tree form.
+ -- For example, as a result of expansion, most of the tasking nodes can
+ -- never appear. For each node to which either a complete or partial
+ -- restriction applies, a note entitled "Gigi restriction" appears which
+ -- documents the restriction.
+
+ -- Note that most of these restrictions apply only to trees generated when
+ -- code is being generated, since they involved expander actions that
+ -- destroy the tree.
+
+ ------------------------
+ -- Common Flag Fields --
+ ------------------------
+
+ -- The following flag fields appear in all nodes
+
+ -- Analyzed
+ -- This flag is used to indicate that a node (and all its children
+ -- have been analyzed. It is used to avoid reanalysis of a node that
+ -- has already been analyzed, both for efficiency and functional
+ -- correctness reasons.
+
+ -- Error_Posted
+ -- This flag is used to avoid multiple error messages being posted
+ -- on or referring to the same node. This flag is set if an error
+ -- message refers to a node or is posted on its source location,
+ -- and has the effect of inhibiting further messages involving
+ -- this same node.
+
+ -- Comes_From_Source
+ -- This flag is on for any nodes built by the scanner or parser from
+ -- the source program, and off for any nodes built by the analyzer or
+ -- expander. It indicates that a node comes from the original source.
+ -- This flag is defined in Atree.
+
+ -- Has_Dynamic_Length_Check and Has_Dynamic_Range_Check also appear on
+ -- all nodes. They are fully described in the next section.
+
+ ------------------------------------
+ -- Description of Semantic Fields --
+ ------------------------------------
+
+ -- The meaning of the syntactic fields is generally clear from their
+ -- names without any further description, since the names are chosen
+ -- to correspond very closely to the syntax in the reference manual.
+ -- This section describes the usage of the semantic fields, which are
+ -- used to contain additional information determined during semantic
+ -- analysis.
+
+ -- ABE_Is_Certain (Flag18-Sem)
+ -- This flag is set in an instantiation node or a call node is
+ -- determined to be sure to raise an ABE. This is used to trigger
+ -- special handling of such cases, particularly in the instantiation
+ -- case where we avoid instantiating the body if this flag is set.
+ -- This flag is also present in an N_Formal_Package_Declaration_Node
+ -- since formal package declarations are treated like instantiations,
+ -- but it is always set to False in this context.
+
+ -- Accept_Handler_Records (List5-Sem)
+ -- This field is present only in an N_Accept_Alternative node. It is
+ -- used to temporarily hold the exception handler records from an
+ -- accept statement in a selective accept. These exception handlers
+ -- will eventually be placed in the Handler_Records list of the
+ -- procedure built for this accept (see Expand_N_Selective_Accept
+ -- procedure in Exp_Ch9 for further details).
+
+ -- Access_Types_To_Process (Elist2-Sem)
+ -- Present in N_Freeze_Entity nodes for Incomplete or private types.
+ -- Contains the list of access types which may require specific
+ -- treatment when the nature of the type completion is completely
+ -- known. An example of such treatement is the generation of the
+ -- associated_final_chain.
+
+ -- Actions (List1-Sem)
+ -- This field contains a sequence of actions that are associated
+ -- with the node holding the field. See the individual node types
+ -- for details of how this field is used, as well as the description
+ -- of the specific use for a particular node type.
+
+ -- Activation_Chain_Entity (Node3-Sem)
+ -- This is used in tree nodes representing task activators (blocks,
+ -- subprogram bodies, package declarations, and task bodies). It is
+ -- initially Empty, and then gets set to point to the entity for the
+ -- declared Activation_Chain variable when the first task is declared.
+ -- When tasks are declared in the corresponding declarative region
+ -- this entity is located by name (its name is always _Chain) and
+ -- the declared tasks are added to the chain.
+
+ -- Acts_As_Spec (Flag4-Sem)
+ -- A flag set in the N_Subprogram_Body node for a subprogram body
+ -- which is acting as its own spec. This flag also appears in the
+ -- compilation unit node at the library level for such a subprogram
+ -- (see further description in spec of Lib package).
+
+ -- Aggregate_Bounds (Node3-Sem)
+ -- Present in array N_Aggregate nodes. If the aggregate contains
+ -- component associations this field points to an N_Range node whose
+ -- bounds give the lowest and highest discrete choice values. If the
+ -- named aggregate contains a dynamic or null choice this field is
+ -- empty. If the aggregate contains positional elements this field
+ -- points to an N_Integer_Literal node giving the number of positional
+ -- elements. Note that if the aggregate contains positional elements
+ -- and an other choice the N_Integer_Literal only accounts for the
+ -- number of positional elements.
+
+ -- All_Others (Flag11-Sem)
+ -- Present in an N_Others_Choice node. This flag is set in the case
+ -- of an others exception where all exceptions, even those that are
+ -- not normally handled (in particular the tasking abort signal) by
+ -- others. This is used for translation of the at end handler into
+ -- a normal exception handler.
+
+ -- Assignment_OK (Flag15-Sem)
+ -- This flag is set in a subexpression node for an object, indicating
+ -- that the associated object can be modified, even if this would not
+ -- normally be permissible (either by direct assignment, or by being
+ -- passed as an out or in-out parameter). This is used by the expander
+ -- for a number of purposes, including initialzation of constants and
+ -- limited type objects (such as tasks), setting discriminant fields,
+ -- setting tag values, etc. N_Object_Declaration nodes also have this
+ -- flag defined. Here it is used to indicate that an initialization
+ -- expression is valid, even where it would normally not be allowed
+ -- (e.g. where the type involved is limited).
+
+ -- At_End_Proc (Node1)
+ -- This field is present in an N_Handled_Sequence_Of_Statements node.
+ -- It contains an identifier reference for the cleanup procedure to
+ -- be called. See description of this node for further details.
+
+ -- Backwards_OK (Flag6-Sem)
+ -- A flag present in the N_Assignment_Statement node. It is used only
+ -- if the type being assigned is an array type, and is set if analysis
+ -- determines that it is definitely safe to do the copy backwards, i.e.
+ -- starting at the highest addressed element. Note that if neither of
+ -- the flags Forwards_OK or Backwards_OK is set, it means that the
+ -- front end could not determine that either direction is definitely
+ -- safe, and a runtime check is required.
+
+ -- Body_To_Inline (Node3-Sem)
+ -- present in subprogram declarations. Denotes analyzed but unexpanded
+ -- body of subprogram, to be used when inlining calls. Present when the
+ -- subprogram has an Inline pragma and inlining is enabled. If the
+ -- declaration is completed by a renaming_as_body, and the renamed en-
+ -- tity is a subprogram, the Body_To_Inline is the name of that entity,
+ -- which is used directly in later calls to the original subprogram.
+
+ -- Body_Required (Flag13-Sem)
+ -- A flag that appears in the N_Compilation_Unit node indicating that
+ -- the corresponding unit requires a body. For the package case, this
+ -- indicates that a completion is required. In Ada 95, if the flag
+ -- is not set for the package case, then a body may not be present.
+ -- In Ada 83, if the flag is not set for the package case, then a
+ -- body is optional. For a subprogram declaration, the flag is set
+ -- except in the case where a pragma Import or Interface applies,
+ -- in which case no body is permitted (in Ada 83 or Ada 95).
+
+ -- By_Ref (Flag5-Sem)
+ -- A flag present in the N_Return_Statement_Node. It is set when the
+ -- returned expression is already allocated on the secondary stack
+ -- and thus the result is passed by reference rather than copied
+ -- another time.
+
+ -- Compile_Time_Known_Aggregate (Flag18-Sem)
+ -- Present in N_Aggregate nodes. Set for aggregates which can be
+ -- fully evaluated at compile time without raising constraint error.
+ -- Such aggregates can be passed as is to Gigi without any expansion.
+ -- See Sem_Aggr for the specific conditions under which an aggregate
+ -- has this flag set. See also the flag Static_Processing_OK.
+
+ -- Condition_Actions (List3-Sem)
+ -- This field appears in else-if nodes and in the iteration scheme
+ -- node for while loops. This field is only used during semantic
+ -- processing to temporarily hold actions inserted into the tree.
+ -- In the tree passed to gigi, the condition actions field is always
+ -- set to No_List. For details on how this field is used, see the
+ -- routine Insert_Actions in package Exp_Util, and also the expansion
+ -- routines for the relevant nodes.
+
+ -- Controlling_Argument (Node1-Sem)
+ -- This field is set in procedure and function call nodes if the call
+ -- is a dispatching call (it is Empty for a non-dispatching call).
+ -- It indicates the source of the controlling tag for the call. For
+ -- Procedure calls, the Controlling_Argument is one of the actuals.
+ -- For a function that has a dispatching result, it is an entity in
+ -- the context of the call that can provide a tag, or else it is the
+ -- tag of the root type of the class.
+
+ -- Conversion_OK (Flag14-Sem)
+ -- A flag set on type conversion nodes to indicate that the conversion
+ -- is to be considered as being valid, even though it is the case that
+ -- the conversion is not valid Ada. This is used for the Enum_Rep,
+ -- Fixed_Value and Integer_Value attributes, for internal conversions
+ -- done for fixed-point operations, and for certain conversions for
+ -- calls to initialization procedures. If Conversion_OK is set, then
+ -- Etype must be set (the analyzer assumes that Etype has been set).
+ -- For the case of fixed-point operands, it also indicates that the
+ -- conversion is to be a direct conversion of the underlying integer
+ -- result, with no regard to the small operand.
+
+ -- Corresponding_Body (Node5-Sem)
+ -- This field is set in subprogram declarations, where it is needed
+ -- if a pragma Inline is present and the subprogram is called, in
+ -- generic declarations if the generic is instantiated, and also in
+ -- package declarations that contain inlined subprograms that are
+ -- called, or generic declarations that are instantiated. It points
+ -- to the defining entity for the corresponding body.
+
+ -- Corresponding_Generic_Association (Node5-Sem)
+ -- This field is defined for object declarations and object renaming
+ -- declarations. It is set for the declarations within an instance that
+ -- map generic formals to their actuals. If set, the field points to
+ -- a generic_association which is the original parent of the expression
+ -- or name appearing in the declaration. This simplifies ASIS queries.
+
+ -- Corresponding_Integer_Value (Uint4-Sem)
+ -- This field is set in real literals of fixed-point types (it is not
+ -- used for floating-point types). It contains the integer value used
+ -- to represent the fixed-point value. It is also set on the universal
+ -- real literals used to represent bounds of fixed-point base types
+ -- and their first named subtypes.
+
+ -- Corresponding_Spec (Node5-Sem)
+ -- This field is set in subprogram, package, task, and protected body
+ -- nodes, where it points to the defining entity in the corresponding
+ -- spec. The attribute is also set in N_With_Clause nodes, where
+ -- it points to the defining entity for the with'ed spec, and in
+ -- a subprogram renaming declaration when it is a Renaming_As_Body.
+ -- The field is Empty if there is no corresponding spec, as in the
+ -- case of a subprogram body that serves as its own spec.
+
+ -- Corresponding_Stub (Node3-Sem)
+ -- This field is present in an N_Subunit node. It holds the node in
+ -- the parent unit that is the stub declaration for the subunit. it is
+ -- set when analysis of the stub forces loading of the proper body. If
+ -- expansion of the proper body creates new declarative nodes, they are
+ -- inserted at the point of the corresponding_stub.
+
+ -- Dcheck_Function (Node5-Sem)
+ -- This field is present in an N_Variant node, It references the entity
+ -- for the discriminant checking function for the variant.
+
+ -- Debug_Statement (Node3)
+ -- This field is present in an N_Pragma node. It is used only for
+ -- a Debug pragma or pragma Assert with a second parameter. The
+ -- parameter is of the form of an expression, as required by the
+ -- pragma syntax, but is actually a procedure call. To simplify
+ -- semantic processing, the parser creates a copy of the argument
+ -- rearranged into a procedure call statement and places it in the
+ -- Debug_Statement field. Note that this field is considered a
+ -- syntactic field, since it is created by the parser.
+
+ -- Default_Expression (Node5-Sem)
+ -- This field is Empty if there is no default expression. If there
+ -- is a simple default expression (one with no side effects), then
+ -- this field simply contains a copy of the Expression field (both
+ -- point to the tree for the default expression). Default_Expression
+ -- is used for conformance checking.
+
+ -- Delay_Finalize_Attach (Flag14-Sem)
+ -- This flag is present in an N_Object_Declaration node. If it is set,
+ -- then in the case of a controlled type being declared and initialized,
+ -- the normal code for attaching the result to the appropriate local
+ -- finalization list is suppressed. This is used for functions that
+ -- return controlled types without using the secondary stack, where
+ -- it is the caller who must do the attachment.
+
+ -- Discr_Check_Funcs_Built (Flag11-Sem)
+ -- This flag is present in N_Full_Type_Declaration nodes. It is set when
+ -- discriminant checking functions are constructed. The purpose is to
+ -- avoid attempting to set these functions more than once.
+
+ -- Do_Access_Check (Flag11-Sem)
+ -- This flag is set on nodes with a Prefix field that can be an object
+ -- of an access type. If the flag is set, it indicates that a check is
+ -- required to ensure that the value of the referenced object is not
+ -- null. The actual check (which may be explicit or implicit by means
+ -- of some trap), is generated by Gigi (all the front end does is to
+ -- set this flag to request the trap).
+
+ -- Do_Accessibility_Check (Flag13-Sem)
+ -- This flag is set on N_Parameter_Specification nodes to indicate
+ -- that an accessibility check is required for the parameter. It is
+ -- not yet decided who takes care of this check (TBD ???).
+
+ -- Do_Discriminant_Check (Flag13-Sem)
+ -- This flag is set on N_Selected_Component nodes to indicate that a
+ -- discriminant check is required using the discriminant check routine
+ -- associated with the selector. The actual check is dealt with by
+ -- Gigi (all the front end does is to set the flag).
+
+ -- Do_Division_Check (Flag13-Sem)
+ -- This flag is set on a division operator (/ mod rem) to indicate
+ -- that a zero divide check is required. The actual check is dealt
+ -- with by the backend (all the front end does is to set the flag).
+
+ -- Do_Length_Check (Flag4-Sem)
+ -- This flag is set in an N_Assignment_Statement, N_Op_And, N_Op_Or,
+ -- N_Op_Xor, or N_Type_Conversion node to indicate that a length check
+ -- is required. It is not determined who deals with this flag (???).
+
+ -- Do_Overflow_Check (Flag17-Sem)
+ -- This flag is set on an operator where an overflow check is required
+ -- on the operation. The actual check is dealt with by the backend
+ -- (all the front end does is to set the flag). The other cases where
+ -- this flag is used is on a Type_Conversion node and for attribute
+ -- reference nodes. For a type conversion, it means that the conversion
+ -- is from one base type to another, and the value may not fit in the
+ -- target base type. See also the description of Do_Range_Check for
+ -- this case. The only attribute references which use this flag are
+ -- Pred and Succ, where it means that the result should be checked
+ -- for going outside the base range.
+
+ -- Do_Range_Check (Flag9-Sem)
+ -- This flag is set on an expression which appears in a context where
+ -- a range check is required. The target type is clear from the
+ -- context. The contexts in which this flag can appear are limited to
+ -- the following.
+
+ -- Right side of an assignment. In this case the target type is
+ -- taken from the left side of the assignment, which is referenced
+ -- by the Name of the N_Assignment_Statement node.
+
+ -- Subscript expressions in an indexed component. In this case the
+ -- target type is determined from the type of the array, which is
+ -- referenced by the Prefix of the N_Indexed_Component node.
+
+ -- Argument expression for a parameter, appearing either directly
+ -- in the Parameter_Associations list of a call or as the Expression
+ -- of an N_Parameter_Association node that appears in this list. In
+ -- either case, the check is against the type of the formal. Note
+ -- that the flag is relevant only in IN and IN OUT parameters, and
+ -- will be ignored for OUT parameters, where no check is required
+ -- in the call, and if a check is required on the return, it is
+ -- generated explicitly with a type conversion.
+
+ -- Initialization expression for the initial value in an object
+ -- declaration. In this case the Do_Range_Check flag is set on
+ -- the initialization expression, and the check is against the
+ -- range of the type of the object being declared.
+
+ -- The expression of a type conversion. In this case the range check
+ -- is against the target type of the conversion. See also the use of
+ -- Do_Overflow_Check on a type conversion. The distinction is that
+ -- the ovrflow check protects against a value that is outside the
+ -- range of the target base type, whereas a range check checks that
+ -- the resulting value (which is a value of the base type of the
+ -- target type), satisfies the range constraint of the target type.
+
+ -- Note: when a range check is required in contexts other than those
+ -- listed above (e.g. in a return statement), an additional type
+ -- conversion node is introduced to represent the required check.
+
+ -- Do_Storage_Check (Flag17-Sem)
+ -- This flag is set in an N_Allocator node to indicate that a storage
+ -- check is required for the allocation, or in an N_Subprogram_Body
+ -- node to indicate that a stack check is required in the subprogram
+ -- prolog. The N_Allocator case is handled by the routine that expands
+ -- the call to the runtime routine. The N_Subprogram_Body case is
+ -- handled by the backend, and all the semantics does is set the flag.
+
+ -- Do_Tag_Check (Flag13-Sem)
+ -- This flag is set on an N_Assignment_Statement, N_Function_Call,
+ -- N_Procedure_Call_Statement, N_Type_Conversion or N_Return_Statememt
+ -- node to indicate that the tag check can be suppressed. It is not
+ -- yet decided how this flag is used (TBD ???).
+
+ -- Elaborate_Present (Flag4-Sem)
+ -- This flag is set in the N_With_Clause node to indicate that a
+ -- pragma Elaborate pragma appears for the with'ed units.
+
+ -- Elaborate_All_Present (Flag15-Sem)
+ -- This flag is set in the N_With_Clause node to indicate that a
+ -- pragma Elaborate_All pragma appears for the with'ed units.
+
+ -- Elaboration_Boolean (Node2-Sem)
+ -- This field is present in function and procedure specification
+ -- nodes. If set, it points to the entity for a Boolean flag that
+ -- must be tested for certain calls to check for access before
+ -- elaboration. See body of Sem_Elab for further details. This
+ -- field is Empty if no elaboration boolean is required.
+
+ -- Else_Actions (List3-Sem)
+ -- This field is present in conditional expression nodes. During code
+ -- expansion we use the Insert_Actions procedure (in Exp_Util) to insert
+ -- actions at an appropriate place in the tree to get elaborated at the
+ -- right time. For conditional expressions, we have to be sure that the
+ -- actions for the Else branch are only elaborated if the condition is
+ -- False. The Else_Actions field is used as a temporary parking place
+ -- for these actions. The final tree is always rewritten to eliminate
+ -- the need for this field, so in the tree passed to Gigi, this field
+ -- is always set to No_List.
+
+ -- Enclosing_Variant (Node2-Sem)
+ -- This field is present in the N_Variant node and identifies the
+ -- Node_Id corresponding to the immediately enclosing variant when
+ -- the variant is nested, and N_Empty otherwise. Set during semantic
+ -- processing of the variant part of a record type.
+
+ -- Entity (Node4-Sem)
+ -- Appears in all direct names (identifier, character literal,
+ -- operator symbol), as well as expanded names, and attributes that
+ -- denote entities, such as 'Class. Points to the entity for the
+ -- corresponding defining occurrence. Set after name resolution.
+ -- In the case of identifiers in a WITH list, the corresponding
+ -- defining occurrence is in a separately compiled file, and this
+ -- pointer must be set using the library Load procedure. Note that
+ -- during name resolution, the value in Entity may be temporarily
+ -- incorrect (e.g. during overload resolution, Entity is
+ -- initially set to the first possible correct interpretation, and
+ -- then later modified if necessary to contain the correct value
+ -- after resolution).
+
+ -- Etype (Node5-Sem)
+ -- Appears in all expression nodes, all direct names, and all
+ -- entities. Points to the entity for the related type. Set after
+ -- type resolution. Normally this is the actual subtype of the
+ -- expression. However, in certain contexts such as the right side
+ -- of an assignment, subscripts, arguments to calls, returned value
+ -- in a function, initial value etc. it is the desired target type.
+ -- In the event that this is different from the actual type, the
+ -- Do_Range_Check flag will be set if a range check is required.
+ -- Note: if the Is_Overloaded flag is set, then Etype points to
+ -- an essentially arbitrary choice from the possible set of types.
+
+ -- Exception_Junk (Flag11-Sem)
+ -- This flag is set in a various nodes appearing in a statement
+ -- sequence to indicate that the corresponding node is an artifact
+ -- of the generated code for exception handling, and should be
+ -- ignored when analyzing the control flow of the relevant sequence
+ -- of statements (e.g. to check that it does not end with a bad
+ -- return statement).
+
+ -- Expansion_Delayed (Flag11-Sem)
+ -- Set on aggregates and extension aggregates that need a top-down
+ -- rather than bottom up expansion. Typically aggregate expansion
+ -- happens bottom up. For nested aggregates the expansion is delayed
+ -- until the enclosing aggregate itself is expanded, e.g. in the context
+ -- of a declaration. To delay it we set this flag. This is done to
+ -- avoid creating a temporary for each level of a nested aggregates,
+ -- and also to prevent the premature generation of constraint checks.
+ -- This is also a requirement if we want to generate the proper
+ -- attachment to the internal finalization lists (for record with
+ -- controlled components). Top down expansion of aggregates is also
+ -- used for in-place array aggregate assignment or initialization.
+ -- When the full context is known, the target of the assignment or
+ -- initialization is used to generate the left-hand side of individual
+ -- assignment to each sub-component.
+
+ -- First_Inlined_Subprogram (Node3-Sem)
+ -- Present in the N_Compilation_Unit node for the main program. Points
+ -- to a chain of entities for subprograms that are to be inlined. The
+ -- Next_Inlined_Subprogram field of these entities is used as a link
+ -- pointer with Empty marking the end of the list. This field is Empty
+ -- if there are no inlined subprograms or inlining is not active.
+
+ -- First_Named_Actual (Node4-Sem)
+ -- Present in procedure call statement and function call nodes, and
+ -- also in Intrinsic nodes. Set during semantic analysis to point to
+ -- the first named parameter where parameters are ordered by declaration
+ -- order (as opposed to the actual order in the call which may be
+ -- different due to named associations). Note: this field points to the
+ -- explicit actual parameter itself, not the N_Parameter_Association
+ -- node (its parent).
+
+ -- First_Real_Statement (Node2-Sem)
+ -- Present in N_Handled_Sequence_Of_Statements node. Normally set to
+ -- Empty. Used only when declarations are moved into the statement
+ -- part of a construct as a result of wrapping an AT END handler that
+ -- is required to cover the declarations. In this case, this field is
+ -- used to remember the location in the statements list of the first
+ -- real statement, i.e. the statement that used to be first in the
+ -- statement list before the declarations were prepended.
+
+ -- First_Subtype_Link (Node5-Sem)
+ -- Present in N_Freeze_Entity node for an anonymous base type that
+ -- is implicitly created by the declaration of a first subtype. It
+ -- points to the entity for the first subtype.
+
+ -- Float_Truncate (Flag11-Sem)
+ -- A flag present in type conversion nodes. This is used for float
+ -- to integer conversions where truncation is required rather than
+ -- rounding. Note that Gigi does not handle type conversions from real
+ -- to integer with rounding (see Expand_N_Type_Conversion).
+
+ -- Forwards_OK (Flag5-Sem)
+ -- A flag present in the N_Assignment_Statement node. It is used only
+ -- if the type being assigned is an array type, and is set if analysis
+ -- determines that it is definitely safe to do the copy forwards, i.e.
+ -- starting at the lowest addressed element. Note that if neither of
+ -- the flags Forwards_OK or Backwards_OK is set, it means that the
+ -- front end could not determine that either direction is definitely
+ -- safe, and a runtime check is required.
+
+ -- From_At_Mod (Flag4-Sem)
+ -- This flag is set on the attribute definition clause node that is
+ -- generated by a transformation of an at mod phrase in a record
+ -- representation clause. This is used to give slightly different
+ -- (Ada 83 compatible) semantics to such a clause, namely it is
+ -- used to specify a minimum acceptable alignment for the base type
+ -- and all subtypes. In Ada 95 terms, the actual alignment of the
+ -- base type and all subtypes must be a multiple of the given value,
+ -- and the representation clause is considered to be type specific
+ -- instead of subtype specific.
+
+ -- Generic_Parent (Node5-Sem)
+ -- Generic_parent is defined on declaration nodes that are instances.
+ -- The value of Generic_Parent is the generic entity from which the
+ -- instance is obtained. Generic_Parent is also defined for the renaming
+ -- declarations and object declarations created for the actuals in an
+ -- instantiation. The generic parent of such a declaration is the
+ -- corresponding generic association in the Instantiation node.
+
+ -- Generic_Parent_Type (Node4-Sem)
+ -- Generic_Parent_Type is defined on Subtype_Declaration nodes for
+ -- the actuals of formal private and derived types. Within the instance,
+ -- the operations on the actual are those inherited from the parent.
+ -- For a formal private type, the parent type is the generic type
+ -- itself. The Generic_Parent_Type is also used in an instance to
+ -- determine whether a private operation overrides an inherited one.
+
+ -- Handler_List_Entry (Node2-Sem)
+ -- This field is present in N_Object_Declaration nodes. It is set only
+ -- for the Handler_Record entry generated for an exception in zero cost
+ -- exception handling mode. It references the corresponding item in the
+ -- handler list, and is used to delete this entry if the corresponding
+ -- handler is deleted during optimization. For further details on why
+ -- this is required, see Exp_Ch11.Remove_Handler_Entries.
+
+ -- Has_Dynamic_Length_Check (Flag10-Sem)
+ -- This flag is present on all nodes. It is set to indicate that one
+ -- of the routines in unit Checks has generated a length check action
+ -- which has been inserted at the flagged node. This is used to avoid
+ -- the generation of duplicate checks.
+
+ -- Has_Dynamic_Range_Check (Flag12-Sem)
+ -- This flag is present on all nodes. It is set to indicate that one
+ -- of the routines in unit Checks has generated a range check action
+ -- which has been inserted at the flagged node. This is used to avoid
+ -- the generation of duplicate checks.
+
+ -- Has_No_Elaboration_Code (Flag17-Sem)
+ -- A flag that appears in the N_Compilation_Unit node to indicate
+ -- whether or not elaboration code is present for this unit. It is
+ -- initially set true for subprogram specs and bodies and for all
+ -- generic units and false for non-generic package specs and bodies.
+ -- Gigi may set the flag in the non-generic package case if it
+ -- determines that no elaboration code is generated. Note that this
+ -- flag is not related to the Is_Preelaborated status, there can be
+ -- preelaborated packages that generate elaboration code, and non-
+ -- preelaborated packages which do not generate elaboration code.
+
+ -- Has_Priority_Pragma (Flag6-Sem)
+ -- A flag present in N_Subprogram_Body, N_Task_Definition and
+ -- N_Protected_Definition nodes to flag the presence of either
+ -- a Priority or Interrupt_Priority pragma in the declaration
+ -- sequence (public or private in the task and protected cases)
+
+ -- Has_Private_View (Flag11-Sem)
+ -- A flag present in generic nodes that have an entity, to indicate
+ -- that the node has a private type. Used to exchange private
+ -- and full declarations if the visibility at instantiation is
+ -- different from the visibility at generic definition.
+
+ -- Has_Storage_Size_Pragma (Flag5-Sem)
+ -- A flag present in an N_Task_Definition node to flag the presence
+ -- of a Storage_Size pragma
+
+ -- Has_Task_Info_Pragma (Flag7-Sem)
+ -- A flag present in an N_Task_Definition node to flag the presence
+ -- of a Task_Info pragma. Used to detect duplicate pragmas.
+
+ -- Has_Task_Name_Pragma (Flag8-Sem)
+ -- A flag present in N_Task_Definition nodes to flag the presence
+ -- of a Task_Name pragma in the declaration sequence for the task.
+
+ -- Has_Wide_Character (Flag11-Sem)
+ -- Present in string literals, set if any wide character (i.e. a
+ -- character code outside the Character range) appears in the string.
+
+ -- Hidden_By_Use_Clause (Elist4-Sem)
+ -- An entity list present in use clauses that appear within
+ -- instantiations. For the resolution of local entities, entities
+ -- introduced by these use clauses have priority over global ones,
+ -- and outer entities must be explicitly hidden/restored on exit.
+
+ -- Implicit_With (Flag17-Sem)
+ -- This flag is set in the N_With_Clause node that is implicitly
+ -- generated for runtime units that are loaded by the expander, and
+ -- also for package System, if it is loaded implicitly by a use of
+ -- the 'Address or 'Tag attribute
+
+ -- Includes_Infinities (Flag11-Sem)
+ -- This flag is present in N_Range nodes. It is set for the range
+ -- of unconstrained float types defined in Standard, which include
+ -- not only the given range of values, but also legtitimately can
+ -- include infinite values. This flag is false for any float type
+ -- for which an explicit range is given by the programmer, even if
+ -- that range is identical to the range for float.
+
+ -- Instance_Spec (Node5-Sem)
+ -- This field is present in generic instantiation nodes, and also in
+ -- formal package declaration nodes (formal package declarations are
+ -- treated in a manner very similar to package instantiations). It
+ -- points to the node for the spec of the instance, inserted as part
+ -- of the semantic processing for instantiations in Sem_Ch12.
+
+ -- Is_Asynchronous_Call_Block (Flag7-Sem)
+ -- A flag set in a Block_Statement node to indicate that it is the
+ -- expansion of an asynchronous entry call. Such a block needs a
+ -- cleanup handler to assure that the call is cancelled.
+
+ -- Is_Component_Left_Opnd (Flag13-Sem)
+ -- Is_Component_Right_Opnd (Flag14-Sem)
+ -- Present in concatenation nodes, to indicate that the corresponding
+ -- operand is of the component type of the result. Used in resolving
+ -- concatenation nodes in instances.
+
+ -- Is_Controlling_Actual (Flag16-Sem)
+ -- This flag is set on in an expression that is a controlling argument
+ -- in a dispatching call. It is off in all other cases. See Sem_Disp
+ -- for details of its use.
+
+ -- Is_Machine_Number (Flag11-Sem)
+ -- This flag is set in an N_Real_Literal node to indicate that the
+ -- value is a machine number. This avoids some unnecessary cases
+ -- of converting real literals to machine numbers.
+
+ -- Is_Power_Of_2_For_Shift (Flag13-Sem)
+ -- A flag present only in N_Op_Expon nodes. It is set when the
+ -- exponentiation is of the forma 2 ** N, where the type of N is
+ -- an unsigned integral subtype whose size does not exceed the size
+ -- of Standard_Integer (i.e. a type that can be safely converted to
+ -- Natural), and the exponentiation appears as the right operand of
+ -- an integer multiplication or an integer division where the dividend
+ -- is unsigned. It is also required that overflow checking is off for
+ -- both the exponentiation and the multiply/divide node. If this set
+ -- of conditions holds, and the flag is set, then the division or
+ -- multiplication can be (and is) converted to a shift.
+
+ -- Is_Overloaded (Flag5-Sem)
+ -- A flag present in all expression nodes. Used temporarily during
+ -- overloading determination. The setting of this flag is not
+ -- relevant once overloading analysis is complete.
+
+ -- Is_Protected_Subprogram_Body (Flag7-Sem)
+ -- A flag set in a Subprogram_Body block to indicate that it is the
+ -- implemenation of a protected subprogram. Such a body needs a
+ -- cleanup handler to make sure that the associated protected object
+ -- is unlocked when the subprogram completes.
+
+ -- Is_Static_Expression (Flag6-Sem)
+ -- Indicates that an expression is a static expression (RM 4.9). See
+ -- spec of package Sem_Eval for full details on the use of this flag.
+
+ -- Is_Subprogram_Descriptor (Flag16-Sem)
+ -- Present in N_Object_Declaration, and set only for the object
+ -- declaration generated for a subprogram descriptor in fast exception
+ -- mode. See Exp_Ch11 for details of use.
+
+ -- Is_Task_Allocation_Block (Flag6-Sem)
+ -- A flag set in a Block_Statement node to indicate that it is the
+ -- expansion of a task allocator, or the allocator of an object
+ -- containing tasks. Such a block requires a cleanup handler to call
+ -- Expunge_Unactivted_Tasks to complete any tasks that have been
+ -- allocated but not activated when the allocator completes abnormally.
+
+ -- Is_Task_Master (Flag5-Sem)
+ -- A flag set in a Subprogram_Body, Block_Statement or Task_Body node
+ -- to indicate that the construct is a task master (i.e. has declared
+ -- tasks or declares an access to a task type).
+
+ -- Itype (Node1-Sem)
+ -- Used in N_Itype_Reference node to reference an itype for which it
+ -- is important to ensure that it is defined. See description of this
+ -- node for further details.
+
+ -- Kill_Range_Check (Flag11-Sem)
+ -- Used in an N_Unchecked_Type_Conversion node to indicate that the
+ -- result should not be subjected to range checks. This is used for
+ -- the implementation of Normalize_Scalars.
+
+ -- Label_Construct (Node2-Sem)
+ -- Used in an N_Implicit_Label_Declaration node. Refers to an N_Label,
+ -- N_Block_Statement or N_Loop_Statement node to which the label
+ -- declaration applies. This is not currently used in the compiler
+ -- itself, but it is useful in the implementation of ASIS queries.
+
+ -- Library_Unit (Node4-Sem)
+ -- In a stub node, the Library_Unit field points to the compilation unit
+ -- node of the corresponding subunit.
+ --
+ -- In a with clause node, the Library_Unit field points to the spec
+ -- of the with'ed unit.
+ --
+ -- In a compilation unit node, the use of this field depends on
+ -- the unit type:
+ --
+ -- For a subprogram body, the Library_Unit field points to the
+ -- compilation unit node of the corresponding spec, unless
+ -- Acts_As_Spec is set, in which case it points to itself.
+ --
+ -- For a package body, the Library_Unit field points to the
+ -- compilation unit node of the corresponding spec.
+ --
+ -- For a subprogram spec to which pragma Inline applies, the
+ -- Library_Unit field points to the compilation unit node of
+ -- the corresponding body, if inlining is active.
+ --
+ -- For a generic declaration, the Library_Unit field points
+ -- to the compilation unit node of the corresponding generic body.
+ --
+ -- For a subunit, the Library_Unit field points to the compilation
+ -- unit node of the parent body.
+ --
+ -- Note that this field is not used to hold the parent pointer for a
+ -- child unit (which might in any case need to use it for some other
+ -- purpose as described above). Instead for a child unit, implicit
+ -- with's are generated for all parents.
+
+ -- Loop_Actions (List2-Sem)
+ -- A list present in Component_Association nodes in array aggregates.
+ -- Used to collect actions that must be executed within the loop because
+ -- they may need to be evaluated anew each time through.
+
+ -- Must_Not_Freeze (Flag8-Sem)
+ -- A flag present in all expression nodes. Normally expressions cause
+ -- freezing as described in the RM. If this flag is set, then this
+ -- is inhibited. This is used by the analyzer and expander to label
+ -- nodes that are created by semantic analysis or expansion and which
+ -- must not cause freezing even though they normally would. This flag
+ -- is also present in an N_Subtype_Indication node, since we also use
+ -- these in calls to Freeze_Expression.
+
+ -- Next_Entity (Node2-Sem)
+ -- Present in defining identifiers, defining character literals and
+ -- defining operator symbols (i.e. in all entities). The entities of
+ -- a scope are chained, and this field is used as the forward pointer
+ -- for this list. See Einfo for further details.
+
+ -- Next_Named_Actual (Node4-Sem)
+ -- Present in parameter association node. Set during semantic
+ -- analysis to point to the next named parameter, where parameters
+ -- are ordered by declaration order (as opposed to the actual order
+ -- in the call, which may be different due to named associations).
+ -- Not that this field points to the explicit actual parameter itself,
+ -- not to the N_Parameter_Association node (its parent).
+
+ -- Next_Rep_Item (Node4-Sem)
+ -- Present in pragma nodes and attribute definition nodes. Used to
+ -- link representation items that apply to an entity. See description
+ -- of First_Rep_Item field in Einfo for full details.
+
+ -- Next_Use_Clause (Node3-Sem)
+ -- While use clauses are active during semantic processing, they
+ -- are chained from the scope stack entry, using Next_Use_Clause
+ -- as a link pointer, with Empty marking the end of the list. The
+ -- head pointer is in the scope stack entry (First_Use_Clause). At
+ -- the end of semantic processing (i.e. when Gigi sees the tree,
+ -- the contents of this field is undefined and should not be read).
+
+ -- No_Ctrl_Actions (Flag7-Sem)
+ -- Present in N_Assignment_Statement to indicate that no finalize nor
+ -- nor adjust should take place on this assignment eventhough the rhs
+ -- is controlled. This is used in init_procs and aggregate expansions
+ -- where the generated assignments are more initialisations than real
+ -- assignments.
+
+ -- No_Entities_Ref_In_Spec (Flag8-Sem)
+ -- Present in N_With_Clause nodes. Set if the with clause is on the
+ -- package or subprogram spec where the main unit is the corresponding
+ -- body, and no entities of the with'ed unit are referenced by the spec
+ -- (an entity may still be referenced in the body, so this flag is used
+ -- to generate the proper message (see Sem_Util.Check_Unused_Withs for
+ -- full details)
+
+ -- No_Initialization (Flag13-Sem)
+ -- Present in N_Object_Declaration & N_Allocator to indicate
+ -- that the object must not be initialized (by Initialize or a
+ -- call to _init_proc). This is needed for controlled aggregates.
+ -- When the Object declaration has an expression, this flag means
+ -- that this expression should not be taken into account (needed
+ -- for in place initialization with aggregates)
+
+ -- OK_For_Stream (Flag4-Sem)
+ -- Present in N_Attribute_Definition clauses for stream attributes. If
+ -- set, indicates that the attribute is permitted even though the type
+ -- involved is a limited type. In the case of a protected type, the
+ -- result is to stream all components (including discriminants) in
+ -- lexical order. For other limited types, the effect is simply to
+ -- use the corresponding stream routine for the full type. This flag
+ -- is used for internally generated code, where the streaming of these
+ -- types is required, even though not normally allowed by the language.
+
+ -- Original_Discriminant (Node2-Sem)
+ -- Present in identifiers. Used in references to discriminants that
+ -- appear in generic units. Because the names of the discriminants
+ -- may be different in an instance, we use this field to recover the
+ -- position of the discriminant in the original type, and replace it
+ -- with the discriminant at the same position in the instantiated type.
+
+ -- Others_Discrete_Choices (List1-Sem)
+ -- When a case statement or variant is analyzed, the semantic checks
+ -- determine the actual list of choices that correspond to an others
+ -- choice. This list is materialized for later use by the expander
+ -- and the Others_Discrete_Choices field of an N_Others_Choice node
+ -- points to this materialized list of choices, which is in standard
+ -- format for a list of discrete choices, except that of course it
+ -- cannot contain an N_Others_Choice entry.
+
+ -- Parameter_List_Truncated (Flag17-Sem)
+ -- Present in N_Function_Call and N_Procedure_Call_Statement nodes.
+ -- Set (for OpenVMS ports of GNAT only) if the parameter list is
+ -- truncated as a result of a First_Optional_Parameter specification
+ -- in an Import_Function, Import_Procedure, or Import_Valued_Procedure
+ -- pragma. The truncation is done by the expander by removing trailing
+ -- parameters from the argument list, in accordance with the set of
+ -- rules allowing such parameter removal. In particular, parameters
+ -- can be removed working from the end of the parameter list backwards
+ -- up to and including the entry designated by First_Optional_Parameter
+ -- in the Import pragma. Parameters can be removed if they are implicit
+ -- and the default value is a known-at-compile-time value, including
+ -- the use of the Null_Parameter attribute, or if explicit parameter
+ -- values are present that match the corresponding defaults.
+
+ -- Parent_Spec (Node4-Sem)
+ -- For a library unit that is a child unit spec (package or subprogram
+ -- declaration, generic declaration or instantiation, or library level
+ -- rename, this field points to the compilation unit node for the parent
+ -- package specification. This field is Empty for library bodies (the
+ -- parent spec in this case can be found from the corresponding spec).
+
+ -- Present_Expr (Uint3-Sem)
+ -- Present in an N_Variant node. This has a meaningful value only after
+ -- Gigi has back annotated the tree with representation information.
+ -- At this point, it contains a reference to a gcc expression that
+ -- depends on the values of one or more discriminants. Give a set of
+ -- discriminant values, this expression evaluates to False (zero) if
+ -- variant is not present, and True (non-zero) if it is present. See
+ -- unit Repinfo for further details on gigi back annotation. This
+ -- field is used during ASIS processing (data decomposition annex)
+ -- to determine if a field is present or not.
+
+ -- Print_In_Hex (Flag13-Sem)
+ -- Set on an N_Integer_Literal node to indicate that the value should
+ -- be printed in hexadecimal in the sprint listing. Has no effect on
+ -- legality or semantics of program, only on the displayed output.
+ -- This is used to clarify output from the packed array cases.
+
+ -- Procedure_To_Call (Node4-Sem)
+ -- Present in N_Allocator. N_Free_Statement, and N_Return_Statement
+ -- nodes. References the entity for the declaration of the procedure
+ -- to be called to accomplish the required operation (i.e. for the
+ -- Allocate procedure in the case of N_Allocator and N_Return_Statement
+ -- (for allocating the return value), and for the Deallocate procedure
+ -- in the case of N_Free_Statement.
+
+ -- Raises_Constraint_Error (Flag7-Sem)
+ -- Set on an expression whose evaluation will definitely fail a
+ -- constraint error check. In the case of static expressions, this
+ -- flag must be set accurately (and if it is set, the expression is
+ -- typically illegal unless it appears as a non-elaborated branch of
+ -- a short-circuit form). For a non-static expression, this flag may
+ -- be set whenever an expression (e.g. an aggregate) is known to raise
+ -- constraint error. If set, the expression definitely will raise CE
+ -- if elaborated at runtime. If not set, the expression may or may
+ -- not raise CE. In other words, on static expressions, the flag is
+ -- set accurately, on non-static expressions it is set conservatively.
+
+ -- Redundant_Use (Flag13-Sem)
+ -- A flag present in nodes that can appear as an operand in a use
+ -- clause or use type clause (identifiers, expanded names, attribute
+ -- references). Set to indicate that a use is redundant (and therefore
+ -- need not be undone on scope exit).
+
+ -- Return_Type (Node2-Sem)
+ -- Present in N_Return_Statement node. For a procedure, this is set
+ -- to Standard_Void_Type. For a function it references the entity
+ -- for the returned type.
+
+ -- Rounded_Result (Flag18-Sem)
+ -- Present in N_Type_Conversion, N_Op_Divide and N_Op_Multiply nodes.
+ -- Used in the fixed-point cases to indicate that the result must be
+ -- rounded as a result of the use of the 'Round attribute. Also used
+ -- for integer N_Op_Divide nodes to indicate that the result should
+ -- be rounded to the nearest integer (breaking ties away from zero),
+ -- rather than truncated towards zero as usual. These rounded integer
+ -- operations are the result of expansion of rounded fixed-point
+ -- divide, conersion and multiplication operations.
+
+ -- Scope (Node3-Sem)
+ -- Present in defining identifiers, defining character literals and
+ -- defining operator symbols (i.e. in all entities). The entities of
+ -- a scope all use this field to reference the corresponding scope
+ -- entity. See Einfo for further details.
+
+ -- Shift_Count_OK (Flag4-Sem)
+ -- A flag present in shift nodes to indicate that the shift count is
+ -- known to be in range, i.e. is in the range from zero to word length
+ -- minus one. If this flag is not set, then the shift count may be
+ -- outside this range, i.e. larger than the word length, and the code
+ -- must ensure that such shift counts give the appropriate result.
+
+ -- Source_Type (Node1-Sem)
+ -- Used in an N_Validate_Unchecked_Conversion node to point to the
+ -- source type entity for the unchecked conversion instantiation
+ -- which gigi must do size validation for.
+
+ -- Static_Processing_OK (Flag4-Sem)
+ -- Present in N_Aggregate nodes. When the Compile_Time_Known_Aggregate
+ -- flag is set, the full value of the aggregate can be determined at
+ -- compile time and the aggregate can be passed as is to the back-end.
+ -- In this event it is irrelevant whether this flag is set or not.
+ -- However, if the Compile_Time_Known_Aggregate flag is not set but
+ -- Static_Processing_OK is set, the aggregate can (but need not) be
+ -- converted into a compile time known aggregate by the expander.
+ -- See Sem_Aggr for the specific conditions under which an aggregate
+ -- has its Static_Processing_OK flag set.
+
+ -- Storage_Pool (Node1-Sem)
+ -- Present in N_Allocator, N_Free_Statement and N_Return_Statement
+ -- nodes. References the entity for the storage pool to be used for
+ -- the allocate or free call or for the allocation of the returned
+ -- value from a function. Empty indicates that the global default
+ -- default pool is to be used. Note that in the case of a return
+ -- statement, this field is set only if the function returns a
+ -- value of a type whose size is not known at compile time on the
+ -- secondary stack. It is never set on targets for which the target
+ -- parameter Targparm.Functions_Return_By_DSP_On_Target is True.
+
+ -- Target_Type (Node2-Sem)
+ -- Used in an N_Validate_Unchecked_Conversion node to point to the
+ -- target type entity for the unchecked conversion instantiation
+ -- which gigi must do size validation for.
+
+ -- Task_Body_Procedure (Node2-Sem)
+ -- Present in task type declaration nodes. Points to the entity for
+ -- the task body procedure (as further described in Exp_Ch9, task
+ -- bodies are expanded into procedures). A convenient function to
+ -- retrieve this field is Sem_Util.Get_Task_Body_Procedure.
+
+ -- Then_Actions (List3-Sem)
+ -- This field is present in conditional expression nodes. During code
+ -- expansion we use the Insert_Actions procedure (in Exp_Util) to insert
+ -- actions at an appropriate place in the tree to get elaborated at the
+ -- right time. For conditional expressions, we have to be sure that the
+ -- actions for the Then branch are only elaborated if the condition is
+ -- True. The Then_Actions field is used as a temporary parking place
+ -- for these actions. The final tree is always rewritten to eliminate
+ -- the need for this field, so in the tree passed to Gigi, this field
+ -- is always set to No_List.
+
+ -- Treat_Fixed_As_Integer (Flag14-Sem)
+ -- This flag appears in operator nodes for divide, multiply, mod and
+ -- rem on fixed-point operands. It indicates that the operands are
+ -- to be treated as integer values, ignoring small values. This flag
+ -- is only set as a result of expansion of fixed-point operations.
+ -- Typically a fixed-point multplication in the source generates
+ -- subsidiary multiplication and division operations that work with
+ -- the underlying integer values and have this flag set. Note that
+ -- this flag is not needed on other arithmetic operations (add, neg,
+ -- subtract etc) since in these cases it is always the case that fixed
+ -- is treated as integer. The Etype field MUST be set if this flag
+ -- is set. The analyzer knows to leave such nodes alone, and whoever
+ -- makes them must set the correct Etype value.
+
+ -- TSS_Elist (Elist3-Sem)
+ -- Present in N_Freeze_Entity nodes. Holds an element list containing
+ -- entries for each TSS (type support subprogram) associated with the
+ -- frozen type. The elements of the list are the entities for the
+ -- subprograms (see package Exp_TSS for further details). Set to
+ -- No_Elist if there are no type support subprograms for the type
+ -- or if the freeze node is not for a type.
+
+ -- Unreferenced_In_Spec (Flag7-Sem)
+ -- Present in N_With_Clause nodes. Set if the with clause is on the
+ -- package or subprogram spec where the main unit is the corresponding
+ -- body, and is not referenced by the spec (it may still be referenced
+ -- by the body, so this flag is used to generate the proper message
+ -- (see Sem_Util.Check_Unused_Withs for details)
+
+ -- Was_Originally_Stub (Flag13-Sem)
+ -- This flag is set in the node for a proper body that replaces a
+ -- stub. During the analysis procedure, stubs in some situations
+ -- get rewritten by the corresponding bodies, and we set this flag
+ -- to remember that this happened. Note that it is not good enough
+ -- to rely on the use of Original_Tree here because of the case of
+ -- nested instantiations where the substituted node can be copied.
+
+ -- Zero_Cost_Handling (Flag5-Sem)
+ -- This flag is set in all handled sequence of statement and exception
+ -- handler nodes if eceptions are to be handled using the zero-cost
+ -- mechanism (see Ada.Exceptions and System.Exceptions in files
+ -- a-except.ads/adb and s-except.ads for full details). What gigi
+ -- needs to do for such a handler is simply to put the code in the
+ -- handler somewhere. The front end has generated all necessary labels.
+
+ --------------------------------------------------
+ -- Note on Use of End_Label and End_Span Fields --
+ --------------------------------------------------
+
+ -- Several constructs have end lines:
+
+ -- Loop Statement end loop [loop_IDENTIFIER];
+ -- Package Specification end [[PARENT_UNIT_NAME .] IDENTIFIER]
+ -- Task Definition end [task_IDENTIFIER]
+ -- Protected Definition end [protected_IDENTIFIER]
+ -- Protected Body end [protected_IDENTIFIER]
+
+ -- Block Statement end [block_IDENTIFIER];
+ -- Subprogram Body end [DESIGNATOR];
+ -- Package Body end [[PARENT_UNIT_NAME .] IDENTIFIER];
+ -- Task Body end [task_IDENTIFIER];
+ -- Accept Statement end [entry_IDENTIFIER]];
+ -- Entry Body end [entry_IDENTIFIER];
+
+ -- If Statement end if;
+ -- Case Statement end case;
+
+ -- Record Definition end record;
+
+ -- The End_Label and End_Span fields are used to mark the locations
+ -- of these lines, and also keep track of the label in the case where
+ -- a label is present.
+
+ -- For the first group above, the End_Label field of the corresponding
+ -- node is used to point to the label identifier. In the case where
+ -- there is no label in the source, the parser supplies a dummy
+ -- identifier (with Comes_From_Source set to False), and the Sloc
+ -- of this dummy identifier marks the location of the token following
+ -- the END token.
+
+ -- For the second group, the use of End_Label is similar, but the
+ -- End_Label is found in the N_Handled_Sequence_Of_Statements node.
+ -- This is done simply because in some cases there is no room in
+ -- the parent node.
+
+ -- For the third group, there is never any label, and instead of
+ -- using End_Label, we use the End_Span field which gives the
+ -- location of the token following END, relative to the starting
+ -- Sloc of the construct, i.e. add Sloc (Node) + End_Span (Node)
+ -- to get the Sloc of the IF or CASE following the End_Label.
+
+ -- The record definition case is handled specially, we treat it
+ -- as though it required an optional label which is never present,
+ -- and so the parser always builds a dummy identifier with Comes
+ -- From Source set False. The reason we do this, rather than using
+ -- End_Span in this case, is that we want to generate a cross-ref
+ -- entry for the end of a record, since it represents a scope for
+ -- name declaration purposes.
+
+ -- Note: the reason we store the difference as a Uint, instead of
+ -- storing the Source_Ptr value directly, is that Source_Ptr values
+ -- cannot be distinguished from other types of values, and we count
+ -- on all general use fields being self describing. To make things
+ -- easier for clients, note that we provide function End_Location,
+ -- and procedure Set_End_Location to allow access to the logical
+ -- value (which is the Source_Ptr value for the end token).
+
+ ---------------------
+ -- Syntactic Nodes --
+ ---------------------
+
+ ---------------------
+ -- 2.3 Identifier --
+ ---------------------
+
+ -- IDENTIFIER ::= IDENTIFIER_LETTER {[UNDERLINE] LETTER_OR_DIGIT}
+ -- LETTER_OR_DIGIT ::= IDENTIFIER_LETTER | DIGIT
+
+ -- An IDENTIFIER shall not be a reserved word
+
+ -- In the Ada grammar identifiers are the bottom level tokens which
+ -- have very few semantics. Actual program identifiers are direct
+ -- names. If we were being 100% honest with the grammar, then we would
+ -- have a node called N_Direct_Name which would point to an identifier.
+ -- However, that's too many extra nodes, so we just use the N_Identifier
+ -- node directly as a direct name, and it contains the expression fields
+ -- and Entity field that correspond to its use as a direct name. In
+ -- those few cases where identifiers appear in contexts where they are
+ -- not direct names (pragmas, pragma argument associations, attribute
+ -- references and attribute definition clauses), the Chars field of the
+ -- node contains the Name_Id for the identifier name.
+
+ -- Note: in GNAT, a reserved word can be treated as an identifier
+ -- in two cases. First, an incorrect use of a reserved word as an
+ -- identifier is diagnosed and then treated as a normal identifier.
+ -- Second, an attribute designator of the form of a reserved word
+ -- (access, delta, digits, range) is treated as an identifier.
+
+ -- Note: The set of letters that is permitted in an identifier depends
+ -- on the character set in use. See package Csets for full details.
+
+ -- N_Identifier
+ -- Sloc points to identifier
+ -- Chars (Name1) contains the Name_Id for the identifier
+ -- Entity (Node4-Sem)
+ -- Original_Discriminant (Node2-Sem)
+ -- Redundant_Use (Flag13-Sem)
+ -- Has_Private_View (Flag11-Sem) (set in generic units)
+ -- plus fields for expression
+
+ --------------------------
+ -- 2.4 Numeric Literal --
+ --------------------------
+
+ -- NUMERIC_LITERAL ::= DECIMAL_LITERAL | BASED_LITERAL
+
+ ----------------------------
+ -- 2.4.1 Decimal Literal --
+ ----------------------------
+
+ -- DECIMAL_LITERAL ::= NUMERAL [.NUMERAL] [EXPONENT]
+
+ -- NUMERAL ::= DIGIT {[UNDERLINE] DIGIT}
+
+ -- EXPONENT ::= E [+] NUMERAL | E - NUMERAL
+
+ -- Decimal literals appear in the tree as either integer literal nodes
+ -- or real literal nodes, depending on whether a period is present.
+
+ -- Note: literal nodes appear as a result of direct use of literals
+ -- in the source program, and also as the result of evaluating
+ -- expressions at compile time. In the latter case, it is possible
+ -- to construct real literals that have no syntactic representation
+ -- using the standard literal format. Such literals are listed by
+ -- Sprint using the notation [numerator / denominator].
+
+ -- N_Integer_Literal
+ -- Sloc points to literal
+ -- Intval (Uint3) contains integer value of literal
+ -- plus fields for expression
+ -- Print_In_Hex (Flag13-Sem)
+
+ -- N_Real_Literal
+ -- Sloc points to literal
+ -- Realval (Ureal3) contains real value of literal
+ -- Corresponding_Integer_Value (Uint4-Sem)
+ -- Is_Machine_Number (Flag11-Sem)
+ -- plus fields for expression
+
+ --------------------------
+ -- 2.4.2 Based Literal --
+ --------------------------
+
+ -- BASED_LITERAL ::=
+ -- BASE # BASED_NUMERAL [.BASED_NUMERAL] # [EXPONENT]
+
+ -- BASE ::= NUMERAL
+
+ -- BASED_NUMERAL ::=
+ -- EXTENDED_DIGIT {[UNDERLINE] EXTENDED_DIGIT}
+
+ -- EXTENDED_DIGIT ::= DIGIT | A | B | C | D | E | F
+
+ -- Based literals appear in the tree as either integer literal nodes
+ -- or real literal nodes, depending on whether a period is present.
+
+ ----------------------------
+ -- 2.5 Character Literal --
+ ----------------------------
+
+ -- CHARACTER_LITERAL ::= ' GRAPHIC_CHARACTER '
+
+ -- N_Character_Literal
+ -- Sloc points to literal
+ -- Chars (Name1) contains the Name_Id for the identifier
+ -- Char_Literal_Value (Char_Code2) contains the literal value
+ -- Entity (Node4-Sem)
+ -- Has_Private_View (Flag11-Sem) set in generic units.
+ -- plus fields for expression
+
+ -- Note: the Entity field will be missing (and set to Empty) for
+ -- character literals whose type is Standard.Wide_Character or
+ -- Standard.Character or a type derived from one of these two.
+ -- In this case the character literal stands for its own coding.
+ -- The reason we take this irregular short cut is to avoid the
+ -- need to build lots of junk defining character literal nodes.
+
+ -------------------------
+ -- 2.6 String Literal --
+ -------------------------
+
+ -- STRING LITERAL ::= "{STRING_ELEMENT}"
+
+ -- A STRING_ELEMENT is either a pair of quotation marks ("), or a
+ -- single GRAPHIC_CHARACTER other than a quotation mark.
+
+ -- N_String_Literal
+ -- Sloc points to literal
+ -- Strval (Str3) contains Id of string value
+ -- Has_Wide_Character (Flag11-Sem)
+ -- plus fields for expression
+
+ ------------------
+ -- 2.7 Comment --
+ ------------------
+
+ -- A COMMENT starts with two adjacent hyphens and extends up to the
+ -- end of the line. A COMMENT may appear on any line of a program.
+
+ -- Comments are skipped by the scanner and do not appear in the tree.
+ -- It is possible to reconstruct the position of comments with respect
+ -- to the elements of the tree by using the source position (Sloc)
+ -- pointers that appear in every tree node.
+
+ -----------------
+ -- 2.8 Pragma --
+ -----------------
+
+ -- PRAGMA ::= pragma IDENTIFIER
+ -- [(PRAGMA_ARGUMENT_ASSOCIATION {, PRAGMA_ARGUMENT_ASSOCIATION})];
+
+ -- Note that a pragma may appear in the tree anywhere a declaration
+ -- or a statement may appear, as well as in some other situations
+ -- which are explicitly documented.
+
+ -- N_Pragma
+ -- Sloc points to PRAGMA
+ -- Chars (Name1) identifier name from pragma identifier
+ -- Pragma_Argument_Associations (List2) (set to No_List if none)
+ -- Debug_Statement (Node3) (set to Empty if not Debug, Assert)
+ -- Next_Rep_Item (Node4-Sem)
+
+ --------------------------------------
+ -- 2.8 Pragma Argument Association --
+ --------------------------------------
+
+ -- PRAGMA_ARGUMENT_ASSOCIATION ::=
+ -- [pragma_argument_IDENTIFIER =>] NAME
+ -- | [pragma_argument_IDENTIFIER =>] EXPRESSION
+
+ -- N_Pragma_Argument_Association
+ -- Sloc points to first token in association
+ -- Chars (Name1) (set to No_Name if no pragma argument identifier)
+ -- Expression (Node3)
+
+ ------------------------
+ -- 2.9 Reserved Word --
+ ------------------------
+
+ -- Reserved words are parsed by the scanner, and returned as the
+ -- corresponding token types (e.g. PACKAGE is returned as Tok_Package)
+
+ ----------------------------
+ -- 3.1 Basic Declaration --
+ ----------------------------
+
+ -- BASIC_DECLARATION ::=
+ -- TYPE_DECLARATION | SUBTYPE_DECLARATION
+ -- | OBJECT_DECLARATION | NUMBER_DECLARATION
+ -- | SUBPROGRAM_DECLARATION | ABSTRACT_SUBPROGRAM_DECLARATION
+ -- | PACKAGE_DECLARATION | RENAMING_DECLARATION
+ -- | EXCEPTION_DECLARATION | GENERIC_DECLARATION
+ -- | GENERIC_INSTANTIATION
+
+ -- Basic declaration also includes IMPLICIT_LABEL_DECLARATION
+ -- see further description in section on semantic nodes.
+
+ -- Also, in the tree that is constructed, a pragma may appear
+ -- anywhere that a declaration may appear.
+
+ ------------------------------
+ -- 3.1 Defining Identifier --
+ ------------------------------
+
+ -- DEFINING_IDENTIFIER ::= IDENTIFIER
+
+ -- A defining identifier is an entity, which has additional fields
+ -- depending on the setting of the Ekind field. These additional
+ -- fields are defined (and access subprograms declared) in package
+ -- Einfo.
+
+ -- Note: N_Defining_Identifier is an extended node whose fields are
+ -- deliberate layed out to match the layout of fields in an ordinary
+ -- N_Identifier node allowing for easy alteration of an identifier
+ -- node into a defining identifier node. For details, see procedure
+ -- Sinfo.CN.Change_Identifier_To_Defining_Identifier.
+
+ -- N_Defining_Identifier
+ -- Sloc points to identifier
+ -- Chars (Name1) contains the Name_Id for the identifier
+ -- Next_Entity (Node2-Sem)
+ -- Scope (Node3-Sem)
+ -- Etype (Node5-Sem)
+
+ -----------------------------
+ -- 3.2.1 Type Declaration --
+ -----------------------------
+
+ -- TYPE_DECLARATION ::=
+ -- FULL_TYPE_DECLARATION
+ -- | INCOMPLETE_TYPE_DECLARATION
+ -- | PRIVATE_TYPE_DECLARATION
+ -- | PRIVATE_EXTENSION_DECLARATION
+
+ ----------------------------------
+ -- 3.2.1 Full Type Declaration --
+ ----------------------------------
+
+ -- FULL_TYPE_DECLARATION ::=
+ -- type DEFINING_IDENTIFIER [KNOWN_DISCRIMINANT_PART]
+ -- is TYPE_DEFINITION;
+ -- | TASK_TYPE_DECLARATION
+ -- | PROTECTED_TYPE_DECLARATION
+
+ -- The full type declaration node is used only for the first case. The
+ -- second case (concurrent type declaration), is represented directly
+ -- by a task type declaration or a protected type declaration.
+
+ -- N_Full_Type_Declaration
+ -- Sloc points to TYPE
+ -- Defining_Identifier (Node1)
+ -- Discriminant_Specifications (List4) (set to No_List if none)
+ -- Type_Definition (Node3)
+ -- Discr_Check_Funcs_Built (Flag11-Sem)
+
+ ----------------------------
+ -- 3.2.1 Type Definition --
+ ----------------------------
+
+ -- TYPE_DEFINITION ::=
+ -- ENUMERATION_TYPE_DEFINITION | INTEGER_TYPE_DEFINITION
+ -- | REAL_TYPE_DEFINITION | ARRAY_TYPE_DEFINITION
+ -- | RECORD_TYPE_DEFINITION | ACCESS_TYPE_DEFINITION
+ -- | DERIVED_TYPE_DEFINITION
+
+ --------------------------------
+ -- 3.2.2 Subtype Declaration --
+ --------------------------------
+
+ -- SUBTYPE_DECLARATION ::=
+ -- subtype DEFINING_IDENTIFIER is SUBTYPE_INDICATION;
+
+ -- The subtype indication field is set to Empty for subtypes
+ -- declared in package Standard (Positive, Natural).
+
+ -- N_Subtype_Declaration
+ -- Sloc points to SUBTYPE
+ -- Defining_Identifier (Node1)
+ -- Subtype_Indication (Node5)
+ -- Generic_Parent_Type (Node4-Sem) (set for an actual derived type).
+ -- Exception_Junk (Flag11-Sem)
+
+ -------------------------------
+ -- 3.2.2 Subtype Indication --
+ -------------------------------
+
+ -- SUBTYPE_INDICATION ::= SUBTYPE_MARK [CONSTRAINT]
+
+ -- Note: if no constraint is present, the subtype indication appears
+ -- directly in the tree as a subtype mark. The N_Subtype_Indication
+ -- node is used only if a constraint is present.
+
+ -- Note: the reason that this node has expression fields is that a
+ -- subtype indication can appear as an operand of a membership test.
+
+ -- N_Subtype_Indication
+ -- Sloc points to first token of subtype mark
+ -- Subtype_Mark (Node4)
+ -- Constraint (Node3)
+ -- Etype (Node5-Sem)
+ -- Must_Not_Freeze (Flag8-Sem)
+
+ -- Note: Etype is a copy of the Etype field of the Subtype_Mark. The
+ -- reason for this redundancy is so that in a list of array index types,
+ -- the Etype can be uniformly accessed to determine the subscript type.
+ -- This means that no Itype is constructed for the actual subtype that
+ -- is created by the subtype indication. If such an Itype is required,
+ -- it is constructed in the context in which the indication appears.
+
+ -------------------------
+ -- 3.2.2 Subtype Mark --
+ -------------------------
+
+ -- SUBTYPE_MARK ::= subtype_NAME
+
+ -----------------------
+ -- 3.2.2 Constraint --
+ -----------------------
+
+ -- CONSTRAINT ::= SCALAR_CONSTRAINT | COMPOSITE_CONSTRAINT
+
+ ------------------------------
+ -- 3.2.2 Scalar Constraint --
+ ------------------------------
+
+ -- SCALAR_CONSTRAINT ::=
+ -- RANGE_CONSTRAINT | DIGITS_CONSTRAINT | DELTA_CONSTRAINT
+
+ ---------------------------------
+ -- 3.2.2 Composite Constraint --
+ ---------------------------------
+
+ -- COMPOSITE_CONSTRAINT ::=
+ -- INDEX_CONSTRAINT | DISCRIMINANT_CONSTRAINT
+
+ -------------------------------
+ -- 3.3.1 Object Declaration --
+ -------------------------------
+
+ -- OBJECT_DECLARATION ::=
+ -- DEFINING_IDENTIFIER_LIST : [aliased] [constant]
+ -- SUBTYPE_INDICATION [:= EXPRESSION];
+ -- | DEFINING_IDENTIFIER_LIST : [aliased] [constant]
+ -- ARRAY_TYPE_DEFINITION [:= EXPRESSION];
+ -- | SINGLE_TASK_DECLARATION
+ -- | SINGLE_PROTECTED_DECLARATION
+
+ -- Note: aliased is not permitted in Ada 83 mode
+
+ -- The N_Object_Declaration node is only for the first two cases.
+ -- Single task declaration is handled by P_Task (9.1)
+ -- Single protected declaration is handled by P_protected (9.5)
+
+ -- Although the syntax allows multiple identifiers in the list, the
+ -- semantics is as though successive declarations were given with
+ -- identical type definition and expression components. To simplify
+ -- semantic processing, the parser represents a multiple declaration
+ -- case as a sequence of single declarations, using the More_Ids and
+ -- Prev_Ids flags to preserve the original source form as described
+ -- in the section on "Handling of Defining Identifier Lists".
+
+ -- Note: if a range check is required for the initialization
+ -- expression then the Do_Range_Check flag is set in the Expression,
+ -- with the check being done against the type given by the object
+ -- definition, which is also the Etype of the defining identifier.
+
+ -- Note: the contents of the Expression field must be ignored (i.e.
+ -- treated as though it were Empty) if No_Initialization is set True.
+
+ -- N_Object_Declaration
+ -- Sloc points to first identifier
+ -- Defining_Identifier (Node1)
+ -- Aliased_Present (Flag4) set if ALIASED appears
+ -- Constant_Present (Flag17) set if CONSTANT appears
+ -- Object_Definition (Node4) subtype indication/array type definition
+ -- Expression (Node3) (set to Empty if not present)
+ -- Handler_List_Entry (Node2-Sem)
+ -- Corresponding_Generic_Association (Node5-Sem)
+ -- More_Ids (Flag5) (set to False if no more identifiers in list)
+ -- Prev_Ids (Flag6) (set to False if no previous identifiers in list)
+ -- No_Initialization (Flag13-Sem)
+ -- Assignment_OK (Flag15-Sem)
+ -- Exception_Junk (Flag11-Sem)
+ -- Delay_Finalize_Attach (Flag14-Sem)
+ -- Is_Subprogram_Descriptor (Flag16-Sem)
+
+ -------------------------------------
+ -- 3.3.1 Defining Identifier List --
+ -------------------------------------
+
+ -- DEFINING_IDENTIFIER_LIST ::=
+ -- DEFINING_IDENTIFIER {, DEFINING_IDENTIFIER}
+
+ -------------------------------
+ -- 3.3.2 Number Declaration --
+ -------------------------------
+
+ -- NUMBER_DECLARATION ::=
+ -- DEFINING_IDENTIFIER_LIST : constant := static_EXPRESSION;
+
+ -- Although the syntax allows multiple identifiers in the list, the
+ -- semantics is as though successive declarations were given with
+ -- identical expressions. To simplify semantic processing, the parser
+ -- represents a multiple declaration case as a sequence of single
+ -- declarations, using the More_Ids and Prev_Ids flags to preserve
+ -- the original source form as described in the section on "Handling
+ -- of Defining Identifier Lists".
+
+ -- N_Number_Declaration
+ -- Sloc points to first identifier
+ -- Defining_Identifier (Node1)
+ -- Expression (Node3)
+ -- More_Ids (Flag5) (set to False if no more identifiers in list)
+ -- Prev_Ids (Flag6) (set to False if no previous identifiers in list)
+
+ ----------------------------------
+ -- 3.4 Derived Type Definition --
+ ----------------------------------
+
+ -- DERIVED_TYPE_DEFINITION ::=
+ -- [abstract] new parent_SUBTYPE_INDICATION [RECORD_EXTENSION_PART]
+
+ -- Note: ABSTRACT, record extension part not permitted in Ada 83 mode
+
+ -- Note: a record extension part is required if ABSTRACT is present
+
+ -- N_Derived_Type_Definition
+ -- Sloc points to NEW
+ -- Abstract_Present (Flag4)
+ -- Subtype_Indication (Node5)
+ -- Record_Extension_Part (Node3) (set to Empty if not present)
+
+ ---------------------------
+ -- 3.5 Range Constraint --
+ ---------------------------
+
+ -- RANGE_CONSTRAINT ::= range RANGE
+
+ -- N_Range_Constraint
+ -- Sloc points to RANGE
+ -- Range_Expression (Node4)
+
+ ----------------
+ -- 3.5 Range --
+ ----------------
+
+ -- RANGE ::=
+ -- RANGE_ATTRIBUTE_REFERENCE
+ -- | SIMPLE_EXPRESSION .. SIMPLE_EXPRESSION
+
+ -- Note: the case of a range given as a range attribute reference
+ -- appears directly in the tree as an attribute reference.
+
+ -- Note: the field name for a reference to a range is Range_Expression
+ -- rather than Range, because range is a reserved keyword in Ada!
+
+ -- Note: the reason that this node has expression fields is that a
+ -- range can appear as an operand of a membership test. The Etype
+ -- field is the type of the range (we do NOT construct an implicit
+ -- subtype to represent the range exactly).
+
+ -- N_Range
+ -- Sloc points to ..
+ -- Low_Bound (Node1)
+ -- High_Bound (Node2)
+ -- Includes_Infinities (Flag11)
+ -- plus fields for expression
+
+ -- Note: if the range appears in a context, such as a subtype
+ -- declaration, where range checks are required on one or both of
+ -- the expression fields, then type conversion nodes are inserted
+ -- to represent the required checks.
+
+ ----------------------------------------
+ -- 3.5.1 Enumeration Type Definition --
+ ----------------------------------------
+
+ -- ENUMERATION_TYPE_DEFINITION ::=
+ -- (ENUMERATION_LITERAL_SPECIFICATION
+ -- {, ENUMERATION_LITERAL_SPECIFICATION})
+
+ -- Note: the Literals field in the node described below is null for
+ -- the case of the standard types CHARACTER and WIDE_CHARACTER, for
+ -- which special processing handles these types as special cases.
+
+ -- N_Enumeration_Type_Definition
+ -- Sloc points to left parenthesis
+ -- Literals (List1) (Empty for CHARACTER or WIDE_CHARACTER)
+
+ ----------------------------------------------
+ -- 3.5.1 Enumeration Literal Specification --
+ ----------------------------------------------
+
+ -- ENUMERATION_LITERAL_SPECIFICATION ::=
+ -- DEFINING_IDENTIFIER | DEFINING_CHARACTER_LITERAL
+
+ ---------------------------------------
+ -- 3.5.1 Defining Character Literal --
+ ---------------------------------------
+
+ -- DEFINING_CHARACTER_LITERAL ::= CHARACTER_LITERAL
+
+ -- A defining character literal is an entity, which has additional
+ -- fields depending on the setting of the Ekind field. These
+ -- additional fields are defined (and access subprograms declared)
+ -- in package Einfo.
+
+ -- Note: N_Defining_Character_Literal is an extended node whose fields
+ -- are deliberate layed out to match the layout of fields in an ordinary
+ -- N_Character_Literal node allowing for easy alteration of a character
+ -- literal node into a defining character literal node. For details, see
+ -- Sinfo.CN.Change_Character_Literal_To_Defining_Character_Literal.
+
+ -- N_Defining_Character_Literal
+ -- Sloc points to literal
+ -- Chars (Name1) contains the Name_Id for the identifier
+ -- Next_Entity (Node2-Sem)
+ -- Scope (Node3-Sem)
+ -- Etype (Node5-Sem)
+
+ ------------------------------------
+ -- 3.5.4 Integer Type Definition --
+ ------------------------------------
+
+ -- Note: there is an error in this rule in the latest version of the
+ -- grammar, so we have retained the old rule pending clarification.
+
+ -- INTEGER_TYPE_DEFINITION ::=
+ -- SIGNED_INTEGER_TYPE_DEFINITION
+ -- MODULAR_TYPE_DEFINITION
+
+ -------------------------------------------
+ -- 3.5.4 Signed Integer Type Definition --
+ -------------------------------------------
+
+ -- SIGNED_INTEGER_TYPE_DEFINITION ::=
+ -- range static_SIMPLE_EXPRESSION .. static_SIMPLE_EXPRESSION
+
+ -- Note: the Low_Bound and High_Bound fields are set to Empty for
+ -- integer types defined in package Standard.
+
+ -- N_Signed_Integer_Type_Definition
+ -- Sloc points to RANGE
+ -- Low_Bound (Node1)
+ -- High_Bound (Node2)
+
+ -----------------------------------------
+ -- 3.5.4 Unsigned Range Specification --
+ -----------------------------------------
+
+ -- MODULAR_TYPE_DEFINITION ::= mod static_EXPRESSION
+
+ -- N_Modular_Type_Definition
+ -- Sloc points to MOD
+ -- Expression (Node3)
+
+ ---------------------------------
+ -- 3.5.6 Real Type Definition --
+ ---------------------------------
+
+ -- REAL_TYPE_DEFINITION ::=
+ -- FLOATING_POINT_DEFINITION | FIXED_POINT_DEFINITION
+
+ --------------------------------------
+ -- 3.5.7 Floating Point Definition --
+ --------------------------------------
+
+ -- FLOATING_POINT_DEFINITION ::=
+ -- digits static_SIMPLE_EXPRESSION [REAL_RANGE_SPECIFICATION]
+
+ -- Note: The Digits_Expression and Real_Range_Specifications fields
+ -- are set to Empty for floating-point types declared in Standard.
+
+ -- N_Floating_Point_Definition
+ -- Sloc points to DIGITS
+ -- Digits_Expression (Node2)
+ -- Real_Range_Specification (Node4) (set to Empty if not present)
+
+ -------------------------------------
+ -- 3.5.7 Real Range Specification --
+ -------------------------------------
+
+ -- REAL_RANGE_SPECIFICATION ::=
+ -- range static_SIMPLE_EXPRESSION .. static_SIMPLE_EXPRESSION
+
+ -- N_Real_Range_Specification
+ -- Sloc points to RANGE
+ -- Low_Bound (Node1)
+ -- High_Bound (Node2)
+
+ -----------------------------------
+ -- 3.5.9 Fixed Point Definition --
+ -----------------------------------
+
+ -- FIXED_POINT_DEFINITION ::=
+ -- ORDINARY_FIXED_POINT_DEFINITION | DECIMAL_FIXED_POINT_DEFINITION
+
+ --------------------------------------------
+ -- 3.5.9 Ordinary Fixed Point Definition --
+ --------------------------------------------
+
+ -- ORDINARY_FIXED_POINT_DEFINITION ::=
+ -- delta static_EXPRESSION REAL_RANGE_SPECIFICATION
+
+ -- Note: In Ada 83, the EXPRESSION must be a SIMPLE_EXPRESSION
+
+ -- Note: the Delta_Expression and Real_Range_Specification fields
+ -- are set to Empty for fixed point types declared in Standard.
+
+ -- N_Ordinary_Fixed_Point_Definition
+ -- Sloc points to DELTA
+ -- Delta_Expression (Node3)
+ -- Real_Range_Specification (Node4)
+
+ -------------------------------------------
+ -- 3.5.9 Decimal Fixed Point Definition --
+ -------------------------------------------
+
+ -- DECIMAL_FIXED_POINT_DEFINITION ::=
+ -- delta static_EXPRESSION
+ -- digits static_EXPRESSION [REAL_RANGE_SPECIFICATION]
+
+ -- Note: decimal types are not permitted in Ada 83 mode
+
+ -- N_Decimal_Fixed_Point_Definition
+ -- Sloc points to DELTA
+ -- Delta_Expression (Node3)
+ -- Digits_Expression (Node2)
+ -- Real_Range_Specification (Node4) (set to Empty if not present)
+
+ ------------------------------
+ -- 3.5.9 Digits Constraint --
+ ------------------------------
+
+ -- DIGITS_CONSTRAINT ::=
+ -- digits static_EXPRESSION [RANGE_CONSTRAINT]
+
+ -- Note: in Ada 83, the EXPRESSION must be a SIMPLE_EXPRESSION
+ -- Note: in Ada 95, reduced accuracy subtypes are obsolescent
+
+ -- N_Digits_Constraint
+ -- Sloc points to DIGITS
+ -- Digits_Expression (Node2)
+ -- Range_Constraint (Node4) (set to Empty if not present)
+
+ --------------------------------
+ -- 3.6 Array Type Definition --
+ --------------------------------
+
+ -- ARRAY_TYPE_DEFINITION ::=
+ -- UNCONSTRAINED_ARRAY_DEFINITION | CONSTRAINED_ARRAY_DEFINITION
+
+ -----------------------------------------
+ -- 3.6 Unconstrained Array Definition --
+ -----------------------------------------
+
+ -- UNCONSTRAINED_ARRAY_DEFINITION ::=
+ -- array (INDEX_SUBTYPE_DEFINITION {, INDEX_SUBTYPE_DEFINITION}) of
+ -- COMPONENT_DEFINITION
+
+ -- Note: dimensionality of array is indicated by number of entries in
+ -- the Subtype_Marks list, which has one entry for each dimension.
+
+ -- N_Unconstrained_Array_Definition
+ -- Sloc points to ARRAY
+ -- Subtype_Marks (List2)
+ -- Aliased_Present (Flag4) from component definition
+ -- Subtype_Indication (Node5) from component definition
+
+ -----------------------------------
+ -- 3.6 Index Subtype Definition --
+ -----------------------------------
+
+ -- INDEX_SUBTYPE_DEFINITION ::= SUBTYPE_MARK range <>
+
+ -- There is no explicit node in the tree for an index subtype
+ -- definition since the N_Unconstrained_Array_Definition node
+ -- incorporates the type marks which appear in this context.
+
+ ---------------------------------------
+ -- 3.6 Constrained Array Definition --
+ ---------------------------------------
+
+ -- CONSTRAINED_ARRAY_DEFINITION ::=
+ -- array (DISCRETE_SUBTYPE_DEFINITION
+ -- {, DISCRETE_SUBTYPE_DEFINITION})
+ -- of COMPONENT_DEFINITION
+
+ -- Note: dimensionality of array is indicated by number of entries
+ -- in the Discrete_Subtype_Definitions list, which has one entry
+ -- for each dimension.
+
+ -- N_Constrained_Array_Definition
+ -- Sloc points to ARRAY
+ -- Discrete_Subtype_Definitions (List2)
+ -- Aliased_Present (Flag4) from component definition
+ -- Subtype_Indication (Node5) from component definition
+
+ --------------------------------------
+ -- 3.6 Discrete Subtype Definition --
+ --------------------------------------
+
+ -- DISCRETE_SUBTYPE_DEFINITION ::=
+ -- discrete_SUBTYPE_INDICATION | RANGE
+
+ -------------------------------
+ -- 3.6 Component Definition --
+ -------------------------------
+
+ -- COMPONENT_DEFINITION ::= [aliased] SUBTYPE_INDICATION
+
+ -- There is no explicit node in the tree for a component definition.
+ -- Instead the subtype indication appears directly, and the ALIASED
+ -- indication (Aliased_Present flag) is in the parent node.
+
+ -- Note: although the syntax does not permit a component definition to
+ -- be an anonymous array (and the parser will diagnose such an attempt
+ -- with an appropriate message), it is possible for anonymous arrays
+ -- to appear as component definitions. The semantics and back end handle
+ -- this case properly, and the expander in fact generates such cases.
+
+ -----------------------------
+ -- 3.6.1 Index Constraint --
+ -----------------------------
+
+ -- INDEX_CONSTRAINT ::= (DISCRETE_RANGE {, DISCRETE_RANGE})
+
+ -- It is not in general possible to distinguish between discriminant
+ -- constraints and index constraints at parse time, since a simple
+ -- name could be either the subtype mark of a discrete range, or an
+ -- expression in a discriminant association with no name. Either
+ -- entry appears simply as the name, and the semantic parse must
+ -- distinguish between the two cases. Thus we use a common tree
+ -- node format for both of these constraint types.
+
+ -- See Discriminant_Constraint for format of node
+
+ ---------------------------
+ -- 3.6.1 Discrete Range --
+ ---------------------------
+
+ -- DISCRETE_RANGE ::= discrete_SUBTYPE_INDICATION | RANGE
+
+ ----------------------------
+ -- 3.7 Discriminant Part --
+ ----------------------------
+
+ -- DISCRIMINANT_PART ::=
+ -- UNKNOWN_DISCRIMINANT_PART | KNOWN_DISCRIMINANT_PART
+
+ ------------------------------------
+ -- 3.7 Unknown Discriminant Part --
+ ------------------------------------
+
+ -- UNKNOWN_DISCRIMINANT_PART ::= (<>)
+
+ -- Note: unknown discriminant parts are not permitted in Ada 83 mode
+
+ -- There is no explicit node in the tree for an unknown discriminant
+ -- part. Instead the Unknown_Discriminants_Present flag is set in the
+ -- parent node.
+
+ ----------------------------------
+ -- 3.7 Known Discriminant Part --
+ ----------------------------------
+
+ -- KNOWN_DISCRIMINANT_PART ::=
+ -- (DISCRIMINANT_SPECIFICATION {; DISCRIMINANT_SPECIFICATION})
+
+ -------------------------------------
+ -- 3.7 Discriminant Specification --
+ -------------------------------------
+
+ -- DISCRIMINANT_SPECIFICATION ::=
+ -- DEFINING_IDENTIFIER_LIST : SUBTYPE_MARK
+ -- [:= DEFAULT_EXPRESSION]
+ -- | DEFINING_IDENTIFIER_LIST : ACCESS_DEFINITION
+ -- [:= DEFAULT_EXPRESSION]
+
+ -- Although the syntax allows multiple identifiers in the list, the
+ -- semantics is as though successive specifications were given with
+ -- identical type definition and expression components. To simplify
+ -- semantic processing, the parser represents a multiple declaration
+ -- case as a sequence of single specifications, using the More_Ids and
+ -- Prev_Ids flags to preserve the original source form as described
+ -- in the section on "Handling of Defining Identifier Lists".
+
+ -- N_Discriminant_Specification
+ -- Sloc points to first identifier
+ -- Defining_Identifier (Node1)
+ -- Discriminant_Type (Node5) subtype mark or
+ -- access parameter definition
+ -- Expression (Node3) (set to Empty if no default expression)
+ -- More_Ids (Flag5) (set to False if no more identifiers in list)
+ -- Prev_Ids (Flag6) (set to False if no previous identifiers in list)
+
+ -----------------------------
+ -- 3.7 Default Expression --
+ -----------------------------
+
+ -- DEFAULT_EXPRESSION ::= EXPRESSION
+
+ ------------------------------------
+ -- 3.7.1 Discriminant Constraint --
+ ------------------------------------
+
+ -- DISCRIMINANT_CONSTRAINT ::=
+ -- (DISCRIMINANT_ASSOCIATION {, DISCRIMINANT_ASSOCIATION})
+
+ -- It is not in general possible to distinguish between discriminant
+ -- constraints and index constraints at parse time, since a simple
+ -- name could be either the subtype mark of a discrete range, or an
+ -- expression in a discriminant association with no name. Either
+ -- entry appears simply as the name, and the semantic parse must
+ -- distinguish between the two cases. Thus we use a common tree
+ -- node format for both of these constraint types.
+
+ -- N_Index_Or_Discriminant_Constraint
+ -- Sloc points to left paren
+ -- Constraints (List1) points to list of discrete ranges or
+ -- discriminant associations
+
+ -------------------------------------
+ -- 3.7.1 Discriminant Association --
+ -------------------------------------
+
+ -- DISCRIMINANT_ASSOCIATION ::=
+ -- [discriminant_SELECTOR_NAME
+ -- {| discriminant_SELECTOR_NAME} =>] EXPRESSION
+
+ -- Note: a discriminant association that has no selector name list
+ -- appears directly as an expression in the tree.
+
+ -- N_Discriminant_Association
+ -- Sloc points to first token of discriminant association
+ -- Selector_Names (List1) (always non-empty, since if no selector
+ -- names are present, this node is not used, see comment above)
+ -- Expression (Node3)
+
+ ---------------------------------
+ -- 3.8 Record Type Definition --
+ ---------------------------------
+
+ -- RECORD_TYPE_DEFINITION ::=
+ -- [[abstract] tagged] [limited] RECORD_DEFINITION
+
+ -- Note: ABSTRACT, TAGGED, LIMITED are not permitted in Ada 83 mode
+
+ -- There is no explicit node in the tree for a record type definition.
+ -- Instead the flags for Tagged_Present and Limited_Present appear in
+ -- the N_Record_Definition node for a record definition appearing in
+ -- the context of a record type definition.
+
+ ----------------------------
+ -- 3.8 Record Definition --
+ ----------------------------
+
+ -- RECORD_DEFINITION ::=
+ -- record
+ -- COMPONENT_LIST
+ -- end record
+ -- | null record
+
+ -- Note: the Abstract_Present, Tagged_Present and Limited_Present
+ -- flags appear only for a record definition appearing in a record
+ -- type definition.
+
+ -- Note: the NULL RECORD case is not permitted in Ada 83
+
+ -- N_Record_Definition
+ -- Sloc points to RECORD or NULL
+ -- End_Label (Node4) (set to Empty if internally generated record)
+ -- Abstract_Present (Flag4)
+ -- Tagged_Present (Flag15)
+ -- Limited_Present (Flag17)
+ -- Component_List (Node1) empty in null record case
+ -- Null_Present (Flag13) set in null record case
+
+ -------------------------
+ -- 3.8 Component List --
+ -------------------------
+
+ -- COMPONENT_LIST ::=
+ -- COMPONENT_ITEM {COMPONENT_ITEM}
+ -- | {COMPONENT_ITEM} VARIANT_PART
+ -- | null;
+
+ -- N_Component_List
+ -- Sloc points to first token of component list
+ -- Component_Items (List3)
+ -- Variant_Part (Node4) (set to Empty if no variant part)
+ -- Null_Present (Flag13)
+
+ -------------------------
+ -- 3.8 Component Item --
+ -------------------------
+
+ -- COMPONENT_ITEM ::= COMPONENT_DECLARATION | REPRESENTATION_CLAUSE
+
+ -- Note: A component item can also be a pragma, and in the tree
+ -- that is obtained after semantic processing, a component item
+ -- can be an N_Null node resulting from a non-recognized pragma.
+
+ --------------------------------
+ -- 3.8 Component Declaration --
+ --------------------------------
+
+ -- COMPONENT_DECLARATION ::=
+ -- DEFINING_IDENTIFIER_LIST : COMPONENT_DEFINITION
+ -- [:= DEFAULT_EXPRESSION]
+
+ -- Note: although the syntax does not permit a component definition to
+ -- be an anonymous array (and the parser will diagnose such an attempt
+ -- with an appropriate message), it is possible for anonymous arrays
+ -- to appear as component definitions. The semantics and back end handle
+ -- this case properly, and the expander in fact generates such cases.
+
+ -- Although the syntax allows multiple identifiers in the list, the
+ -- semantics is as though successive declarations were given with the
+ -- same component definition and expression components. To simplify
+ -- semantic processing, the parser represents a multiple declaration
+ -- case as a sequence of single declarations, using the More_Ids and
+ -- Prev_Ids flags to preserve the original source form as described
+ -- in the section on "Handling of Defining Identifier Lists".
+
+ -- N_Component_Declaration
+ -- Sloc points to first identifier
+ -- Defining_Identifier (Node1)
+ -- Aliased_Present (Flag4) from component definition
+ -- Subtype_Indication (Node5) from component definition
+ -- Expression (Node3) (set to Empty if no default expression)
+ -- More_Ids (Flag5) (set to False if no more identifiers in list)
+ -- Prev_Ids (Flag6) (set to False if no previous identifiers in list)
+
+ -------------------------
+ -- 3.8.1 Variant Part --
+ -------------------------
+
+ -- VARIANT_PART ::=
+ -- case discriminant_DIRECT_NAME is
+ -- VARIANT
+ -- {VARIANT}
+ -- end case;
+
+ -- Note: the variants list can contain pragmas as well as variants.
+ -- In a properly formed program there is at least one variant.
+
+ -- N_Variant_Part
+ -- Sloc points to CASE
+ -- Name (Node2)
+ -- Variants (List1)
+
+ --------------------
+ -- 3.8.1 Variant --
+ --------------------
+
+ -- VARIANT ::=
+ -- when DISCRETE_CHOICE_LIST =>
+ -- COMPONENT_LIST
+
+ -- N_Variant
+ -- Sloc points to WHEN
+ -- Discrete_Choices (List4)
+ -- Component_List (Node1)
+ -- Enclosing_Variant (Node2-Sem)
+ -- Present_Expr (Uint3-Sem)
+ -- Dcheck_Function (Node5-Sem)
+
+ ---------------------------------
+ -- 3.8.1 Discrete Choice List --
+ ---------------------------------
+
+ -- DISCRETE_CHOICE_LIST ::= DISCRETE_CHOICE {| DISCRETE_CHOICE}
+
+ ----------------------------
+ -- 3.8.1 Discrete Choice --
+ ----------------------------
+
+ -- DISCRETE_CHOICE ::= EXPRESSION | DISCRETE_RANGE | others
+
+ -- Note: in Ada 83 mode, the expression must be a simple expression
+
+ -- The only choice that appears explicitly is the OTHERS choice, as
+ -- defined here. Other cases of discrete choice (expression and
+ -- discrete range) appear directly. This production is also used
+ -- for the OTHERS possibility of an exception choice.
+
+ -- Note: in accordance with the syntax, the parser does not check that
+ -- OTHERS appears at the end on its own in a choice list context. This
+ -- is a semantic check.
+
+ -- N_Others_Choice
+ -- Sloc points to OTHERS
+ -- Others_Discrete_Choices (List1-Sem)
+ -- All_Others (Flag11-Sem)
+
+ ----------------------------------
+ -- 3.9.1 Record Extension Part --
+ ----------------------------------
+
+ -- RECORD_EXTENSION_PART ::= with RECORD_DEFINITION
+
+ -- Note: record extension parts are not permitted in Ada 83 mode
+
+ ----------------------------------
+ -- 3.10 Access Type Definition --
+ ----------------------------------
+
+ -- ACCESS_TYPE_DEFINITION ::=
+ -- ACCESS_TO_OBJECT_DEFINITION
+ -- | ACCESS_TO_SUBPROGRAM_DEFINITION
+
+ ---------------------------------------
+ -- 3.10 Access To Object Definition --
+ ---------------------------------------
+
+ -- ACCESS_TO_OBJECT_DEFINITION ::=
+ -- access [GENERAL_ACCESS_MODIFIER] SUBTYPE_INDICATION
+
+ -- N_Access_To_Object_Definition
+ -- Sloc points to ACCESS
+ -- All_Present (Flag15)
+ -- Subtype_Indication (Node5)
+ -- Constant_Present (Flag17)
+
+ -----------------------------------
+ -- 3.10 General Access Modifier --
+ -----------------------------------
+
+ -- GENERAL_ACCESS_MODIFIER ::= all | constant
+
+ -- Note: general access modifiers are not permitted in Ada 83 mode
+
+ -- There is no explicit node in the tree for general access modifier.
+ -- Instead the All_Present or Constant_Present flags are set in the
+ -- parent node.
+
+ -------------------------------------------
+ -- 3.10 Access To Subprogram Definition --
+ -------------------------------------------
+
+ -- ACCESS_TO_SUBPROGRAM_DEFINITION
+ -- access [protected] procedure PARAMETER_PROFILE
+ -- | access [protected] function PARAMETER_AND_RESULT_PROFILE
+
+ -- Note: access to subprograms are not permitted in Ada 83 mode
+
+ -- N_Access_Function_Definition
+ -- Sloc points to ACCESS
+ -- Protected_Present (Flag15)
+ -- Parameter_Specifications (List3) (set to No_List if no formal part)
+ -- Subtype_Mark (Node4) result subtype
+
+ -- N_Access_Procedure_Definition
+ -- Sloc points to ACCESS
+ -- Protected_Present (Flag15)
+ -- Parameter_Specifications (List3) (set to No_List if no formal part)
+
+ -----------------------------
+ -- 3.10 Access Definition --
+ -----------------------------
+
+ -- ACCESS_DEFINITION ::= access SUBTYPE_MARK
+
+ -- N_Access_Definition
+ -- Sloc points to ACCESS
+ -- Subtype_Mark (Node4)
+
+ -----------------------------------------
+ -- 3.10.1 Incomplete Type Declaration --
+ -----------------------------------------
+
+ -- INCOMPLETE_TYPE_DECLARATION ::=
+ -- type DEFINING_IDENTIFIER [DISCRIMINANT_PART];
+
+ -- N_Incomplete_Type_Declaration
+ -- Sloc points to TYPE
+ -- Defining_Identifier (Node1)
+ -- Discriminant_Specifications (List4) (set to No_List if no
+ -- discriminant part, or if the discriminant part is an
+ -- unknown discriminant part)
+ -- Unknown_Discriminants_Present (Flag13) set if (<>) discriminant
+
+ ----------------------------
+ -- 3.11 Declarative Part --
+ ----------------------------
+
+ -- DECLARATIVE_PART ::= {DECLARATIVE_ITEM}
+
+ -- Note: although the parser enforces the syntactic requirement that
+ -- a declarative part can contain only declarations, the semantic
+ -- processing may add statements to the list of actions in a
+ -- declarative part, so the code generator should be prepared
+ -- to accept a statement in this position.
+
+ ----------------------------
+ -- 3.11 Declarative Item --
+ ----------------------------
+
+ -- DECLARATIVE_ITEM ::= BASIC_DECLARATIVE_ITEM | BODY
+
+ ----------------------------------
+ -- 3.11 Basic Declarative Item --
+ ----------------------------------
+
+ -- BASIC_DECLARATIVE_ITEM ::=
+ -- BASIC_DECLARATION | REPRESENTATION_CLAUSE | USE_CLAUSE
+
+ ----------------
+ -- 3.11 Body --
+ ----------------
+
+ -- BODY ::= PROPER_BODY | BODY_STUB
+
+ -----------------------
+ -- 3.11 Proper Body --
+ -----------------------
+
+ -- PROPER_BODY ::=
+ -- SUBPROGRAM_BODY | PACKAGE_BODY | TASK_BODY | PROTECTED_BODY
+
+ ---------------
+ -- 4.1 Name --
+ ---------------
+
+ -- NAME ::=
+ -- DIRECT_NAME | EXPLICIT_DEREFERENCE
+ -- | INDEXED_COMPONENT | SLICE
+ -- | SELECTED_COMPONENT | ATTRIBUTE_REFERENCE
+ -- | TYPE_CONVERSION | FUNCTION_CALL
+ -- | CHARACTER_LITERAL
+
+ ----------------------
+ -- 4.1 Direct Name --
+ ----------------------
+
+ -- DIRECT_NAME ::= IDENTIFIER | OPERATOR_SYMBOL
+
+ -----------------
+ -- 4.1 Prefix --
+ -----------------
+
+ -- PREFIX ::= NAME | IMPLICIT_DEREFERENCE
+
+ -------------------------------
+ -- 4.1 Explicit Dereference --
+ -------------------------------
+
+ -- EXPLICIT_DEREFERENCE ::= NAME . all
+
+ -- N_Explicit_Dereference
+ -- Sloc points to ALL
+ -- Prefix (Node3)
+ -- Do_Access_Check (Flag11-Sem)
+ -- plus fields for expression
+
+ -------------------------------
+ -- 4.1 Implicit Dereference --
+ -------------------------------
+
+ -- IMPLICIT_DEREFERENCE ::= NAME
+
+ ------------------------------
+ -- 4.1.1 Indexed Component --
+ ------------------------------
+
+ -- INDEXED_COMPONENT ::= PREFIX (EXPRESSION {, EXPRESSION})
+
+ -- Note: the parser may generate this node in some situations where it
+ -- should be a function call. The semantic pass must correct this
+ -- misidentification (which is inevitable at the parser level).
+
+ -- N_Indexed_Component
+ -- Sloc contains a copy of the Sloc value of the Prefix
+ -- Prefix (Node3)
+ -- Expressions (List1)
+ -- Do_Access_Check (Flag11-Sem)
+ -- plus fields for expression
+
+ -- Note: if any of the subscripts requires a range check, then the
+ -- Do_Range_Check flag is set on the corresponding expression, with
+ -- the index type being determined from the type of the Prefix, which
+ -- references the array being indexed.
+
+ -- Note: in a fully analyzed and expanded indexed component node, and
+ -- hence in any such node that gigi sees, if the prefix is an access
+ -- type, then an explicit dereference operation has been inserted.
+
+ ------------------
+ -- 4.1.2 Slice --
+ ------------------
+
+ -- SLICE ::= PREFIX (DISCRETE_RANGE)
+
+ -- Note: an implicit subtype is created to describe the resulting
+ -- type, so that the bounds of this type are the bounds of the slice.
+
+ -- N_Slice
+ -- Sloc points to first token of prefix
+ -- Prefix (Node3)
+ -- Discrete_Range (Node4)
+ -- Do_Access_Check (Flag11-Sem)
+ -- plus fields for expression
+
+ -------------------------------
+ -- 4.1.3 Selected Component --
+ -------------------------------
+
+ -- SELECTED_COMPONENT ::= PREFIX . SELECTOR_NAME
+
+ -- Note: selected components that are semantically expanded names get
+ -- changed during semantic processing into the separate N_Expanded_Name
+ -- node. See description of this node in the section on semantic nodes.
+
+ -- N_Selected_Component
+ -- Sloc points to period
+ -- Prefix (Node3)
+ -- Selector_Name (Node2)
+ -- Do_Access_Check (Flag11-Sem)
+ -- Do_Discriminant_Check (Flag13-Sem)
+ -- plus fields for expression
+
+ --------------------------
+ -- 4.1.3 Selector Name --
+ --------------------------
+
+ -- SELECTOR_NAME ::= IDENTIFIER | CHARACTER_LITERAL | OPERATOR_SYMBOL
+
+ --------------------------------
+ -- 4.1.4 Attribute Reference --
+ --------------------------------
+
+ -- ATTRIBUTE_REFERENCE ::= PREFIX ' ATTRIBUTE_DESIGNATOR
+
+ -- Note: the syntax is quite ambiguous at this point. Consider:
+
+ -- A'Length (X) X is part of the attribute designator
+ -- A'Pos (X) X is an explicit actual parameter of function A'Pos
+ -- A'Class (X) X is the expression of a type conversion
+
+ -- It would be possible for the parser to distinguish these cases
+ -- by looking at the attribute identifier. However, that would mean
+ -- more work in introducing new implementation defined attributes,
+ -- and also it would mean that special processing for attributes
+ -- would be scattered around, instead of being centralized in the
+ -- semantic routine that handles an N_Attribute_Reference node.
+ -- Consequently, the parser in all the above cases stores the
+ -- expression (X in these examples) as a single element list in
+ -- in the Expressions field of the N_Attribute_Reference node.
+
+ -- Similarly, for attributes like Max which take two arguments,
+ -- we store the two arguments as a two element list in the
+ -- Expressions field. Of course it is clear at parse time that
+ -- this case is really a function call with an attribute as the
+ -- prefix, but it turns out to be convenient to handle the two
+ -- argument case in a similar manner to the one argument case,
+ -- and indeed in general the parser will accept any number of
+ -- expressions in this position and store them as a list in the
+ -- attribute reference node. This allows for future addition of
+ -- attributes that take more than two arguments.
+
+ -- Note: named associates are not permitted in function calls where
+ -- the function is an attribute (see RM 6.4(3)) so it is legitimate
+ -- to skip the normal subprogram argument processing.
+
+ -- Note: for the attributes whose designators are technically keywords,
+ -- i.e. digits, access, delta, range, the Attribute_Name field contains
+ -- the corresponding name, even though no identifier is involved.
+
+ -- The flag OK_For_Stream is used in generated code to indicate that
+ -- a stream attribute is permissible for a limited type, and results
+ -- in the use of the stream attribute for the underlying full type,
+ -- or in the case of a protected type, the components (including any
+ -- disriminants) are merely streamed in order.
+
+ -- See Exp_Attr for a complete description of which attributes are
+ -- passed onto Gigi, and which are handled entirely by the front end.
+
+ -- Gigi restriction: For the Pos attribute, the prefix cannot be
+ -- a non-standard enumeration type or a nonzero/zero semantics
+ -- boolean type, so the value is simply the stored representation.
+
+ -- N_Attribute_Reference
+ -- Sloc points to apostrophe
+ -- Prefix (Node3)
+ -- Attribute_Name (Name2) identifier name from attribute designator
+ -- Expressions (List1) (set to No_List if no associated expressions)
+ -- Entity (Node4-Sem) used if the attribute yields a type
+ -- Do_Access_Check (Flag11-Sem)
+ -- Do_Overflow_Check (Flag17-Sem)
+ -- Redundant_Use (Flag13-Sem)
+ -- OK_For_Stream (Flag4-Sem)
+ -- plus fields for expression
+
+ ---------------------------------
+ -- 4.1.4 Attribute Designator --
+ ---------------------------------
+
+ -- ATTRIBUTE_DESIGNATOR ::=
+ -- IDENTIFIER [(static_EXPRESSION)]
+ -- | access | delta | digits
+
+ -- There is no explicit node in the tree for an attribute designator.
+ -- Instead the Attribute_Name and Expressions fields of the parent
+ -- node (N_Attribute_Reference node) hold the information.
+
+ -- Note: if ACCESS, DELTA or DIGITS appears in an attribute
+ -- designator, then they are treated as identifiers internally
+ -- rather than the keywords of the same name.
+
+ --------------------------------------
+ -- 4.1.4 Range Attribute Reference --
+ --------------------------------------
+
+ -- RANGE_ATTRIBUTE_REFERENCE ::= PREFIX ' RANGE_ATTRIBUTE_DESIGNATOR
+
+ -- A range attribute reference is represented in the tree using the
+ -- normal N_Attribute_Reference node.
+
+ ---------------------------------------
+ -- 4.1.4 Range Attribute Designator --
+ ---------------------------------------
+
+ -- RANGE_ATTRIBUTE_DESIGNATOR ::= Range [(static_EXPRESSION)]
+
+ -- A range attribute designator is represented in the tree using the
+ -- normal N_Attribute_Reference node.
+
+ --------------------
+ -- 4.3 Aggregate --
+ --------------------
+
+ -- AGGREGATE ::=
+ -- RECORD_AGGREGATE | EXTENSION_AGGREGATE | ARRAY_AGGREGATE
+
+ -----------------------------
+ -- 4.3.1 Record Aggregate --
+ -----------------------------
+
+ -- RECORD_AGGREGATE ::= (RECORD_COMPONENT_ASSOCIATION_LIST)
+
+ -- N_Aggregate
+ -- Sloc points to left parenthesis
+ -- Expressions (List1) (set to No_List if none or null record case)
+ -- Component_Associations (List2) (set to No_List if none)
+ -- Null_Record_Present (Flag17)
+ -- Aggregate_Bounds (Node3-Sem)
+ -- Static_Processing_OK (Flag4-Sem)
+ -- Compile_Time_Known_Aggregate (Flag18-Sem)
+ -- Expansion_Delayed (Flag11-Sem)
+ -- plus fields for expression
+
+ -- Note: this structure is used for both record and array aggregates
+ -- since the two cases are not separable by the parser. The parser
+ -- makes no attempt to enforce consistency here, so it is up to the
+ -- semantic phase to make sure that the aggregate is consistent (i.e.
+ -- that it is not a "half-and-half" case that mixes record and array
+ -- syntax. In particular, for a record aggregate, the expressions
+ -- field will be set if there are positional associations.
+
+ -- Note: gigi/gcc can handle array aggregates correctly providing that
+ -- they are entirely positional, and the array subtype involved has a
+ -- known at compile time length and is not bit packed, or a convention
+ -- Fortran array with more than one dimension. If these conditions
+ -- are not met, then the front end must translate the aggregate into
+ -- an appropriate set of assignments into a temporary.
+
+ -- Note: for the record aggregate case, gigi/gcc can handle all cases
+ -- of record aggregates, including those for packed, and rep-claused
+ -- records, and also variant records, providing that there are no
+ -- variable length fields whose size is not known at runtime, and
+ -- providing that the aggregate is presented in fully named form.
+
+ ----------------------------------------------
+ -- 4.3.1 Record Component Association List --
+ ----------------------------------------------
+
+ -- RECORD_COMPONENT_ASSOCIATION_LIST ::=
+ -- RECORD_COMPONENT_ASSOCIATION {, RECORD_COMPONENT_ASSOCIATION}
+ -- | null record
+
+ -- There is no explicit node in the tree for a record component
+ -- association list. Instead the Null_Record_Present flag is set in
+ -- the parent node for the NULL RECORD case.
+
+ ------------------------------------------------------
+ -- 4.3.1 Record Component Association (also 4.3.3) --
+ ------------------------------------------------------
+
+ -- RECORD_COMPONENT_ASSOCIATION ::=
+ -- [COMPONENT_CHOICE_LIST =>] EXPRESSION
+
+ -- N_Component_Association
+ -- Sloc points to first selector name
+ -- Choices (List1)
+ -- Loop_Actions (List2-Sem)
+ -- Expression (Node3)
+
+ -- Note: this structure is used for both record component associations
+ -- and array component associations, since the two cases aren't always
+ -- separable by the parser. The choices list may represent either a
+ -- list of selector names in the record aggregate case, or a list of
+ -- discrete choices in the array aggregate case or an N_Others_Choice
+ -- node (which appears as a singleton list).
+
+ ------------------------------------
+ -- 4.3.1 Commponent Choice List --
+ ------------------------------------
+
+ -- COMPONENT_CHOICE_LIST ::=
+ -- component_SELECTOR_NAME {| component_SELECTOR_NAME}
+ -- | others
+
+ -- The entries of a component choice list appear in the Choices list
+ -- of the associated N_Component_Association, as either selector
+ -- names, or as an N_Others_Choice node.
+
+ --------------------------------
+ -- 4.3.2 Extension Aggregate --
+ --------------------------------
+
+ -- EXTENSION_AGGREGATE ::=
+ -- (ANCESTOR_PART with RECORD_COMPONENT_ASSOCIATION_LIST)
+
+ -- Note: extension aggregates are not permitted in Ada 83 mode
+
+ -- N_Extension_Aggregate
+ -- Sloc points to left parenthesis
+ -- Ancestor_Part (Node3)
+ -- Expressions (List1) (set to No_List if none or null record case)
+ -- Component_Associations (List2) (set to No_List if none)
+ -- Null_Record_Present (Flag17)
+ -- Expansion_Delayed (Flag11-Sem)
+ -- plus fields for expression
+
+ --------------------------
+ -- 4.3.2 Ancestor Part --
+ --------------------------
+
+ -- ANCESTOR_PART ::= EXPRESSION | SUBTYPE_MARK
+
+ ----------------------------
+ -- 4.3.3 Array Aggregate --
+ ----------------------------
+
+ -- ARRAY_AGGREGATE ::=
+ -- POSITIONAL_ARRAY_AGGREGATE | NAMED_ARRAY_AGGREGATE
+
+ ---------------------------------------
+ -- 4.3.3 Positional Array Aggregate --
+ ---------------------------------------
+
+ -- POSITIONAL_ARRAY_AGGREGATE ::=
+ -- (EXPRESSION, EXPRESSION {, EXPRESSION})
+ -- | (EXPRESSION {, EXPRESSION}, others => EXPRESSION)
+
+ -- See Record_Aggregate (4.3.1) for node structure
+
+ ----------------------------------
+ -- 4.3.3 Named Array Aggregate --
+ ----------------------------------
+
+ -- NAMED_ARRAY_AGGREGATE ::=
+ -- | (ARRAY_COMPONENT_ASSOCIATION {, ARRAY_COMPONENT_ASSOCIATION})
+
+ -- See Record_Aggregate (4.3.1) for node structure
+
+ ----------------------------------------
+ -- 4.3.3 Array Component Association --
+ ----------------------------------------
+
+ -- ARRAY_COMPONENT_ASSOCIATION ::=
+ -- DISCRETE_CHOICE_LIST => EXPRESSION
+
+ -- See Record_Component_Association (4.3.1) for node structure
+
+ --------------------------------------------------
+ -- 4.4 Expression/Relation/Term/Factor/Primary --
+ --------------------------------------------------
+
+ -- EXPRESSION ::=
+ -- RELATION {and RELATION} | RELATION {and then RELATION}
+ -- | RELATION {or RELATION} | RELATION {or else RELATION}
+ -- | RELATION {xor RELATION}
+
+ -- RELATION ::=
+ -- SIMPLE_EXPRESSION [RELATIONAL_OPERATOR SIMPLE_EXPRESSION]
+ -- | SIMPLE_EXPRESSION [not] in RANGE
+ -- | SIMPLE_EXPRESSION [not] in SUBTYPE_MARK
+
+ -- SIMPLE_EXPRESSION ::=
+ -- [UNARY_ADDING_OPERATOR] TERM {BINARY_ADDING_OPERATOR TERM}
+
+ -- TERM ::= FACTOR {MULTIPLYING_OPERATOR FACTOR}
+
+ -- FACTOR ::= PRIMARY [** PRIMARY] | abs PRIMARY | not PRIMARY
+
+ -- No nodes are generated for any of these constructs. Instead, the
+ -- node for the operator appears directly. When we refer to an
+ -- expression in this description, we mean any of the possible
+ -- consistuent components of an expression (e.g. identifier is
+ -- an example of an expression).
+
+ ------------------
+ -- 4.4 Primary --
+ ------------------
+
+ -- PRIMARY ::=
+ -- NUMERIC_LITERAL | null
+ -- | STRING_LITERAL | AGGREGATE
+ -- | NAME | QUALIFIED_EXPRESSION
+ -- | ALLOCATOR | (EXPRESSION)
+
+ -- Usually there is no explicit node in the tree for primary. Instead
+ -- the constituent (e.g. AGGREGATE) appears directly. There are two
+ -- exceptions. First, there is an explicit node for a null primary.
+
+ -- N_Null
+ -- Sloc points to NULL
+ -- plus fields for expression
+
+ -- Second, the case of (EXPRESSION) is handled specially. Ada requires
+ -- that the parser keep track of which subexpressions are enclosed
+ -- in parentheses, and how many levels of parentheses are used. This
+ -- information is required for optimization purposes, and also for
+ -- some semantic checks (e.g. (((1))) in a procedure spec does not
+ -- conform with ((((1)))) in the body).
+
+ -- The parentheses are recorded by keeping a Paren_Count field in every
+ -- subexpression node (it is actually present in all nodes, but only
+ -- used in subexpression nodes). This count records the number of
+ -- levels of parentheses. If the number of levels in the source exceeds
+ -- the maximum accomodated by this count, then the count is simply left
+ -- at the maximum value. This means that there are some pathalogical
+ -- cases of failure to detect conformance failures (e.g. an expression
+ -- with 500 levels of parens will conform with one with 501 levels),
+ -- but we do not need to lose sleep over this.
+
+ -- Historical note: in versions of GNAT prior to 1.75, there was a node
+ -- type N_Parenthesized_Expression used to accurately record unlimited
+ -- numbers of levels of parentheses. However, it turned out to be a
+ -- real nuisance to have to take into account the possible presence of
+ -- this node during semantic analysis, since basically parentheses have
+ -- zero relevance to semantic analysis.
+
+ -- Note: the level of parentheses always present in things like
+ -- aggregates does not count, only the parentheses in the primary
+ -- (EXPRESSION) affect the setting of the Paren_Count field.
+
+ -- 2nd Note: the contents of the Expression field must be ignored (i.e.
+ -- treated as though it were Empty) if No_Initialization is set True.
+
+ --------------------------------------
+ -- 4.5 Short Circuit Control Forms --
+ --------------------------------------
+
+ -- EXPRESSION ::=
+ -- RELATION {and then RELATION} | RELATION {or else RELATION}
+
+ -- Gigi restriction: For both these control forms, the operand and
+ -- result types are always Standard.Boolean. The expander inserts the
+ -- required conversion operations where needed to ensure this is the
+ -- case.
+
+ -- N_And_Then
+ -- Sloc points to AND of AND THEN
+ -- Left_Opnd (Node2)
+ -- Right_Opnd (Node3)
+ -- Actions (List1-Sem)
+ -- plus fields for expression
+
+ -- N_Or_Else
+ -- Sloc points to OR of OR ELSE
+ -- Left_Opnd (Node2)
+ -- Right_Opnd (Node3)
+ -- Actions (List1-Sem)
+ -- plus fields for expression
+
+ -- Note: The Actions field is used to hold actions associated with
+ -- the right hand operand. These have to be treated specially since
+ -- they are not unconditionally executed. See Insert_Actions for a
+ -- more detailed description of how these actions are handled.
+
+ ---------------------------
+ -- 4.5 Membership Tests --
+ ---------------------------
+
+ -- RELATION ::=
+ -- SIMPLE_EXPRESSION [not] in RANGE
+ -- | SIMPLE_EXPRESSION [not] in SUBTYPE_MARK
+
+ -- Note: although the grammar above allows only a range or a
+ -- subtype mark, the parser in fact will accept any simple
+ -- expression in place of a subtype mark. This means that the
+ -- semantic analyzer must be prepared to deal with, and diagnose
+ -- a simple expression other than a name for the right operand.
+ -- This simplifies error recovery in the parser.
+
+ -- N_In
+ -- Sloc points to IN
+ -- Left_Opnd (Node2)
+ -- Right_Opnd (Node3)
+ -- plus fields for expression
+
+ -- N_Not_In
+ -- Sloc points to NOT of NOT IN
+ -- Left_Opnd (Node2)
+ -- Right_Opnd (Node3)
+ -- plus fields for expression
+
+ --------------------
+ -- 4.5 Operators --
+ --------------------
+
+ -- LOGICAL_OPERATOR ::= and | or | xor
+
+ -- RELATIONAL_OPERATOR ::= = | /= | < | <= | > | >=
+
+ -- BINARY_ADDING_OPERATOR ::= + | - | &
+
+ -- UNARY_ADDING_OPERATOR ::= + | -
+
+ -- MULTIPLYING_OPERATOR ::= * | / | mod | rem
+
+ -- HIGHEST_PRECEDENCE_OPERATOR ::= ** | abs | not
+
+ -- Sprint syntax if Treat_Fixed_As_Integer is set:
+
+ -- x #* y
+ -- x #/ y
+ -- x #mod y
+ -- x #rem y
+
+ -- Gigi restriction: For * / mod rem with fixed-point operands, Gigi
+ -- will only be given nodes with the Treat_Fixed_As_Integer flag set.
+ -- All handling of smalls for multiplication and division is handled
+ -- by the front end (mod and rem result only from expansion). Gigi
+ -- thus never needs to worry about small values (for other operators
+ -- operating on fixed-point, e.g. addition, the small value does not
+ -- have any semantic effect anyway, these are always integer operations.
+
+ -- Gigi restriction: For all operators taking Boolean operands, the
+ -- type is always Standard.Boolean. The expander inserts the required
+ -- conversion operations where needed to ensure this is the case.
+
+ -- N_Op_And
+ -- Sloc points to AND
+ -- Do_Length_Check (Flag4-Sem)
+ -- plus fields for binary operator
+ -- plus fields for expression
+
+ -- N_Op_Or
+ -- Sloc points to OR
+ -- Do_Length_Check (Flag4-Sem)
+ -- plus fields for binary operator
+ -- plus fields for expression
+
+ -- N_Op_Xor
+ -- Sloc points to XOR
+ -- Do_Length_Check (Flag4-Sem)
+ -- plus fields for binary operator
+ -- plus fields for expression
+
+ -- N_Op_Eq
+ -- Sloc points to =
+ -- plus fields for binary operator
+ -- plus fields for expression
+
+ -- N_Op_Ne
+ -- Sloc points to /=
+ -- plus fields for binary operator
+ -- plus fields for expression
+
+ -- N_Op_Lt
+ -- Sloc points to <
+ -- plus fields for binary operator
+ -- plus fields for expression
+
+ -- N_Op_Le
+ -- Sloc points to <=
+ -- plus fields for binary operator
+ -- plus fields for expression
+
+ -- N_Op_Gt
+ -- Sloc points to >
+ -- plus fields for binary operator
+ -- plus fields for expression
+
+ -- N_Op_Ge
+ -- Sloc points to >=
+ -- plus fields for binary operator
+ -- plus fields for expression
+
+ -- N_Op_Add
+ -- Sloc points to + (binary)
+ -- plus fields for binary operator
+ -- plus fields for expression
+
+ -- N_Op_Subtract
+ -- Sloc points to - (binary)
+ -- plus fields for binary operator
+ -- plus fields for expression
+
+ -- N_Op_Concat
+ -- Sloc points to &
+ -- Is_Component_Left_Opnd (Flag13-Sem)
+ -- Is_Component_Right_Opnd (Flag14-Sem)
+ -- plus fields for binary operator
+ -- plus fields for expression
+
+ -- N_Op_Multiply
+ -- Sloc points to *
+ -- Treat_Fixed_As_Integer (Flag14-Sem)
+ -- Rounded_Result (Flag18-Sem)
+ -- plus fields for binary operator
+ -- plus fields for expression
+
+ -- N_Op_Divide
+ -- Sloc points to /
+ -- Treat_Fixed_As_Integer (Flag14-Sem)
+ -- Do_Division_Check (Flag13-Sem)
+ -- Rounded_Result (Flag18-Sem)
+ -- plus fields for binary operator
+ -- plus fields for expression
+
+ -- N_Op_Mod
+ -- Sloc points to MOD
+ -- Treat_Fixed_As_Integer (Flag14-Sem)
+ -- Do_Division_Check (Flag13-Sem)
+ -- plus fields for binary operator
+ -- plus fields for expression
+
+ -- N_Op_Rem
+ -- Sloc points to REM
+ -- Treat_Fixed_As_Integer (Flag14-Sem)
+ -- Do_Division_Check (Flag13-Sem)
+ -- plus fields for binary operator
+ -- plus fields for expression
+
+ -- N_Op_Expon
+ -- Is_Power_Of_2_For_Shift (Flag13-Sem)
+ -- Sloc points to **
+ -- plus fields for binary operator
+ -- plus fields for expression
+
+ -- N_Op_Plus
+ -- Sloc points to + (unary)
+ -- plus fields for unary operator
+ -- plus fields for expression
+
+ -- N_Op_Minus
+ -- Sloc points to - (unary)
+ -- plus fields for unary operator
+ -- plus fields for expression
+
+ -- N_Op_Abs
+ -- Sloc points to ABS
+ -- plus fields for unary operator
+ -- plus fields for expression
+
+ -- N_Op_Not
+ -- Sloc points to NOT
+ -- plus fields for unary operator
+ -- plus fields for expression
+
+ -- See also shift operators in section B.2
+
+ -- Note on fixed-point operations passed to Gigi: For adding operators,
+ -- the semantics is to treat these simply as integer operations, with
+ -- the small values being ignored (the bounds are already stored in
+ -- units of small, so that constraint checking works as usual). For the
+ -- case of multiply/divide/rem/mod operations, Gigi will only see fixed
+ -- point operands if the Treat_Fixed_As_Integer flag is set and will
+ -- thus treat these nodes in identical manner, ignoring small values.
+
+ --------------------------
+ -- 4.6 Type Conversion --
+ --------------------------
+
+ -- TYPE_CONVERSION ::=
+ -- SUBTYPE_MARK (EXPRESSION) | SUBTYPE_MARK (NAME)
+
+ -- In the (NAME) case, the name is stored as the expression
+
+ -- Note: the parser never generates a type conversion node, since it
+ -- looks like an indexed component which is generated by preference.
+ -- The semantic pass must correct this misidentification.
+
+ -- Gigi handles conversions that involve no change in the root type,
+ -- and also all conversions from integer to floating-point types.
+ -- Conversions from floating-point to integer are only handled in
+ -- the case where Float_Truncate flag set. Other conversions from
+ -- floating-point to integer (involving rounding) and all conversions
+ -- involving fixed-point types are handled by the expander.
+
+ -- Sprint syntax if Float_Truncate set: X^(Y)
+ -- Sprint syntax if Conversion_OK set X?(Y)
+ -- Sprint syntax if both flags set X?^(Y)
+
+ -- Note: If either the operand or result type is fixed-point, Gigi will
+ -- only see a type conversion node with Conversion_OK set. The front end
+ -- takes care of all handling of small's for fixed-point conversions.
+
+ -- N_Type_Conversion
+ -- Sloc points to first token of subtype mark
+ -- Subtype_Mark (Node4)
+ -- Expression (Node3)
+ -- Do_Overflow_Check (Flag17-Sem)
+ -- Do_Tag_Check (Flag13-Sem)
+ -- Do_Length_Check (Flag4-Sem)
+ -- Float_Truncate (Flag11-Sem)
+ -- Rounded_Result (Flag18-Sem)
+ -- Conversion_OK (Flag14-Sem)
+ -- plus fields for expression
+
+ -- Note: if a range check is required, then the Do_Range_Check flag
+ -- is set in the Expression with the check being done against the
+ -- target type range (after the base type conversion, if any).
+
+ -------------------------------
+ -- 4.7 Qualified Expression --
+ -------------------------------
+
+ -- QUALIFIED_EXPRESSION ::=
+ -- SUBTYPE_MARK ' (EXPRESSION) | SUBTYPE_MARK ' AGGREGATE
+
+ -- Note: the parentheses in the (EXPRESSION) case are deemed to enclose
+ -- the expression, so the Expression field of this node always points
+ -- to a parenthesized expression in this case (i.e. Paren_Count will
+ -- always be non-zero for the referenced expression if it is not an
+ -- aggregate).
+
+ -- N_Qualified_Expression
+ -- Sloc points to apostrophe
+ -- Subtype_Mark (Node4)
+ -- Expression (Node3) expression or aggregate
+ -- plus fields for expression
+
+ --------------------
+ -- 4.8 Allocator --
+ --------------------
+
+ -- ALLOCATOR ::=
+ -- new SUBTYPE_INDICATION | new QUALIFIED_EXPRESSION
+
+ -- Sprint syntax (when storage pool present)
+ -- new xxx (storage_pool = pool)
+
+ -- N_Allocator
+ -- Sloc points to NEW
+ -- Expression (Node3) subtype indication or qualified expression
+ -- Storage_Pool (Node1-Sem)
+ -- Procedure_To_Call (Node4-Sem)
+ -- No_Initialization (Flag13-Sem)
+ -- Do_Storage_Check (Flag17-Sem)
+ -- plus fields for expression
+
+ ---------------------------------
+ -- 5.1 Sequence Of Statements --
+ ---------------------------------
+
+ -- SEQUENCE_OF_STATEMENTS ::= STATEMENT {STATEMENT}
+
+ -- Note: Although the parser will not accept a declaration as a
+ -- statement, the semantic analyzer may insert declarations (e.g.
+ -- declarations of implicit types needed for execution of other
+ -- statements) into a sequence of statements, so the code genmerator
+ -- should be prepared to accept a declaration where a statement is
+ -- expected. Note also that pragmas can appear as statements.
+
+ --------------------
+ -- 5.1 Statement --
+ --------------------
+
+ -- STATEMENT ::=
+ -- {LABEL} SIMPLE_STATEMENT | {LABEL} COMPOUND_STATEMENT
+
+ -- There is no explicit node in the tree for a statement. Instead, the
+ -- individual statement appears directly. Labels are treated as a
+ -- kind of statement, i.e. they are linked into a statement list at
+ -- the point they appear, so the labeled statement appears following
+ -- the label or labels in the statement list.
+
+ ---------------------------
+ -- 5.1 Simple Statement --
+ ---------------------------
+
+ -- SIMPLE_STATEMENT ::= NULL_STATEMENT
+ -- | ASSIGNMENT_STATEMENT | EXIT_STATEMENT
+ -- | GOTO_STATEMENT | PROCEDURE_CALL_STATEMENT
+ -- | RETURN_STATEMENT | ENTRY_CALL_STATEMENT
+ -- | REQUEUE_STATEMENT | DELAY_STATEMENT
+ -- | ABORT_STATEMENT | RAISE_STATEMENT
+ -- | CODE_STATEMENT
+
+ -----------------------------
+ -- 5.1 Compound Statement --
+ -----------------------------
+
+ -- COMPOUND_STATEMENT ::=
+ -- IF_STATEMENT | CASE_STATEMENT
+ -- | LOOP_STATEMENT | BLOCK_STATEMENT
+ -- | ACCEPT_STATEMENT | SELECT_STATEMENT
+
+ -------------------------
+ -- 5.1 Null Statement --
+ -------------------------
+
+ -- NULL_STATEMENT ::= null;
+
+ -- N_Null_Statement
+ -- Sloc points to NULL
+
+ ----------------
+ -- 5.1 Label --
+ ----------------
+
+ -- LABEL ::= <<label_STATEMENT_IDENTIFIER>>
+
+ -- Note that the occurrence of a label is not a defining identifier,
+ -- but rather a referencing occurrence. The defining occurrence is
+ -- in the implicit label declaration which occurs in the innermost
+ -- enclosing block.
+
+ -- N_Label
+ -- Sloc points to <<
+ -- Identifier (Node1) direct name of statement identifier
+ -- Exception_Junk (Flag11-Sem)
+
+ -------------------------------
+ -- 5.1 Statement Identifier --
+ -------------------------------
+
+ -- STATEMENT_INDENTIFIER ::= DIRECT_NAME
+
+ -- The IDENTIFIER of a STATEMENT_IDENTIFIER shall be an identifier
+ -- (not an OPERATOR_SYMBOL)
+
+ -------------------------------
+ -- 5.2 Assignment Statement --
+ -------------------------------
+
+ -- ASSIGNMENT_STATEMENT ::=
+ -- variable_NAME := EXPRESSION;
+
+ -- N_Assignment_Statement
+ -- Sloc points to :=
+ -- Name (Node2)
+ -- Expression (Node3)
+ -- Do_Tag_Check (Flag13-Sem)
+ -- Do_Length_Check (Flag4-Sem)
+ -- Forwards_OK (Flag5-Sem)
+ -- Backwards_OK (Flag6-Sem)
+ -- No_Ctrl_Actions (Flag7-Sem)
+
+ -- Note: if a range check is required, then the Do_Range_Check flag
+ -- is set in the Expression (right hand side), with the check being
+ -- done against the type of the Name (left hand side).
+
+ -----------------------
+ -- 5.3 If Statement --
+ -----------------------
+
+ -- IF_STATEMENT ::=
+ -- if CONDITION then
+ -- SEQUENCE_OF_STATEMENTS
+ -- {elsif CONDITION then
+ -- SEQUENCE_OF_STATEMENTS}
+ -- [else
+ -- SEQUENCE_OF_STATEMENTS]
+ -- end if;
+
+ -- Gigi restriction: This expander ensures that the type of the
+ -- Condition fields is always Standard.Boolean, even if the type
+ -- in the source is some non-standard boolean type.
+
+ -- N_If_Statement
+ -- Sloc points to IF
+ -- Condition (Node1)
+ -- Then_Statements (List2)
+ -- Elsif_Parts (List3) (set to No_List if none present)
+ -- Else_Statements (List4) (set to No_List if no else part present)
+ -- End_Span (Uint5) (set to No_Uint if expander generated)
+
+ -- N_Elsif_Part
+ -- Sloc points to ELSIF
+ -- Condition (Node1)
+ -- Then_Statements (List2)
+ -- Condition_Actions (List3-Sem)
+
+ --------------------
+ -- 5.3 Condition --
+ --------------------
+
+ -- CONDITION ::= boolean_EXPRESSION
+
+ -------------------------
+ -- 5.4 Case Statement --
+ -------------------------
+
+ -- CASE_STATEMENT ::=
+ -- case EXPRESSION is
+ -- CASE_STATEMENT_ALTERNATIVE
+ -- {CASE_STATEMENT_ALTERNATIVE}
+ -- end case;
+
+ -- Note: the Alternatives can contain pragmas. These only occur at
+ -- the start of the list, since any pragmas occurring after the first
+ -- alternative are absorbed into the corresponding statement sequence.
+
+ -- N_Case_Statement
+ -- Sloc points to CASE
+ -- Expression (Node3)
+ -- Alternatives (List4)
+ -- End_Span (Uint5) (set to No_Uint if expander generated)
+
+ -------------------------------------
+ -- 5.4 Case Statement Alternative --
+ -------------------------------------
+
+ -- CASE_STATEMENT_ALTERNATIVE ::=
+ -- when DISCRETE_CHOICE_LIST =>
+ -- SEQUENCE_OF_STATEMENTS
+
+ -- N_Case_Statement_Alternative
+ -- Sloc points to WHEN
+ -- Discrete_Choices (List4)
+ -- Statements (List3)
+
+ -------------------------
+ -- 5.5 Loop Statement --
+ -------------------------
+
+ -- LOOP_STATEMENT ::=
+ -- [loop_STATEMENT_IDENTIFIER :]
+ -- [ITERATION_SCHEME] loop
+ -- SEQUENCE_OF_STATEMENTS
+ -- end loop [loop_IDENTIFIER];
+
+ -- Note: The occurrence of a loop label is not a defining identifier
+ -- but rather a referencing occurrence. The defining occurrence is in
+ -- the implicit label declaration which occurs in the innermost
+ -- enclosing block.
+
+ -- Note: there is always a loop statement identifier present in
+ -- the tree, even if none was given in the source. In the case where
+ -- no loop identifier is given in the source, the parser creates
+ -- a name of the form _Loop_n, where n is a decimal integer (the
+ -- two underlines ensure that the loop names created in this manner
+ -- do not conflict with any user defined identifiers), and the flag
+ -- Has_Created_Identifier is set to True. The only exception to the
+ -- rule that all loop statement nodes have identifiers occurs for
+ -- loops constructed by the expander, and the semantic analyzer will
+ -- create and supply dummy loop identifiers in these cases.
+
+ -- N_Loop_Statement
+ -- Sloc points to LOOP
+ -- Identifier (Node1) loop identifier (set to Empty if no identifier)
+ -- Iteration_Scheme (Node2) (set to Empty if no iteration scheme)
+ -- Statements (List3)
+ -- End_Label (Node4)
+ -- Has_Created_Identifier (Flag15)
+
+ --------------------------
+ -- 5.5 Iteration Scheme --
+ --------------------------
+
+ -- ITERATION_SCHEME ::=
+ -- while CONDITION | for LOOP_PARAMETER_SPECIFICATION
+
+ -- Gigi restriction: This expander ensures that the type of the
+ -- Condition field is always Standard.Boolean, even if the type
+ -- in the source is some non-standard boolean type.
+
+ -- N_Iteration_Scheme
+ -- Sloc points to WHILE or FOR
+ -- Condition (Node1) (set to Empty if FOR case)
+ -- Condition_Actions (List3-Sem)
+ -- Loop_Parameter_Specification (Node4) (set to Empty if WHILE case)
+
+ ---------------------------------------
+ -- 5.5 Loop parameter specification --
+ ---------------------------------------
+
+ -- LOOP_PARAMETER_SPECIFICATION ::=
+ -- DEFINING_IDENTIFIER in [reverse] DISCRETE_SUBTYPE_DEFINITION
+
+ -- N_Loop_Parameter_Specification
+ -- Sloc points to first identifier
+ -- Defining_Identifier (Node1)
+ -- Reverse_Present (Flag15)
+ -- Discrete_Subtype_Definition (Node4)
+
+ --------------------------
+ -- 5.6 Block Statement --
+ --------------------------
+
+ -- BLOCK_STATEMENT ::=
+ -- [block_STATEMENT_IDENTIFIER:]
+ -- [declare
+ -- DECLARATIVE_PART]
+ -- begin
+ -- HANDLED_SEQUENCE_OF_STATEMENTS
+ -- end [block_IDENTIFIER];
+
+ -- Note that the occurrence of a block identifier is not a defining
+ -- identifier, but rather a referencing occurrence. The defining
+ -- occurrence is in the implicit label declaration which occurs in
+ -- the innermost enclosing block.
+
+ -- Note: there is always a block statement identifier present in
+ -- the tree, even if none was given in the source. In the case where
+ -- no block identifier is given in the source, the parser creates
+ -- a name of the form _Block_n, where n is a decimal integer (the
+ -- two underlines ensure that the block names created in this manner
+ -- do not conflict with any user defined identifiers), and the flag
+ -- Has_Created_Identifier is set to True. The only exception to the
+ -- rule that all loop statement nodes have identifiers occurs for
+ -- blocks constructed by the expander, and the semantic analyzer
+ -- creates and supplies dummy names for the blocks).
+
+ -- N_Block_Statement
+ -- Sloc points to DECLARE or BEGIN
+ -- Identifier (Node1) block direct name (set to Empty if not present)
+ -- Declarations (List2) (set to No_List if no DECLARE part)
+ -- Handled_Statement_Sequence (Node4)
+ -- Is_Task_Master (Flag5-Sem)
+ -- Activation_Chain_Entity (Node3-Sem)
+ -- Has_Created_Identifier (Flag15)
+ -- Is_Task_Allocation_Block (Flag6)
+ -- Is_Asynchronous_Call_Block (Flag7)
+
+ -------------------------
+ -- 5.7 Exit Statement --
+ -------------------------
+
+ -- EXIT_STATEMENT ::= exit [loop_NAME] [when CONDITION];
+
+ -- Gigi restriction: This expander ensures that the type of the
+ -- Condition field is always Standard.Boolean, even if the type
+ -- in the source is some non-standard boolean type.
+
+ -- N_Exit_Statement
+ -- Sloc points to EXIT
+ -- Name (Node2) (set to Empty if no loop name present)
+ -- Condition (Node1) (set to Empty if no when part present)
+
+ -------------------------
+ -- 5.9 Goto Statement --
+ -------------------------
+
+ -- GOTO_STATEMENT ::= goto label_NAME;
+
+ -- N_Goto_Statement
+ -- Sloc points to GOTO
+ -- Name (Node2)
+ -- Exception_Junk (Flag11-Sem)
+
+ ---------------------------------
+ -- 6.1 Subprogram Declaration --
+ ---------------------------------
+
+ -- SUBPROGRAM_DECLARATION ::= SUBPROGRAM_SPECIFICATION;
+
+ -- N_Subprogram_Declaration
+ -- Sloc points to FUNCTION or PROCEDURE
+ -- Specification (Node1)
+ -- Body_To_Inline (Node3-Sem)
+ -- Corresponding_Body (Node5-Sem)
+ -- Parent_Spec (Node4-Sem)
+
+ ------------------------------------------
+ -- 6.1 Abstract Subprogram Declaration --
+ ------------------------------------------
+
+ -- ABSTRACT_SUBPROGRAM_DECLARATION ::=
+ -- SUBPROGRAM_SPECIFICATION is abstract;
+
+ -- N_Abstract_Subprogram_Declaration
+ -- Sloc points to ABSTRACT
+ -- Specification (Node1)
+
+ -----------------------------------
+ -- 6.1 Subprogram Specification --
+ -----------------------------------
+
+ -- SUBPROGRAM_SPECIFICATION ::=
+ -- procedure DEFINING_PROGRAM_UNIT_NAME PARAMETER_PROFILE
+ -- | function DEFINING_DESIGNATOR PARAMETER_AND_RESULT_PROFILE
+
+ -- Note: there are no separate nodes for the profiles, instead the
+ -- information appears directly in the following nodes.
+
+ -- N_Function_Specification
+ -- Sloc points to FUNCTION
+ -- Defining_Unit_Name (Node1) (the designator)
+ -- Elaboration_Boolean (Node2-Sem)
+ -- Parameter_Specifications (List3) (set to No_List if no formal part)
+ -- Subtype_Mark (Node4) for return type
+ -- Generic_Parent (Node5-Sem)
+
+ -- N_Procedure_Specification
+ -- Sloc points to PROCEDURE
+ -- Defining_Unit_Name (Node1)
+ -- Elaboration_Boolean (Node2-Sem)
+ -- Parameter_Specifications (List3) (set to No_List if no formal part)
+ -- Generic_Parent (Node5-Sem)
+
+ ---------------------
+ -- 6.1 Designator --
+ ---------------------
+
+ -- DESIGNATOR ::=
+ -- [PARENT_UNIT_NAME .] IDENTIFIER | OPERATOR_SYMBOL
+
+ -- Designators that are simply identifiers or operator symbols appear
+ -- directly in the tree in this form. The following node is used only
+ -- in the case where the designator has a parent unit name component.
+
+ -- N_Designator
+ -- Sloc points to period
+ -- Name (Node2) holds the parent unit name. Note that this is always
+ -- non-Empty, since this node is only used for the case where a
+ -- parent library unit package name is present.
+ -- Identifier (Node1)
+
+ -- Note that the identifier can also be an operator symbol here.
+
+ ------------------------------
+ -- 6.1 Defining Designator --
+ ------------------------------
+
+ -- DEFINING_DESIGNATOR ::=
+ -- DEFINING_PROGRAM_UNIT_NAME | DEFINING_OPERATOR_SYMBOL
+
+ -------------------------------------
+ -- 6.1 Defining Program Unit Name --
+ -------------------------------------
+
+ -- DEFINING_PROGRAM_UNIT_NAME ::=
+ -- [PARENT_UNIT_NAME .] DEFINING_IDENTIFIER
+
+ -- The parent unit name is present only in the case of a child unit
+ -- name (permissible only for Ada 95 for a library level unit, i.e.
+ -- a unit at scope level one). If no such name is present, the defining
+ -- program unit name is represented simply as the defining identifier.
+ -- In the child unit case, the following node is used to represent the
+ -- child unit name.
+
+ -- N_Defining_Program_Unit_Name
+ -- Sloc points to period
+ -- Name (Node2) holds the parent unit name. Note that this is always
+ -- non-Empty, since this node is only used for the case where a
+ -- parent unit name is present.
+ -- Defining_Identifier (Node1)
+
+ --------------------------
+ -- 6.1 Operator Symbol --
+ --------------------------
+
+ -- OPERATOR_SYMBOL ::= STRING_LITERAL
+
+ -- Note: the fields of the N_Operator_Symbol node are laid out to
+ -- match the corresponding fields of an N_Character_Literal node. This
+ -- allows easy conversion of the operator symbol node into a character
+ -- literal node in the case where a string constant of the form of an
+ -- operator symbol is scanned out as such, but turns out semantically
+ -- to be a string literal that is not an operator. For details see
+ -- Sinfo.CN.Change_Operator_Symbol_To_String_Literal.
+
+ -- N_Operator_Symbol
+ -- Sloc points to literal
+ -- Chars (Name1) contains the Name_Id for the operator symbol
+ -- Strval (Str3) Id of string value. This is used if the operator
+ -- symbol turns out to be a normal string after all.
+ -- Entity (Node4-Sem)
+ -- Has_Private_View (Flag11-Sem) set in generic units.
+ -- Etype (Node5-Sem)
+
+ -- Note: the Strval field may be set to No_String for generated
+ -- operator symbols that are known not to be string literals
+ -- semantically.
+
+ -----------------------------------
+ -- 6.1 Defining Operator Symbol --
+ -----------------------------------
+
+ -- DEFINING_OPERATOR_SYMBOL ::= OPERATOR_SYMBOL
+
+ -- A defining operator symbol is an entity, which has additional
+ -- fields depending on the setting of the Ekind field. These
+ -- additional fields are defined (and access subprograms declared)
+ -- in package Einfo.
+
+ -- Note: N_Defining_Operator_Symbol is an extended node whose fields
+ -- are deliberately layed out to match the layout of fields in an
+ -- ordinary N_Operator_Symbol node allowing for easy alteration of
+ -- an operator symbol node into a defining operator symbol node.
+ -- See Sinfo.CN.Change_Operator_Symbol_To_Defining_Operator_Symbol
+ -- for further details.
+
+ -- N_Defining_Operator_Symbol
+ -- Sloc points to literal
+ -- Chars (Name1) contains the Name_Id for the operator symbol
+ -- Next_Entity (Node2-Sem)
+ -- Scope (Node3-Sem)
+ -- Etype (Node5-Sem)
+
+ ----------------------------
+ -- 6.1 Parameter Profile --
+ ----------------------------
+
+ -- PARAMETER_PROFILE ::= [FORMAL_PART]
+
+ ---------------------------------------
+ -- 6.1 Parameter and Result Profile --
+ ---------------------------------------
+
+ -- PARAMETER_AND_RESULT_PROFILE ::= [FORMAL_PART] return SUBTYPE_MARK
+
+ -- There is no explicit node in the tree for a parameter and result
+ -- profile. Instead the information appears directly in the parent.
+
+ ----------------------
+ -- 6.1 Formal part --
+ ----------------------
+
+ -- FORMAL_PART ::=
+ -- (PARAMETER_SPECIFICATION {; PARAMETER_SPECIFICATION})
+
+ ----------------------------------
+ -- 6.1 Parameter specification --
+ ----------------------------------
+
+ -- PARAMETER_SPECIFICATION ::=
+ -- DEFINING_IDENTIFIER_LIST : MODE SUBTYPE_MARK
+ -- [:= DEFAULT_EXPRESSION]
+ -- | DEFINING_IDENTIFIER_LIST : ACCESS_DEFINITION
+ -- [:= DEFAULT_EXPRESSION]
+
+ -- Although the syntax allows multiple identifiers in the list, the
+ -- semantics is as though successive specifications were given with
+ -- identical type definition and expression components. To simplify
+ -- semantic processing, the parser represents a multiple declaration
+ -- case as a sequence of single Specifications, using the More_Ids and
+ -- Prev_Ids flags to preserve the original source form as described
+ -- in the section on "Handling of Defining Identifier Lists".
+
+ -- N_Parameter_Specification
+ -- Sloc points to first identifier
+ -- Defining_Identifier (Node1)
+ -- In_Present (Flag15)
+ -- Out_Present (Flag17)
+ -- Parameter_Type (Node2) subtype mark or access definition
+ -- Expression (Node3) (set to Empty if no default expression present)
+ -- Do_Accessibility_Check (Flag13-Sem)
+ -- More_Ids (Flag5) (set to False if no more identifiers in list)
+ -- Prev_Ids (Flag6) (set to False if no previous identifiers in list)
+ -- Default_Expression (Node5-Sem)
+
+ ---------------
+ -- 6.1 Mode --
+ ---------------
+
+ -- MODE ::= [in] | in out | out
+
+ -- There is no explicit node in the tree for the Mode. Instead the
+ -- In_Present and Out_Present flags are set in the parent node to
+ -- record the presence of keywords specifying the mode.
+
+ --------------------------
+ -- 6.3 Subprogram Body --
+ --------------------------
+
+ -- SUBPROGRAM_BODY ::=
+ -- SUBPROGRAM_SPECIFICATION is
+ -- DECLARATIVE_PART
+ -- begin
+ -- HANDLED_SEQUENCE_OF_STATEMENTS
+ -- end [DESIGNATOR];
+
+ -- N_Subprogram_Body
+ -- Sloc points to FUNCTION or PROCEDURE
+ -- Specification (Node1)
+ -- Declarations (List2)
+ -- Handled_Statement_Sequence (Node4)
+ -- Activation_Chain_Entity (Node3-Sem)
+ -- Corresponding_Spec (Node5-Sem)
+ -- Acts_As_Spec (Flag4-Sem)
+ -- Bad_Is_Detected (Flag15) used only by parser
+ -- Do_Storage_Check (Flag17-Sem)
+ -- Has_Priority_Pragma (Flag6-Sem)
+ -- Is_Protected_Subprogram_Body (Flag7-Sem)
+ -- Is_Task_Master (Flag5-Sem)
+ -- Was_Originally_Stub (Flag13-Sem)
+
+ -----------------------------------
+ -- 6.4 Procedure Call Statement --
+ -----------------------------------
+
+ -- PROCEDURE_CALL_STATEMENT ::=
+ -- procedure_NAME; | procedure_PREFIX ACTUAL_PARAMETER_PART;
+
+ -- Note: the reason that a procedure call has expression fields is
+ -- that it semantically resembles an expression, e.g. overloading is
+ -- allowed and a type is concocted for semantic processing purposes.
+ -- Certain of these fields, such as Parens are not relevant, but it
+ -- is easier to just supply all of them together!
+
+ -- N_Procedure_Call_Statement
+ -- Sloc points to first token of name or prefix
+ -- Name (Node2) stores name or prefix
+ -- Parameter_Associations (List3) (set to No_List if no
+ -- actual parameter part)
+ -- First_Named_Actual (Node4-Sem)
+ -- Controlling_Argument (Node1-Sem) (set to Empty if not dispatching)
+ -- Do_Tag_Check (Flag13-Sem)
+ -- Parameter_List_Truncated (Flag17-Sem)
+ -- ABE_Is_Certain (Flag18-Sem)
+ -- plus fields for expression
+
+ -- If any IN parameter requires a range check, then the corresponding
+ -- argument expression has the Do_Range_Check flag set, and the range
+ -- check is done against the formal type. Note that this argument
+ -- expression may appear directly in the Parameter_Associations list,
+ -- or may be a descendent of an N_Parameter_Association node that
+ -- appears in this list.
+
+ ------------------------
+ -- 6.4 Function Call --
+ ------------------------
+
+ -- FUNCTION_CALL ::=
+ -- function_NAME | function_PREFIX ACTUAL_PARAMETER_PART
+
+ -- Note: the parser may generate an indexed component node or simply
+ -- a name node instead of a function call node. The semantic pass must
+ -- correct this misidentification.
+
+ -- N_Function_Call
+ -- Sloc points to first token of name or prefix
+ -- Name (Node2) stores name or prefix
+ -- Parameter_Associations (List3) (set to No_List if no
+ -- actual parameter part)
+ -- First_Named_Actual (Node4-Sem)
+ -- Controlling_Argument (Node1-Sem) (set to Empty if not dispatching)
+ -- Do_Tag_Check (Flag13-Sem)
+ -- Parameter_List_Truncated (Flag17-Sem)
+ -- ABE_Is_Certain (Flag18-Sem)
+ -- plus fields for expression
+
+ --------------------------------
+ -- 6.4 Actual Parameter Part --
+ --------------------------------
+
+ -- ACTUAL_PARAMETER_PART ::=
+ -- (PARAMETER_ASSOCIATION {,PARAMETER_ASSOCIATION})
+
+ --------------------------------
+ -- 6.4 Parameter Association --
+ --------------------------------
+
+ -- PARAMETER_ASSOCIATION ::=
+ -- [formal_parameter_SELECTOR_NAME =>] EXPLICIT_ACTUAL_PARAMETER
+
+ -- Note: the N_Parameter_Association node is built only if a formal
+ -- parameter selector name is present, otherwise the parameter
+ -- association appears in the tree simply as the node for the
+ -- explicit actual parameter.
+
+ -- N_Parameter_Association
+ -- Sloc points to formal parameter
+ -- Selector_Name (Node2) (always non-Empty, since this node is
+ -- only used if a formal parameter selector name is present)
+ -- Explicit_Actual_Parameter (Node3)
+ -- Next_Named_Actual (Node4-Sem)
+
+ ---------------------------
+ -- 6.4 Actual Parameter --
+ ---------------------------
+
+ -- EXPLICIT_ACTUAL_PARAMETER ::= EXPRESSION | variable_NAME
+
+ ---------------------------
+ -- 6.5 Return Statement --
+ ---------------------------
+
+ -- RETURN_STATEMENT ::= return [EXPRESSION];
+
+ -- N_Return_Statement
+ -- Sloc points to RETURN
+ -- Expression (Node3) (set to Empty if no expression present)
+ -- Storage_Pool (Node1-Sem)
+ -- Procedure_To_Call (Node4-Sem)
+ -- Do_Tag_Check (Flag13-Sem)
+ -- Return_Type (Node2-Sem)
+ -- By_Ref (Flag5-Sem)
+
+ -- Note: if a range check is required, then Do_Range_Check is set
+ -- on the Expression. The range check is against Return_Type.
+
+ ------------------------------
+ -- 7.1 Package Declaration --
+ ------------------------------
+
+ -- PACKAGE_DECLARATION ::= PACKAGE_SPECIFICATION;
+
+ -- Note: the activation chain entity for a package spec is used for
+ -- all tasks declared in the package spec, or in the package body.
+
+ -- N_Package_Declaration
+ -- Sloc points to PACKAGE
+ -- Specification (Node1)
+ -- Corresponding_Body (Node5-Sem)
+ -- Parent_Spec (Node4-Sem)
+ -- Activation_Chain_Entity (Node3-Sem)
+
+ --------------------------------
+ -- 7.1 Package Specification --
+ --------------------------------
+
+ -- PACKAGE_SPECIFICATION ::=
+ -- package DEFINING_PROGRAM_UNIT_NAME is
+ -- {BASIC_DECLARATIVE_ITEM}
+ -- [private
+ -- {BASIC_DECLARATIVE_ITEM}]
+ -- end [[PARENT_UNIT_NAME .] IDENTIFIER]
+
+ -- N_Package_Specification
+ -- Sloc points to PACKAGE
+ -- Defining_Unit_Name (Node1)
+ -- Visible_Declarations (List2)
+ -- Private_Declarations (List3) (set to No_List if no private
+ -- part present)
+ -- End_Label (Node4)
+ -- Generic_Parent (Node5-Sem)
+
+ -----------------------
+ -- 7.1 Package Body --
+ -----------------------
+
+ -- PACKAGE_BODY ::=
+ -- package body DEFINING_PROGRAM_UNIT_NAME is
+ -- DECLARATIVE_PART
+ -- [begin
+ -- HANDLED_SEQUENCE_OF_STATEMENTS]
+ -- end [[PARENT_UNIT_NAME .] IDENTIFIER];
+
+ -- N_Package_Body
+ -- Sloc points to PACKAGE
+ -- Defining_Unit_Name (Node1)
+ -- Declarations (List2)
+ -- Handled_Statement_Sequence (Node4) (set to Empty if no HSS present)
+ -- Corresponding_Spec (Node5-Sem)
+ -- Was_Originally_Stub (Flag13-Sem)
+
+ -- Note: if a source level package does not contain a handled sequence
+ -- of statements, then the parser supplies a dummy one with a null
+ -- sequence of statements. Comes_From_Source will be False in this
+ -- constructed sequence. The reason we need this is for the End_Label
+ -- field in the HSS.
+
+ -----------------------------------
+ -- 7.4 Private Type Declaration --
+ -----------------------------------
+
+ -- PRIVATE_TYPE_DECLARATION ::=
+ -- type DEFINING_IDENTIFIER [DISCRIMINANT_PART]
+ -- is [[abstract] tagged] [limited] private;
+
+ -- Note: TAGGED is not permitted in Ada 83 mode
+
+ -- N_Private_Type_Declaration
+ -- Sloc points to TYPE
+ -- Defining_Identifier (Node1)
+ -- Discriminant_Specifications (List4) (set to No_List if no
+ -- discriminant part)
+ -- Unknown_Discriminants_Present (Flag13) set if (<>) discriminant
+ -- Abstract_Present (Flag4)
+ -- Tagged_Present (Flag15)
+ -- Limited_Present (Flag17)
+
+ ----------------------------------------
+ -- 7.4 Private Extension Declaration --
+ ----------------------------------------
+
+ -- PRIVATE_EXTENSION_DECLARATION ::=
+ -- type DEFINING_IDENTIFIER [DISCRIMINANT_PART] is
+ -- [abstract] new ancestor_SUBTYPE_INDICATION with private;
+
+ -- Note: private extension declarations are not allowed in Ada 83 mode
+
+ -- N_Private_Extension_Declaration
+ -- Sloc points to TYPE
+ -- Defining_Identifier (Node1)
+ -- Discriminant_Specifications (List4) (set to No_List if no
+ -- discriminant part)
+ -- Unknown_Discriminants_Present (Flag13) set if (<>) discriminant
+ -- Abstract_Present (Flag4)
+ -- Subtype_Indication (Node5)
+
+ ---------------------
+ -- 8.4 Use Clause --
+ ---------------------
+
+ -- USE_CLAUSE ::= USE_PACKAGE_CLAUSE | USE_TYPE_CLAUSE
+
+ -----------------------------
+ -- 8.4 Use Package Clause --
+ -----------------------------
+
+ -- USE_PACKAGE_CLAUSE ::= use package_NAME {, package_NAME};
+
+ -- N_Use_Package_Clause
+ -- Sloc points to USE
+ -- Names (List2)
+ -- Next_Use_Clause (Node3-Sem)
+ -- Hidden_By_Use_Clause (Elist4-Sem)
+
+ --------------------------
+ -- 8.4 Use Type Clause --
+ --------------------------
+
+ -- USE_TYPE_CLAUSE ::= use type SUBTYPE_MARK {, SUBTYPE_MARK};
+
+ -- Note: use type clause is not permitted in Ada 83 mode
+
+ -- N_Use_Type_Clause
+ -- Sloc points to USE
+ -- Subtype_Marks (List2)
+ -- Next_Use_Clause (Node3-Sem)
+ -- Hidden_By_Use_Clause (Elist4-Sem)
+
+ -------------------------------
+ -- 8.5 Renaming Declaration --
+ -------------------------------
+
+ -- RENAMING_DECLARATION ::=
+ -- OBJECT_RENAMING_DECLARATION
+ -- | EXCEPTION_RENAMING_DECLARATION
+ -- | PACKAGE_RENAMING_DECLARATION
+ -- | SUBPROGRAM_RENAMING_DECLARATION
+ -- | GENERIC_RENAMING_DECLARATION
+
+ --------------------------------------
+ -- 8.5 Object Renaming Declaration --
+ --------------------------------------
+
+ -- OBJECT_RENAMING_DECLARATION ::=
+ -- DEFINING_IDENTIFIER : SUBTYPE_MARK renames object_NAME;
+
+ -- N_Object_Renaming_Declaration
+ -- Sloc points to first identifier
+ -- Defining_Identifier (Node1)
+ -- Subtype_Mark (Node4)
+ -- Name (Node2)
+ -- Corresponding_Generic_Association (Node5-Sem)
+
+ -----------------------------------------
+ -- 8.5 Exception Renaming Declaration --
+ -----------------------------------------
+
+ -- EXCEPTION_RENAMING_DECLARATION ::=
+ -- DEFINING_IDENTIFIER : exception renames exception_NAME;
+
+ -- N_Exception_Renaming_Declaration
+ -- Sloc points to first identifier
+ -- Defining_Identifier (Node1)
+ -- Name (Node2)
+
+ ---------------------------------------
+ -- 8.5 Package Renaming Declaration --
+ ---------------------------------------
+
+ -- PACKAGE_RENAMING_DECLARATION ::=
+ -- package DEFINING_PROGRAM_UNIT_NAME renames package_NAME;
+
+ -- N_Package_Renaming_Declaration
+ -- Sloc points to PACKAGE
+ -- Defining_Unit_Name (Node1)
+ -- Name (Node2)
+ -- Parent_Spec (Node4-Sem)
+
+ ------------------------------------------
+ -- 8.5 Subprogram Renaming Declaration --
+ ------------------------------------------
+
+ -- SUBPROGRAM_RENAMING_DECLARATION ::=
+ -- SUBPROGRAM_SPECIFICATION renames callable_entity_NAME;
+
+ -- N_Subprogram_Renaming_Declaration
+ -- Sloc points to RENAMES
+ -- Specification (Node1)
+ -- Name (Node2)
+ -- Parent_Spec (Node4-Sem)
+ -- Corresponding_Spec (Node5-Sem)
+
+ -----------------------------------------
+ -- 8.5.5 Generic Renaming Declaration --
+ -----------------------------------------
+
+ -- GENERIC_RENAMING_DECLARATION ::=
+ -- generic package DEFINING_PROGRAM_UNIT_NAME
+ -- renames generic_package_NAME
+ -- | generic procedure DEFINING_PROGRAM_UNIT_NAME
+ -- renames generic_procedure_NAME
+ -- | generic function DEFINING_PROGRAM_UNIT_NAME
+ -- renames generic_function_NAME
+
+ -- N_Generic_Package_Renaming_Declaration
+ -- Sloc points to GENERIC
+ -- Defining_Unit_Name (Node1)
+ -- Name (Node2)
+ -- Parent_Spec (Node4-Sem)
+
+ -- N_Generic_Procedure_Renaming_Declaration
+ -- Sloc points to GENERIC
+ -- Defining_Unit_Name (Node1)
+ -- Name (Node2)
+ -- Parent_Spec (Node4-Sem)
+
+ -- N_Generic_Function_Renaming_Declaration
+ -- Sloc points to GENERIC
+ -- Defining_Unit_Name (Node1)
+ -- Name (Node2)
+ -- Parent_Spec (Node4-Sem)
+
+ --------------------------------
+ -- 9.1 Task Type Declaration --
+ --------------------------------
+
+ -- TASK_TYPE_DECLARATION ::=
+ -- task type DEFINING_IDENTIFIER [KNOWN_DISCRIMINANT_PART]
+ -- [is TASK_DEFINITITION];
+
+ -- N_Task_Type_Declaration
+ -- Sloc points to TASK
+ -- Defining_Identifier (Node1)
+ -- Task_Body_Procedure (Node2-Sem)
+ -- Discriminant_Specifications (List4) (set to No_List if no
+ -- discriminant part)
+ -- Task_Definition (Node3) (set to Empty if not present)
+ -- Corresponding_Body (Node5-Sem)
+
+ ----------------------------------
+ -- 9.1 Single Task Declaration --
+ ----------------------------------
+
+ -- SINGLE_TASK_DECLARATION ::=
+ -- task DEFINING_IDENTIFIER [is TASK_DEFINITION];
+
+ -- N_Single_Task_Declaration
+ -- Sloc points to TASK
+ -- Defining_Identifier (Node1)
+ -- Task_Definition (Node3) (set to Empty if not present)
+
+ --------------------------
+ -- 9.1 Task Definition --
+ --------------------------
+
+ -- TASK_DEFINITION ::=
+ -- {TASK_ITEM}
+ -- [private
+ -- {TASK_ITEM}]
+ -- end [task_IDENTIFIER]
+
+ -- Note: as a result of semantic analysis, the list of task items can
+ -- include implicit type declarations resulting from entry families.
+
+ -- N_Task_Definition
+ -- Sloc points to first token of task definition
+ -- Visible_Declarations (List2)
+ -- Private_Declarations (List3) (set to No_List if no private part)
+ -- End_Label (Node4)
+ -- Has_Priority_Pragma (Flag6-Sem)
+ -- Has_Storage_Size_Pragma (Flag5-Sem)
+ -- Has_Task_Info_Pragma (Flag7-Sem)
+ -- Has_Task_Name_Pragma (Flag8-Sem)
+
+ --------------------
+ -- 9.1 Task Item --
+ --------------------
+
+ -- TASK_ITEM ::= ENTRY_DECLARATION | REPRESENTATION_CLAUSE
+
+ --------------------
+ -- 9.1 Task Body --
+ --------------------
+
+ -- TASK_BODY ::=
+ -- task body task_DEFINING_IDENTIFIER is
+ -- DECLARATIVE_PART
+ -- begin
+ -- HANDLED_SEQUENCE_OF_STATEMENTS
+ -- end [task_IDENTIFIER];
+
+ -- Gigi restriction: This node never appears.
+
+ -- N_Task_Body
+ -- Sloc points to TASK
+ -- Defining_Identifier (Node1)
+ -- Declarations (List2)
+ -- Handled_Statement_Sequence (Node4)
+ -- Is_Task_Master (Flag5-Sem)
+ -- Activation_Chain_Entity (Node3-Sem)
+ -- Corresponding_Spec (Node5-Sem)
+ -- Was_Originally_Stub (Flag13-Sem)
+
+ -------------------------------------
+ -- 9.4 Protected Type Declaration --
+ -------------------------------------
+
+ -- PROTECTED_TYPE_DECLARATION ::=
+ -- protected type DEFINING_IDENTIFIER [KNOWN_DISCRIMINANT_PART]
+ -- is PROTECTED_DEFINITION;
+
+ -- Note: protected type declarations are not permitted in Ada 83 mode
+
+ -- N_Protected_Type_Declaration
+ -- Sloc points to PROTECTED
+ -- Defining_Identifier (Node1)
+ -- Discriminant_Specifications (List4) (set to No_List if no
+ -- discriminant part)
+ -- Protected_Definition (Node3)
+ -- Corresponding_Body (Node5-Sem)
+
+ ---------------------------------------
+ -- 9.4 Single Protected Declaration --
+ ---------------------------------------
+
+ -- SINGLE_PROTECTED_DECLARATION ::=
+ -- protected DEFINING_IDENTIFIER is PROTECTED_DEFINITION;
+
+ -- Note: single protected declarations are not allowed in Ada 83 mode
+
+ -- N_Single_Protected_Declaration
+ -- Sloc points to PROTECTED
+ -- Defining_Identifier (Node1)
+ -- Protected_Definition (Node3)
+
+ -------------------------------
+ -- 9.4 Protected Definition --
+ -------------------------------
+
+ -- PROTECTED_DEFINITION ::=
+ -- {PROTECTED_OPERATION_DECLARATION}
+ -- [private
+ -- {PROTECTED_ELEMENT_DECLARATION}]
+ -- end [protected_IDENTIFIER]
+
+ -- N_Protected_Definition
+ -- Sloc points to first token of protected definition
+ -- Visible_Declarations (List2)
+ -- Private_Declarations (List3) (set to No_List if no private part)
+ -- End_Label (Node4)
+ -- Has_Priority_Pragma (Flag6-Sem)
+
+ ------------------------------------------
+ -- 9.4 Protected Operation Declaration --
+ ------------------------------------------
+
+ -- PROTECTED_OPERATION_DECLARATION ::=
+ -- SUBPROGRAM_DECLARATION
+ -- | ENTRY_DECLARATION
+ -- | REPRESENTATION_CLAUSE
+
+ ----------------------------------------
+ -- 9.4 Protected Element Declaration --
+ ----------------------------------------
+
+ -- PROTECTED_ELEMENT_DECLARATION ::=
+ -- PROTECTED_OPERATION_DECLARATION | COMPONENT_DECLARATION
+
+ -------------------------
+ -- 9.4 Protected Body --
+ -------------------------
+
+ -- PROTECTED_BODY ::=
+ -- protected body DEFINING_IDENTIFIER is
+ -- {PROTECTED_OPERATION_ITEM}
+ -- end [protected_IDENTIFIER];
+
+ -- Note: protected bodies are not allowed in Ada 83 mode
+
+ -- Gigi restriction: This node never appears.
+
+ -- N_Protected_Body
+ -- Sloc points to PROTECTED
+ -- Defining_Identifier (Node1)
+ -- Declarations (List2) protected operation items (and pragmas)
+ -- End_Label (Node4)
+ -- Corresponding_Spec (Node5-Sem)
+ -- Was_Originally_Stub (Flag13-Sem)
+
+ -----------------------------------
+ -- 9.4 Protected Operation Item --
+ -----------------------------------
+
+ -- PROTECTED_OPERATION_ITEM ::=
+ -- SUBPROGRAM_DECLARATION
+ -- | SUBPROGRAM_BODY
+ -- | ENTRY_BODY
+ -- | REPRESENTATION_CLAUSE
+
+ ------------------------------
+ -- 9.5.2 Entry Declaration --
+ ------------------------------
+
+ -- ENTRY_DECLARATION ::=
+ -- entry DEFINING_IDENTIFIER
+ -- [(DISCRETE_SUBTYPE_DEFINITION)] PARAMETER_PROFILE;
+
+ -- N_Entry_Declaration
+ -- Sloc points to ENTRY
+ -- Defining_Identifier (Node1)
+ -- Discrete_Subtype_Definition (Node4) (set to Empty if not present)
+ -- Parameter_Specifications (List3) (set to No_List if no formal part)
+
+ -----------------------------
+ -- 9.5.2 Accept statement --
+ -----------------------------
+
+ -- ACCEPT_STATEMENT ::=
+ -- accept entry_DIRECT_NAME
+ -- [(ENTRY_INDEX)] PARAMETER_PROFILE [do
+ -- HANDLED_SEQUENCE_OF_STATEMENTS
+ -- end [entry_IDENTIFIER]];
+
+ -- Gigi restriction: This node never appears.
+
+ -- Note: there are no explicit declarations allowed in an accept
+ -- statement. However, the implicit declarations for any statement
+ -- identifiers (labels and block/loop identifiers) are declarations
+ -- that belong logically to the accept statement, and that is why
+ -- there is a Declarations field in this node.
+
+ -- N_Accept_Statement
+ -- Sloc points to ACCEPT
+ -- Entry_Direct_Name (Node1)
+ -- Entry_Index (Node5) (set to Empty if not present)
+ -- Parameter_Specifications (List3) (set to No_List if no formal part)
+ -- Handled_Statement_Sequence (Node4)
+ -- Declarations (List2) (set to No_List if no declarations)
+
+ ------------------------
+ -- 9.5.2 Entry Index --
+ ------------------------
+
+ -- ENTRY_INDEX ::= EXPRESSION
+
+ -----------------------
+ -- 9.5.2 Entry Body --
+ -----------------------
+
+ -- ENTRY_BODY ::=
+ -- entry DEFINING_IDENTIFIER ENTRY_BODY_FORMAL_PART ENTRY_BARRIER is
+ -- DECLARATIVE_PART
+ -- begin
+ -- HANDLED_SEQUENCE_OF_STATEMENTS
+ -- end [entry_IDENTIFIER];
+
+ -- ENTRY_BARRIER ::= when CONDITION
+
+ -- Note: we store the CONDITION of the ENTRY_BARRIER in the node for
+ -- the ENTRY_BODY_FORMAL_PART to avoid the N_Entry_Body node getting
+ -- too full (it would otherwise have too many fields)
+
+ -- Gigi restriction: This node never appears.
+
+ -- N_Entry_Body
+ -- Sloc points to ENTRY
+ -- Defining_Identifier (Node1)
+ -- Entry_Body_Formal_Part (Node5)
+ -- Declarations (List2)
+ -- Handled_Statement_Sequence (Node4)
+ -- Activation_Chain_Entity (Node3-Sem)
+
+ -----------------------------------
+ -- 9.5.2 Entry Body Formal Part --
+ -----------------------------------
+
+ -- ENTRY_BODY_FORMAL_PART ::=
+ -- [(ENTRY_INDEX_SPECIFICATION)] PARAMETER_PROFILE
+
+ -- Note that an entry body formal part node is present even if it is
+ -- empty. This reflects the grammar, in which it is the components of
+ -- the entry body formal part that are optional, not the entry body
+ -- formal part itself. Also this means that the barrier condition
+ -- always has somewhere to be stored.
+
+ -- Gigi restriction: This node never appears.
+
+ -- N_Entry_Body_Formal_Part
+ -- Sloc points to first token
+ -- Entry_Index_Specification (Node4) (set to Empty if not present)
+ -- Parameter_Specifications (List3) (set to No_List if no formal part)
+ -- Condition (Node1) from entry barrier of entry body
+
+ --------------------------
+ -- 9.5.2 Entry Barrier --
+ --------------------------
+
+ -- ENTRY_BARRIER ::= when CONDITION
+
+ --------------------------------------
+ -- 9.5.2 Entry Index Specification --
+ --------------------------------------
+
+ -- ENTRY_INDEX_SPECIFICATION ::=
+ -- for DEFINING_IDENTIFIER in DISCRETE_SUBTYPE_DEFINITION
+
+ -- Gigi restriction: This node never appears.
+
+ -- N_Entry_Index_Specification
+ -- Sloc points to FOR
+ -- Defining_Identifier (Node1)
+ -- Discrete_Subtype_Definition (Node4)
+
+ ---------------------------------
+ -- 9.5.3 Entry Call Statement --
+ ---------------------------------
+
+ -- ENTRY_CALL_STATEMENT ::= entry_NAME [ACTUAL_PARAMETER_PART];
+
+ -- The parser may generate a procedure call for this construct. The
+ -- semantic pass must correct this misidentification where needed.
+
+ -- Gigi restriction: This node never appears.
+
+ -- N_Entry_Call_Statement
+ -- Sloc points to first token of name
+ -- Name (Node2)
+ -- Parameter_Associations (List3) (set to No_List if no
+ -- actual parameter part)
+ -- First_Named_Actual (Node4-Sem)
+
+ ------------------------------
+ -- 9.5.4 Requeue Statement --
+ ------------------------------
+
+ -- REQUEUE_STATEMENT ::= requeue entry_NAME [with abort];
+
+ -- Note: requeue statements are not permitted in Ada 83 mode
+
+ -- Gigi restriction: This node never appears.
+
+ -- N_Requeue_Statement
+ -- Sloc points to REQUEUE
+ -- Name (Node2)
+ -- Abort_Present (Flag15)
+
+ --------------------------
+ -- 9.6 Delay Statement --
+ --------------------------
+
+ -- DELAY_STATEMENT ::=
+ -- DELAY_UNTIL_STATEMENT
+ -- | DELAY_RELATIVE_STATEMENT
+
+ --------------------------------
+ -- 9.6 Delay Until Statement --
+ --------------------------------
+
+ -- DELAY_UNTIL_STATEMENT ::= delay until delay_EXPRESSION;
+
+ -- Note: delay until statements are not permitted in Ada 83 mode
+
+ -- Gigi restriction: This node never appears.
+
+ -- N_Delay_Until_Statement
+ -- Sloc points to DELAY
+ -- Expression (Node3)
+
+ -----------------------------------
+ -- 9.6 Delay Relative Statement --
+ -----------------------------------
+
+ -- DELAY_RELATIVE_STATEMENT ::= delay delay_EXPRESSION;
+
+ -- Gigi restriction: This node never appears.
+
+ -- N_Delay_Relative_Statement
+ -- Sloc points to DELAY
+ -- Expression (Node3)
+
+ ---------------------------
+ -- 9.7 Select Statement --
+ ---------------------------
+
+ -- SELECT_STATEMENT ::=
+ -- SELECTIVE_ACCEPT
+ -- | TIMED_ENTRY_CALL
+ -- | CONDITIONAL_ENTRY_CALL
+ -- | ASYNCHRONOUS_SELECT
+
+ -----------------------------
+ -- 9.7.1 Selective Accept --
+ -----------------------------
+
+ -- SELECTIVE_ACCEPT ::=
+ -- select
+ -- [GUARD]
+ -- SELECT_ALTERNATIVE
+ -- {or
+ -- [GUARD]
+ -- SELECT_ALTERNATIVE}
+ -- [else
+ -- SEQUENCE_OF_STATEMENTS]
+ -- end select;
+
+ -- Gigi restriction: This node never appears.
+
+ -- Note: the guard expression, if present, appears in the node for
+ -- the select alternative.
+
+ -- N_Selective_Accept
+ -- Sloc points to SELECT
+ -- Select_Alternatives (List1)
+ -- Else_Statements (List4) (set to No_List if no else part)
+
+ ------------------
+ -- 9.7.1 Guard --
+ ------------------
+
+ -- GUARD ::= when CONDITION =>
+
+ -- As noted above, the CONDITION that is part of a GUARD is included
+ -- in the node for the select alernative for convenience.
+
+ -------------------------------
+ -- 9.7.1 Select Alternative --
+ -------------------------------
+
+ -- SELECT_ALTERNATIVE ::=
+ -- ACCEPT_ALTERNATIVE
+ -- | DELAY_ALTERNATIVE
+ -- | TERMINATE_ALTERNATIVE
+
+ -------------------------------
+ -- 9.7.1 Accept Alternative --
+ -------------------------------
+
+ -- ACCEPT_ALTERNATIVE ::=
+ -- ACCEPT_STATEMENT [SEQUENCE_OF_STATEMENTS]
+
+ -- Gigi restriction: This node never appears.
+
+ -- N_Accept_Alternative
+ -- Sloc points to ACCEPT
+ -- Accept_Statement (Node2)
+ -- Condition (Node1) from the guard (set to Empty if no guard present)
+ -- Statements (List3) (set to Empty_List if no statements)
+ -- Pragmas_Before (List4) pragmas before alt (set to No_List if none)
+ -- Accept_Handler_Records (List5-Sem)
+
+ ------------------------------
+ -- 9.7.1 Delay Alternative --
+ ------------------------------
+
+ -- DELAY_ALTERNATIVE ::=
+ -- DELAY_STATEMENT [SEQUENCE_OF_STATEMENTS]
+
+ -- Gigi restriction: This node never appears.
+
+ -- N_Delay_Alternative
+ -- Sloc points to DELAY
+ -- Delay_Statement (Node2)
+ -- Condition (Node1) from the guard (set to Empty if no guard present)
+ -- Statements (List3) (set to Empty_List if no statements)
+ -- Pragmas_Before (List4) pragmas before alt (set to No_List if none)
+
+ ----------------------------------
+ -- 9.7.1 Terminate Alternative --
+ ----------------------------------
+
+ -- TERMINATE_ALTERNATIVE ::= terminate;
+
+ -- Gigi restriction: This node never appears.
+
+ -- N_Terminate_Alternative
+ -- Sloc points to TERMINATE
+ -- Condition (Node1) from the guard (set to Empty if no guard present)
+ -- Pragmas_Before (List4) pragmas before alt (set to No_List if none)
+ -- Pragmas_After (List5) pragmas after alt (set to No_List if none)
+
+ -----------------------------
+ -- 9.7.2 Timed Entry Call --
+ -----------------------------
+
+ -- TIMED_ENTRY_CALL ::=
+ -- select
+ -- ENTRY_CALL_ALTERNATIVE
+ -- or
+ -- DELAY_ALTERNATIVE
+ -- end select;
+
+ -- Gigi restriction: This node never appears.
+
+ -- N_Timed_Entry_Call
+ -- Sloc points to SELECT
+ -- Entry_Call_Alternative (Node1)
+ -- Delay_Alternative (Node4)
+
+ -----------------------------------
+ -- 9.7.2 Entry Call Alternative --
+ -----------------------------------
+
+ -- ENTRY_CALL_ALTERNATIVE ::=
+ -- ENTRY_CALL_STATEMENT [SEQUENCE_OF_STATEMENTS]
+
+ -- Gigi restriction: This node never appears.
+
+ -- N_Entry_Call_Alternative
+ -- Sloc points to first token of entry call statement
+ -- Entry_Call_Statement (Node1)
+ -- Statements (List3) (set to Empty_List if no statements)
+ -- Pragmas_Before (List4) pragmas before alt (set to No_List if none)
+
+ -----------------------------------
+ -- 9.7.3 Conditional Entry Call --
+ -----------------------------------
+
+ -- CONDITIONAL_ENTRY_CALL ::=
+ -- select
+ -- ENTRY_CALL_ALTERNATIVE
+ -- else
+ -- SEQUENCE_OF_STATEMENTS
+ -- end select;
+
+ -- Gigi restriction: This node never appears.
+
+ -- N_Conditional_Entry_Call
+ -- Sloc points to SELECT
+ -- Entry_Call_Alternative (Node1)
+ -- Else_Statements (List4)
+
+ --------------------------------
+ -- 9.7.4 Asynchronous Select --
+ --------------------------------
+
+ -- ASYNCHRONOUS_SELECT ::=
+ -- select
+ -- TRIGGERING_ALTERNATIVE
+ -- then abort
+ -- ABORTABLE_PART
+ -- end select;
+
+ -- Note: asynchronous select is not permitted in Ada 83 mode
+
+ -- Gigi restriction: This node never appears.
+
+ -- N_Asynchronous_Select
+ -- Sloc points to SELECT
+ -- Triggering_Alternative (Node1)
+ -- Abortable_Part (Node2)
+
+ -----------------------------------
+ -- 9.7.4 Triggering Alternative --
+ -----------------------------------
+
+ -- TRIGGERING_ALTERNATIVE ::=
+ -- TRIGGERING_STATEMENT [SEQUENCE_OF_STATEMENTS]
+
+ -- Gigi restriction: This node never appears.
+
+ -- N_Triggering_Alternative
+ -- Sloc points to first token of triggering statement
+ -- Triggering_Statement (Node1)
+ -- Statements (List3) (set to Empty_List if no statements)
+ -- Pragmas_Before (List4) pragmas before alt (set to No_List if none)
+
+ ---------------------------------
+ -- 9.7.4 Triggering Statement --
+ ---------------------------------
+
+ -- TRIGGERING_STATEMENT ::= ENTRY_CALL_STATEMENT | DELAY_STATEMENT
+
+ ---------------------------
+ -- 9.7.4 Abortable Part --
+ ---------------------------
+
+ -- ABORTABLE_PART ::= SEQUENCE_OF_STATEMENTS
+
+ -- Gigi restriction: This node never appears.
+
+ -- N_Abortable_Part
+ -- Sloc points to ABORT
+ -- Statements (List3)
+
+ --------------------------
+ -- 9.8 Abort Statement --
+ --------------------------
+
+ -- ABORT_STATEMENT ::= abort task_NAME {, task_NAME};
+
+ -- Gigi restriction: This node never appears.
+
+ -- N_Abort_Statement
+ -- Sloc points to ABORT
+ -- Names (List2)
+
+ -------------------------
+ -- 10.1.1 Compilation --
+ -------------------------
+
+ -- COMPILATION ::= {COMPILATION_UNIT}
+
+ -- There is no explicit node in the tree for a compilation, since in
+ -- general the compiler is processing only a single compilation unit
+ -- at a time. It is possible to parse multiple units in syntax check
+ -- only mode, but they the trees are discarded in any case.
+
+ ------------------------------
+ -- 10.1.1 Compilation Unit --
+ ------------------------------
+
+ -- COMPILATION_UNIT ::=
+ -- CONTEXT_CLAUSE LIBRARY_ITEM
+ -- | CONTEXT_CLAUSE SUBUNIT
+
+ -- The N_Compilation_Unit node itself respresents the above syntax.
+ -- However, there are two additional items not reflected in the above
+ -- syntax. First we have the global declarations that are added by the
+ -- code generator. These are outer level declarations (so they cannot
+ -- be represented as being inside the units). An example is the wrapper
+ -- subprograms that are created to do ABE checking. As always a list of
+ -- declarations can contain actions as well (i.e. statements), and such
+ -- statements are executed as part of the elaboration of the unit. Note
+ -- that all such declarations are elaborated before the library unit.
+
+ -- Similarly, certain actions need to be elaborated at the completion
+ -- of elaboration of the library unit (notably the statement that sets
+ -- the Boolean flag indicating that elaboration is complete).
+
+ -- The third item not reflected in the syntax is pragmas that appear
+ -- after the compilation unit. As always pragmas are a problem since
+ -- they are not part of the formal syntax, but can be stuck into the
+ -- source following a set of ad hoc rules, and we have to find an ad
+ -- hoc way of sticking them into the tree. For pragmas that appear
+ -- before the library unit, we just consider them to be part of the
+ -- context clause, and pragmas can appear in the Context_Items list
+ -- of the compilation unit. However, pragmas can also appear after
+ -- the library item.
+
+ -- To deal with all these problems, we create an auxiliary node for
+ -- a compilation unit, referenced from the N_Compilation_Unit node
+ -- that contains these three items.
+
+ -- N_Compilation_Unit
+ -- Sloc points to first token of defining unit name
+ -- Library_Unit (Node4-Sem) corresponding/parent spec/body
+ -- Context_Items (List1) context items and pragmas preceding unit
+ -- Private_Present (Flag15) set if library unit has private keyword
+ -- Unit (Node2) library item or subunit
+ -- Aux_Decls_Node (Node5) points to the N_Compilation_Unit_Aux node
+ -- Has_No_Elaboration_Code (Flag17-Sem)
+ -- Body_Required (Flag13-Sem) set for spec if body is required
+ -- Acts_As_Spec (Flag4-Sem) flag for subprogram body with no spec
+ -- First_Inlined_Subprogram (Node3-Sem)
+
+ -- N_Compilation_Unit_Aux
+ -- Sloc is a copy of the Sloc from the N_Compilation_Unit node
+ -- Declarations (List2) (set to No_List if no global declarations)
+ -- Actions (List1) (set to No_List if no actions)
+ -- Pragmas_After (List5) pragmas after unit (set to No_List if none)
+
+ --------------------------
+ -- 10.1.1 Library Item --
+ --------------------------
+
+ -- LIBRARY_ITEM ::=
+ -- [private] LIBRARY_UNIT_DECLARATION
+ -- | LIBRARY_UNIT_BODY
+ -- | [private] LIBRARY_UNIT_RENAMING_DECLARATION
+
+ -- Note: PRIVATE is not allowed in Ada 83 mode
+
+ -- There is no explicit node in the tree for library item, instead
+ -- the declaration or body, and the flag for private if present,
+ -- appear in the N_Compilation_Unit clause.
+
+ ----------------------------------------
+ -- 10.1.1 Library Unit Declararation --
+ ----------------------------------------
+
+ -- LIBRARY_UNIT_DECLARATION ::=
+ -- SUBPROGRAM_DECLARATION | PACKAGE_DECLARATION
+ -- | GENERIC_DECLARATION | GENERIC_INSTANTIATION
+
+ -------------------------------------------------
+ -- 10.1.1 Library Unit Renaming Declararation --
+ -------------------------------------------------
+
+ -- LIBRARY_UNIT_RENAMING_DECLARATION ::=
+ -- PACKAGE_RENAMING_DECLARATION
+ -- | GENERIC_RENAMING_DECLARATION
+ -- | SUBPROGRAM_RENAMING_DECLARATION
+
+ -------------------------------
+ -- 10.1.1 Library unit body --
+ -------------------------------
+
+ -- LIBRARY_UNIT_BODY ::= SUBPROGRAM_BODY | PACKAGE_BODY
+
+ ------------------------------
+ -- 10.1.1 Parent Unit Name --
+ ------------------------------
+
+ -- PARENT_UNIT_NAME ::= NAME
+
+ ----------------------------
+ -- 10.1.2 Context clause --
+ ----------------------------
+
+ -- CONTEXT_CLAUSE ::= {CONTEXT_ITEM}
+
+ -- The context clause can include pragmas, and any pragmas that appear
+ -- before the context clause proper (i.e. all configuration pragmas,
+ -- also appear at the front of this list).
+
+ --------------------------
+ -- 10.1.2 Context_Item --
+ --------------------------
+
+ -- CONTEXT_ITEM ::= WITH_CLAUSE | USE_CLAUSE | WITH_TYPE_CLAUSE
+
+ -------------------------
+ -- 10.1.2 With clause --
+ -------------------------
+
+ -- WITH_CLAUSE ::=
+ -- with library_unit_NAME {,library_unit_NAME};
+
+ -- A separate With clause is built for each name, so that we have
+ -- a Corresponding_Spec field for each with'ed spec. The flags
+ -- First_Name and Last_Name are used to reconstruct the exact
+ -- source form. When a list of names appears in one with clause,
+ -- the first name in the list has First_Name set, and the last
+ -- has Last_Name set. If the with clause has only one name, then
+ -- both of the flags First_Name and Last_Name are set in this name.
+
+ -- Note: in the case of implicit with's that are installed by the
+ -- Rtsfind routine, Implicit_With is set, and the Sloc is typically
+ -- set to Standard_Location, but it is incorrect to test the Sloc
+ -- to find out if a with clause is implicit, test the flag instead.
+
+ -- N_With_Clause
+ -- Sloc points to first token of library unit name
+ -- Name (Node2)
+ -- Library_Unit (Node4-Sem)
+ -- Corresponding_Spec (Node5-Sem)
+ -- First_Name (Flag5) (set to True if first name or only one name)
+ -- Last_Name (Flag6) (set to True if last name or only one name)
+ -- Context_Installed (Flag13-Sem)
+ -- Elaborate_Present (Flag4-Sem)
+ -- Elaborate_All_Present (Flag15-Sem)
+ -- Implicit_With (Flag17-Sem)
+ -- Unreferenced_In_Spec (Flag7-Sem)
+ -- No_Entities_Ref_In_Spec (Flag8-Sem)
+
+ ----------------------
+ -- With_Type clause --
+ ----------------------
+
+ -- This is a GNAT extension, used to implement mutually recursive
+ -- types declared in different packages.
+
+ -- WITH_TYPE_CLAUSE ::=
+ -- with type type_NAME is access | with type type_NAME is tagged
+
+ -- N_With_Type_Clause
+ -- Sloc points to first token of type name
+ -- Name (Node2)
+ -- Tagged_Present (Flag15)
+
+ ---------------------
+ -- 10.2 Body stub --
+ ---------------------
+
+ -- BODY_STUB ::=
+ -- SUBPROGRAM_BODY_STUB
+ -- | PACKAGE_BODY_STUB
+ -- | TASK_BODY_STUB
+ -- | PROTECTED_BODY_STUB
+
+ ----------------------------------
+ -- 10.1.3 Subprogram Body Stub --
+ ----------------------------------
+
+ -- SUBPROGRAM_BODY_STUB ::=
+ -- SUBPROGRAM_SPECIFICATION is separate;
+
+ -- N_Subprogram_Body_Stub
+ -- Sloc points to FUNCTION or PROCEDURE
+ -- Specification (Node1)
+ -- Library_Unit (Node4-Sem) points to the subunit
+ -- Corresponding_Body (Node5-Sem)
+
+ -------------------------------
+ -- 10.1.3 Package Body Stub --
+ -------------------------------
+
+ -- PACKAGE_BODY_STUB ::=
+ -- package body DEFINING_IDENTIFIER is separate;
+
+ -- N_Package_Body_Stub
+ -- Sloc points to PACKAGE
+ -- Defining_Identifier (Node1)
+ -- Library_Unit (Node4-Sem) points to the subunit
+ -- Corresponding_Body (Node5-Sem)
+
+ ----------------------------
+ -- 10.1.3 Task Body Stub --
+ ----------------------------
+
+ -- TASK_BODY_STUB ::=
+ -- task body DEFINING_IDENTIFIER is separate;
+
+ -- N_Task_Body_Stub
+ -- Sloc points to TASK
+ -- Defining_Identifier (Node1)
+ -- Library_Unit (Node4-Sem) points to the subunit
+ -- Corresponding_Body (Node5-Sem)
+
+ ---------------------------------
+ -- 10.1.3 Protected Body Stub --
+ ---------------------------------
+
+ -- PROTECTED_BODY_STUB ::=
+ -- protected body DEFINING_IDENTIFIER is separate;
+
+ -- Note: protected body stubs are not allowed in Ada 83 mode
+
+ -- N_Protected_Body_Stub
+ -- Sloc points to PROTECTED
+ -- Defining_Identifier (Node1)
+ -- Library_Unit (Node4-Sem) points to the subunit
+ -- Corresponding_Body (Node5-Sem)
+
+ ---------------------
+ -- 10.1.3 Subunit --
+ ---------------------
+
+ -- SUBUNIT ::= separate (PARENT_UNIT_NAME) PROPER_BODY
+
+ -- N_Subunit
+ -- Sloc points to SEPARATE
+ -- Name (Node2) is the name of the parent unit
+ -- Proper_Body (Node1) is the subunit body
+ -- Corresponding_Stub (Node3-Sem) is the stub declaration for the unit.
+
+ ---------------------------------
+ -- 11.1 Exception Declaration --
+ ---------------------------------
+
+ -- EXCEPTION_DECLARATION ::= DEFINING_IDENTIFIER_LIST : exception;
+
+ -- For consistency with object declarations etc, the parser converts
+ -- the case of multiple identifiers being declared to a series of
+ -- declarations in which the expression is copied, using the More_Ids
+ -- and Prev_Ids flags to remember the souce form as described in the
+ -- section on "Handling of Defining Identifier Lists".
+
+ -- N_Exception_Declaration
+ -- Sloc points to EXCEPTION
+ -- Defining_Identifier (Node1)
+ -- Expression (Node3-Sem)
+ -- More_Ids (Flag5) (set to False if no more identifiers in list)
+ -- Prev_Ids (Flag6) (set to False if no previous identifiers in list)
+
+ ------------------------------------------
+ -- 11.2 Handled Sequence Of Statements --
+ ------------------------------------------
+
+ -- HANDLED_SEQUENCE_OF_STATEMENTS ::=
+ -- SEQUENCE_OF_STATEMENTS
+ -- [exception
+ -- EXCEPTION_HANDLER
+ -- {EXCEPTION_HANDLER}]
+ -- [at end
+ -- cleanup_procedure_call (param, param, param, ...);]
+
+ -- The AT END phrase is a GNAT extension to provide for cleanups. It is
+ -- used only internally currently, but is considered to be syntactic.
+ -- At the moment, the only cleanup action allowed is a single call to
+ -- a parameterless procedure, and the Identifier field of the node is
+ -- the procedure to be called. Also there is a current restriction
+ -- that exception handles and a cleanup cannot be present in the same
+ -- frame, so at least one of Exception_Handlers or the Identifier must
+ -- be missing.
+
+ -- Actually, more accurately, this restriction applies to the original
+ -- source program. In the expanded tree, if the At_End_Proc field is
+ -- present, then there will also be an exception handler of the form:
+
+ -- when all others =>
+ -- cleanup;
+ -- raise;
+
+ -- where cleanup is the procedure to be generated. The reason we do
+ -- this is so that the front end can handle the necessary entries in
+ -- the exception tables, and other exception handler actions required
+ -- as part of the normal handling for exception handlers.
+
+ -- The AT END cleanup handler protects only the sequence of statements
+ -- (not the associated declarations of the parent), just like exception
+ -- handlers. The big difference is that the cleanup procedure is called
+ -- on either a normal or an abnormal exit from the statement sequence.
+
+ -- Note: the list of Exception_Handlers can contain pragmas as well
+ -- as actual handlers. In practice these pragmas can only occur at
+ -- the start of the list, since any pragmas occurring later on will
+ -- be included in the statement list of the corresponding handler.
+
+ -- Note: although in the Ada syntax, the sequence of statements in
+ -- a handled sequence of statements can only contain statements, we
+ -- allow free mixing of declarations and statements in the resulting
+ -- expanded tree. This is for example used to deal with the case of
+ -- a cleanup procedure that must handle declarations as well as the
+ -- statements of a block.
+
+ -- N_Handled_Sequence_Of_Statements
+ -- Sloc points to first token of first statement
+ -- Statements (List3)
+ -- End_Label (Node4) (set to Empty if expander generated)
+ -- Exception_Handlers (List5) (set to No_List if none present)
+ -- At_End_Proc (Node1) (set to Empty if no clean up procedure)
+ -- First_Real_Statement (Node2-Sem)
+ -- Zero_Cost_Handling (Flag5-Sem)
+
+ -- Note: the parent always contains a Declarations field which contains
+ -- declarations associated with the handled sequence of statements. This
+ -- is true even in the case of an accept statement (see description of
+ -- the N_Accept_Statement node).
+
+ -- End_Label refers to the containing construct.
+
+ -----------------------------
+ -- 11.2 Exception Handler --
+ -----------------------------
+
+ -- EXCEPTION_HANDLER ::=
+ -- when [CHOICE_PARAMETER_SPECIFICATION :]
+ -- EXCEPTION_CHOICE {| EXCEPTION_CHOICE} =>
+ -- SEQUENCE_OF_STATEMENTS
+
+ -- Note: choice parameter specification is not allowed in Ada 83 mode
+
+ -- N_Exception_Handler
+ -- Sloc points to WHEN
+ -- Choice_Parameter (Node2) (set to Empty if not present)
+ -- Exception_Choices (List4)
+ -- Statements (List3)
+ -- Zero_Cost_Handling (Flag5-Sem)
+
+ ------------------------------------------
+ -- 11.2 Choice parameter specification --
+ ------------------------------------------
+
+ -- CHOICE_PARAMETER_SPECIFICATION ::= DEFINING_IDENTIFIER
+
+ ----------------------------
+ -- 11.2 Exception Choice --
+ ----------------------------
+
+ -- EXCEPTION_CHOICE ::= exception_NAME | others
+
+ -- Except in the case of OTHERS, no explicit node appears in the tree
+ -- for exception choice. Instead the exception name appears directly.
+ -- An OTHERS choice is represented by a N_Others_Choice node (see
+ -- section 3.8.1.
+
+ -- Note: for the exception choice created for an at end handler, the
+ -- exception choice is an N_Others_Choice node with All_Others set.
+
+ ---------------------------
+ -- 11.3 Raise Statement --
+ ---------------------------
+
+ -- RAISE_STATEMENT ::= raise [exception_NAME];
+
+ -- N_Raise_Statement
+ -- Sloc points to RAISE
+ -- Name (Node2) (set to Empty if no exception name present)
+
+ -------------------------------
+ -- 12.1 Generic Declaration --
+ -------------------------------
+
+ -- GENERIC_DECLARATION ::=
+ -- GENERIC_SUBPROGRAM_DECLARATION | GENERIC_PACKAGE_DECLARATION
+
+ ------------------------------------------
+ -- 12.1 Generic Subprogram Declaration --
+ ------------------------------------------
+
+ -- GENERIC_SUBPROGRAM_DECLARATION ::=
+ -- GENERIC_FORMAL_PART SUBPROGRAM_SPECIFICATION;
+
+ -- Note: Generic_Formal_Declarations can include pragmas
+
+ -- N_Generic_Subprogram_Declaration
+ -- Sloc points to GENERIC
+ -- Specification (Node1) subprogram specification
+ -- Corresponding_Body (Node5-Sem)
+ -- Generic_Formal_Declarations (List2) from generic formal part
+ -- Parent_Spec (Node4-Sem)
+
+ ---------------------------------------
+ -- 12.1 Generic Package Declaration --
+ ---------------------------------------
+
+ -- GENERIC_PACKAGE_DECLARATION ::=
+ -- GENERIC_FORMAL_PART PACKAGE_SPECIFICATION;
+
+ -- Note: when we do generics right, the Activation_Chain_Entity entry
+ -- for this node can be removed (since the expander won't see generic
+ -- units any more)???.
+
+ -- Note: Generic_Formal_Declarations can include pragmas
+
+ -- N_Generic_Package_Declaration
+ -- Sloc points to GENERIC
+ -- Specification (Node1) package specification
+ -- Corresponding_Body (Node5-Sem)
+ -- Generic_Formal_Declarations (List2) from generic formal part
+ -- Parent_Spec (Node4-Sem)
+ -- Activation_Chain_Entity (Node3-Sem)
+
+ -------------------------------
+ -- 12.1 Generic Formal Part --
+ -------------------------------
+
+ -- GENERIC_FORMAL_PART ::=
+ -- generic {GENERIC_FORMAL_PARAMETER_DECLARATION | USE_CLAUSE}
+
+ ------------------------------------------------
+ -- 12.1 Generic Formal Parameter Declaration --
+ ------------------------------------------------
+
+ -- GENERIC_FORMAL_PARAMETER_DECLARATION ::=
+ -- FORMAL_OBJECT_DECLARATION
+ -- | FORMAL_TYPE_DECLARATION
+ -- | FORMAL_SUBPROGRAM_DECLARATION
+ -- | FORMAL_PACKAGE_DECLARATION
+
+ ---------------------------------
+ -- 12.3 Generic Instantiation --
+ ---------------------------------
+
+ -- GENERIC_INSTANTIATION ::=
+ -- package DEFINING_PROGRAM_UNIT_NAME is
+ -- new generic_package_NAME [GENERIC_ACTUAL_PART];
+ -- | procedure DEFINING_PROGRAM_UNIT_NAME is
+ -- new generic_procedure_NAME [GENERIC_ACTUAL_PART];
+ -- | function DEFINING_DESIGNATOR is
+ -- new generic_function_NAME [GENERIC_ACTUAL_PART];
+
+ -- N_Package_Instantiation
+ -- Sloc points to PACKAGE
+ -- Defining_Unit_Name (Node1)
+ -- Name (Node2)
+ -- Generic_Associations (List3) (set to No_List if no
+ -- generic actual part)
+ -- Parent_Spec (Node4-Sem)
+ -- Instance_Spec (Node5-Sem)
+ -- ABE_Is_Certain (Flag18-Sem)
+
+ -- N_Procedure_Instantiation
+ -- Sloc points to PROCEDURE
+ -- Defining_Unit_Name (Node1)
+ -- Name (Node2)
+ -- Parent_Spec (Node4-Sem)
+ -- Generic_Associations (List3) (set to No_List if no
+ -- generic actual part)
+ -- Instance_Spec (Node5-Sem)
+ -- ABE_Is_Certain (Flag18-Sem)
+
+ -- N_Function_Instantiation
+ -- Sloc points to FUNCTION
+ -- Defining_Unit_Name (Node1)
+ -- Name (Node2)
+ -- Generic_Associations (List3) (set to No_List if no
+ -- generic actual part)
+ -- Parent_Spec (Node4-Sem)
+ -- Instance_Spec (Node5-Sem)
+ -- ABE_Is_Certain (Flag18-Sem)
+
+ ------------------------------
+ -- 12.3 Generic Actual Part --
+ ------------------------------
+
+ -- GENERIC_ACTUAL_PART ::=
+ -- (GENERIC_ASSOCIATION {, GENERIC_ASSOCIATION})
+
+ -------------------------------
+ -- 12.3 Generic Association --
+ -------------------------------
+
+ -- GENERIC_ASSOCIATION ::=
+ -- [generic_formal_parameter_SELECTOR_NAME =>]
+ -- EXPLICIT_GENERIC_ACTUAL_PARAMETER
+
+ -- Note: unlike the procedure call case, a generic association node
+ -- is generated for every association, even if no formal is present.
+ -- In this case the parser will leave the Selector_Name field set
+ -- to Empty, to be filled in later by the semantic pass.
+
+ -- N_Generic_Association
+ -- Sloc points to first token of generic association
+ -- Selector_Name (Node2) (set to Empty if no formal
+ -- parameter selector name)
+ -- Explicit_Generic_Actual_Parameter (Node1)
+
+ ---------------------------------------------
+ -- 12.3 Explicit Generic Actual Parameter --
+ ---------------------------------------------
+
+ -- EXPLICIT_GENERIC_ACTUAL_PARAMETER ::=
+ -- EXPRESSION | variable_NAME | subprogram_NAME
+ -- | entry_NAME | SUBTYPE_MARK | package_instance_NAME
+
+ -------------------------------------
+ -- 12.4 Formal Object Declaration --
+ -------------------------------------
+
+ -- FORMAL_OBJECT_DECLARATION ::=
+ -- DEFINING_IDENTIFIER_LIST :
+ -- MODE SUBTYPE_MARK [:= DEFAULT_EXPRESSION];
+
+ -- Although the syntax allows multiple identifiers in the list, the
+ -- semantics is as though successive declarations were given with
+ -- identical type definition and expression components. To simplify
+ -- semantic processing, the parser represents a multiple declaration
+ -- case as a sequence of single declarations, using the More_Ids and
+ -- Prev_Ids flags to preserve the original source form as described
+ -- in the section on "Handling of Defining Identifier Lists".
+
+ -- N_Formal_Object_Declaration
+ -- Sloc points to first identifier
+ -- Defining_Identifier (Node1)
+ -- In_Present (Flag15)
+ -- Out_Present (Flag17)
+ -- Subtype_Mark (Node4)
+ -- Expression (Node3) (set to Empty if no default expression)
+ -- More_Ids (Flag5) (set to False if no more identifiers in list)
+ -- Prev_Ids (Flag6) (set to False if no previous identifiers in list)
+
+ -----------------------------------
+ -- 12.5 Formal Type Declaration --
+ -----------------------------------
+
+ -- FORMAL_TYPE_DECLARATION ::=
+ -- type DEFINING_IDENTIFIER [DISCRIMINANT_PART]
+ -- is FORMAL_TYPE_DEFINITION;
+
+ -- N_Formal_Type_Declaration
+ -- Sloc points to TYPE
+ -- Defining_Identifier (Node1)
+ -- Formal_Type_Definition (Node3)
+ -- Discriminant_Specifications (List4) (set to No_List if no
+ -- discriminant part)
+ -- Unknown_Discriminants_Present (Flag13) set if (<>) discriminant
+
+ ----------------------------------
+ -- 12.5 Formal type definition --
+ ----------------------------------
+
+ -- FORMAL_TYPE_DEFINITION ::=
+ -- FORMAL_PRIVATE_TYPE_DEFINITION
+ -- | FORMAL_DERIVED_TYPE_DEFINITION
+ -- | FORMAL_DISCRETE_TYPE_DEFINITION
+ -- | FORMAL_SIGNED_INTEGER_TYPE_DEFINITION
+ -- | FORMAL_MODULAR_TYPE_DEFINITION
+ -- | FORMAL_FLOATING_POINT_DEFINITION
+ -- | FORMAL_ORDINARY_FIXED_POINT_DEFINITION
+ -- | FORMAL_DECIMAL_FIXED_POINT_DEFINITION
+ -- | FORMAL_ARRAY_TYPE_DEFINITION
+ -- | FORMAL_ACCESS_TYPE_DEFINITION
+
+ ---------------------------------------------
+ -- 12.5.1 Formal Private Type Definition --
+ ---------------------------------------------
+
+ -- FORMAL_PRIVATE_TYPE_DEFINITION ::=
+ -- [[abstract] tagged] [limited] private
+
+ -- Note: TAGGED is not allowed in Ada 83 mode
+
+ -- N_Formal_Private_Type_Definition
+ -- Sloc points to PRIVATE
+ -- Abstract_Present (Flag4)
+ -- Tagged_Present (Flag15)
+ -- Limited_Present (Flag17)
+
+ --------------------------------------------
+ -- 12.5.1 Formal Derived Type Definition --
+ --------------------------------------------
+
+ -- FORMAL_DERIVED_TYPE_DEFINITION ::=
+ -- [abstract] new SUBTYPE_MARK [with private]
+
+ -- Note: this construct is not allowed in Ada 83 mode
+
+ -- N_Formal_Derived_Type_Definition
+ -- Sloc points to NEW
+ -- Subtype_Mark (Node4)
+ -- Private_Present (Flag15)
+ -- Abstract_Present (Flag4)
+
+ ---------------------------------------------
+ -- 12.5.2 Formal Discrete Type Definition --
+ ---------------------------------------------
+
+ -- FORMAL_DISCRETE_TYPE_DEFINITION ::= (<>)
+
+ -- N_Formal_Discrete_Type_Definition
+ -- Sloc points to (
+
+ ---------------------------------------------------
+ -- 12.5.2 Formal Signed Integer Type Definition --
+ ---------------------------------------------------
+
+ -- FORMAL_SIGNED_INTEGER_TYPE_DEFINITION ::= range <>
+
+ -- N_Formal_Signed_Integer_Type_Definition
+ -- Sloc points to RANGE
+
+ --------------------------------------------
+ -- 12.5.2 Formal Modular Type Definition --
+ --------------------------------------------
+
+ -- FORMAL_MODULAR_TYPE_DEFINITION ::= mod <>
+
+ -- N_Formal_Modular_Type_Definition
+ -- Sloc points to MOD
+
+ ----------------------------------------------
+ -- 12.5.2 Formal Floating Point Definition --
+ ----------------------------------------------
+
+ -- FORMAL_FLOATING_POINT_DEFINITION ::= digits <>
+
+ -- N_Formal_Floating_Point_Definition
+ -- Sloc points to DIGITS
+
+ ----------------------------------------------------
+ -- 12.5.2 Formal Ordinary Fixed Point Definition --
+ ----------------------------------------------------
+
+ -- FORMAL_ORDINARY_FIXED_POINT_DEFINITION ::= delta <>
+
+ -- N_Formal_Ordinary_Fixed_Point_Definition
+ -- Sloc points to DELTA
+
+ ---------------------------------------------------
+ -- 12.5.2 Formal Decimal Fixed Point Definition --
+ ---------------------------------------------------
+
+ -- FORMAL_DECIMAL_FIXED_POINT_DEFINITION ::= delta <> digits <>
+
+ -- Note: formal decimal fixed point definition not allowed in Ada 83
+
+ -- N_Formal_Decimal_Fixed_Point_Definition
+ -- Sloc points to DELTA
+
+ ------------------------------------------
+ -- 12.5.3 Formal Array Type Definition --
+ ------------------------------------------
+
+ -- FORMAL_ARRAY_TYPE_DEFINITION ::= ARRAY_TYPE_DEFINITION
+
+ -------------------------------------------
+ -- 12.5.4 Formal Access Type Definition --
+ -------------------------------------------
+
+ -- FORMAL_ACCESS_TYPE_DEFINITION ::= ACCESS_TYPE_DEFINITION
+
+ -----------------------------------------
+ -- 12.6 Formal Subprogram Declaration --
+ -----------------------------------------
+
+ -- FORMAL_SUBPROGRAM_DECLARATION ::=
+ -- with SUBPROGRAM_SPECIFICATION [is SUBPROGRAM_DEFAULT];
+
+ -- N_Formal_Subprogram_Declaration
+ -- Sloc points to WITH
+ -- Specification (Node1)
+ -- Default_Name (Node2) (set to Empty if no subprogram default)
+ -- Box_Present (Flag15)
+
+ -- Note: if no subprogram default is present, then Name is set
+ -- to Empty, and Box_Present is False.
+
+ ------------------------------
+ -- 12.6 Subprogram Default --
+ ------------------------------
+
+ -- SUBPROGRAM_DEFAULT ::= DEFAULT_NAME | <>
+
+ -- There is no separate node in the tree for a subprogram default.
+ -- Instead the parent (N_Formal_Subprogram_Declaration) node contains
+ -- the default name or box indication, as needed.
+
+ ------------------------
+ -- 12.6 Default Name --
+ ------------------------
+
+ -- DEFAULT_NAME ::= NAME
+
+ --------------------------------------
+ -- 12.7 Formal Package Declaration --
+ --------------------------------------
+
+ -- FORMAL_PACKAGE_DECLARATION ::=
+ -- with package DEFINING_IDENTIFIER
+ -- is new generic_package_NAME FORMAL_PACKAGE_ACTUAL_PART;
+
+ -- Note: formal package declarations not allowed in Ada 83 mode
+
+ -- N_Formal_Package_Declaration
+ -- Sloc points to WITH
+ -- Defining_Identifier (Node1)
+ -- Name (Node2)
+ -- Generic_Associations (List3) (set to No_List if (<>) case or
+ -- empty generic actual part)
+ -- Box_Present (Flag15)
+ -- Instance_Spec (Node5-Sem)
+ -- ABE_Is_Certain (Flag18-Sem)
+
+ --------------------------------------
+ -- 12.7 Formal Package Actual Part --
+ --------------------------------------
+
+ -- FORMAL_PACKAGE_ACTUAL_PART ::=
+ -- (<>) | [GENERIC_ACTUAL_PART]
+
+ -- There is no explicit node in the tree for a formal package
+ -- actual part. Instead the information appears in the parent node
+ -- (i.e. the formal package declaration node itself).
+
+ ---------------------------------
+ -- 13.1 Representation clause --
+ ---------------------------------
+
+ -- REPRESENTATION_CLAUSE ::=
+ -- ATTRIBUTE_DEFINITION_CLAUSE
+ -- | ENUMERATION_REPRESENTATION_CLAUSE
+ -- | RECORD_REPRESENTATION_CLAUSE
+ -- | AT_CLAUSE
+
+ ----------------------
+ -- 13.1 Local Name --
+ ----------------------
+
+ -- LOCAL_NAME :=
+ -- DIRECT_NAME
+ -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR
+ -- | library_unit_NAME
+
+ -- The construct DIRECT_NAME'ATTRIBUTE_DESIGNATOR appears in the tree
+ -- as an attribute reference, which has essentially the same form.
+
+ ---------------------------------------
+ -- 13.3 Attribute definition clause --
+ ---------------------------------------
+
+ -- ATTRIBUTE_DEFINITION_CLAUSE ::=
+ -- for LOCAL_NAME'ATTRIBUTE_DESIGNATOR use EXPRESSION;
+ -- | for LOCAL_NAME'ATTRIBUTE_DESIGNATOR use NAME;
+
+ -- In Ada 83, the expression must be a simple expression and the
+ -- local name must be a direct name.
+
+ -- Note: The only attribute definition clause that is processed
+ -- by Gigi is the alignment clause (for all other cases, the
+ -- information is extracted by the front end and either results
+ -- in setting entity information, e.g. Esize for the Size case,
+ -- or in appropriate expansion actions (e.g. in the storage size
+ -- case). For the alignment case, Gigi requires that the expression
+ -- be an integer literal.
+
+ -- N_Attribute_Definition_Clause
+ -- Sloc points to FOR
+ -- Name (Node2) the local name
+ -- Chars (Name1) the identifier name from the attribute designator
+ -- Expression (Node3) the expression or name
+ -- Next_Rep_Item (Node4-Sem)
+ -- From_At_Mod (Flag4-Sem)
+
+ ---------------------------------------------
+ -- 13.4 Enumeration representation clause --
+ ---------------------------------------------
+
+ -- ENUMERATION_REPRESENTATION_CLAUSE ::=
+ -- for first_subtype_LOCAL_NAME use ENUMERATION_AGGREGATE;
+
+ -- In Ada 83, the name must be a direct name
+
+ -- N_Enumeration_Representation_Clause
+ -- Sloc points to FOR
+ -- Identifier (Node1) direct name
+ -- Array_Aggregate (Node3)
+ -- Next_Rep_Item (Node4-Sem)
+
+ ---------------------------------
+ -- 13.4 Enumeration aggregate --
+ ---------------------------------
+
+ -- ENUMERATION_AGGREGATE ::= ARRAY_AGGREGATE
+
+ ------------------------------------------
+ -- 13.5.1 Record representation clause --
+ ------------------------------------------
+
+ -- RECORD_REPRESENTATION_CLAUSE ::=
+ -- for first_subtype_LOCAL_NAME use
+ -- record [MOD_CLAUSE]
+ -- {COMPONENT_CLAUSE}
+ -- end record;
+
+ -- Gigi restriction: Mod_Clause is always Empty (if present it is
+ -- replaced by a corresponding Alignment attribute definition clause).
+
+ -- Note: Component_Clauses can include pragmas
+
+ -- N_Record_Representation_Clause
+ -- Sloc points to FOR
+ -- Identifier (Node1) direct name
+ -- Mod_Clause (Node2) (set to Empty if no mod clause present)
+ -- Component_Clauses (List3)
+ -- Next_Rep_Item (Node4-Sem)
+
+ ------------------------------
+ -- 13.5.1 Component clause --
+ ------------------------------
+
+ -- COMPONENT_CLAUSE ::=
+ -- component_LOCAL_NAME at POSITION
+ -- range FIRST_BIT .. LAST_BIT;
+
+ -- N_Component_Clause
+ -- Sloc points to AT
+ -- Component_Name (Node1) points to Name or Attribute_Reference
+ -- Position (Node2)
+ -- First_Bit (Node3)
+ -- Last_Bit (Node4)
+
+ ----------------------
+ -- 13.5.1 Position --
+ ----------------------
+
+ -- POSITION ::= static_EXPRESSION
+
+ -----------------------
+ -- 13.5.1 First_Bit --
+ -----------------------
+
+ -- FIRST_BIT ::= static_SIMPLE_EXPRESSION
+
+ ----------------------
+ -- 13.5.1 Last_Bit --
+ ----------------------
+
+ -- LAST_BIT ::= static_SIMPLE_EXPRESSION
+
+ --------------------------
+ -- 13.8 Code statement --
+ --------------------------
+
+ -- CODE_STATEMENT ::= QUALIFIED_EXPRESSION;
+
+ -- Note: in GNAT, the qualified expression has the form
+
+ -- Asm_Insn'(Asm (...));
+
+ -- or
+
+ -- Asm_Insn'(Asm_Volatile (...))
+
+ -- See package System.Machine_Code in file s-maccod.ads for details
+ -- on the allowed parameters to Asm[_Volatile]. There are two ways
+ -- this node can arise, as a code statement, in which case the
+ -- expression is the qualified expression, or as a result of the
+ -- expansion of an intrinsic call to the Asm or Asm_Input procedure.
+
+ -- N_Code_Statement
+ -- Sloc points to first token of the expression
+ -- Expression (Node3)
+
+ -- Note: package Exp_Code contains an abstract functional interface
+ -- for use by Gigi in accessing the data from N_Code_Statement nodes.
+
+ ------------------------
+ -- 13.12 Restriction --
+ ------------------------
+
+ -- RESTRICTION ::=
+ -- restriction_IDENTIFIER
+ -- | restriction_parameter_IDENTIFIER => EXPRESSION
+
+ -- There is no explicit node for restrictions. Instead the restriction
+ -- appears in normal pragma syntax as a pragma argument association,
+ -- which has the same syntactic form.
+
+ --------------------------
+ -- B.2 Shift Operators --
+ --------------------------
+
+ -- Calls to the intrinsic shift functions are converted to one of
+ -- the following shift nodes, which have the form of normal binary
+ -- operator names. Note that for a given shift operation, one node
+ -- covers all possible types, as for normal operators.
+
+ -- Note: it is perfectly permissible for the expander to generate
+ -- shift operation nodes directly, in which case they will be analyzed
+ -- and parsed in the usual manner.
+
+ -- Sprint syntax: shift-function-name!(expr, count)
+
+ -- Note: the Left_Opnd field holds the first argument (the value to
+ -- be shifted). The Right_Opnd field holds the second argument (the
+ -- shift count). The Chars field is the name of the intrinsic function.
+
+ -- N_Op_Rotate_Left
+ -- Sloc points to the function name
+ -- plus fields for binary operator
+ -- plus fields for expression
+ -- Shift_Count_OK (Flag4-Sem)
+
+ -- N_Op_Rotate_Right
+ -- Sloc points to the function name
+ -- plus fields for binary operator
+ -- plus fields for expression
+ -- Shift_Count_OK (Flag4-Sem)
+
+ -- N_Op_Shift_Left
+ -- Sloc points to the function name
+ -- plus fields for binary operator
+ -- plus fields for expression
+ -- Shift_Count_OK (Flag4-Sem)
+
+ -- N_Op_Shift_Right_Arithmetic
+ -- Sloc points to the function name
+ -- plus fields for binary operator
+ -- plus fields for expression
+ -- Shift_Count_OK (Flag4-Sem)
+
+ -- N_Op_Shift_Right
+ -- Sloc points to the function name
+ -- plus fields for binary operator
+ -- plus fields for expression
+ -- Shift_Count_OK (Flag4-Sem)
+
+ --------------------------
+ -- Obsolescent Features --
+ --------------------------
+
+ -- The syntax descriptions and tree nodes for obsolescent features are
+ -- grouped together, corresponding to their location in appendix I in
+ -- the RM. However, parsing and semantic analysis for these constructs
+ -- is located in an appropriate chapter (see individual notes).
+
+ ---------------------------
+ -- J.3 Delta Constraint --
+ ---------------------------
+
+ -- Note: the parse routine for this construct is located in section
+ -- 3.5.9 of Par-Ch3, and semantic analysis is in Sem_Ch3, which is
+ -- where delta constraint logically belongs.
+
+ -- DELTA_CONSTRAINT ::= DELTA static_EXPRESSION [RANGE_CONSTRAINT]
+
+ -- N_Delta_Constraint
+ -- Sloc points to DELTA
+ -- Delta_Expression (Node3)
+ -- Range_Constraint (Node4) (set to Empty if not present)
+
+ --------------------
+ -- J.7 At Clause --
+ --------------------
+
+ -- AT_CLAUSE ::= for DIRECT_NAME use at EXPRESSION;
+
+ -- Note: the parse routine for this construct is located in Par-Ch13,
+ -- and the semantic analysis is in Sem_Ch13, where at clause logically
+ -- belongs if it were not obsolescent.
+
+ -- Note: in Ada 83 the expression must be a simple expression
+
+ -- Gigi restriction: This node never appears, it is rewritten as an
+ -- address attribute definition clause.
+
+ -- N_At_Clause
+ -- Sloc points to FOR
+ -- Identifier (Node1)
+ -- Expression (Node3)
+
+ ---------------------
+ -- J.8 Mod clause --
+ ---------------------
+
+ -- MOD_CLAUSE ::= at mod static_EXPRESSION;
+
+ -- Note: the parse routine for this construct is located in Par-Ch13,
+ -- and the semantic analysis is in Sem_Ch13, where mod clause logically
+ -- belongs if it were not obsolescent.
+
+ -- Note: in Ada 83, the expression must be a simple expression
+
+ -- Gigi restriction: this node never appears. It is replaced
+ -- by a corresponding Alignment attribute definition clause.
+
+ -- Note: pragmas can appear before and after the MOD_CLAUSE since
+ -- its name has "clause" in it. This is rather strange, but is quite
+ -- definitely specified. The pragmas before are collected in the
+ -- Pragmas_Before field of the mod clause node itself, and pragmas
+ -- after are simply swallowed up in the list of component clauses.
+
+ -- N_Mod_Clause
+ -- Sloc points to AT
+ -- Expression (Node3)
+ -- Pragmas_Before (List4) Pragmas before mod clause (No_List if none)
+
+ --------------------
+ -- Semantic Nodes --
+ --------------------
+
+ -- These semantic nodes are used to hold additional semantic information.
+ -- They are inserted into the tree as a result of semantic processing.
+ -- Although there are no legitimate source syntax constructions that
+ -- correspond directly to these nodes, we need a source syntax for the
+ -- reconstructed tree printed by Sprint, and the node descriptions here
+ -- show this syntax.
+
+ ----------------------------
+ -- Conditional Expression --
+ ----------------------------
+
+ -- This node is used to represent an expression corresponding to the
+ -- C construct (condition ? then-expression : else_expression), where
+ -- Expressions is a three element list, whose first expression is the
+ -- condition, and whose second and third expressions are the then and
+ -- else expressions respectively.
+
+ -- Note: the Then_Actions and Else_Actions fields are always set to
+ -- No_List in the tree passed to Gigi. These fields are used only
+ -- for temporary processing purposes in the expander.
+
+ -- Sprint syntax: (if expr then expr else expr)
+
+ -- N_Conditional_Expression
+ -- Sloc points to related node
+ -- Expressions (List1)
+ -- Then_Actions (List2-Sem)
+ -- Else_Actions (List3-Sem)
+ -- plus fields for expression
+
+ -- Note: in the case where a debug source file is generated, the Sloc
+ -- for this node points to the IF keyword in the Sprint file output.
+
+ -------------------
+ -- Expanded_Name --
+ -------------------
+
+ -- The N_Expanded_Name node is used to represent a selected component
+ -- name that has been resolved to an expanded name. The semantic phase
+ -- replaces N_Selected_Component nodes that represent names by the use
+ -- of this node, leaving the N_Selected_Component node used only when
+ -- the prefix is a record or protected type.
+
+ -- The fields of the N_Expanded_Name node are layed out identically
+ -- to those of the N_Selected_Component node, allowing conversion of
+ -- an expanded name node to a selected component node to be done
+ -- easily, see Sinfo.CN.Change_Selected_Component_To_Expanded_Name.
+
+ -- There is no special sprint syntax for an expanded name.
+
+ -- N_Expanded_Name
+ -- Sloc points to the period
+ -- Chars (Name1) copy of Chars field of selector name
+ -- Prefix (Node3)
+ -- Selector_Name (Node2)
+ -- Entity (Node4-Sem)
+ -- Redundant_Use (Flag13-Sem)
+ -- Has_Private_View (Flag11-Sem) set in generic units.
+ -- plus fields for expression
+
+ --------------------
+ -- Free Statement --
+ --------------------
+
+ -- The N_Free_Statement node is generated as a result of a call to an
+ -- instantiation of Unchecked_Deallocation. The instantiation of this
+ -- generic is handled specially and generates this node directly.
+
+ -- Sprint syntax: free expression
+
+ -- N_Free_Statement
+ -- Sloc is copied from the unchecked deallocation call
+ -- Expression (Node3) argument to unchecked deallocation call
+ -- Storage_Pool (Node1-Sem)
+ -- Procedure_To_Call (Node4-Sem)
+
+ -- Note: in the case where a debug source file is generated, the Sloc
+ -- for this node points to the FREE keyword in the Sprint file output.
+
+ -------------------
+ -- Freeze Entity --
+ -------------------
+
+ -- This node marks the point in a declarative part at which an entity
+ -- declared therein becomes frozen. The expander places initialization
+ -- procedures for types at those points. Gigi uses the freezing point
+ -- to elaborate entities that may depend on previous private types.
+
+ -- See the section in Einfo "Delayed Freezing and Elaboration" for
+ -- a full description of the use of this node.
+
+ -- The Entity field points back to the entity for the type (whose
+ -- Freeze_Node field points back to this freeze node).
+
+ -- The Actions field contains a list of declarations and statements
+ -- generated by the expander which are associated with the freeze
+ -- node, and are elaborated as though the freeze node were replaced
+ -- by this sequence of actions.
+
+ -- Note: the Sloc field in the freeze node references a construct
+ -- associated with the freezing point. This is used for posting
+ -- messages in some error/warning situations, e.g. the case where
+ -- a primitive operation of a tagged type is declared too late.
+
+ -- Sprint syntax: freeze entity-name [
+ -- freeze actions
+ -- ]
+
+ -- N_Freeze_Entity
+ -- Sloc points near freeze point (see above special note)
+ -- Entity (Node4-Sem)
+ -- Access_Types_To_Process (Elist2-Sem) (set to No_Elist if none)
+ -- TSS_Elist (Elist3-Sem) (set to No_Elist if no associated TSS's)
+ -- Actions (List1) (set to No_List if no freeze actions)
+ -- First_Subtype_Link (Node5-Sem) (set to Empty if no link)
+
+ -- The Actions field holds actions associated with the freeze. These
+ -- actions are elaborated at the point where the type is frozen.
+
+ -- Note: in the case where a debug source file is generated, the Sloc
+ -- for this node points to the FREEZE keyword in the Sprint file output.
+
+ --------------------------------
+ -- Implicit Label Declaration --
+ --------------------------------
+
+ -- An implicit label declaration is created for every occurrence of a
+ -- label on a statement or a label on a block or loop. It is chained
+ -- in the declarations of the innermost enclosing block as specified
+ -- in RM section 5.1 (3).
+
+ -- The Defining_Identifier is the actual identifier for the
+ -- statement identifier. Note that the occurrence of the label
+ -- is a reference, NOT the defining occurrence. The defining
+ -- occurrence occurs at the head of the innermost enclosing
+ -- block, and is represented by this node.
+
+ -- Note: from the grammar, this might better be called an implicit
+ -- statement identifier declaration, but the term we choose seems
+ -- friendlier, since at least informally statement identifiers are
+ -- called labels in both cases (i.e. when used in labels, and when
+ -- used as the identifiers of blocks and loops).
+
+ -- Note: although this is logically a semantic node, since it does
+ -- not correspond directly to a source syntax construction, these
+ -- nodes are actually created by the parser in a post pass done just
+ -- after parsing is complete, before semantic analysis is started (see
+ -- the Par.Labl subunit in file par-labl.adb).
+
+ -- Sprint syntax: labelname : label;
+
+ -- N_Implicit_Label_Declaration
+ -- Sloc points to the << of the label
+ -- Defining_Identifier (Node1)
+ -- Label_Construct (Node2-Sem)
+
+ -- Note: in the case where a debug source file is generated, the Sloc
+ -- for this node points to the label name in the generated declaration.
+
+ ---------------------
+ -- Itype_Reference --
+ ---------------------
+
+ -- This node is used to create a reference to an Itype. The only
+ -- purpose is to make sure that the Itype is defined if this is the
+ -- first reference.
+
+ -- A typical use of this node is when an Itype is to be referenced in
+ -- two branches of an if statement. In this case it is important that
+ -- the first use of the Itype not be inside the conditional, since
+ -- then it might not be defined if the wrong branch of the if is
+ -- taken in the case where the definition generates elaboration code.
+
+ -- The Itype field points to the referenced Itype
+
+ -- sprint syntax: reference itype-name
+
+ -- N_Itype_Reference
+ -- Sloc points to the node generating the reference
+ -- Itype (Node1-Sem)
+
+ -- Note: in the case where a debug source file is generated, the Sloc
+ -- for this node points to the REFERENCE keyword in the file output.
+
+ ---------------------
+ -- Raise_xxx_Error --
+ ---------------------
+
+ -- One of these nodes is created during semantic analysis to replace
+ -- a node for an expression that is determined to definitely raise
+ -- the corresponding exception.
+
+ -- The N_Raise_xxx_Error node may also stand alone in place
+ -- of a declaration or statement, in which case it simply causes
+ -- the exception to be raised (i.e. it is equivalent to a raise
+ -- statement that raises the corresponding exception). This use
+ -- is distinguished by the fact that the Etype in this case is
+ -- Standard_Void_Type, In the subexprssion case, the Etype is the
+ -- same as the type of the subexpression which it replaces.
+
+ -- If Condition is empty, then the raise is unconditional. If the
+ -- Condition field is non-empty, it is a boolean expression which
+ -- is first evaluated, and the exception is raised only if the
+ -- value of the expression is True. In the unconditional case, the
+ -- creation of this node is usually accompanied by a warning message
+ -- error. The creation of this node will usually be accompanied by a
+ -- message (unless it appears within the right operand of a short
+ -- circuit form whose left argument is static and decisively
+ -- eliminates elaboration of the raise operation.
+
+ -- Gigi restriction: This expander ensures that the type of the
+ -- Condition field is always Standard.Boolean, even if the type
+ -- in the source is some non-standard boolean type.
+
+ -- Sprint syntax: [xxx_error]
+ -- or: [xxx_error when condition]
+
+ -- N_Raise_Constraint_Error
+ -- Sloc references related construct
+ -- Condition (Node1) (set to Empty if no condition)
+ -- Sloc is copied from the expression generating the exception
+ -- plus fields for expression
+
+ -- N_Raise_Program_Error
+ -- Sloc references related construct
+ -- Condition (Node1) (set to Empty if no condition)
+ -- Sloc is copied from the construct generating the exception
+ -- plus fields for expression
+
+ -- N_Raise_Storage_Error
+ -- Sloc references related construct
+ -- Condition (Node1) (set to Empty if no condition)
+ -- Sloc is copied from the construct generating the exception
+ -- plus fields for expression
+
+ -- Note: in the case where a debug source file is generated, the Sloc
+ -- for this node points to the left bracket in the Sprint file output.
+
+ ---------------
+ -- Reference --
+ ---------------
+
+ -- For a number of purposes, we need to construct references to objects.
+ -- These references are subsequently treated as normal access values.
+ -- An example is the construction of the parameter block passed to a
+ -- task entry. The N_Reference node is provided for this purpose. It is
+ -- similar in effect to the use of the Unrestricted_Access attribute,
+ -- and like Unrestricted_Access can be applied to objects which would
+ -- not be valid prefixes for the Unchecked_Access attribute (e.g.
+ -- objects which are not aliased, and slices). In addition it can be
+ -- applied to composite type values as well as objects, including string
+ -- values and aggregates.
+
+ -- Note: we use the Prefix field for this expression so that the
+ -- resulting node can be treated using common code with the attribute
+ -- nodes for the 'Access and related attributes. Logically it would make
+ -- more sense to call it an Expression field, but then we would have to
+ -- special case the treatment of the N_Reference node.
+
+ -- Sprint syntax: prefix'reference
+
+ -- N_Reference
+ -- Sloc is copied from the expression
+ -- Prefix (Node3)
+ -- plus fields for expression
+
+ -- Note: in the case where a debug source file is generated, the Sloc
+ -- for this node points to the quote in the Sprint file output.
+
+ ---------------------
+ -- Subprogram_Info --
+ ---------------------
+
+ -- This node generates the appropriate Subprogram_Info value for a
+ -- given procedure. See Ada.Exceptions for further details
+
+ -- Sprint syntax: subprog'subprogram_info
+
+ -- N_Subprogram_Info
+ -- Sloc points to the entity for the procedure
+ -- Identifier (Node1) identifier referencing the procedure
+ -- Etype (Node5-Sem) type (always set to Ada.Exceptions.Code_Loc
+
+ -- Note: in the case where a debug source file is generated, the Sloc
+ -- for this node points to the quote in the Sprint file output.
+
+ --------------------------
+ -- Unchecked Expression --
+ --------------------------
+
+ -- An unchecked expression is one that must be analyzed and resolved
+ -- with all checks off, regardless of the current setting of scope
+ -- suppress flags.
+
+ -- Sprint syntax: `(expression).
+
+ -- Note: this node is always removed from the tree (and replaced by
+ -- its constituent expression) on completion of analysis, so it only
+ -- appears in intermediate trees, and will never be seen by Gigi.
+
+ -- N_Unchecked_Expression
+ -- Sloc is a copy of the Sloc of the expression
+ -- Expression (Node3)
+ -- plus fields for expression
+
+ -- Note: in the case where a debug source file is generated, the Sloc
+ -- for this node points to the back quote in the Sprint file output.
+
+ -------------------------------
+ -- Unchecked Type Conversion --
+ -------------------------------
+
+ -- An unchecked type conversion node represents the semantic action
+ -- corresponding to a call to an instantiation of Unchecked_Conversion.
+ -- It is generated as a result of actual use of Unchecked_Conversion
+ -- and also the expander generates unchecked type conversion nodes
+ -- directly for expansion of complex semantic actions.
+
+ -- Note: an unchecked type conversion is a variable as far as the
+ -- semantics are concerned, which is convenient for the expander.
+ -- This does not change what Ada source programs are legal, since
+ -- clearly a function call to an instantiation of Unchecked_Conversion
+ -- is not a variable in any case.
+
+ -- Sprint syntax: subtype-mark!(expression).
+
+ -- N_Unchecked_Type_Conversion
+ -- Sloc points to related node in source
+ -- Subtype_Mark (Node4)
+ -- Expression (Node3)
+ -- Kill_Range_Check (Flag11-Sem)
+ -- plus fields for expression
+
+ -- Note: in the case where a debug source file is generated, the Sloc
+ -- for this node points to the exclamation in the Sprint file output.
+
+ -----------------------------------
+ -- Validate_Unchecked_Conversion --
+ -----------------------------------
+
+ -- The front end does most of the validation of unchecked conversion,
+ -- including checking sizes (this is done after the back end is called
+ -- to take advantage of back-annotation of calculated sizes).
+
+ -- The front end also deals with specific cases that are not allowed
+ -- e.g. involving unconstrained array types.
+
+ -- For the case of the standard gigi backend, this means that all
+ -- checks are done in the front-end.
+
+ -- However, in the case of specialized back-ends, notably the JVM
+ -- backend for JGNAT, additional requirements and restrictions apply
+ -- to unchecked conversion, and these are most conveniently performed
+ -- in the specialized back-end.
+
+ -- To accomodate this requirement, for such back ends, the following
+ -- special node is generated recording an unchecked conversion that
+ -- needs to be validated. The back end should post an appropriate
+ -- error message if the unchecked conversion is invalid or warrants
+ -- a special warning message.
+
+ -- Source_Type and Target_Type point to the entities for the two
+ -- types involved in the unchecked conversion instantiation that
+ -- is to be validated.
+
+ -- Sprint syntax: validate Unchecked_Conversion (source, target);
+
+ -- N_Validate_Unchecked_Conversion
+ -- Sloc points to instantiation (location for warning message)
+ -- Source_Type (Node1-Sem)
+ -- Target_Type (Node2-Sem)
+
+ -- Note: in the case where a debug source file is generated, the Sloc
+ -- for this node points to the VALIDATE keyword in the file output.
+
+ -----------
+ -- Empty --
+ -----------
+
+ -- N_Empty
+ -- Chars (Name1) is set to No_Name
+ -- Used as the contents of the Nkind field of the dummy Empty node
+ -- and in some other situations to indicate an uninitialized value.
+
+ -----------
+ -- Error --
+ -----------
+
+ -- N_Error
+ -- Chars (Name1) is set to Error_Name
+ -- Used as the contents of the Nkind field of the dummy Error node
+
+ --------------------------
+ -- Node Type Definition --
+ --------------------------
+
+ -- The following is the definition of the Node_Kind type. As previously
+ -- discussed, this is separated off to allow rearrangement of the order
+ -- to facilitiate definition of subtype ranges. The comments show the
+ -- subtype classes which apply to each set of node kinds. The first
+ -- entry in the comment characterizes the following list of nodes.
+
+ type Node_Kind is (
+ N_Unused_At_Start,
+
+ -- N_Representation_Clause
+ N_At_Clause,
+ N_Component_Clause,
+ N_Enumeration_Representation_Clause,
+ N_Mod_Clause,
+ N_Record_Representation_Clause,
+
+ -- N_Representation_Clause, N_Has_Chars
+ N_Attribute_Definition_Clause,
+
+ -- N_Has_Chars
+ N_Empty,
+ N_Error,
+ N_Pragma,
+ N_Pragma_Argument_Association,
+
+ -- N_Entity, N_Has_Etype, N_Has_Chars
+ N_Defining_Character_Literal,
+ N_Defining_Identifier,
+ N_Defining_Operator_Symbol,
+
+ -- N_Subexpr, N_Has_Etype, N_Has_Chars, N_Has_Entity
+ N_Expanded_Name,
+
+ -- N_Direct_Name, N_Subexpr, N_Has_Etype,
+ -- N_Has_Chars, N_Has_Entity
+ N_Identifier,
+ N_Operator_Symbol,
+
+ -- N_Direct_Name, N_Subexpr, N_Has_Etype,
+ -- N_Has_Chars, N_Has_Entity
+ N_Character_Literal,
+
+ -- N_Binary_Op, N_Op, N_Subexpr,
+ -- N_Has_Etype, N_Has_Chars, N_Has_Entity
+ N_Op_Add,
+ N_Op_Concat,
+ N_Op_Divide,
+ N_Op_Expon,
+ N_Op_Mod,
+ N_Op_Multiply,
+ N_Op_Rem,
+ N_Op_Subtract,
+
+ -- N_Binary_Op, N_Op, N_Subexpr, N_Has_Etype
+ -- N_Has_Entity, N_Has_Chars, N_Op_Boolean
+ N_Op_And,
+
+ -- N_Binary_Op, N_Op, N_Subexpr, N_Has_Etype
+ -- N_Has_Entity, N_Has_Chars, N_Op_Boolean,
+ -- N_Op_Compare
+ N_Op_Eq,
+ N_Op_Ge,
+ N_Op_Gt,
+ N_Op_Le,
+ N_Op_Lt,
+ N_Op_Ne,
+
+ -- N_Binary_Op, N_Op, N_Subexpr, N_Has_Etype
+ -- N_Has_Entity, N_Has_Chars, N_Op_Boolean
+ N_Op_Or,
+ N_Op_Xor,
+
+ -- N_Binary_Op, N_Op, N_Subexpr, N_Has_Etype,
+ -- N_Op_Shift, N_Has_Chars, N_Has_Entity
+ N_Op_Rotate_Left,
+ N_Op_Rotate_Right,
+ N_Op_Shift_Left,
+ N_Op_Shift_Right,
+ N_Op_Shift_Right_Arithmetic,
+
+ -- N_Unary_Op, N_Op, N_Subexpr, N_Has_Etype,
+ -- N_Has_Chars, N_Has_Entity
+ N_Op_Abs,
+ N_Op_Minus,
+ N_Op_Not,
+ N_Op_Plus,
+
+ -- N_Subexpr, N_Has_Etype, N_Has_Entity
+ N_Attribute_Reference,
+
+ -- N_Subexpr, N_Has_Etype
+ N_And_Then,
+ N_Conditional_Expression,
+ N_Explicit_Dereference,
+ N_Function_Call,
+ N_In,
+ N_Indexed_Component,
+ N_Integer_Literal,
+ N_Not_In,
+ N_Null,
+ N_Or_Else,
+ N_Procedure_Call_Statement,
+ N_Qualified_Expression,
+
+ -- N_Raise_xxx_Error, N_Subexpr, N_Has_Etype
+
+ N_Raise_Constraint_Error,
+ N_Raise_Program_Error,
+ N_Raise_Storage_Error,
+
+ -- N_Subexpr, N_Has_Etype
+
+ N_Aggregate,
+ N_Allocator,
+ N_Extension_Aggregate,
+ N_Range,
+ N_Real_Literal,
+ N_Reference,
+ N_Selected_Component,
+ N_Slice,
+ N_String_Literal,
+ N_Subprogram_Info,
+ N_Type_Conversion,
+ N_Unchecked_Expression,
+ N_Unchecked_Type_Conversion,
+
+ -- N_Has_Etype
+ N_Subtype_Indication,
+
+ -- N_Declaration
+ N_Component_Declaration,
+ N_Entry_Declaration,
+ N_Formal_Object_Declaration,
+ N_Formal_Type_Declaration,
+ N_Full_Type_Declaration,
+ N_Incomplete_Type_Declaration,
+ N_Loop_Parameter_Specification,
+ N_Object_Declaration,
+ N_Protected_Type_Declaration,
+ N_Private_Extension_Declaration,
+ N_Private_Type_Declaration,
+ N_Subtype_Declaration,
+
+ -- N_Subprogram_Specification, N_Declaration
+ N_Function_Specification,
+ N_Procedure_Specification,
+
+ -- (nothing special)
+ N_Entry_Index_Specification,
+ N_Freeze_Entity,
+
+ -- N_Access_To_Subprogram_Definition
+ N_Access_Function_Definition,
+ N_Access_Procedure_Definition,
+
+ -- N_Later_Decl_Item,
+ N_Task_Type_Declaration,
+
+ -- N_Body_Stub, N_Later_Decl_Item
+ N_Package_Body_Stub,
+ N_Protected_Body_Stub,
+ N_Subprogram_Body_Stub,
+ N_Task_Body_Stub,
+
+ -- N_Generic_Instantiation, N_Later_Decl_Item
+ N_Function_Instantiation,
+ N_Package_Instantiation,
+ N_Procedure_Instantiation,
+
+ -- N_Unit_Body, N_Later_Decl_Item, N_Proper_Body
+ N_Package_Body,
+ N_Subprogram_Body,
+
+ -- N_Later_Decl_Item, N_Proper_Body
+ N_Protected_Body,
+ N_Task_Body,
+
+ -- N_Later_Decl_Item
+ N_Implicit_Label_Declaration,
+ N_Package_Declaration,
+ N_Single_Task_Declaration,
+ N_Subprogram_Declaration,
+ N_Use_Package_Clause,
+
+ -- N_Generic_Declaration, N_Later_Decl_Item
+ N_Generic_Package_Declaration,
+ N_Generic_Subprogram_Declaration,
+
+ -- N_Array_Type_Definition
+ N_Constrained_Array_Definition,
+ N_Unconstrained_Array_Definition,
+
+ -- N_Renaming_Declaration
+ N_Exception_Renaming_Declaration,
+ N_Object_Renaming_Declaration,
+ N_Package_Renaming_Declaration,
+ N_Subprogram_Renaming_Declaration,
+
+ -- N_Generic_Renaming_Declarations, N_Renaming_Declaration
+ N_Generic_Function_Renaming_Declaration,
+ N_Generic_Package_Renaming_Declaration,
+ N_Generic_Procedure_Renaming_Declaration,
+
+ -- N_Statement_Other_Than_Procedure_Call
+ N_Abort_Statement,
+ N_Accept_Statement,
+ N_Assignment_Statement,
+ N_Asynchronous_Select,
+ N_Block_Statement,
+ N_Case_Statement,
+ N_Code_Statement,
+ N_Conditional_Entry_Call,
+ N_Delay_Relative_Statement,
+ N_Delay_Until_Statement,
+ N_Entry_Call_Statement,
+ N_Free_Statement,
+ N_Goto_Statement,
+ N_Loop_Statement,
+ N_Null_Statement,
+ N_Raise_Statement,
+ N_Requeue_Statement,
+ N_Return_Statement,
+ N_Selective_Accept,
+ N_Timed_Entry_Call,
+
+ -- N_Statement_Other_Than_Procedure_Call, N_Has_Condition
+ N_Exit_Statement,
+ N_If_Statement,
+
+ -- N_Has_Condition
+ N_Accept_Alternative,
+ N_Delay_Alternative,
+ N_Elsif_Part,
+ N_Entry_Body_Formal_Part,
+ N_Iteration_Scheme,
+ N_Terminate_Alternative,
+
+ -- Other nodes (not part of any subtype class)
+ N_Abortable_Part,
+ N_Abstract_Subprogram_Declaration,
+ N_Access_Definition,
+ N_Access_To_Object_Definition,
+ N_Case_Statement_Alternative,
+ N_Compilation_Unit,
+ N_Compilation_Unit_Aux,
+ N_Component_Association,
+ N_Component_List,
+ N_Derived_Type_Definition,
+ N_Decimal_Fixed_Point_Definition,
+ N_Defining_Program_Unit_Name,
+ N_Delta_Constraint,
+ N_Designator,
+ N_Digits_Constraint,
+ N_Discriminant_Association,
+ N_Discriminant_Specification,
+ N_Enumeration_Type_Definition,
+ N_Entry_Body,
+ N_Entry_Call_Alternative,
+ N_Exception_Declaration,
+ N_Exception_Handler,
+ N_Floating_Point_Definition,
+ N_Formal_Decimal_Fixed_Point_Definition,
+ N_Formal_Derived_Type_Definition,
+ N_Formal_Discrete_Type_Definition,
+ N_Formal_Floating_Point_Definition,
+ N_Formal_Modular_Type_Definition,
+ N_Formal_Ordinary_Fixed_Point_Definition,
+ N_Formal_Package_Declaration,
+ N_Formal_Private_Type_Definition,
+ N_Formal_Signed_Integer_Type_Definition,
+ N_Formal_Subprogram_Declaration,
+ N_Generic_Association,
+ N_Handled_Sequence_Of_Statements,
+ N_Index_Or_Discriminant_Constraint,
+ N_Itype_Reference,
+ N_Label,
+ N_Modular_Type_Definition,
+ N_Number_Declaration,
+ N_Ordinary_Fixed_Point_Definition,
+ N_Others_Choice,
+ N_Package_Specification,
+ N_Parameter_Association,
+ N_Parameter_Specification,
+ N_Protected_Definition,
+ N_Range_Constraint,
+ N_Real_Range_Specification,
+ N_Record_Definition,
+ N_Signed_Integer_Type_Definition,
+ N_Single_Protected_Declaration,
+ N_Subunit,
+ N_Task_Definition,
+ N_Triggering_Alternative,
+ N_Use_Type_Clause,
+ N_Validate_Unchecked_Conversion,
+ N_Variant,
+ N_Variant_Part,
+ N_With_Clause,
+ N_With_Type_Clause,
+ N_Unused_At_End);
+
+ for Node_Kind'Size use 8;
+ -- The data structures in Atree assume this!
+
+ ----------------------------
+ -- Node Class Definitions --
+ ----------------------------
+
+ subtype N_Access_To_Subprogram_Definition is Node_Kind range
+ N_Access_Function_Definition ..
+ N_Access_Procedure_Definition;
+
+ subtype N_Array_Type_Definition is Node_Kind range
+ N_Constrained_Array_Definition ..
+ N_Unconstrained_Array_Definition;
+
+ subtype N_Binary_Op is Node_Kind range
+ N_Op_Add ..
+ N_Op_Shift_Right_Arithmetic;
+
+ subtype N_Body_Stub is Node_Kind range
+ N_Package_Body_Stub ..
+ N_Task_Body_Stub;
+
+ subtype N_Declaration is Node_Kind range
+ N_Component_Declaration ..
+ N_Procedure_Specification;
+ -- Note: this includes all constructs normally thought of as declarations
+ -- except those which are separately grouped as later declarations.
+
+ subtype N_Direct_Name is Node_Kind range
+ N_Identifier ..
+ N_Character_Literal;
+
+ subtype N_Entity is Node_Kind range
+ N_Defining_Character_Literal ..
+ N_Defining_Operator_Symbol;
+
+ subtype N_Generic_Declaration is Node_Kind range
+ N_Generic_Package_Declaration ..
+ N_Generic_Subprogram_Declaration;
+
+ subtype N_Generic_Instantiation is Node_Kind range
+ N_Function_Instantiation ..
+ N_Procedure_Instantiation;
+
+ subtype N_Generic_Renaming_Declaration is Node_Kind range
+ N_Generic_Function_Renaming_Declaration ..
+ N_Generic_Procedure_Renaming_Declaration;
+
+ subtype N_Has_Chars is Node_Kind range
+ N_Attribute_Definition_Clause ..
+ N_Op_Plus;
+
+ subtype N_Has_Entity is Node_Kind range
+ N_Expanded_Name ..
+ N_Attribute_Reference;
+ -- Nodes that have Entity fields
+ -- Warning: DOES NOT INCLUDE N_Freeze_Entity!
+
+ subtype N_Has_Etype is Node_Kind range
+ N_Defining_Character_Literal ..
+ N_Subtype_Indication;
+
+ subtype N_Later_Decl_Item is Node_Kind range
+ N_Task_Type_Declaration ..
+ N_Generic_Subprogram_Declaration;
+ -- Note: this is Ada 83 relevant only (see Ada 83 RM 3.9 (2)) and
+ -- includes only those items which can appear as later declarative
+ -- items. This also includes N_Implicit_Label_Declaration which is
+ -- not specifically in the grammar but may appear as a valid later
+ -- declarative items. It does NOT include N_Pragma which can also
+ -- appear among later declarative items. It does however include
+ -- N_Protected_Body, which is a bit peculiar, but harmless since
+ -- this cannot appear in Ada 83 mode anyway.
+
+ subtype N_Op is Node_Kind range
+ N_Op_Add ..
+ N_Op_Plus;
+
+ subtype N_Op_Boolean is Node_Kind range
+ N_Op_And ..
+ N_Op_Xor;
+ -- Binary operators which take operands of a boolean type, and yield
+ -- a result of a boolean type.
+
+ subtype N_Op_Compare is Node_Kind range
+ N_Op_Eq ..
+ N_Op_Ne;
+
+ subtype N_Op_Shift is Node_Kind range
+ N_Op_Rotate_Left ..
+ N_Op_Shift_Right_Arithmetic;
+
+ subtype N_Proper_Body is Node_Kind range
+ N_Package_Body ..
+ N_Task_Body;
+
+ subtype N_Raise_xxx_Error is Node_Kind range
+ N_Raise_Constraint_Error ..
+ N_Raise_Storage_Error;
+
+ subtype N_Renaming_Declaration is Node_Kind range
+ N_Exception_Renaming_Declaration ..
+ N_Generic_Procedure_Renaming_Declaration;
+
+ subtype N_Representation_Clause is Node_Kind range
+ N_At_Clause ..
+ N_Attribute_Definition_Clause;
+
+ subtype N_Statement_Other_Than_Procedure_Call is Node_Kind range
+ N_Abort_Statement ..
+ N_If_Statement;
+ -- Note that this includes all statement types except for the cases of the
+ -- N_Procedure_Call_Statement which is considered to be a subexpression
+ -- (since overloading is possible, so it needs to go through the normal
+ -- overloading resolution for expressions).
+
+ subtype N_Has_Condition is Node_Kind range
+ N_Exit_Statement ..
+ N_Terminate_Alternative;
+ -- Nodes with condition fields (does not include N_Raise_xxx_Error)
+
+ subtype N_Subexpr is Node_Kind range
+ N_Expanded_Name ..
+ N_Unchecked_Type_Conversion;
+ -- Nodes with expression fields
+
+ subtype N_Subprogram_Specification is Node_Kind range
+ N_Function_Specification ..
+ N_Procedure_Specification;
+
+ subtype N_Unary_Op is Node_Kind range
+ N_Op_Abs ..
+ N_Op_Plus;
+
+ subtype N_Unit_Body is Node_Kind range
+ N_Package_Body ..
+ N_Subprogram_Body;
+
+ ---------------------------
+ -- Node Access Functions --
+ ---------------------------
+
+ -- The following functions return the contents of the indicated field of
+ -- the node referenced by the argument, which is a Node_Id. They provide
+ -- logical access to fields in the node which could be accessed using the
+ -- Atree.Unchecked_Access package, but the idea is always to use these
+ -- higher level routines which preserve strong typing. In debug mode,
+ -- these routines check that they are being applied to an appropriate
+ -- node, as well as checking that the node is in range.
+
+ function ABE_Is_Certain
+ (N : Node_Id) return Boolean; -- Flag18
+
+ function Abort_Present
+ (N : Node_Id) return Boolean; -- Flag15
+
+ function Abortable_Part
+ (N : Node_Id) return Node_Id; -- Node2
+
+ function Abstract_Present
+ (N : Node_Id) return Boolean; -- Flag4
+
+ function Accept_Handler_Records
+ (N : Node_Id) return List_Id; -- List5
+
+ function Accept_Statement
+ (N : Node_Id) return Node_Id; -- Node2
+
+ function Access_Types_To_Process
+ (N : Node_Id) return Elist_Id; -- Elist2
+
+ function Actions
+ (N : Node_Id) return List_Id; -- List1
+
+ function Activation_Chain_Entity
+ (N : Node_Id) return Node_Id; -- Node3
+
+ function Acts_As_Spec
+ (N : Node_Id) return Boolean; -- Flag4
+
+ function Aggregate_Bounds
+ (N : Node_Id) return Node_Id; -- Node3
+
+ function Aliased_Present
+ (N : Node_Id) return Boolean; -- Flag4
+
+ function All_Others
+ (N : Node_Id) return Boolean; -- Flag11
+
+ function All_Present
+ (N : Node_Id) return Boolean; -- Flag15
+
+ function Alternatives
+ (N : Node_Id) return List_Id; -- List4
+
+ function Ancestor_Part
+ (N : Node_Id) return Node_Id; -- Node3
+
+ function Array_Aggregate
+ (N : Node_Id) return Node_Id; -- Node3
+
+ function Assignment_OK
+ (N : Node_Id) return Boolean; -- Flag15
+
+ function At_End_Proc
+ (N : Node_Id) return Node_Id; -- Node1
+
+ function Attribute_Name
+ (N : Node_Id) return Name_Id; -- Name2
+
+ function Aux_Decls_Node
+ (N : Node_Id) return Node_Id; -- Node5
+
+ function Backwards_OK
+ (N : Node_Id) return Boolean; -- Flag6
+
+ function Bad_Is_Detected
+ (N : Node_Id) return Boolean; -- Flag15
+
+ function By_Ref
+ (N : Node_Id) return Boolean; -- Flag5
+
+ function Body_Required
+ (N : Node_Id) return Boolean; -- Flag13
+
+ function Body_To_Inline
+ (N : Node_Id) return Node_Id; -- Node3
+
+ function Box_Present
+ (N : Node_Id) return Boolean; -- Flag15
+
+ function Char_Literal_Value
+ (N : Node_Id) return Char_Code; -- Char_Code2
+
+ function Chars
+ (N : Node_Id) return Name_Id; -- Name1
+
+ function Choice_Parameter
+ (N : Node_Id) return Node_Id; -- Node2
+
+ function Choices
+ (N : Node_Id) return List_Id; -- List1
+
+ function Compile_Time_Known_Aggregate
+ (N : Node_Id) return Boolean; -- Flag18
+
+ function Component_Associations
+ (N : Node_Id) return List_Id; -- List2
+
+ function Component_Clauses
+ (N : Node_Id) return List_Id; -- List3
+
+ function Component_Items
+ (N : Node_Id) return List_Id; -- List3
+
+ function Component_List
+ (N : Node_Id) return Node_Id; -- Node1
+
+ function Component_Name
+ (N : Node_Id) return Node_Id; -- Node1
+
+ function Condition
+ (N : Node_Id) return Node_Id; -- Node1
+
+ function Condition_Actions
+ (N : Node_Id) return List_Id; -- List3
+
+ function Constant_Present
+ (N : Node_Id) return Boolean; -- Flag17
+
+ function Constraint
+ (N : Node_Id) return Node_Id; -- Node3
+
+ function Constraints
+ (N : Node_Id) return List_Id; -- List1
+
+ function Context_Installed
+ (N : Node_Id) return Boolean; -- Flag13
+
+ function Context_Items
+ (N : Node_Id) return List_Id; -- List1
+
+ function Controlling_Argument
+ (N : Node_Id) return Node_Id; -- Node1
+
+ function Conversion_OK
+ (N : Node_Id) return Boolean; -- Flag14
+
+ function Corresponding_Body
+ (N : Node_Id) return Node_Id; -- Node5
+
+ function Corresponding_Generic_Association
+ (N : Node_Id) return Node_Id; -- Node5
+
+ function Corresponding_Integer_Value
+ (N : Node_Id) return Uint; -- Uint4
+
+ function Corresponding_Spec
+ (N : Node_Id) return Node_Id; -- Node5
+
+ function Corresponding_Stub
+ (N : Node_Id) return Node_Id; -- Node3
+
+ function Dcheck_Function
+ (N : Node_Id) return Entity_Id; -- Node5
+
+ function Debug_Statement
+ (N : Node_Id) return Node_Id; -- Node3
+
+ function Declarations
+ (N : Node_Id) return List_Id; -- List2
+
+ function Default_Expression
+ (N : Node_Id) return Node_Id; -- Node5
+
+ function Default_Name
+ (N : Node_Id) return Node_Id; -- Node2
+
+ function Defining_Identifier
+ (N : Node_Id) return Entity_Id; -- Node1
+
+ function Defining_Unit_Name
+ (N : Node_Id) return Node_Id; -- Node1
+
+ function Delay_Alternative
+ (N : Node_Id) return Node_Id; -- Node4
+
+ function Delay_Finalize_Attach
+ (N : Node_Id) return Boolean; -- Flag14
+
+ function Delay_Statement
+ (N : Node_Id) return Node_Id; -- Node2
+
+ function Delta_Expression
+ (N : Node_Id) return Node_Id; -- Node3
+
+ function Digits_Expression
+ (N : Node_Id) return Node_Id; -- Node2
+
+ function Discr_Check_Funcs_Built
+ (N : Node_Id) return Boolean; -- Flag11
+
+ function Discrete_Choices
+ (N : Node_Id) return List_Id; -- List4
+
+ function Discrete_Range
+ (N : Node_Id) return Node_Id; -- Node4
+
+ function Discrete_Subtype_Definition
+ (N : Node_Id) return Node_Id; -- Node4
+
+ function Discrete_Subtype_Definitions
+ (N : Node_Id) return List_Id; -- List2
+
+ function Discriminant_Specifications
+ (N : Node_Id) return List_Id; -- List4
+
+ function Discriminant_Type
+ (N : Node_Id) return Node_Id; -- Node5
+
+ function Do_Access_Check
+ (N : Node_Id) return Boolean; -- Flag11
+
+ function Do_Accessibility_Check
+ (N : Node_Id) return Boolean; -- Flag13
+
+ function Do_Discriminant_Check
+ (N : Node_Id) return Boolean; -- Flag13
+
+ function Do_Division_Check
+ (N : Node_Id) return Boolean; -- Flag13
+
+ function Do_Length_Check
+ (N : Node_Id) return Boolean; -- Flag4
+
+ function Do_Overflow_Check
+ (N : Node_Id) return Boolean; -- Flag17
+
+ function Do_Range_Check
+ (N : Node_Id) return Boolean; -- Flag9
+
+ function Do_Storage_Check
+ (N : Node_Id) return Boolean; -- Flag17
+
+ function Do_Tag_Check
+ (N : Node_Id) return Boolean; -- Flag13
+
+ function Elaborate_All_Present
+ (N : Node_Id) return Boolean; -- Flag15
+
+ function Elaborate_Present
+ (N : Node_Id) return Boolean; -- Flag4
+
+ function Elaboration_Boolean
+ (N : Node_Id) return Node_Id; -- Node2
+
+ function Else_Actions
+ (N : Node_Id) return List_Id; -- List3
+
+ function Else_Statements
+ (N : Node_Id) return List_Id; -- List4
+
+ function Elsif_Parts
+ (N : Node_Id) return List_Id; -- List3
+
+ function Enclosing_Variant
+ (N : Node_Id) return Node_Id; -- Node2
+
+ function End_Label
+ (N : Node_Id) return Node_Id; -- Node4
+
+ function End_Span
+ (N : Node_Id) return Uint; -- Uint5
+
+ function Entity
+ (N : Node_Id) return Node_Id; -- Node4
+
+ function Entry_Body_Formal_Part
+ (N : Node_Id) return Node_Id; -- Node5
+
+ function Entry_Call_Alternative
+ (N : Node_Id) return Node_Id; -- Node1
+
+ function Entry_Call_Statement
+ (N : Node_Id) return Node_Id; -- Node1
+
+ function Entry_Direct_Name
+ (N : Node_Id) return Node_Id; -- Node1
+
+ function Entry_Index
+ (N : Node_Id) return Node_Id; -- Node5
+
+ function Entry_Index_Specification
+ (N : Node_Id) return Node_Id; -- Node4
+
+ function Etype
+ (N : Node_Id) return Node_Id; -- Node5
+
+ function Exception_Choices
+ (N : Node_Id) return List_Id; -- List4
+
+ function Exception_Handlers
+ (N : Node_Id) return List_Id; -- List5
+
+ function Exception_Junk
+ (N : Node_Id) return Boolean; -- Flag11
+
+ function Explicit_Actual_Parameter
+ (N : Node_Id) return Node_Id; -- Node3
+
+ function Expansion_Delayed
+ (N : Node_Id) return Boolean; -- Flag11
+
+ function Explicit_Generic_Actual_Parameter
+ (N : Node_Id) return Node_Id; -- Node1
+
+ function Expression
+ (N : Node_Id) return Node_Id; -- Node3
+
+ function Expressions
+ (N : Node_Id) return List_Id; -- List1
+
+ function First_Bit
+ (N : Node_Id) return Node_Id; -- Node3
+
+ function First_Inlined_Subprogram
+ (N : Node_Id) return Entity_Id; -- Node3
+
+ function First_Name
+ (N : Node_Id) return Boolean; -- Flag5
+
+ function First_Named_Actual
+ (N : Node_Id) return Node_Id; -- Node4
+
+ function First_Real_Statement
+ (N : Node_Id) return Node_Id; -- Node2
+
+ function First_Subtype_Link
+ (N : Node_Id) return Entity_Id; -- Node5
+
+ function Float_Truncate
+ (N : Node_Id) return Boolean; -- Flag11
+
+ function Formal_Type_Definition
+ (N : Node_Id) return Node_Id; -- Node3
+
+ function Forwards_OK
+ (N : Node_Id) return Boolean; -- Flag5
+
+ function From_At_Mod
+ (N : Node_Id) return Boolean; -- Flag4
+
+ function Generic_Associations
+ (N : Node_Id) return List_Id; -- List3
+
+ function Generic_Formal_Declarations
+ (N : Node_Id) return List_Id; -- List2
+
+ function Generic_Parent
+ (N : Node_Id) return Node_Id; -- Node5
+
+ function Generic_Parent_Type
+ (N : Node_Id) return Node_Id; -- Node4
+
+ function Handled_Statement_Sequence
+ (N : Node_Id) return Node_Id; -- Node4
+
+ function Handler_List_Entry
+ (N : Node_Id) return Node_Id; -- Node2
+
+ function Has_Created_Identifier
+ (N : Node_Id) return Boolean; -- Flag15
+
+ function Has_Dynamic_Length_Check
+ (N : Node_Id) return Boolean; -- Flag10
+
+ function Has_Dynamic_Range_Check
+ (N : Node_Id) return Boolean; -- Flag12
+
+ function Has_No_Elaboration_Code
+ (N : Node_Id) return Boolean; -- Flag17
+
+ function Has_Priority_Pragma
+ (N : Node_Id) return Boolean; -- Flag6
+
+ function Has_Private_View
+ (N : Node_Id) return Boolean; -- Flag11
+
+ function Has_Storage_Size_Pragma
+ (N : Node_Id) return Boolean; -- Flag5
+
+ function Has_Task_Info_Pragma
+ (N : Node_Id) return Boolean; -- Flag7
+
+ function Has_Task_Name_Pragma
+ (N : Node_Id) return Boolean; -- Flag8
+
+ function Has_Wide_Character
+ (N : Node_Id) return Boolean; -- Flag11
+
+ function Hidden_By_Use_Clause
+ (N : Node_Id) return Elist_Id; -- Elist4
+
+ function High_Bound
+ (N : Node_Id) return Node_Id; -- Node2
+
+ function Identifier
+ (N : Node_Id) return Node_Id; -- Node1
+
+ function Implicit_With
+ (N : Node_Id) return Boolean; -- Flag17
+
+ function In_Present
+ (N : Node_Id) return Boolean; -- Flag15
+
+ function Includes_Infinities
+ (N : Node_Id) return Boolean; -- Flag11
+
+ function Instance_Spec
+ (N : Node_Id) return Node_Id; -- Node5
+
+ function Intval
+ (N : Node_Id) return Uint; -- Uint3
+
+ function Is_Asynchronous_Call_Block
+ (N : Node_Id) return Boolean; -- Flag7
+
+ function Is_Component_Left_Opnd
+ (N : Node_Id) return Boolean; -- Flag13
+
+ function Is_Component_Right_Opnd
+ (N : Node_Id) return Boolean; -- Flag14
+
+ function Is_Controlling_Actual
+ (N : Node_Id) return Boolean; -- Flag16
+
+ function Is_Machine_Number
+ (N : Node_Id) return Boolean; -- Flag11
+
+ function Is_Overloaded
+ (N : Node_Id) return Boolean; -- Flag5
+
+ function Is_Power_Of_2_For_Shift
+ (N : Node_Id) return Boolean; -- Flag13
+
+ function Is_Protected_Subprogram_Body
+ (N : Node_Id) return Boolean; -- Flag7
+
+ function Is_Static_Expression
+ (N : Node_Id) return Boolean; -- Flag6
+
+ function Is_Subprogram_Descriptor
+ (N : Node_Id) return Boolean; -- Flag16
+
+ function Is_Task_Allocation_Block
+ (N : Node_Id) return Boolean; -- Flag6
+
+ function Is_Task_Master
+ (N : Node_Id) return Boolean; -- Flag5
+
+ function Iteration_Scheme
+ (N : Node_Id) return Node_Id; -- Node2
+
+ function Itype
+ (N : Node_Id) return Entity_Id; -- Node1
+
+ function Kill_Range_Check
+ (N : Node_Id) return Boolean; -- Flag11
+
+ function Label_Construct
+ (N : Node_Id) return Node_Id; -- Node2
+
+ function Left_Opnd
+ (N : Node_Id) return Node_Id; -- Node2
+
+ function Last_Bit
+ (N : Node_Id) return Node_Id; -- Node4
+
+ function Last_Name
+ (N : Node_Id) return Boolean; -- Flag6
+
+ function Library_Unit
+ (N : Node_Id) return Node_Id; -- Node4
+
+ function Limited_Present
+ (N : Node_Id) return Boolean; -- Flag17
+
+ function Literals
+ (N : Node_Id) return List_Id; -- List1
+
+ function Loop_Actions
+ (N : Node_Id) return List_Id; -- List2
+
+ function Loop_Parameter_Specification
+ (N : Node_Id) return Node_Id; -- Node4
+
+ function Low_Bound
+ (N : Node_Id) return Node_Id; -- Node1
+
+ function Mod_Clause
+ (N : Node_Id) return Node_Id; -- Node2
+
+ function More_Ids
+ (N : Node_Id) return Boolean; -- Flag5
+
+ function Must_Not_Freeze
+ (N : Node_Id) return Boolean; -- Flag8
+
+ function Name
+ (N : Node_Id) return Node_Id; -- Node2
+
+ function Names
+ (N : Node_Id) return List_Id; -- List2
+
+ function Next_Entity
+ (N : Node_Id) return Node_Id; -- Node2
+
+ function Next_Named_Actual
+ (N : Node_Id) return Node_Id; -- Node4
+
+ function Next_Rep_Item
+ (N : Node_Id) return Node_Id; -- Node4
+
+ function Next_Use_Clause
+ (N : Node_Id) return Node_Id; -- Node3
+
+ function No_Ctrl_Actions
+ (N : Node_Id) return Boolean; -- Flag7
+
+ function No_Entities_Ref_In_Spec
+ (N : Node_Id) return Boolean; -- Flag8
+
+ function No_Initialization
+ (N : Node_Id) return Boolean; -- Flag13
+
+ function Null_Present
+ (N : Node_Id) return Boolean; -- Flag13
+
+ function Null_Record_Present
+ (N : Node_Id) return Boolean; -- Flag17
+
+ function Object_Definition
+ (N : Node_Id) return Node_Id; -- Node4
+
+ function OK_For_Stream
+ (N : Node_Id) return Boolean; -- Flag4
+
+ function Original_Discriminant
+ (N : Node_Id) return Node_Id; -- Node2
+
+ function Others_Discrete_Choices
+ (N : Node_Id) return List_Id; -- List1
+
+ function Out_Present
+ (N : Node_Id) return Boolean; -- Flag17
+
+ function Parameter_Associations
+ (N : Node_Id) return List_Id; -- List3
+
+ function Parameter_List_Truncated
+ (N : Node_Id) return Boolean; -- Flag17
+
+ function Parameter_Specifications
+ (N : Node_Id) return List_Id; -- List3
+
+ function Parameter_Type
+ (N : Node_Id) return Node_Id; -- Node2
+
+ function Parent_Spec
+ (N : Node_Id) return Node_Id; -- Node4
+
+ function Position
+ (N : Node_Id) return Node_Id; -- Node2
+
+ function Pragma_Argument_Associations
+ (N : Node_Id) return List_Id; -- List2
+
+ function Pragmas_After
+ (N : Node_Id) return List_Id; -- List5
+
+ function Pragmas_Before
+ (N : Node_Id) return List_Id; -- List4
+
+ function Prefix
+ (N : Node_Id) return Node_Id; -- Node3
+
+ function Present_Expr
+ (N : Node_Id) return Uint; -- Uint3
+
+ function Prev_Ids
+ (N : Node_Id) return Boolean; -- Flag6
+
+ function Print_In_Hex
+ (N : Node_Id) return Boolean; -- Flag13
+
+ function Private_Declarations
+ (N : Node_Id) return List_Id; -- List3
+
+ function Private_Present
+ (N : Node_Id) return Boolean; -- Flag15
+
+ function Procedure_To_Call
+ (N : Node_Id) return Node_Id; -- Node4
+
+ function Proper_Body
+ (N : Node_Id) return Node_Id; -- Node1
+
+ function Protected_Definition
+ (N : Node_Id) return Node_Id; -- Node3
+
+ function Protected_Present
+ (N : Node_Id) return Boolean; -- Flag15
+
+ function Raises_Constraint_Error
+ (N : Node_Id) return Boolean; -- Flag7
+
+ function Range_Constraint
+ (N : Node_Id) return Node_Id; -- Node4
+
+ function Range_Expression
+ (N : Node_Id) return Node_Id; -- Node4
+
+ function Real_Range_Specification
+ (N : Node_Id) return Node_Id; -- Node4
+
+ function Realval
+ (N : Node_Id) return Ureal; -- Ureal3
+
+ function Record_Extension_Part
+ (N : Node_Id) return Node_Id; -- Node3
+
+ function Redundant_Use
+ (N : Node_Id) return Boolean; -- Flag13
+
+ function Return_Type
+ (N : Node_Id) return Node_Id; -- Node2
+
+ function Reverse_Present
+ (N : Node_Id) return Boolean; -- Flag15
+
+ function Right_Opnd
+ (N : Node_Id) return Node_Id; -- Node3
+
+ function Rounded_Result
+ (N : Node_Id) return Boolean; -- Flag18
+
+ function Scope
+ (N : Node_Id) return Node_Id; -- Node3
+
+ function Select_Alternatives
+ (N : Node_Id) return List_Id; -- List1
+
+ function Selector_Name
+ (N : Node_Id) return Node_Id; -- Node2
+
+ function Selector_Names
+ (N : Node_Id) return List_Id; -- List1
+
+ function Shift_Count_OK
+ (N : Node_Id) return Boolean; -- Flag4
+
+ function Source_Type
+ (N : Node_Id) return Entity_Id; -- Node1
+
+ function Specification
+ (N : Node_Id) return Node_Id; -- Node1
+
+ function Statements
+ (N : Node_Id) return List_Id; -- List3
+
+ function Static_Processing_OK
+ (N : Node_Id) return Boolean; -- Flag4
+
+ function Storage_Pool
+ (N : Node_Id) return Node_Id; -- Node1
+
+ function Strval
+ (N : Node_Id) return String_Id; -- Str3
+
+ function Subtype_Indication
+ (N : Node_Id) return Node_Id; -- Node5
+
+ function Subtype_Mark
+ (N : Node_Id) return Node_Id; -- Node4
+
+ function Subtype_Marks
+ (N : Node_Id) return List_Id; -- List2
+
+ function Tagged_Present
+ (N : Node_Id) return Boolean; -- Flag15
+
+ function Target_Type
+ (N : Node_Id) return Entity_Id; -- Node2
+
+ function Task_Body_Procedure
+ (N : Node_Id) return Entity_Id; -- Node2
+
+ function Task_Definition
+ (N : Node_Id) return Node_Id; -- Node3
+
+ function Then_Actions
+ (N : Node_Id) return List_Id; -- List2
+
+ function Then_Statements
+ (N : Node_Id) return List_Id; -- List2
+
+ function Treat_Fixed_As_Integer
+ (N : Node_Id) return Boolean; -- Flag14
+
+ function Triggering_Alternative
+ (N : Node_Id) return Node_Id; -- Node1
+
+ function Triggering_Statement
+ (N : Node_Id) return Node_Id; -- Node1
+
+ function TSS_Elist
+ (N : Node_Id) return Elist_Id; -- Elist3
+
+ function Type_Definition
+ (N : Node_Id) return Node_Id; -- Node3
+
+ function Unit
+ (N : Node_Id) return Node_Id; -- Node2
+
+ function Unknown_Discriminants_Present
+ (N : Node_Id) return Boolean; -- Flag13
+
+ function Unreferenced_In_Spec
+ (N : Node_Id) return Boolean; -- Flag7
+
+ function Variant_Part
+ (N : Node_Id) return Node_Id; -- Node4
+
+ function Variants
+ (N : Node_Id) return List_Id; -- List1
+
+ function Visible_Declarations
+ (N : Node_Id) return List_Id; -- List2
+
+ function Was_Originally_Stub
+ (N : Node_Id) return Boolean; -- Flag13
+
+ function Zero_Cost_Handling
+ (N : Node_Id) return Boolean; -- Flag5
+
+ -- End functions (note used by xsinfo utility program to end processing)
+
+ ----------------------------
+ -- Node Update Procedures --
+ ----------------------------
+
+ -- These are the corresponding node update routines, which again provide
+ -- a high level logical access with type checking. In addition to setting
+ -- the indicated field of the node N to the given Val, in the case of
+ -- tree pointers (List1-4), the parent pointer of the Val node is set to
+ -- point back to node N. This automates the setting of the parent pointer.
+
+ procedure Set_ABE_Is_Certain
+ (N : Node_Id; Val : Boolean := True); -- Flag18
+
+ procedure Set_Abort_Present
+ (N : Node_Id; Val : Boolean := True); -- Flag15
+
+ procedure Set_Abortable_Part
+ (N : Node_Id; Val : Node_Id); -- Node2
+
+ procedure Set_Abstract_Present
+ (N : Node_Id; Val : Boolean := True); -- Flag4
+
+ procedure Set_Accept_Handler_Records
+ (N : Node_Id; Val : List_Id); -- List5
+
+ procedure Set_Accept_Statement
+ (N : Node_Id; Val : Node_Id); -- Node2
+
+ procedure Set_Access_Types_To_Process
+ (N : Node_Id; Val : Elist_Id); -- Elist2
+
+ procedure Set_Actions
+ (N : Node_Id; Val : List_Id); -- List1
+
+ procedure Set_Activation_Chain_Entity
+ (N : Node_Id; Val : Node_Id); -- Node3
+
+ procedure Set_Acts_As_Spec
+ (N : Node_Id; Val : Boolean := True); -- Flag4
+
+ procedure Set_Aggregate_Bounds
+ (N : Node_Id; Val : Node_Id); -- Node3
+
+ procedure Set_Aliased_Present
+ (N : Node_Id; Val : Boolean := True); -- Flag4
+
+ procedure Set_All_Others
+ (N : Node_Id; Val : Boolean := True); -- Flag11
+
+ procedure Set_All_Present
+ (N : Node_Id; Val : Boolean := True); -- Flag15
+
+ procedure Set_Alternatives
+ (N : Node_Id; Val : List_Id); -- List4
+
+ procedure Set_Ancestor_Part
+ (N : Node_Id; Val : Node_Id); -- Node3
+
+ procedure Set_Array_Aggregate
+ (N : Node_Id; Val : Node_Id); -- Node3
+
+ procedure Set_Assignment_OK
+ (N : Node_Id; Val : Boolean := True); -- Flag15
+
+ procedure Set_Attribute_Name
+ (N : Node_Id; Val : Name_Id); -- Name2
+
+ procedure Set_At_End_Proc
+ (N : Node_Id; Val : Node_Id); -- Node1
+
+ procedure Set_Aux_Decls_Node
+ (N : Node_Id; Val : Node_Id); -- Node5
+
+ procedure Set_Backwards_OK
+ (N : Node_Id; Val : Boolean := True); -- Flag6
+
+ procedure Set_Bad_Is_Detected
+ (N : Node_Id; Val : Boolean := True); -- Flag15
+
+ procedure Set_Body_Required
+ (N : Node_Id; Val : Boolean := True); -- Flag13
+
+ procedure Set_Body_To_Inline
+ (N : Node_Id; Val : Node_Id); -- Node3
+
+ procedure Set_Box_Present
+ (N : Node_Id; Val : Boolean := True); -- Flag15
+
+ procedure Set_By_Ref
+ (N : Node_Id; Val : Boolean := True); -- Flag5
+
+ procedure Set_Char_Literal_Value
+ (N : Node_Id; Val : Char_Code); -- Char_Code2
+
+ procedure Set_Chars
+ (N : Node_Id; Val : Name_Id); -- Name1
+
+ procedure Set_Choice_Parameter
+ (N : Node_Id; Val : Node_Id); -- Node2
+
+ procedure Set_Choices
+ (N : Node_Id; Val : List_Id); -- List1
+
+ procedure Set_Compile_Time_Known_Aggregate
+ (N : Node_Id; Val : Boolean := True); -- Flag18
+
+ procedure Set_Component_Associations
+ (N : Node_Id; Val : List_Id); -- List2
+
+ procedure Set_Component_Clauses
+ (N : Node_Id; Val : List_Id); -- List3
+
+ procedure Set_Component_Items
+ (N : Node_Id; Val : List_Id); -- List3
+
+ procedure Set_Component_List
+ (N : Node_Id; Val : Node_Id); -- Node1
+
+ procedure Set_Component_Name
+ (N : Node_Id; Val : Node_Id); -- Node1
+
+ procedure Set_Condition
+ (N : Node_Id; Val : Node_Id); -- Node1
+
+ procedure Set_Condition_Actions
+ (N : Node_Id; Val : List_Id); -- List3
+
+ procedure Set_Constant_Present
+ (N : Node_Id; Val : Boolean := True); -- Flag17
+
+ procedure Set_Constraint
+ (N : Node_Id; Val : Node_Id); -- Node3
+
+ procedure Set_Constraints
+ (N : Node_Id; Val : List_Id); -- List1
+
+ procedure Set_Context_Installed
+ (N : Node_Id; Val : Boolean := True); -- Flag13
+
+ procedure Set_Context_Items
+ (N : Node_Id; Val : List_Id); -- List1
+
+ procedure Set_Controlling_Argument
+ (N : Node_Id; Val : Node_Id); -- Node1
+
+ procedure Set_Conversion_OK
+ (N : Node_Id; Val : Boolean := True); -- Flag14
+
+ procedure Set_Corresponding_Body
+ (N : Node_Id; Val : Node_Id); -- Node5
+
+ procedure Set_Corresponding_Generic_Association
+ (N : Node_Id; Val : Node_Id); -- Node5
+
+ procedure Set_Corresponding_Integer_Value
+ (N : Node_Id; Val : Uint); -- Uint4
+
+ procedure Set_Corresponding_Spec
+ (N : Node_Id; Val : Node_Id); -- Node5
+
+ procedure Set_Corresponding_Stub
+ (N : Node_Id; Val : Node_Id); -- Node3
+
+ procedure Set_Dcheck_Function
+ (N : Node_Id; Val : Entity_Id); -- Node5
+
+ procedure Set_Debug_Statement
+ (N : Node_Id; Val : Node_Id); -- Node3
+
+ procedure Set_Declarations
+ (N : Node_Id; Val : List_Id); -- List2
+
+ procedure Set_Default_Expression
+ (N : Node_Id; Val : Node_Id); -- Node5
+
+ procedure Set_Default_Name
+ (N : Node_Id; Val : Node_Id); -- Node2
+
+ procedure Set_Defining_Identifier
+ (N : Node_Id; Val : Entity_Id); -- Node1
+
+ procedure Set_Defining_Unit_Name
+ (N : Node_Id; Val : Node_Id); -- Node1
+
+ procedure Set_Delay_Alternative
+ (N : Node_Id; Val : Node_Id); -- Node4
+
+ procedure Set_Delay_Finalize_Attach
+ (N : Node_Id; Val : Boolean := True); -- Flag14
+
+ procedure Set_Delay_Statement
+ (N : Node_Id; Val : Node_Id); -- Node2
+
+ procedure Set_Delta_Expression
+ (N : Node_Id; Val : Node_Id); -- Node3
+
+ procedure Set_Digits_Expression
+ (N : Node_Id; Val : Node_Id); -- Node2
+
+ procedure Set_Discr_Check_Funcs_Built
+ (N : Node_Id; Val : Boolean := True); -- Flag11
+
+ procedure Set_Discrete_Choices
+ (N : Node_Id; Val : List_Id); -- List4
+
+ procedure Set_Discrete_Range
+ (N : Node_Id; Val : Node_Id); -- Node4
+
+ procedure Set_Discrete_Subtype_Definition
+ (N : Node_Id; Val : Node_Id); -- Node4
+
+ procedure Set_Discrete_Subtype_Definitions
+ (N : Node_Id; Val : List_Id); -- List2
+
+ procedure Set_Discriminant_Specifications
+ (N : Node_Id; Val : List_Id); -- List4
+
+ procedure Set_Discriminant_Type
+ (N : Node_Id; Val : Node_Id); -- Node5
+
+ procedure Set_Do_Access_Check
+ (N : Node_Id; Val : Boolean := True); -- Flag11
+
+ procedure Set_Do_Accessibility_Check
+ (N : Node_Id; Val : Boolean := True); -- Flag13
+
+ procedure Set_Do_Discriminant_Check
+ (N : Node_Id; Val : Boolean := True); -- Flag13
+
+ procedure Set_Do_Division_Check
+ (N : Node_Id; Val : Boolean := True); -- Flag13
+
+ procedure Set_Do_Length_Check
+ (N : Node_Id; Val : Boolean := True); -- Flag4
+
+ procedure Set_Do_Overflow_Check
+ (N : Node_Id; Val : Boolean := True); -- Flag17
+
+ procedure Set_Do_Range_Check
+ (N : Node_Id; Val : Boolean := True); -- Flag9
+
+ procedure Set_Do_Storage_Check
+ (N : Node_Id; Val : Boolean := True); -- Flag17
+
+ procedure Set_Do_Tag_Check
+ (N : Node_Id; Val : Boolean := True); -- Flag13
+
+ procedure Set_Elaborate_All_Present
+ (N : Node_Id; Val : Boolean := True); -- Flag15
+
+ procedure Set_Elaborate_Present
+ (N : Node_Id; Val : Boolean := True); -- Flag4
+
+ procedure Set_Elaboration_Boolean
+ (N : Node_Id; Val : Node_Id); -- Node2
+
+ procedure Set_Else_Actions
+ (N : Node_Id; Val : List_Id); -- List3
+
+ procedure Set_Else_Statements
+ (N : Node_Id; Val : List_Id); -- List4
+
+ procedure Set_Elsif_Parts
+ (N : Node_Id; Val : List_Id); -- List3
+
+ procedure Set_Enclosing_Variant
+ (N : Node_Id; Val : Node_Id); -- Node2
+
+ procedure Set_End_Label
+ (N : Node_Id; Val : Node_Id); -- Node4
+
+ procedure Set_End_Span
+ (N : Node_Id; Val : Uint); -- Uint5
+
+ procedure Set_Entity
+ (N : Node_Id; Val : Node_Id); -- Node4
+
+ procedure Set_Entry_Body_Formal_Part
+ (N : Node_Id; Val : Node_Id); -- Node5
+
+ procedure Set_Entry_Call_Alternative
+ (N : Node_Id; Val : Node_Id); -- Node1
+
+ procedure Set_Entry_Call_Statement
+ (N : Node_Id; Val : Node_Id); -- Node1
+
+ procedure Set_Entry_Direct_Name
+ (N : Node_Id; Val : Node_Id); -- Node1
+
+ procedure Set_Entry_Index
+ (N : Node_Id; Val : Node_Id); -- Node5
+
+ procedure Set_Entry_Index_Specification
+ (N : Node_Id; Val : Node_Id); -- Node4
+
+ procedure Set_Etype
+ (N : Node_Id; Val : Node_Id); -- Node5
+
+ procedure Set_Exception_Choices
+ (N : Node_Id; Val : List_Id); -- List4
+
+ procedure Set_Exception_Handlers
+ (N : Node_Id; Val : List_Id); -- List5
+
+ procedure Set_Exception_Junk
+ (N : Node_Id; Val : Boolean := True); -- Flag11
+
+ procedure Set_Expansion_Delayed
+ (N : Node_Id; Val : Boolean := True); -- Flag11
+
+ procedure Set_Explicit_Actual_Parameter
+ (N : Node_Id; Val : Node_Id); -- Node3
+
+ procedure Set_Explicit_Generic_Actual_Parameter
+ (N : Node_Id; Val : Node_Id); -- Node1
+
+ procedure Set_Expression
+ (N : Node_Id; Val : Node_Id); -- Node3
+
+ procedure Set_Expressions
+ (N : Node_Id; Val : List_Id); -- List1
+
+ procedure Set_First_Bit
+ (N : Node_Id; Val : Node_Id); -- Node3
+
+ procedure Set_First_Inlined_Subprogram
+ (N : Node_Id; Val : Entity_Id); -- Node3
+
+ procedure Set_First_Name
+ (N : Node_Id; Val : Boolean := True); -- Flag5
+
+ procedure Set_First_Named_Actual
+ (N : Node_Id; Val : Node_Id); -- Node4
+
+ procedure Set_First_Real_Statement
+ (N : Node_Id; Val : Node_Id); -- Node2
+
+ procedure Set_First_Subtype_Link
+ (N : Node_Id; Val : Entity_Id); -- Node5
+
+ procedure Set_Float_Truncate
+ (N : Node_Id; Val : Boolean := True); -- Flag11
+
+ procedure Set_Formal_Type_Definition
+ (N : Node_Id; Val : Node_Id); -- Node3
+
+ procedure Set_Forwards_OK
+ (N : Node_Id; Val : Boolean := True); -- Flag5
+
+ procedure Set_From_At_Mod
+ (N : Node_Id; Val : Boolean := True); -- Flag4
+
+ procedure Set_Generic_Associations
+ (N : Node_Id; Val : List_Id); -- List3
+
+ procedure Set_Generic_Formal_Declarations
+ (N : Node_Id; Val : List_Id); -- List2
+
+ procedure Set_Generic_Parent
+ (N : Node_Id; Val : Node_Id); -- Node5
+
+ procedure Set_Generic_Parent_Type
+ (N : Node_Id; Val : Node_Id); -- Node4
+
+ procedure Set_Handled_Statement_Sequence
+ (N : Node_Id; Val : Node_Id); -- Node4
+
+ procedure Set_Handler_List_Entry
+ (N : Node_Id; Val : Node_Id); -- Node2
+
+ procedure Set_Has_Created_Identifier
+ (N : Node_Id; Val : Boolean := True); -- Flag15
+
+ procedure Set_Has_Dynamic_Length_Check
+ (N : Node_Id; Val : Boolean := True); -- Flag10
+
+ procedure Set_Has_Dynamic_Range_Check
+ (N : Node_Id; Val : Boolean := True); -- Flag12
+
+ procedure Set_Has_No_Elaboration_Code
+ (N : Node_Id; Val : Boolean := True); -- Flag17
+
+ procedure Set_Has_Priority_Pragma
+ (N : Node_Id; Val : Boolean := True); -- Flag6
+
+ procedure Set_Has_Private_View
+ (N : Node_Id; Val : Boolean := True); -- Flag11
+
+ procedure Set_Has_Storage_Size_Pragma
+ (N : Node_Id; Val : Boolean := True); -- Flag5
+
+ procedure Set_Has_Task_Info_Pragma
+ (N : Node_Id; Val : Boolean := True); -- Flag7
+
+ procedure Set_Has_Task_Name_Pragma
+ (N : Node_Id; Val : Boolean := True); -- Flag8
+
+ procedure Set_Has_Wide_Character
+ (N : Node_Id; Val : Boolean := True); -- Flag11
+
+ procedure Set_Hidden_By_Use_Clause
+ (N : Node_Id; Val : Elist_Id); -- Elist4
+
+ procedure Set_High_Bound
+ (N : Node_Id; Val : Node_Id); -- Node2
+
+ procedure Set_Identifier
+ (N : Node_Id; Val : Node_Id); -- Node1
+
+ procedure Set_Implicit_With
+ (N : Node_Id; Val : Boolean := True); -- Flag17
+
+ procedure Set_In_Present
+ (N : Node_Id; Val : Boolean := True); -- Flag15
+
+ procedure Set_Includes_Infinities
+ (N : Node_Id; Val : Boolean := True); -- Flag11
+
+ procedure Set_Instance_Spec
+ (N : Node_Id; Val : Node_Id); -- Node5
+
+ procedure Set_Intval
+ (N : Node_Id; Val : Uint); -- Uint3
+
+ procedure Set_Is_Asynchronous_Call_Block
+ (N : Node_Id; Val : Boolean := True); -- Flag7
+
+ procedure Set_Is_Component_Left_Opnd
+ (N : Node_Id; Val : Boolean := True); -- Flag13
+
+ procedure Set_Is_Component_Right_Opnd
+ (N : Node_Id; Val : Boolean := True); -- Flag14
+
+ procedure Set_Is_Controlling_Actual
+ (N : Node_Id; Val : Boolean := True); -- Flag16
+
+ procedure Set_Is_Machine_Number
+ (N : Node_Id; Val : Boolean := True); -- Flag11
+
+ procedure Set_Is_Overloaded
+ (N : Node_Id; Val : Boolean := True); -- Flag5
+
+ procedure Set_Is_Power_Of_2_For_Shift
+ (N : Node_Id; Val : Boolean := True); -- Flag13
+
+ procedure Set_Is_Protected_Subprogram_Body
+ (N : Node_Id; Val : Boolean := True); -- Flag7
+
+ procedure Set_Is_Static_Expression
+ (N : Node_Id; Val : Boolean := True); -- Flag6
+
+ procedure Set_Is_Subprogram_Descriptor
+ (N : Node_Id; Val : Boolean := True); -- Flag16
+
+ procedure Set_Is_Task_Allocation_Block
+ (N : Node_Id; Val : Boolean := True); -- Flag6
+
+ procedure Set_Is_Task_Master
+ (N : Node_Id; Val : Boolean := True); -- Flag5
+
+ procedure Set_Iteration_Scheme
+ (N : Node_Id; Val : Node_Id); -- Node2
+
+ procedure Set_Itype
+ (N : Node_Id; Val : Entity_Id); -- Node1
+
+ procedure Set_Kill_Range_Check
+ (N : Node_Id; Val : Boolean := True); -- Flag11
+
+ procedure Set_Last_Bit
+ (N : Node_Id; Val : Node_Id); -- Node4
+
+ procedure Set_Last_Name
+ (N : Node_Id; Val : Boolean := True); -- Flag6
+
+ procedure Set_Library_Unit
+ (N : Node_Id; Val : Node_Id); -- Node4
+
+ procedure Set_Label_Construct
+ (N : Node_Id; Val : Node_Id); -- Node2
+
+ procedure Set_Left_Opnd
+ (N : Node_Id; Val : Node_Id); -- Node2
+
+ procedure Set_Limited_Present
+ (N : Node_Id; Val : Boolean := True); -- Flag17
+
+ procedure Set_Literals
+ (N : Node_Id; Val : List_Id); -- List1
+
+ procedure Set_Loop_Actions
+ (N : Node_Id; Val : List_Id); -- List2
+
+ procedure Set_Loop_Parameter_Specification
+ (N : Node_Id; Val : Node_Id); -- Node4
+
+ procedure Set_Low_Bound
+ (N : Node_Id; Val : Node_Id); -- Node1
+
+ procedure Set_Mod_Clause
+ (N : Node_Id; Val : Node_Id); -- Node2
+
+ procedure Set_More_Ids
+ (N : Node_Id; Val : Boolean := True); -- Flag5
+
+ procedure Set_Must_Not_Freeze
+ (N : Node_Id; Val : Boolean := True); -- Flag8
+
+ procedure Set_Name
+ (N : Node_Id; Val : Node_Id); -- Node2
+
+ procedure Set_Names
+ (N : Node_Id; Val : List_Id); -- List2
+
+ procedure Set_Next_Entity
+ (N : Node_Id; Val : Node_Id); -- Node2
+
+ procedure Set_Next_Named_Actual
+ (N : Node_Id; Val : Node_Id); -- Node4
+
+ procedure Set_Next_Rep_Item
+ (N : Node_Id; Val : Node_Id); -- Node4
+
+ procedure Set_Next_Use_Clause
+ (N : Node_Id; Val : Node_Id); -- Node3
+
+ procedure Set_No_Ctrl_Actions
+ (N : Node_Id; Val : Boolean := True); -- Flag7
+
+ procedure Set_No_Entities_Ref_In_Spec
+ (N : Node_Id; Val : Boolean := True); -- Flag8
+
+ procedure Set_No_Initialization
+ (N : Node_Id; Val : Boolean := True); -- Flag13
+
+ procedure Set_Null_Present
+ (N : Node_Id; Val : Boolean := True); -- Flag13
+
+ procedure Set_Null_Record_Present
+ (N : Node_Id; Val : Boolean := True); -- Flag17
+
+ procedure Set_Object_Definition
+ (N : Node_Id; Val : Node_Id); -- Node4
+
+ procedure Set_OK_For_Stream
+ (N : Node_Id; Val : Boolean := True); -- Flag4
+
+ procedure Set_Original_Discriminant
+ (N : Node_Id; Val : Node_Id); -- Node2
+
+ procedure Set_Others_Discrete_Choices
+ (N : Node_Id; Val : List_Id); -- List1
+
+ procedure Set_Out_Present
+ (N : Node_Id; Val : Boolean := True); -- Flag17
+
+ procedure Set_Parameter_Associations
+ (N : Node_Id; Val : List_Id); -- List3
+
+ procedure Set_Parameter_List_Truncated
+ (N : Node_Id; Val : Boolean := True); -- Flag17
+
+ procedure Set_Parameter_Specifications
+ (N : Node_Id; Val : List_Id); -- List3
+
+ procedure Set_Parameter_Type
+ (N : Node_Id; Val : Node_Id); -- Node2
+
+ procedure Set_Parent_Spec
+ (N : Node_Id; Val : Node_Id); -- Node4
+
+ procedure Set_Position
+ (N : Node_Id; Val : Node_Id); -- Node2
+
+ procedure Set_Pragma_Argument_Associations
+ (N : Node_Id; Val : List_Id); -- List2
+
+ procedure Set_Pragmas_After
+ (N : Node_Id; Val : List_Id); -- List5
+
+ procedure Set_Pragmas_Before
+ (N : Node_Id; Val : List_Id); -- List4
+
+ procedure Set_Prefix
+ (N : Node_Id; Val : Node_Id); -- Node3
+
+ procedure Set_Present_Expr
+ (N : Node_Id; Val : Uint); -- Uint3
+
+ procedure Set_Prev_Ids
+ (N : Node_Id; Val : Boolean := True); -- Flag6
+
+ procedure Set_Print_In_Hex
+ (N : Node_Id; Val : Boolean := True); -- Flag13
+
+ procedure Set_Private_Declarations
+ (N : Node_Id; Val : List_Id); -- List3
+
+ procedure Set_Private_Present
+ (N : Node_Id; Val : Boolean := True); -- Flag15
+
+ procedure Set_Procedure_To_Call
+ (N : Node_Id; Val : Node_Id); -- Node4
+
+ procedure Set_Proper_Body
+ (N : Node_Id; Val : Node_Id); -- Node1
+
+ procedure Set_Protected_Definition
+ (N : Node_Id; Val : Node_Id); -- Node3
+
+ procedure Set_Protected_Present
+ (N : Node_Id; Val : Boolean := True); -- Flag15
+
+ procedure Set_Raises_Constraint_Error
+ (N : Node_Id; Val : Boolean := True); -- Flag7
+
+ procedure Set_Range_Constraint
+ (N : Node_Id; Val : Node_Id); -- Node4
+
+ procedure Set_Range_Expression
+ (N : Node_Id; Val : Node_Id); -- Node4
+
+ procedure Set_Real_Range_Specification
+ (N : Node_Id; Val : Node_Id); -- Node4
+
+ procedure Set_Realval
+ (N : Node_Id; Val : Ureal); -- Ureal3
+
+ procedure Set_Record_Extension_Part
+ (N : Node_Id; Val : Node_Id); -- Node3
+
+ procedure Set_Redundant_Use
+ (N : Node_Id; Val : Boolean := True); -- Flag13
+
+ procedure Set_Return_Type
+ (N : Node_Id; Val : Node_Id); -- Node2
+
+ procedure Set_Reverse_Present
+ (N : Node_Id; Val : Boolean := True); -- Flag15
+
+ procedure Set_Right_Opnd
+ (N : Node_Id; Val : Node_Id); -- Node3
+
+ procedure Set_Rounded_Result
+ (N : Node_Id; Val : Boolean := True); -- Flag18
+
+ procedure Set_Scope
+ (N : Node_Id; Val : Node_Id); -- Node3
+
+ procedure Set_Select_Alternatives
+ (N : Node_Id; Val : List_Id); -- List1
+
+ procedure Set_Selector_Name
+ (N : Node_Id; Val : Node_Id); -- Node2
+
+ procedure Set_Selector_Names
+ (N : Node_Id; Val : List_Id); -- List1
+
+ procedure Set_Shift_Count_OK
+ (N : Node_Id; Val : Boolean := True); -- Flag4
+
+ procedure Set_Source_Type
+ (N : Node_Id; Val : Entity_Id); -- Node1
+
+ procedure Set_Specification
+ (N : Node_Id; Val : Node_Id); -- Node1
+
+ procedure Set_Statements
+ (N : Node_Id; Val : List_Id); -- List3
+
+ procedure Set_Static_Processing_OK
+ (N : Node_Id; Val : Boolean); -- Flag4
+
+ procedure Set_Storage_Pool
+ (N : Node_Id; Val : Node_Id); -- Node1
+
+ procedure Set_Strval
+ (N : Node_Id; Val : String_Id); -- Str3
+
+ procedure Set_Subtype_Indication
+ (N : Node_Id; Val : Node_Id); -- Node5
+
+ procedure Set_Subtype_Mark
+ (N : Node_Id; Val : Node_Id); -- Node4
+
+ procedure Set_Subtype_Marks
+ (N : Node_Id; Val : List_Id); -- List2
+
+ procedure Set_Tagged_Present
+ (N : Node_Id; Val : Boolean := True); -- Flag15
+
+ procedure Set_Target_Type
+ (N : Node_Id; Val : Entity_Id); -- Node2
+
+ procedure Set_Task_Body_Procedure
+ (N : Node_Id; Val : Entity_Id); -- Node2
+
+ procedure Set_Task_Definition
+ (N : Node_Id; Val : Node_Id); -- Node3
+
+ procedure Set_Then_Actions
+ (N : Node_Id; Val : List_Id); -- List2
+
+ procedure Set_Then_Statements
+ (N : Node_Id; Val : List_Id); -- List2
+
+ procedure Set_Treat_Fixed_As_Integer
+ (N : Node_Id; Val : Boolean := True); -- Flag14
+
+ procedure Set_Triggering_Alternative
+ (N : Node_Id; Val : Node_Id); -- Node1
+
+ procedure Set_Triggering_Statement
+ (N : Node_Id; Val : Node_Id); -- Node1
+
+ procedure Set_TSS_Elist
+ (N : Node_Id; Val : Elist_Id); -- Elist3
+
+ procedure Set_Type_Definition
+ (N : Node_Id; Val : Node_Id); -- Node3
+
+ procedure Set_Unit
+ (N : Node_Id; Val : Node_Id); -- Node2
+
+ procedure Set_Unknown_Discriminants_Present
+ (N : Node_Id; Val : Boolean := True); -- Flag13
+
+ procedure Set_Unreferenced_In_Spec
+ (N : Node_Id; Val : Boolean := True); -- Flag7
+
+ procedure Set_Variant_Part
+ (N : Node_Id; Val : Node_Id); -- Node4
+
+ procedure Set_Variants
+ (N : Node_Id; Val : List_Id); -- List1
+
+ procedure Set_Visible_Declarations
+ (N : Node_Id; Val : List_Id); -- List2
+
+ procedure Set_Was_Originally_Stub
+ (N : Node_Id; Val : Boolean := True); -- Flag13
+
+ procedure Set_Zero_Cost_Handling
+ (N : Node_Id; Val : Boolean := True); -- Flag5
+
+ -------------------------
+ -- Iterator Procedures --
+ -------------------------
+
+ -- The call to Next_xxx (N) is equivalent to N := Next_xxx (N)
+
+ procedure Next_Entity (N : in out Node_Id);
+ procedure Next_Named_Actual (N : in out Node_Id);
+ procedure Next_Rep_Item (N : in out Node_Id);
+ procedure Next_Use_Clause (N : in out Node_Id);
+
+ --------------------------------------
+ -- Logical Access to End_Span Field --
+ --------------------------------------
+
+ function End_Location (N : Node_Id) return Source_Ptr;
+ -- N is an N_If_Statement or N_Case_Statement node, and this
+ -- function returns the location of the IF token in the END IF
+ -- sequence by translating the value of the End_Span field.
+
+ procedure Set_End_Location (N : Node_Id; S : Source_Ptr);
+ -- N is an N_If_Statement or N_Case_Statement node. This procedure
+ -- sets the End_Span field to correspond to the given value S. In
+ -- other words, End_Span is set to the difference between S and
+ -- Sloc (N), the starting location.
+
+ --------------------
+ -- Inline Pragmas --
+ --------------------
+
+ pragma Inline (ABE_Is_Certain);
+ pragma Inline (Abort_Present);
+ pragma Inline (Abortable_Part);
+ pragma Inline (Abstract_Present);
+ pragma Inline (Accept_Handler_Records);
+ pragma Inline (Accept_Statement);
+ pragma Inline (Access_Types_To_Process);
+ pragma Inline (Actions);
+ pragma Inline (Activation_Chain_Entity);
+ pragma Inline (Acts_As_Spec);
+ pragma Inline (Aggregate_Bounds);
+ pragma Inline (Aliased_Present);
+ pragma Inline (All_Others);
+ pragma Inline (All_Present);
+ pragma Inline (Alternatives);
+ pragma Inline (Ancestor_Part);
+ pragma Inline (Array_Aggregate);
+ pragma Inline (Assignment_OK);
+ pragma Inline (At_End_Proc);
+ pragma Inline (Attribute_Name);
+ pragma Inline (Aux_Decls_Node);
+ pragma Inline (Backwards_OK);
+ pragma Inline (Bad_Is_Detected);
+ pragma Inline (Body_To_Inline);
+ pragma Inline (Body_Required);
+ pragma Inline (By_Ref);
+ pragma Inline (Box_Present);
+ pragma Inline (Char_Literal_Value);
+ pragma Inline (Chars);
+ pragma Inline (Choice_Parameter);
+ pragma Inline (Choices);
+ pragma Inline (Compile_Time_Known_Aggregate);
+ pragma Inline (Component_Associations);
+ pragma Inline (Component_Clauses);
+ pragma Inline (Component_Items);
+ pragma Inline (Component_List);
+ pragma Inline (Component_Name);
+ pragma Inline (Condition);
+ pragma Inline (Condition_Actions);
+ pragma Inline (Constant_Present);
+ pragma Inline (Constraint);
+ pragma Inline (Constraints);
+ pragma Inline (Context_Installed);
+ pragma Inline (Context_Items);
+ pragma Inline (Controlling_Argument);
+ pragma Inline (Conversion_OK);
+ pragma Inline (Corresponding_Body);
+ pragma Inline (Corresponding_Generic_Association);
+ pragma Inline (Corresponding_Integer_Value);
+ pragma Inline (Corresponding_Spec);
+ pragma Inline (Corresponding_Stub);
+ pragma Inline (Dcheck_Function);
+ pragma Inline (Debug_Statement);
+ pragma Inline (Declarations);
+ pragma Inline (Default_Expression);
+ pragma Inline (Default_Name);
+ pragma Inline (Defining_Identifier);
+ pragma Inline (Defining_Unit_Name);
+ pragma Inline (Delay_Alternative);
+ pragma Inline (Delay_Finalize_Attach);
+ pragma Inline (Delay_Statement);
+ pragma Inline (Delta_Expression);
+ pragma Inline (Digits_Expression);
+ pragma Inline (Discr_Check_Funcs_Built);
+ pragma Inline (Discrete_Choices);
+ pragma Inline (Discrete_Range);
+ pragma Inline (Discrete_Subtype_Definition);
+ pragma Inline (Discrete_Subtype_Definitions);
+ pragma Inline (Discriminant_Specifications);
+ pragma Inline (Discriminant_Type);
+ pragma Inline (Do_Access_Check);
+ pragma Inline (Do_Accessibility_Check);
+ pragma Inline (Do_Discriminant_Check);
+ pragma Inline (Do_Length_Check);
+ pragma Inline (Do_Division_Check);
+ pragma Inline (Do_Overflow_Check);
+ pragma Inline (Do_Range_Check);
+ pragma Inline (Do_Storage_Check);
+ pragma Inline (Do_Tag_Check);
+ pragma Inline (Elaborate_Present);
+ pragma Inline (Elaborate_All_Present);
+ pragma Inline (Elaboration_Boolean);
+ pragma Inline (Else_Actions);
+ pragma Inline (Else_Statements);
+ pragma Inline (Elsif_Parts);
+ pragma Inline (Enclosing_Variant);
+ pragma Inline (End_Label);
+ pragma Inline (End_Span);
+ pragma Inline (Entity);
+ pragma Inline (Entry_Body_Formal_Part);
+ pragma Inline (Entry_Call_Alternative);
+ pragma Inline (Entry_Call_Statement);
+ pragma Inline (Entry_Direct_Name);
+ pragma Inline (Entry_Index);
+ pragma Inline (Entry_Index_Specification);
+ pragma Inline (Etype);
+ pragma Inline (Exception_Choices);
+ pragma Inline (Exception_Junk);
+ pragma Inline (Exception_Handlers);
+ pragma Inline (Expansion_Delayed);
+ pragma Inline (Explicit_Actual_Parameter);
+ pragma Inline (Explicit_Generic_Actual_Parameter);
+ pragma Inline (Expression);
+ pragma Inline (Expressions);
+ pragma Inline (First_Bit);
+ pragma Inline (First_Inlined_Subprogram);
+ pragma Inline (First_Name);
+ pragma Inline (First_Named_Actual);
+ pragma Inline (First_Real_Statement);
+ pragma Inline (First_Subtype_Link);
+ pragma Inline (Float_Truncate);
+ pragma Inline (Formal_Type_Definition);
+ pragma Inline (Forwards_OK);
+ pragma Inline (From_At_Mod);
+ pragma Inline (Generic_Associations);
+ pragma Inline (Generic_Formal_Declarations);
+ pragma Inline (Generic_Parent);
+ pragma Inline (Generic_Parent_Type);
+ pragma Inline (Handled_Statement_Sequence);
+ pragma Inline (Handler_List_Entry);
+ pragma Inline (Has_Created_Identifier);
+ pragma Inline (Has_Dynamic_Length_Check);
+ pragma Inline (Has_Dynamic_Range_Check);
+ pragma Inline (Has_No_Elaboration_Code);
+ pragma Inline (Has_Priority_Pragma);
+ pragma Inline (Has_Private_View);
+ pragma Inline (Has_Storage_Size_Pragma);
+ pragma Inline (Has_Task_Info_Pragma);
+ pragma Inline (Has_Task_Name_Pragma);
+ pragma Inline (Has_Wide_Character);
+ pragma Inline (Hidden_By_Use_Clause);
+ pragma Inline (High_Bound);
+ pragma Inline (Identifier);
+ pragma Inline (Implicit_With);
+ pragma Inline (Includes_Infinities);
+ pragma Inline (In_Present);
+ pragma Inline (Instance_Spec);
+ pragma Inline (Intval);
+ pragma Inline (Is_Asynchronous_Call_Block);
+ pragma Inline (Is_Component_Left_Opnd);
+ pragma Inline (Is_Component_Right_Opnd);
+ pragma Inline (Is_Controlling_Actual);
+ pragma Inline (Is_Machine_Number);
+ pragma Inline (Is_Overloaded);
+ pragma Inline (Is_Power_Of_2_For_Shift);
+ pragma Inline (Is_Protected_Subprogram_Body);
+ pragma Inline (Is_Static_Expression);
+ pragma Inline (Is_Subprogram_Descriptor);
+ pragma Inline (Is_Task_Allocation_Block);
+ pragma Inline (Is_Task_Master);
+ pragma Inline (Iteration_Scheme);
+ pragma Inline (Itype);
+ pragma Inline (Kill_Range_Check);
+ pragma Inline (Last_Bit);
+ pragma Inline (Last_Name);
+ pragma Inline (Library_Unit);
+ pragma Inline (Label_Construct);
+ pragma Inline (Left_Opnd);
+ pragma Inline (Limited_Present);
+ pragma Inline (Literals);
+ pragma Inline (Loop_Actions);
+ pragma Inline (Loop_Parameter_Specification);
+ pragma Inline (Low_Bound);
+ pragma Inline (Mod_Clause);
+ pragma Inline (More_Ids);
+ pragma Inline (Must_Not_Freeze);
+ pragma Inline (Name);
+ pragma Inline (Names);
+ pragma Inline (Next_Entity);
+ pragma Inline (Next_Named_Actual);
+ pragma Inline (Next_Rep_Item);
+ pragma Inline (Next_Use_Clause);
+ pragma Inline (No_Ctrl_Actions);
+ pragma Inline (No_Entities_Ref_In_Spec);
+ pragma Inline (No_Initialization);
+ pragma Inline (Null_Present);
+ pragma Inline (Null_Record_Present);
+ pragma Inline (Object_Definition);
+ pragma Inline (OK_For_Stream);
+ pragma Inline (Original_Discriminant);
+ pragma Inline (Others_Discrete_Choices);
+ pragma Inline (Out_Present);
+ pragma Inline (Parameter_Associations);
+ pragma Inline (Parameter_Specifications);
+ pragma Inline (Parameter_List_Truncated);
+ pragma Inline (Parameter_Type);
+ pragma Inline (Parent_Spec);
+ pragma Inline (Position);
+ pragma Inline (Pragma_Argument_Associations);
+ pragma Inline (Pragmas_After);
+ pragma Inline (Pragmas_Before);
+ pragma Inline (Prefix);
+ pragma Inline (Present_Expr);
+ pragma Inline (Prev_Ids);
+ pragma Inline (Print_In_Hex);
+ pragma Inline (Private_Declarations);
+ pragma Inline (Private_Present);
+ pragma Inline (Procedure_To_Call);
+ pragma Inline (Proper_Body);
+ pragma Inline (Protected_Definition);
+ pragma Inline (Protected_Present);
+ pragma Inline (Raises_Constraint_Error);
+ pragma Inline (Range_Constraint);
+ pragma Inline (Range_Expression);
+ pragma Inline (Realval);
+ pragma Inline (Real_Range_Specification);
+ pragma Inline (Record_Extension_Part);
+ pragma Inline (Redundant_Use);
+ pragma Inline (Return_Type);
+ pragma Inline (Reverse_Present);
+ pragma Inline (Right_Opnd);
+ pragma Inline (Rounded_Result);
+ pragma Inline (Scope);
+ pragma Inline (Select_Alternatives);
+ pragma Inline (Selector_Name);
+ pragma Inline (Selector_Names);
+ pragma Inline (Shift_Count_OK);
+ pragma Inline (Source_Type);
+ pragma Inline (Specification);
+ pragma Inline (Statements);
+ pragma Inline (Static_Processing_OK);
+ pragma Inline (Storage_Pool);
+ pragma Inline (Strval);
+ pragma Inline (Subtype_Indication);
+ pragma Inline (Subtype_Mark);
+ pragma Inline (Subtype_Marks);
+ pragma Inline (Tagged_Present);
+ pragma Inline (Target_Type);
+ pragma Inline (Task_Body_Procedure);
+ pragma Inline (Task_Definition);
+ pragma Inline (Then_Actions);
+ pragma Inline (Then_Statements);
+ pragma Inline (Triggering_Alternative);
+ pragma Inline (Triggering_Statement);
+ pragma Inline (Treat_Fixed_As_Integer);
+ pragma Inline (TSS_Elist);
+ pragma Inline (Type_Definition);
+ pragma Inline (Unit);
+ pragma Inline (Unknown_Discriminants_Present);
+ pragma Inline (Unreferenced_In_Spec);
+ pragma Inline (Variant_Part);
+ pragma Inline (Variants);
+ pragma Inline (Visible_Declarations);
+ pragma Inline (Was_Originally_Stub);
+ pragma Inline (Zero_Cost_Handling);
+
+ pragma Inline (Set_ABE_Is_Certain);
+ pragma Inline (Set_Abort_Present);
+ pragma Inline (Set_Abortable_Part);
+ pragma Inline (Set_Abstract_Present);
+ pragma Inline (Set_Accept_Handler_Records);
+ pragma Inline (Set_Accept_Statement);
+ pragma Inline (Set_Access_Types_To_Process);
+ pragma Inline (Set_Actions);
+ pragma Inline (Set_Activation_Chain_Entity);
+ pragma Inline (Set_Acts_As_Spec);
+ pragma Inline (Set_Aggregate_Bounds);
+ pragma Inline (Set_Aliased_Present);
+ pragma Inline (Set_All_Others);
+ pragma Inline (Set_All_Present);
+ pragma Inline (Set_Alternatives);
+ pragma Inline (Set_Ancestor_Part);
+ pragma Inline (Set_Array_Aggregate);
+ pragma Inline (Set_Assignment_OK);
+ pragma Inline (Set_At_End_Proc);
+ pragma Inline (Set_Attribute_Name);
+ pragma Inline (Set_Aux_Decls_Node);
+ pragma Inline (Set_Backwards_OK);
+ pragma Inline (Set_Bad_Is_Detected);
+ pragma Inline (Set_Body_To_Inline);
+ pragma Inline (Set_Body_Required);
+ pragma Inline (Set_By_Ref);
+ pragma Inline (Set_Box_Present);
+ pragma Inline (Set_Char_Literal_Value);
+ pragma Inline (Set_Chars);
+ pragma Inline (Set_Choice_Parameter);
+ pragma Inline (Set_Choices);
+ pragma Inline (Set_Compile_Time_Known_Aggregate);
+ pragma Inline (Set_Component_Associations);
+ pragma Inline (Set_Component_Clauses);
+ pragma Inline (Set_Component_Items);
+ pragma Inline (Set_Component_List);
+ pragma Inline (Set_Component_Name);
+ pragma Inline (Set_Condition);
+ pragma Inline (Set_Condition_Actions);
+ pragma Inline (Set_Constant_Present);
+ pragma Inline (Set_Constraint);
+ pragma Inline (Set_Constraints);
+ pragma Inline (Set_Context_Installed);
+ pragma Inline (Set_Context_Items);
+ pragma Inline (Set_Controlling_Argument);
+ pragma Inline (Set_Conversion_OK);
+ pragma Inline (Set_Corresponding_Body);
+ pragma Inline (Set_Corresponding_Generic_Association);
+ pragma Inline (Set_Corresponding_Integer_Value);
+ pragma Inline (Set_Corresponding_Spec);
+ pragma Inline (Set_Corresponding_Stub);
+ pragma Inline (Set_Dcheck_Function);
+ pragma Inline (Set_Debug_Statement);
+ pragma Inline (Set_Declarations);
+ pragma Inline (Set_Default_Expression);
+ pragma Inline (Set_Default_Name);
+ pragma Inline (Set_Defining_Identifier);
+ pragma Inline (Set_Defining_Unit_Name);
+ pragma Inline (Set_Delay_Alternative);
+ pragma Inline (Set_Delay_Finalize_Attach);
+ pragma Inline (Set_Delay_Statement);
+ pragma Inline (Set_Delta_Expression);
+ pragma Inline (Set_Digits_Expression);
+ pragma Inline (Set_Discr_Check_Funcs_Built);
+ pragma Inline (Set_Discrete_Choices);
+ pragma Inline (Set_Discrete_Range);
+ pragma Inline (Set_Discrete_Subtype_Definition);
+ pragma Inline (Set_Discrete_Subtype_Definitions);
+ pragma Inline (Set_Discriminant_Specifications);
+ pragma Inline (Set_Discriminant_Type);
+ pragma Inline (Set_Do_Access_Check);
+ pragma Inline (Set_Do_Accessibility_Check);
+ pragma Inline (Set_Do_Discriminant_Check);
+ pragma Inline (Set_Do_Length_Check);
+ pragma Inline (Set_Do_Division_Check);
+ pragma Inline (Set_Do_Overflow_Check);
+ pragma Inline (Set_Do_Range_Check);
+ pragma Inline (Set_Do_Storage_Check);
+ pragma Inline (Set_Do_Tag_Check);
+ pragma Inline (Set_Elaborate_Present);
+ pragma Inline (Set_Elaborate_All_Present);
+ pragma Inline (Set_Elaboration_Boolean);
+ pragma Inline (Set_Else_Actions);
+ pragma Inline (Set_Else_Statements);
+ pragma Inline (Set_Elsif_Parts);
+ pragma Inline (Set_Enclosing_Variant);
+ pragma Inline (Set_End_Label);
+ pragma Inline (Set_End_Span);
+ pragma Inline (Set_Entity);
+ pragma Inline (Set_Entry_Body_Formal_Part);
+ pragma Inline (Set_Entry_Call_Alternative);
+ pragma Inline (Set_Entry_Call_Statement);
+ pragma Inline (Set_Entry_Direct_Name);
+ pragma Inline (Set_Entry_Index);
+ pragma Inline (Set_Entry_Index_Specification);
+ pragma Inline (Set_Etype);
+ pragma Inline (Set_Exception_Choices);
+ pragma Inline (Set_Exception_Junk);
+ pragma Inline (Set_Exception_Handlers);
+ pragma Inline (Set_Expansion_Delayed);
+ pragma Inline (Set_Explicit_Actual_Parameter);
+ pragma Inline (Set_Explicit_Generic_Actual_Parameter);
+ pragma Inline (Set_Expression);
+ pragma Inline (Set_Expressions);
+ pragma Inline (Set_First_Bit);
+ pragma Inline (Set_First_Inlined_Subprogram);
+ pragma Inline (Set_First_Name);
+ pragma Inline (Set_First_Named_Actual);
+ pragma Inline (Set_First_Real_Statement);
+ pragma Inline (Set_First_Subtype_Link);
+ pragma Inline (Set_Float_Truncate);
+ pragma Inline (Set_Formal_Type_Definition);
+ pragma Inline (Set_Forwards_OK);
+ pragma Inline (Set_From_At_Mod);
+ pragma Inline (Set_Generic_Associations);
+ pragma Inline (Set_Generic_Formal_Declarations);
+ pragma Inline (Set_Generic_Parent);
+ pragma Inline (Set_Generic_Parent_Type);
+ pragma Inline (Set_Handled_Statement_Sequence);
+ pragma Inline (Set_Handler_List_Entry);
+ pragma Inline (Set_Has_Created_Identifier);
+ pragma Inline (Set_Has_Dynamic_Length_Check);
+ pragma Inline (Set_Has_Dynamic_Range_Check);
+ pragma Inline (Set_Has_No_Elaboration_Code);
+ pragma Inline (Set_Has_Priority_Pragma);
+ pragma Inline (Set_Has_Private_View);
+ pragma Inline (Set_Has_Storage_Size_Pragma);
+ pragma Inline (Set_Has_Task_Info_Pragma);
+ pragma Inline (Set_Has_Task_Name_Pragma);
+ pragma Inline (Set_Has_Wide_Character);
+ pragma Inline (Set_Hidden_By_Use_Clause);
+ pragma Inline (Set_High_Bound);
+ pragma Inline (Set_Identifier);
+ pragma Inline (Set_Implicit_With);
+ pragma Inline (Set_Includes_Infinities);
+ pragma Inline (Set_In_Present);
+ pragma Inline (Set_Instance_Spec);
+ pragma Inline (Set_Intval);
+ pragma Inline (Set_Is_Asynchronous_Call_Block);
+ pragma Inline (Set_Is_Component_Left_Opnd);
+ pragma Inline (Set_Is_Component_Right_Opnd);
+ pragma Inline (Set_Is_Controlling_Actual);
+ pragma Inline (Set_Is_Machine_Number);
+ pragma Inline (Set_Is_Overloaded);
+ pragma Inline (Set_Is_Power_Of_2_For_Shift);
+ pragma Inline (Set_Is_Protected_Subprogram_Body);
+ pragma Inline (Set_Is_Static_Expression);
+ pragma Inline (Set_Is_Subprogram_Descriptor);
+ pragma Inline (Set_Is_Task_Allocation_Block);
+ pragma Inline (Set_Is_Task_Master);
+ pragma Inline (Set_Iteration_Scheme);
+ pragma Inline (Set_Itype);
+ pragma Inline (Set_Kill_Range_Check);
+ pragma Inline (Set_Last_Bit);
+ pragma Inline (Set_Last_Name);
+ pragma Inline (Set_Library_Unit);
+ pragma Inline (Set_Label_Construct);
+ pragma Inline (Set_Left_Opnd);
+ pragma Inline (Set_Limited_Present);
+ pragma Inline (Set_Literals);
+ pragma Inline (Set_Loop_Actions);
+ pragma Inline (Set_Loop_Parameter_Specification);
+ pragma Inline (Set_Low_Bound);
+ pragma Inline (Set_Mod_Clause);
+ pragma Inline (Set_More_Ids);
+ pragma Inline (Set_Must_Not_Freeze);
+ pragma Inline (Set_Name);
+ pragma Inline (Set_Names);
+ pragma Inline (Set_Next_Entity);
+ pragma Inline (Set_Next_Named_Actual);
+ pragma Inline (Set_Next_Use_Clause);
+ pragma Inline (Set_No_Ctrl_Actions);
+ pragma Inline (Set_No_Entities_Ref_In_Spec);
+ pragma Inline (Set_No_Initialization);
+ pragma Inline (Set_Null_Present);
+ pragma Inline (Set_Null_Record_Present);
+ pragma Inline (Set_Object_Definition);
+ pragma Inline (Set_OK_For_Stream);
+ pragma Inline (Set_Original_Discriminant);
+ pragma Inline (Set_Others_Discrete_Choices);
+ pragma Inline (Set_Out_Present);
+ pragma Inline (Set_Parameter_Associations);
+ pragma Inline (Set_Parameter_Specifications);
+ pragma Inline (Set_Parameter_List_Truncated);
+ pragma Inline (Set_Parameter_Type);
+ pragma Inline (Set_Parent_Spec);
+ pragma Inline (Set_Position);
+ pragma Inline (Set_Pragma_Argument_Associations);
+ pragma Inline (Set_Pragmas_After);
+ pragma Inline (Set_Pragmas_Before);
+ pragma Inline (Set_Prefix);
+ pragma Inline (Set_Present_Expr);
+ pragma Inline (Set_Prev_Ids);
+ pragma Inline (Set_Print_In_Hex);
+ pragma Inline (Set_Private_Declarations);
+ pragma Inline (Set_Private_Present);
+ pragma Inline (Set_Procedure_To_Call);
+ pragma Inline (Set_Proper_Body);
+ pragma Inline (Set_Protected_Definition);
+ pragma Inline (Set_Protected_Present);
+ pragma Inline (Set_Raises_Constraint_Error);
+ pragma Inline (Set_Range_Constraint);
+ pragma Inline (Set_Range_Expression);
+ pragma Inline (Set_Realval);
+ pragma Inline (Set_Real_Range_Specification);
+ pragma Inline (Set_Record_Extension_Part);
+ pragma Inline (Set_Redundant_Use);
+ pragma Inline (Set_Return_Type);
+ pragma Inline (Set_Reverse_Present);
+ pragma Inline (Set_Right_Opnd);
+ pragma Inline (Set_Rounded_Result);
+ pragma Inline (Set_Scope);
+ pragma Inline (Set_Select_Alternatives);
+ pragma Inline (Set_Selector_Name);
+ pragma Inline (Set_Selector_Names);
+ pragma Inline (Set_Shift_Count_OK);
+ pragma Inline (Set_Source_Type);
+ pragma Inline (Set_Specification);
+ pragma Inline (Set_Statements);
+ pragma Inline (Set_Static_Processing_OK);
+ pragma Inline (Set_Storage_Pool);
+ pragma Inline (Set_Strval);
+ pragma Inline (Set_Subtype_Indication);
+ pragma Inline (Set_Subtype_Mark);
+ pragma Inline (Set_Subtype_Marks);
+ pragma Inline (Set_Tagged_Present);
+ pragma Inline (Set_Target_Type);
+ pragma Inline (Set_Task_Body_Procedure);
+ pragma Inline (Set_Task_Definition);
+ pragma Inline (Set_Then_Actions);
+ pragma Inline (Set_Then_Statements);
+ pragma Inline (Set_Triggering_Alternative);
+ pragma Inline (Set_Triggering_Statement);
+ pragma Inline (Set_Treat_Fixed_As_Integer);
+ pragma Inline (Set_TSS_Elist);
+ pragma Inline (Set_Type_Definition);
+ pragma Inline (Set_Unit);
+ pragma Inline (Set_Unknown_Discriminants_Present);
+ pragma Inline (Set_Unreferenced_In_Spec);
+ pragma Inline (Set_Variant_Part);
+ pragma Inline (Set_Variants);
+ pragma Inline (Set_Visible_Declarations);
+ pragma Inline (Set_Was_Originally_Stub);
+ pragma Inline (Set_Zero_Cost_Handling);
+
+end Sinfo;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S I N P U T . L --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.40 $
+-- --
+-- 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). --
+-- --
+------------------------------------------------------------------------------
+
+with Alloc;
+with Atree; use Atree;
+with Debug; use Debug;
+with Einfo; use Einfo;
+with Namet; use Namet;
+with Opt;
+with Osint; use Osint;
+with Output; use Output;
+with Scans; use Scans;
+with Scn; use Scn;
+with Sinfo; use Sinfo;
+with System; use System;
+
+with Unchecked_Conversion;
+
+package body Sinput.L is
+
+ Dfile : Source_File_Index;
+ -- Index of currently active debug source file
+
+ -----------------
+ -- Subprograms --
+ -----------------
+
+ procedure Trim_Lines_Table (S : Source_File_Index);
+ -- Set lines table size for entry S in the source file table to
+ -- correspond to the current value of Num_Source_Lines, releasing
+ -- any unused storage.
+
+ function Load_File
+ (N : File_Name_Type;
+ T : File_Type)
+ return Source_File_Index;
+ -- Load a source file or a configuration pragma file.
+
+ -------------------------------
+ -- Adjust_Instantiation_Sloc --
+ -------------------------------
+
+ procedure Adjust_Instantiation_Sloc (N : Node_Id; A : Sloc_Adjustment) is
+ Loc : constant Source_Ptr := Sloc (N);
+
+ begin
+ -- We only do the adjustment if the value is between the appropriate
+ -- low and high values. It is not clear that this should ever not be
+ -- the case, but in practice there seem to be some nodes that get
+ -- copied twice, and this is a defence against that happening.
+
+ if A.Lo <= Loc and then Loc <= A.Hi then
+ Set_Sloc (N, Loc + A.Adjust);
+ end if;
+ end Adjust_Instantiation_Sloc;
+
+ ------------------------
+ -- Close_Debug_Source --
+ ------------------------
+
+ procedure Close_Debug_Source is
+ S : Source_File_Record renames Source_File.Table (Dfile);
+ Src : Source_Buffer_Ptr;
+
+ begin
+ Trim_Lines_Table (Dfile);
+ Close_Debug_File;
+
+ -- Now we need to read the file that we wrote and store it
+ -- in memory for subsequent access.
+
+ Read_Source_File
+ (S.Debug_Source_Name, S.Source_First, S.Source_Last, Src);
+ S.Source_Text := Src;
+ end Close_Debug_Source;
+
+ --------------------------------
+ -- Complete_Source_File_Entry --
+ --------------------------------
+
+ procedure Complete_Source_File_Entry is
+ CSF : constant Source_File_Index := Current_Source_File;
+
+ begin
+ Trim_Lines_Table (CSF);
+ Source_File.Table (CSF).Source_Checksum := Checksum;
+ end Complete_Source_File_Entry;
+
+ -------------------------
+ -- Create_Debug_Source --
+ -------------------------
+
+ procedure Create_Debug_Source
+ (Source : Source_File_Index;
+ Loc : out Source_Ptr)
+ is
+ begin
+ Loc := Source_File.Table (Source_File.Last).Source_Last + 1;
+ Source_File.Increment_Last;
+ Dfile := Source_File.Last;
+
+ declare
+ S : Source_File_Record renames Source_File.Table (Dfile);
+
+ begin
+ S := Source_File.Table (Source);
+ S.Debug_Source_Name := Create_Debug_File (S.File_Name);
+ S.Source_First := Loc;
+ S.Source_Last := Loc;
+ S.Lines_Table := null;
+ S.Last_Source_Line := 1;
+
+ -- Allocate lines table, guess that it needs to be three times
+ -- bigger than the original source (in number of lines).
+
+ Alloc_Line_Tables
+ (S, Int (Source_File.Table (Source).Last_Source_Line * 3));
+ S.Lines_Table (1) := Loc;
+ end;
+
+ if Debug_Flag_GG then
+ Write_Str ("---> Create_Debug_Source (Source => ");
+ Write_Int (Int (Source));
+ Write_Str (", Loc => ");
+ Write_Int (Int (Loc));
+ Write_Str (");");
+ Write_Eol;
+ end if;
+
+ end Create_Debug_Source;
+
+ ---------------------------------
+ -- Create_Instantiation_Source --
+ ---------------------------------
+
+ procedure Create_Instantiation_Source
+ (Inst_Node : Entity_Id;
+ Template_Id : Entity_Id;
+ A : out Sloc_Adjustment)
+ is
+ Dnod : constant Node_Id := Declaration_Node (Template_Id);
+ Xold : Source_File_Index;
+ Xnew : Source_File_Index;
+
+ begin
+ Xold := Get_Source_File_Index (Sloc (Template_Id));
+ A.Lo := Source_File.Table (Xold).Source_First;
+ A.Hi := Source_File.Table (Xold).Source_Last;
+
+ Source_File.Increment_Last;
+ Xnew := Source_File.Last;
+
+ Source_File.Table (Xnew) := Source_File.Table (Xold);
+ Source_File.Table (Xnew).Instantiation := Sloc (Inst_Node);
+ Source_File.Table (Xnew).Template := Xold;
+
+ -- Now we need to compute the new values of Source_First, Source_Last
+ -- and adjust the source file pointer to have the correct virtual
+ -- origin for the new range of values.
+
+ Source_File.Table (Xnew).Source_First :=
+ Source_File.Table (Xnew - 1).Source_Last + 1;
+
+ A.Adjust := Source_File.Table (Xnew).Source_First - A.Lo;
+ Source_File.Table (Xnew).Source_Last := A.Hi + A.Adjust;
+
+ Source_File.Table (Xnew).Sloc_Adjust :=
+ Source_File.Table (Xold).Sloc_Adjust - A.Adjust;
+
+ if Debug_Flag_L then
+ Write_Eol;
+ Write_Str ("*** Create instantiation source for ");
+
+ if Nkind (Dnod) in N_Proper_Body
+ and then Was_Originally_Stub (Dnod)
+ then
+ Write_Str ("subunit ");
+
+ elsif Ekind (Template_Id) = E_Generic_Package then
+ if Nkind (Dnod) = N_Package_Body then
+ Write_Str ("body of package ");
+ else
+ Write_Str ("spec of package ");
+ end if;
+
+ elsif Ekind (Template_Id) = E_Function then
+ Write_Str ("body of function ");
+
+ elsif Ekind (Template_Id) = E_Procedure then
+ Write_Str ("body of procedure ");
+
+ elsif Ekind (Template_Id) = E_Generic_Function then
+ Write_Str ("spec of function ");
+
+ elsif Ekind (Template_Id) = E_Generic_Procedure then
+ Write_Str ("spec of procedure ");
+
+ elsif Ekind (Template_Id) = E_Package_Body then
+ Write_Str ("body of package ");
+
+ else pragma Assert (Ekind (Template_Id) = E_Subprogram_Body);
+
+ if Nkind (Dnod) = N_Procedure_Specification then
+ Write_Str ("body of procedure ");
+ else
+ Write_Str ("body of function ");
+ end if;
+ end if;
+
+ Write_Name (Chars (Template_Id));
+ Write_Eol;
+
+ Write_Str (" new source index = ");
+ Write_Int (Int (Xnew));
+ Write_Eol;
+
+ Write_Str (" copying from file name = ");
+ Write_Name (File_Name (Xold));
+ Write_Eol;
+
+ Write_Str (" old source index = ");
+ Write_Int (Int (Xold));
+ Write_Eol;
+
+ Write_Str (" old lo = ");
+ Write_Int (Int (A.Lo));
+ Write_Eol;
+
+ Write_Str (" old hi = ");
+ Write_Int (Int (A.Hi));
+ Write_Eol;
+
+ Write_Str (" new lo = ");
+ Write_Int (Int (Source_File.Table (Xnew).Source_First));
+ Write_Eol;
+
+ Write_Str (" new hi = ");
+ Write_Int (Int (Source_File.Table (Xnew).Source_Last));
+ Write_Eol;
+
+ Write_Str (" adjustment factor = ");
+ Write_Int (Int (A.Adjust));
+ Write_Eol;
+
+ Write_Str (" instantiation location: ");
+ Write_Location (Sloc (Inst_Node));
+ Write_Eol;
+ end if;
+
+ -- For a given character in the source, a higher subscript will be
+ -- used to access the instantiation, which means that the virtual
+ -- origin must have a corresponding lower value. We compute this
+ -- new origin by taking the address of the appropriate adjusted
+ -- element in the old array. Since this adjusted element will be
+ -- at a negative subscript, we must suppress checks.
+
+ declare
+ pragma Suppress (All_Checks);
+
+ function To_Source_Buffer_Ptr is new
+ Unchecked_Conversion (Address, Source_Buffer_Ptr);
+
+ begin
+ Source_File.Table (Xnew).Source_Text :=
+ To_Source_Buffer_Ptr
+ (Source_File.Table (Xold).Source_Text (-A.Adjust)'Address);
+ end;
+
+ end Create_Instantiation_Source;
+
+ ----------------------
+ -- Load_Config_File --
+ ----------------------
+
+ function Load_Config_File
+ (N : File_Name_Type)
+ return Source_File_Index
+ is
+ begin
+ return Load_File (N, Osint.Config);
+ end Load_Config_File;
+
+ ---------------
+ -- Load_File --
+ ---------------
+
+ function Load_File
+ (N : File_Name_Type;
+ T : File_Type)
+ return Source_File_Index
+ is
+ Src : Source_Buffer_Ptr;
+ X : Source_File_Index;
+ Lo : Source_Ptr;
+ Hi : Source_Ptr;
+
+ begin
+ for J in 1 .. Source_File.Last loop
+ if Source_File.Table (J).File_Name = N then
+ return J;
+ end if;
+ end loop;
+
+ -- Here we must build a new entry in the file table
+
+ Source_File.Increment_Last;
+ X := Source_File.Last;
+
+ if X = Source_File.First then
+ Lo := First_Source_Ptr;
+ else
+ Lo := Source_File.Table (X - 1).Source_Last + 1;
+ end if;
+
+ Read_Source_File (N, Lo, Hi, Src, T);
+
+ if Src = null then
+ Source_File.Decrement_Last;
+ return No_Source_File;
+
+ else
+ if Debug_Flag_L then
+ Write_Eol;
+ Write_Str ("*** Build source file table entry, Index = ");
+ Write_Int (Int (X));
+ Write_Str (", file name = ");
+ Write_Name (N);
+ Write_Eol;
+ Write_Str (" lo = ");
+ Write_Int (Int (Lo));
+ Write_Eol;
+ Write_Str (" hi = ");
+ Write_Int (Int (Hi));
+ Write_Eol;
+
+ Write_Str (" first 10 chars -->");
+
+ declare
+ procedure Wchar (C : Character);
+ -- Writes character or ? for control character
+
+ procedure Wchar (C : Character) is
+ begin
+ if C < ' ' or C in ASCII.DEL .. Character'Val (16#9F#) then
+ Write_Char ('?');
+ else
+ Write_Char (C);
+ end if;
+ end Wchar;
+
+ begin
+ for J in Lo .. Lo + 9 loop
+ Wchar (Src (J));
+ end loop;
+
+ Write_Str ("<--");
+ Write_Eol;
+
+ Write_Str (" last 10 chars -->");
+
+ for J in Hi - 10 .. Hi - 1 loop
+ Wchar (Src (J));
+ end loop;
+
+ Write_Str ("<--");
+ Write_Eol;
+
+ if Src (Hi) /= EOF then
+ Write_Str (" error: no EOF at end");
+ Write_Eol;
+ end if;
+ end;
+ end if;
+
+ declare
+ S : Source_File_Record renames Source_File.Table (X);
+
+ begin
+ S := (Debug_Source_Name => Full_Source_Name,
+ File_Name => N,
+ First_Mapped_Line => No_Line_Number,
+ Full_File_Name => Full_Source_Name,
+ Full_Ref_Name => Full_Source_Name,
+ Identifier_Casing => Unknown,
+ Instantiation => No_Location,
+ Keyword_Casing => Unknown,
+ Last_Source_Line => 1,
+ License => Unknown,
+ Lines_Table => null,
+ Lines_Table_Max => 1,
+ Logical_Lines_Table => null,
+ Num_SRef_Pragmas => 0,
+ Reference_Name => N,
+ Sloc_Adjust => 0,
+ Source_Checksum => 0,
+ Source_First => Lo,
+ Source_Last => Hi,
+ Source_Text => Src,
+ Template => No_Source_File,
+ Time_Stamp => Current_Source_File_Stamp);
+
+ Alloc_Line_Tables (S, Opt.Table_Factor * Alloc.Lines_Initial);
+ S.Lines_Table (1) := Lo;
+ end;
+
+ return X;
+ end if;
+ end Load_File;
+
+ ----------------------
+ -- Load_Source_File --
+ ----------------------
+
+ function Load_Source_File
+ (N : File_Name_Type)
+ return Source_File_Index
+ is
+ begin
+ return Load_File (N, Osint.Source);
+ end Load_Source_File;
+
+ ----------------------------
+ -- Source_File_Is_Subunit --
+ ----------------------------
+
+ function Source_File_Is_Subunit (X : Source_File_Index) return Boolean is
+ begin
+ Initialize_Scanner (No_Unit, X);
+
+ -- We scan past junk to the first interesting compilation unit
+ -- token, to see if it is SEPARATE. We ignore WITH keywords during
+ -- this and also PRIVATE. The reason for ignoring PRIVATE is that
+ -- it handles some error situations, and also it is possible that
+ -- a PRIVATE WITH feature might be approved some time in the future.
+
+ while Token = Tok_With
+ or else Token = Tok_Private
+ or else (Token not in Token_Class_Cunit and then Token /= Tok_EOF)
+ loop
+ Scan;
+ end loop;
+
+ return Token = Tok_Separate;
+ end Source_File_Is_Subunit;
+
+ ----------------------
+ -- Trim_Lines_Table --
+ ----------------------
+
+ procedure Trim_Lines_Table (S : Source_File_Index) is
+
+ function realloc
+ (P : Lines_Table_Ptr;
+ New_Size : Int)
+ return Lines_Table_Ptr;
+ pragma Import (C, realloc);
+
+ Max : constant Nat := Nat (Source_File.Table (S).Last_Source_Line);
+
+ begin
+ -- Release allocated storage that is no longer needed
+
+ Source_File.Table (S).Lines_Table :=
+ realloc
+ (Source_File.Table (S).Lines_Table,
+ Max * (Lines_Table_Type'Component_Size / System.Storage_Unit));
+ Source_File.Table (S).Lines_Table_Max := Physical_Line_Number (Max);
+ end Trim_Lines_Table;
+
+ ----------------------
+ -- Write_Debug_Line --
+ ----------------------
+
+ procedure Write_Debug_Line (Str : String; Loc : in out Source_Ptr) is
+ S : Source_File_Record renames Source_File.Table (Dfile);
+
+ begin
+ -- Ignore write request if null line at start of file
+
+ if Str'Length = 0 and then Loc = S.Source_First then
+ return;
+
+ -- Here we write the line, and update the source record entry
+
+ else
+ Write_Debug_Info (Str);
+ Add_Line_Tables_Entry (S, Loc);
+ Loc := Loc + Source_Ptr (Str'Length + Debug_File_Eol_Length);
+ S.Source_Last := Loc;
+
+ if Debug_Flag_GG then
+ declare
+ Lin : constant String := Str;
+
+ begin
+ Column := 1;
+ Write_Str ("---> Write_Debug_Line (Str => """);
+ Write_Str (Lin);
+ Write_Str (""", Loc => ");
+ Write_Int (Int (Loc));
+ Write_Str (");");
+ Write_Eol;
+ end;
+ end if;
+ end if;
+ end Write_Debug_Line;
+
+end Sinput.L;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S I N P U T . L --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.14 $ --
+-- --
+-- 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 child package contains the routines used to actually load a source
+-- file and create entries in the source file table. It also contains the
+-- routines to create virtual entries for instantiations. This is separated
+-- off into a child package to avoid a dependence of Sinput on Osint which
+-- would cause trouble in the tree read/write routines.
+
+with Types; use Types;
+
+package Sinput.L is
+
+ -------------------------------------------
+ -- Subprograms for Loading Source Files --
+ -------------------------------------------
+
+ function Load_Source_File (N : File_Name_Type) return Source_File_Index;
+ -- Given a source file name, returns the index of the corresponding entry
+ -- in the source file table. If the file is not currently loaded, then
+ -- this is the call that causes the source file to be read and an entry
+ -- made in the table. A new entry in the table has the file name and time
+ -- stamp entries set and the Casing entries set to Unknown. Version is set
+ -- to all blanks, and the lines table is initialized but only the first
+ -- entry is set (and Last_Line is set to 1). If the given source file
+ -- cannot be opened, then the value returned is No_Source_File.
+
+ function Load_Config_File (N : File_Name_Type) return Source_File_Index;
+ -- Similar to Load_Source_File, except that the file name is always
+ -- interpreted in the context of the current working directory.
+
+ procedure Complete_Source_File_Entry;
+ -- Called on completing the parsing of a source file. This call completes
+ -- the source file table entry for the current source file.
+
+ function Source_File_Is_Subunit (X : Source_File_Index) return Boolean;
+ -- This function determines if a source file represents a subunit. It
+ -- works by scanning for the first compilation unit token, and returning
+ -- True if it is the token SEPARATE. It will return False otherwise,
+ -- meaning that the file cannot possibly be a legal subunit. This
+ -- function does NOT do a complete parse of the file, or build a
+ -- tree. It is used in the main driver in the check for bad bodies.
+
+ -------------------------------------------------
+ -- Subprograms for Dealing With Instantiations --
+ -------------------------------------------------
+
+ type Sloc_Adjustment is private;
+ -- Type returned by Create_Instantiation_Source for use in subsequent
+ -- calls to Adjust_Instantiation_Sloc.
+
+ procedure Create_Instantiation_Source
+ (Inst_Node : Entity_Id;
+ Template_Id : Entity_Id;
+ A : out Sloc_Adjustment);
+ -- This procedure creates the source table entry for an instantiation.
+ -- Inst_Node is the instantiation node, and Template_Id is the defining
+ -- identifier of the generic declaration or body unit as appropriate.
+ -- A is set to an adjustment factor to be used in subsequent calls to
+ -- Adjust_Instantiation_Sloc.
+
+ procedure Adjust_Instantiation_Sloc (N : Node_Id; A : Sloc_Adjustment);
+ -- The instantiation tree is created by copying the tree of the generic
+ -- template (including the original Sloc values), and then applying
+ -- Adjust_Instantiation_Sloc to each copied node to adjust the Sloc
+ -- to reference the source entry for the instantiation.
+
+ ------------------------------------------------
+ -- Subprograms for Writing Debug Source Files --
+ ------------------------------------------------
+
+ procedure Create_Debug_Source
+ (Source : Source_File_Index;
+ Loc : out Source_Ptr);
+ -- Given a source file, creates a new source file table entry to be used
+ -- for the debug source file output (Debug_Generated_Code switch set).
+ -- Loc is set to the initial Sloc value for the first line. This call
+ -- also creates the debug source output file (using Create_Debug_File).
+
+ procedure Write_Debug_Line (Str : String; Loc : in out Source_Ptr);
+ -- This procedure is called to write a line to the debug source file
+ -- previously created by Create_Debug_Source using Write_Debug_Info.
+ -- Str is the source line to be written to the file (it does not include
+ -- an end of line character). On entry Loc is the Sloc value previously
+ -- returned by Create_Debug_Source or Write_Debug_Line, and on exit,
+ -- Sloc is updated to point to the start of the next line to be written,
+ -- taking into account the length of the ternminator that was written by
+ -- Write_Debug_Info.
+
+ procedure Close_Debug_Source;
+ -- This procedure completes the source table entry for the debug file
+ -- previously created by Create_Debug_Source, and written using the
+ -- Write_Debug_Line procedure. It then calls Close_Debug_File to
+ -- complete the writing of the file itself.
+
+private
+
+ type Sloc_Adjustment is record
+ Adjust : Source_Ptr;
+ -- Adjustment factor. To be added to source location values in the
+ -- source table entry for the template to get corresponding sloc
+ -- values for the instantiation image of the template. This is not
+ -- really a Source_Ptr value, but rather an offset, but it is more
+ -- convenient to represent it as a Source_Ptr value and this is a
+ -- private type anyway.
+
+ Lo, Hi : Source_Ptr;
+ -- Lo and hi values to which adjustment factor can legitimately
+ -- be applied, used to ensure that no incorrect adjustments are
+ -- made. Really it is a bug if anyone ever tries to adjust outside
+ -- this range, but since we are only doing this anyway for getting
+ -- better error messages, it is not critical
+
+ end record;
+
+end Sinput.L;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S I N P U T . P --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.9 $
+-- --
+-- 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). --
+-- --
+------------------------------------------------------------------------------
+
+with Ada.Unchecked_Conversion;
+
+with GNAT.OS_Lib; use GNAT.OS_Lib;
+with Namet; use Namet;
+with Opt; use Opt;
+with System; use System;
+
+package body Sinput.P is
+
+ First : Boolean := True;
+ -- Flag used when Load_Project_File is called the first time,
+ -- to set Main_Source_File.
+ -- The flag is reset to False at the first call to Load_Project_File
+
+ -----------------------
+ -- Load_Project_File --
+ -----------------------
+
+ function Load_Project_File (Path : String) return Source_File_Index is
+ Src : Source_Buffer_Ptr;
+ X : Source_File_Index;
+ Lo : Source_Ptr;
+ Hi : Source_Ptr;
+
+ Source_File_FD : File_Descriptor;
+ -- The file descriptor for the current source file. A negative value
+ -- indicates failure to open the specified source file.
+
+ Len : Integer;
+ -- Length of file. Assume no more than 2 gigabytes of source!
+
+ Actual_Len : Integer;
+
+ Path_Id : Name_Id;
+ File_Id : Name_Id;
+
+ begin
+ if Path = "" then
+ return No_Source_File;
+ end if;
+
+ Source_File.Increment_Last;
+ X := Source_File.Last;
+
+ if First then
+ Main_Source_File := X;
+ First := False;
+ end if;
+
+ if X = Source_File.First then
+ Lo := First_Source_Ptr;
+ else
+ Lo := Source_File.Table (X - 1).Source_Last + 1;
+ end if;
+
+ Name_Len := Path'Length;
+ Name_Buffer (1 .. Name_Len) := Path;
+ Path_Id := Name_Find;
+ Name_Buffer (Name_Len + 1) := ASCII.NUL;
+
+ -- Open the source FD, note that we open in binary mode, because as
+ -- documented in the spec, the caller is expected to handle either
+ -- DOS or Unix mode files, and there is no point in wasting time on
+ -- text translation when it is not required.
+
+ Source_File_FD := Open_Read (Name_Buffer'Address, Binary);
+
+ if Source_File_FD = Invalid_FD then
+ Source_File.Decrement_Last;
+ return No_Source_File;
+
+ end if;
+
+ Len := Integer (File_Length (Source_File_FD));
+
+ -- Set Hi so that length is one more than the physical length,
+ -- allowing for the extra EOF character at the end of the buffer
+
+ Hi := Lo + Source_Ptr (Len);
+
+ -- Do the actual read operation
+
+ declare
+ subtype Actual_Source_Buffer is Source_Buffer (Lo .. Hi);
+ -- Physical buffer allocated
+
+ type Actual_Source_Ptr is access Actual_Source_Buffer;
+ -- This is the pointer type for the physical buffer allocated
+
+ Actual_Ptr : Actual_Source_Ptr := new Actual_Source_Buffer;
+ -- And this is the actual physical buffer
+
+ begin
+ -- Allocate source buffer, allowing extra character at end for EOF
+
+ -- Some systems (e.g. VMS) have file types that require one
+ -- read per line, so read until we get the Len bytes or until
+ -- there are no more characters.
+
+ Hi := Lo;
+ loop
+ Actual_Len := Read (Source_File_FD, Actual_Ptr (Hi)'Address, Len);
+ Hi := Hi + Source_Ptr (Actual_Len);
+ exit when Actual_Len = Len or Actual_Len <= 0;
+ end loop;
+
+ Actual_Ptr (Hi) := EOF;
+
+ -- Now we need to work out the proper virtual origin pointer to
+ -- return. This is exactly Actual_Ptr (0)'Address, but we have
+ -- to be careful to suppress checks to compute this address.
+
+ declare
+ pragma Suppress (All_Checks);
+
+ function To_Source_Buffer_Ptr is new
+ Ada.Unchecked_Conversion (Address, Source_Buffer_Ptr);
+
+ begin
+ Src := To_Source_Buffer_Ptr (Actual_Ptr (0)'Address);
+ end;
+ end;
+
+ -- Read is complete, get time stamp and close file and we are done
+
+ Close (Source_File_FD);
+
+ -- Get the file name, without path information
+
+ declare
+ Index : Positive := Path'Last;
+
+ begin
+ while Index > Path'First loop
+ exit when Path (Index - 1) = '/';
+ exit when Path (Index - 1) = Directory_Separator;
+ Index := Index - 1;
+ end loop;
+
+ Name_Len := Path'Last - Index + 1;
+ Name_Buffer (1 .. Name_Len) := Path (Index .. Path'Last);
+ File_Id := Name_Find;
+ end;
+
+ declare
+ S : Source_File_Record renames Source_File.Table (X);
+
+ begin
+ S := (Debug_Source_Name => Path_Id,
+ File_Name => File_Id,
+ First_Mapped_Line => No_Line_Number,
+ Full_File_Name => Path_Id,
+ Full_Ref_Name => Path_Id,
+ Identifier_Casing => Unknown,
+ Instantiation => No_Location,
+ Keyword_Casing => Unknown,
+ Last_Source_Line => 1,
+ License => Unknown,
+ Lines_Table => null,
+ Lines_Table_Max => 1,
+ Logical_Lines_Table => null,
+ Num_SRef_Pragmas => 0,
+ Reference_Name => File_Id,
+ Sloc_Adjust => 0,
+ Source_Checksum => 0,
+ Source_First => Lo,
+ Source_Last => Hi,
+ Source_Text => Src,
+ Template => No_Source_File,
+ Time_Stamp => Empty_Time_Stamp);
+
+ Alloc_Line_Tables (S, Opt.Table_Factor * Alloc.Lines_Initial);
+ S.Lines_Table (1) := Lo;
+ end;
+
+ return X;
+ end Load_Project_File;
+
+ --------------------------------
+ -- Restore_Project_Scan_State --
+ --------------------------------
+
+ procedure Restore_Project_Scan_State
+ (Saved_State : in Saved_Project_Scan_State)
+ is
+ begin
+ Restore_Scan_State (Saved_State.Scan_State);
+ Source := Saved_State.Source;
+ Current_Source_File := Saved_State.Current_Source_File;
+ end Restore_Project_Scan_State;
+
+ -----------------------------
+ -- Save_Project_Scan_State --
+ -----------------------------
+
+ procedure Save_Project_Scan_State
+ (Saved_State : out Saved_Project_Scan_State)
+ is
+ begin
+ Save_Scan_State (Saved_State.Scan_State);
+ Saved_State.Source := Source;
+ Saved_State.Current_Source_File := Current_Source_File;
+ end Save_Project_Scan_State;
+
+end Sinput.P;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S I N P U T . P --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.3 $
+-- --
+-- 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 child package contains the routines used to actually load a project
+-- file and create entries in the source file table. It also contains two
+-- routines to save and restore a project scan context.
+
+with Scans; use Scans;
+with Types; use Types;
+
+package Sinput.P is
+
+ function Load_Project_File (Path : String) return Source_File_Index;
+ -- Load into memory the source of a project source file.
+ -- Initialize the Scans state.
+
+ type Saved_Project_Scan_State is limited private;
+ -- Used to save project scan state in following two routines
+
+ procedure Save_Project_Scan_State
+ (Saved_State : out Saved_Project_Scan_State);
+ pragma Inline (Save_Project_Scan_State);
+ -- Save the Scans state, as well as the values of
+ -- Source and Current_Source_File.
+
+ procedure Restore_Project_Scan_State
+ (Saved_State : Saved_Project_Scan_State);
+ pragma Inline (Restore_Project_Scan_State);
+ -- Restore the Scans state and the values of
+ -- Source and Current_Source_File.
+
+private
+
+ type Saved_Project_Scan_State is record
+ Scan_State : Saved_Scan_State;
+ Source : Source_Buffer_Ptr;
+ Current_Source_File : Source_File_Index;
+ end record;
+
+end Sinput.P;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S I N P U T --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.99 $
+-- --
+-- 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 other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception 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). --
+-- --
+------------------------------------------------------------------------------
+
+pragma Style_Checks (All_Checks);
+-- Subprograms not all in alpha order
+
+with Debug; use Debug;
+with Namet; use Namet;
+with Opt; use Opt;
+with Output; use Output;
+with Tree_IO; use Tree_IO;
+with System; use System;
+
+with Unchecked_Conversion;
+with Unchecked_Deallocation;
+
+package body Sinput is
+
+ use ASCII;
+ -- Make control characters visible
+
+ First_Time_Around : Boolean := True;
+
+ ---------------------------
+ -- Add_Line_Tables_Entry --
+ ---------------------------
+
+ procedure Add_Line_Tables_Entry
+ (S : in out Source_File_Record;
+ P : Source_Ptr)
+ is
+ LL : Physical_Line_Number;
+
+ begin
+ -- Reallocate the lines tables if necessary.
+
+ -- Note: the reason we do not use the normal Table package
+ -- mechanism is that we have several of these tables. We could
+ -- use the new GNAT.Dynamic_Tables package and that would probably
+ -- be a good idea ???
+
+ if S.Last_Source_Line = S.Lines_Table_Max then
+ Alloc_Line_Tables
+ (S,
+ Int (S.Last_Source_Line) *
+ ((100 + Alloc.Lines_Increment) / 100));
+
+ if Debug_Flag_D then
+ Write_Str ("--> Reallocating lines table, size = ");
+ Write_Int (Int (S.Lines_Table_Max));
+ Write_Eol;
+ end if;
+ end if;
+
+ S.Last_Source_Line := S.Last_Source_Line + 1;
+ LL := S.Last_Source_Line;
+
+ S.Lines_Table (LL) := P;
+
+ -- Deal with setting new entry in logical lines table if one is
+ -- present. Note that there is always space (because the call to
+ -- Alloc_Line_Tables makes sure both tables are the same length),
+
+ if S.Logical_Lines_Table /= null then
+
+ -- We can always set the entry from the previous one, because
+ -- the processing for a Source_Reference pragma ensures that
+ -- at least one entry following the pragma is set up correctly.
+
+ S.Logical_Lines_Table (LL) := S.Logical_Lines_Table (LL - 1) + 1;
+ end if;
+ end Add_Line_Tables_Entry;
+
+ -----------------------
+ -- Alloc_Line_Tables --
+ -----------------------
+
+ procedure Alloc_Line_Tables
+ (S : in out Source_File_Record;
+ New_Max : Nat)
+ is
+ function realloc
+ (memblock : Lines_Table_Ptr;
+ size : size_t)
+ return Lines_Table_Ptr;
+ pragma Import (C, realloc, "realloc");
+
+ function reallocl
+ (memblock : Logical_Lines_Table_Ptr;
+ size : size_t)
+ return Logical_Lines_Table_Ptr;
+ pragma Import (C, reallocl, "realloc");
+
+ function malloc
+ (size : size_t)
+ return Lines_Table_Ptr;
+ pragma Import (C, malloc, "malloc");
+
+ function mallocl
+ (size : size_t)
+ return Logical_Lines_Table_Ptr;
+ pragma Import (C, mallocl, "malloc");
+
+ New_Table : Lines_Table_Ptr;
+
+ New_Logical_Table : Logical_Lines_Table_Ptr;
+
+ New_Size : constant size_t :=
+ size_t (New_Max * Lines_Table_Type'Component_Size /
+ Storage_Unit);
+
+ begin
+ if S.Lines_Table = null then
+ New_Table := malloc (New_Size);
+
+ else
+ New_Table :=
+ realloc (memblock => S.Lines_Table, size => New_Size);
+ end if;
+
+ if New_Table = null then
+ raise Storage_Error;
+ else
+ S.Lines_Table := New_Table;
+ S.Lines_Table_Max := Physical_Line_Number (New_Max);
+ end if;
+
+ if S.Num_SRef_Pragmas /= 0 then
+ if S.Logical_Lines_Table = null then
+ New_Logical_Table := mallocl (New_Size);
+ else
+ New_Logical_Table :=
+ reallocl (memblock => S.Logical_Lines_Table, size => New_Size);
+ end if;
+
+ if New_Logical_Table = null then
+ raise Storage_Error;
+ else
+ S.Logical_Lines_Table := New_Logical_Table;
+ end if;
+ end if;
+ end Alloc_Line_Tables;
+
+ -----------------
+ -- Backup_Line --
+ -----------------
+
+ procedure Backup_Line (P : in out Source_Ptr) is
+ Sindex : constant Source_File_Index := Get_Source_File_Index (P);
+ Src : constant Source_Buffer_Ptr :=
+ Source_File.Table (Sindex).Source_Text;
+ Sfirst : constant Source_Ptr :=
+ Source_File.Table (Sindex).Source_First;
+
+ begin
+ P := P - 1;
+
+ if P = Sfirst then
+ return;
+ end if;
+
+ if Src (P) = CR then
+ if Src (P - 1) = LF then
+ P := P - 1;
+ end if;
+
+ else -- Src (P) = LF
+ if Src (P - 1) = CR then
+ P := P - 1;
+ end if;
+ end if;
+
+ -- Now find first character of the previous line
+
+ while P > Sfirst
+ and then Src (P - 1) /= LF
+ and then Src (P - 1) /= CR
+ loop
+ P := P - 1;
+ end loop;
+ end Backup_Line;
+
+ ---------------------------
+ -- Build_Location_String --
+ ---------------------------
+
+ procedure Build_Location_String (Loc : Source_Ptr) is
+ Ptr : Source_Ptr;
+
+ begin
+ Name_Len := 0;
+
+ -- Loop through instantiations
+
+ Ptr := Loc;
+ loop
+ Get_Name_String_And_Append
+ (Reference_Name (Get_Source_File_Index (Ptr)));
+ Add_Char_To_Name_Buffer (':');
+ Add_Nat_To_Name_Buffer
+ (Nat (Get_Logical_Line_Number (Ptr)));
+
+ Ptr := Instantiation_Location (Ptr);
+ exit when Ptr = No_Location;
+ Add_Str_To_Name_Buffer (" instantiated at ");
+ end loop;
+
+ Name_Buffer (Name_Len + 1) := NUL;
+ return;
+ end Build_Location_String;
+
+ -----------------------
+ -- Get_Column_Number --
+ -----------------------
+
+ function Get_Column_Number (P : Source_Ptr) return Column_Number is
+ S : Source_Ptr;
+ C : Column_Number;
+ Sindex : Source_File_Index;
+ Src : Source_Buffer_Ptr;
+
+ begin
+ -- If the input source pointer is not a meaningful value then return
+ -- at once with column number 1. This can happen for a file not found
+ -- condition for a file loaded indirectly by RTE, and also perhaps on
+ -- some unknown internal error conditions. In either case we certainly
+ -- don't want to blow up.
+
+ if P < 1 then
+ return 1;
+
+ else
+ Sindex := Get_Source_File_Index (P);
+ Src := Source_File.Table (Sindex).Source_Text;
+ S := Line_Start (P);
+ C := 1;
+
+ while S < P loop
+ if Src (S) = HT then
+ C := (C - 1) / 8 * 8 + (8 + 1);
+ else
+ C := C + 1;
+ end if;
+
+ S := S + 1;
+ end loop;
+
+ return C;
+ end if;
+ end Get_Column_Number;
+
+ -----------------------------
+ -- Get_Logical_Line_Number --
+ -----------------------------
+
+ function Get_Logical_Line_Number
+ (P : Source_Ptr)
+ return Logical_Line_Number
+ is
+ SFR : Source_File_Record
+ renames Source_File.Table (Get_Source_File_Index (P));
+
+ L : constant Physical_Line_Number := Get_Physical_Line_Number (P);
+
+ begin
+ if SFR.Num_SRef_Pragmas = 0 then
+ return Logical_Line_Number (L);
+ else
+ return SFR.Logical_Lines_Table (L);
+ end if;
+ end Get_Logical_Line_Number;
+
+ ------------------------------
+ -- Get_Physical_Line_Number --
+ ------------------------------
+
+ function Get_Physical_Line_Number
+ (P : Source_Ptr)
+ return Physical_Line_Number
+ is
+ Sfile : Source_File_Index;
+ Table : Lines_Table_Ptr;
+ Lo : Physical_Line_Number;
+ Hi : Physical_Line_Number;
+ Mid : Physical_Line_Number;
+ Loc : Source_Ptr;
+
+ begin
+ -- If the input source pointer is not a meaningful value then return
+ -- at once with line number 1. This can happen for a file not found
+ -- condition for a file loaded indirectly by RTE, and also perhaps on
+ -- some unknown internal error conditions. In either case we certainly
+ -- don't want to blow up.
+
+ if P < 1 then
+ return 1;
+
+ -- Otherwise we can do the binary search
+
+ else
+ Sfile := Get_Source_File_Index (P);
+ Loc := P + Source_File.Table (Sfile).Sloc_Adjust;
+ Table := Source_File.Table (Sfile).Lines_Table;
+ Lo := 1;
+ Hi := Source_File.Table (Sfile).Last_Source_Line;
+
+ loop
+ Mid := (Lo + Hi) / 2;
+
+ if Loc < Table (Mid) then
+ Hi := Mid - 1;
+
+ else -- Loc >= Table (Mid)
+
+ if Mid = Hi or else
+ Loc < Table (Mid + 1)
+ then
+ return Mid;
+ else
+ Lo := Mid + 1;
+ end if;
+
+ end if;
+
+ end loop;
+ end if;
+ end Get_Physical_Line_Number;
+
+ ---------------------------
+ -- Get_Source_File_Index --
+ ---------------------------
+
+ Source_Cache_First : Source_Ptr := 1;
+ Source_Cache_Last : Source_Ptr := 0;
+ -- Records the First and Last subscript values for the most recently
+ -- referenced entry in the source table, to optimize the common case
+ -- of repeated references to the same entry. The initial values force
+ -- an initial search to set the cache value.
+
+ Source_Cache_Index : Source_File_Index := No_Source_File;
+ -- Contains the index of the entry corresponding to Source_Cache
+
+ function Get_Source_File_Index
+ (S : Source_Ptr)
+ return Source_File_Index
+ is
+ begin
+ if S in Source_Cache_First .. Source_Cache_Last then
+ return Source_Cache_Index;
+
+ else
+ for J in 1 .. Source_File.Last loop
+ if S in Source_File.Table (J).Source_First ..
+ Source_File.Table (J).Source_Last
+ then
+ Source_Cache_Index := J;
+ Source_Cache_First :=
+ Source_File.Table (Source_Cache_Index).Source_First;
+ Source_Cache_Last :=
+ Source_File.Table (Source_Cache_Index).Source_Last;
+ return Source_Cache_Index;
+ end if;
+ end loop;
+ end if;
+
+ -- We must find a matching entry in the above loop!
+
+ raise Program_Error;
+ end Get_Source_File_Index;
+
+ ----------------
+ -- Initialize --
+ ----------------
+
+ procedure Initialize is
+ begin
+ Source_File.Init;
+ end Initialize;
+
+ -------------------------
+ -- Instantiation_Depth --
+ -------------------------
+
+ function Instantiation_Depth (S : Source_Ptr) return Nat is
+ Sind : Source_File_Index;
+ Sval : Source_Ptr;
+ Depth : Nat;
+
+ begin
+ Sval := S;
+ Depth := 0;
+
+ loop
+ Sind := Get_Source_File_Index (Sval);
+ Sval := Instantiation (Sind);
+ exit when Sval = No_Location;
+ Depth := Depth + 1;
+ end loop;
+
+ return Depth;
+ end Instantiation_Depth;
+
+ ----------------------------
+ -- Instantiation_Location --
+ ----------------------------
+
+ function Instantiation_Location (S : Source_Ptr) return Source_Ptr is
+ begin
+ return Instantiation (Get_Source_File_Index (S));
+ end Instantiation_Location;
+
+ ----------------------
+ -- Last_Source_File --
+ ----------------------
+
+ function Last_Source_File return Source_File_Index is
+ begin
+ return Source_File.Last;
+ end Last_Source_File;
+
+ ----------------
+ -- Line_Start --
+ ----------------
+
+ function Line_Start (P : Source_Ptr) return Source_Ptr is
+ Sindex : constant Source_File_Index := Get_Source_File_Index (P);
+ Src : constant Source_Buffer_Ptr :=
+ Source_File.Table (Sindex).Source_Text;
+ Sfirst : constant Source_Ptr :=
+ Source_File.Table (Sindex).Source_First;
+ S : Source_Ptr;
+
+ begin
+ S := P;
+
+ while S > Sfirst
+ and then Src (S - 1) /= CR
+ and then Src (S - 1) /= LF
+ loop
+ S := S - 1;
+ end loop;
+
+ return S;
+ end Line_Start;
+
+ function Line_Start
+ (L : Physical_Line_Number;
+ S : Source_File_Index)
+ return Source_Ptr
+ is
+ begin
+ return Source_File.Table (S).Lines_Table (L);
+ end Line_Start;
+
+ ----------
+ -- Lock --
+ ----------
+
+ procedure Lock is
+ begin
+ Source_File.Locked := True;
+ Source_File.Release;
+ end Lock;
+
+ ----------------------
+ -- Num_Source_Files --
+ ----------------------
+
+ function Num_Source_Files return Nat is
+ begin
+ return Int (Source_File.Last) - Int (Source_File.First) + 1;
+ end Num_Source_Files;
+
+ ----------------------
+ -- Num_Source_Lines --
+ ----------------------
+
+ function Num_Source_Lines (S : Source_File_Index) return Nat is
+ begin
+ return Nat (Source_File.Table (S).Last_Source_Line);
+ end Num_Source_Lines;
+
+ -----------------------
+ -- Original_Location --
+ -----------------------
+
+ function Original_Location (S : Source_Ptr) return Source_Ptr is
+ Sindex : Source_File_Index;
+ Tindex : Source_File_Index;
+
+ begin
+ if S <= No_Location then
+ return S;
+
+ else
+ Sindex := Get_Source_File_Index (S);
+
+ if Instantiation (Sindex) = No_Location then
+ return S;
+
+ else
+ Tindex := Template (Sindex);
+ while Instantiation (Tindex) /= No_Location loop
+ Tindex := Template (Tindex);
+ end loop;
+
+ return S - Source_First (Sindex) + Source_First (Tindex);
+ end if;
+ end if;
+ end Original_Location;
+
+ -------------------------
+ -- Physical_To_Logical --
+ -------------------------
+
+ function Physical_To_Logical
+ (Line : Physical_Line_Number;
+ S : Source_File_Index)
+ return Logical_Line_Number
+ is
+ SFR : Source_File_Record renames Source_File.Table (S);
+
+ begin
+ if SFR.Num_SRef_Pragmas = 0 then
+ return Logical_Line_Number (Line);
+ else
+ return SFR.Logical_Lines_Table (Line);
+ end if;
+ end Physical_To_Logical;
+
+ --------------------------------
+ -- Register_Source_Ref_Pragma --
+ --------------------------------
+
+ procedure Register_Source_Ref_Pragma
+ (File_Name : Name_Id;
+ Stripped_File_Name : Name_Id;
+ Mapped_Line : Nat;
+ Line_After_Pragma : Physical_Line_Number)
+ is
+ SFR : Source_File_Record renames Source_File.Table (Current_Source_File);
+
+ function malloc
+ (size : size_t)
+ return Logical_Lines_Table_Ptr;
+ pragma Import (C, malloc);
+
+ ML : Logical_Line_Number;
+
+ begin
+ if File_Name /= No_Name then
+ SFR.Full_Ref_Name := File_Name;
+
+ if not Debug_Generated_Code then
+ SFR.Debug_Source_Name := File_Name;
+ end if;
+
+ SFR.Reference_Name := Stripped_File_Name;
+ SFR.Num_SRef_Pragmas := SFR.Num_SRef_Pragmas + 1;
+ end if;
+
+ if SFR.Num_SRef_Pragmas = 1 then
+ SFR.First_Mapped_Line := Logical_Line_Number (Mapped_Line);
+ end if;
+
+ if SFR.Logical_Lines_Table = null then
+ SFR.Logical_Lines_Table :=
+ malloc
+ (size_t (SFR.Lines_Table_Max *
+ Logical_Lines_Table_Type'Component_Size /
+ Storage_Unit));
+ end if;
+
+ SFR.Logical_Lines_Table (Line_After_Pragma - 1) := No_Line_Number;
+
+ ML := Logical_Line_Number (Mapped_Line);
+ for J in Line_After_Pragma .. SFR.Last_Source_Line loop
+ SFR.Logical_Lines_Table (J) := ML;
+ ML := ML + 1;
+ end loop;
+ end Register_Source_Ref_Pragma;
+
+ ---------------------------
+ -- Skip_Line_Terminators --
+ ---------------------------
+
+ -- There are two distinct concepts of line terminator in GNAT
+
+ -- A logical line terminator is what corresponds to the "end of a line"
+ -- as described in RM 2.2 (13). Any of the characters FF, LF, CR or VT
+ -- acts as an end of logical line in this sense, and it is essentially
+ -- irrelevant whether one or more appears in sequence (since if a
+ -- sequence of such characters is regarded as separate ends of line,
+ -- then the intervening logical lines are null in any case).
+
+ -- A physical line terminator is a sequence of format effectors that
+ -- is treated as ending a physical line. Physical lines have no Ada
+ -- semantic significance, but they are significant for error reporting
+ -- purposes, since errors are identified by line and column location.
+
+ -- In GNAT, a physical line is ended by any of the sequences LF, CR/LF,
+ -- CR or LF/CR. LF is used in typical Unix systems, CR/LF in DOS systems,
+ -- and CR alone in System 7. We don't know of any system using LF/CR, but
+ -- it seems reasonable to include this case for consistency. In addition,
+ -- we recognize any of these sequences in any of the operating systems,
+ -- for better behavior in treating foreign files (e.g. a Unix file with
+ -- LF terminators transferred to a DOS system).
+
+ procedure Skip_Line_Terminators
+ (P : in out Source_Ptr;
+ Physical : out Boolean)
+ is
+ begin
+ pragma Assert (Source (P) in Line_Terminator);
+
+ if Source (P) = CR then
+ if Source (P + 1) = LF then
+ P := P + 2;
+ else
+ P := P + 1;
+ end if;
+
+ elsif Source (P) = LF then
+ if Source (P + 1) = CR then
+ P := P + 2;
+ else
+ P := P + 1;
+ end if;
+
+ else -- Source (P) = FF or else Source (P) = VT
+ P := P + 1;
+ Physical := False;
+ return;
+ end if;
+
+ -- Fall through in the physical line terminator case. First deal with
+ -- making a possible entry into the lines table if one is needed.
+
+ -- Note: we are dealing with a real source file here, this cannot be
+ -- the instantiation case, so we need not worry about Sloc adjustment.
+
+ declare
+ S : Source_File_Record
+ renames Source_File.Table (Current_Source_File);
+
+ begin
+ Physical := True;
+
+ -- Make entry in lines table if not already made (in some scan backup
+ -- cases, we will be rescanning previously scanned source, so the
+ -- entry may have already been made on the previous forward scan).
+
+ if Source (P) /= EOF
+ and then P > S.Lines_Table (S.Last_Source_Line)
+ then
+ Add_Line_Tables_Entry (S, P);
+ end if;
+ end;
+ end Skip_Line_Terminators;
+
+ -------------------
+ -- Source_Offset --
+ -------------------
+
+ function Source_Offset (S : Source_Ptr) return Nat is
+ Sindex : constant Source_File_Index := Get_Source_File_Index (S);
+ Sfirst : constant Source_Ptr :=
+ Source_File.Table (Sindex).Source_First;
+
+ begin
+ return Nat (S - Sfirst);
+ end Source_Offset;
+
+ ------------------------
+ -- Top_Level_Location --
+ ------------------------
+
+ function Top_Level_Location (S : Source_Ptr) return Source_Ptr is
+ Oldloc : Source_Ptr;
+ Newloc : Source_Ptr;
+
+ begin
+ Newloc := S;
+ loop
+ Oldloc := Newloc;
+ Newloc := Instantiation_Location (Oldloc);
+ exit when Newloc = No_Location;
+ end loop;
+
+ return Oldloc;
+ end Top_Level_Location;
+
+ ---------------
+ -- Tree_Read --
+ ---------------
+
+ procedure Tree_Read is
+ begin
+ -- First we must free any old source buffer pointers
+
+ if not First_Time_Around then
+ for J in Source_File.First .. Source_File.Last loop
+ declare
+ S : Source_File_Record renames Source_File.Table (J);
+
+ procedure Free_Ptr is new Unchecked_Deallocation
+ (Big_Source_Buffer, Source_Buffer_Ptr);
+
+ -- Note: we are using free here, because we used malloc
+ -- or realloc directly to allocate the tables. That is
+ -- because we were playing the big array trick.
+
+ procedure free (X : Lines_Table_Ptr);
+ pragma Import (C, free, "free");
+
+ procedure freel (X : Logical_Lines_Table_Ptr);
+ pragma Import (C, freel, "free");
+
+ function To_Source_Buffer_Ptr is new
+ Unchecked_Conversion (Address, Source_Buffer_Ptr);
+
+ Tmp1 : Source_Buffer_Ptr;
+
+ begin
+ if S.Instantiation /= No_Location then
+ null;
+
+ else
+ -- We have to recreate a proper pointer to the actual array
+ -- from the zero origin pointer stored in the source table.
+
+ Tmp1 :=
+ To_Source_Buffer_Ptr
+ (S.Source_Text (S.Source_First)'Address);
+ Free_Ptr (Tmp1);
+
+ if S.Lines_Table /= null then
+ free (S.Lines_Table);
+ S.Lines_Table := null;
+ end if;
+
+ if S.Logical_Lines_Table /= null then
+ freel (S.Logical_Lines_Table);
+ S.Logical_Lines_Table := null;
+ end if;
+ end if;
+ end;
+ end loop;
+ end if;
+
+ -- Reset source cache pointers to force new read
+
+ Source_Cache_First := 1;
+ Source_Cache_Last := 0;
+
+ -- Read in source file table
+
+ Source_File.Tree_Read;
+
+ -- The pointers we read in there for the source buffer and lines
+ -- table pointers are junk. We now read in the actual data that
+ -- is referenced by these two fields.
+
+ for J in Source_File.First .. Source_File.Last loop
+ declare
+ S : Source_File_Record renames Source_File.Table (J);
+
+ begin
+ -- For the instantiation case, we do not read in any data. Instead
+ -- we share the data for the generic template entry. Since the
+ -- template always occurs first, we can safetly refer to its data.
+
+ if S.Instantiation /= No_Location then
+ declare
+ ST : Source_File_Record renames
+ Source_File.Table (S.Template);
+
+ begin
+ -- The lines tables are copied from the template entry
+
+ S.Lines_Table :=
+ Source_File.Table (S.Template).Lines_Table;
+ S.Logical_Lines_Table :=
+ Source_File.Table (S.Template).Logical_Lines_Table;
+
+ -- In the case of the source table pointer, we share the
+ -- same data as the generic template, but the virtual origin
+ -- is adjusted. For example, if the first subscript of the
+ -- template is 100, and that of the instantiation is 200,
+ -- then the instantiation pointer is obtained by subtracting
+ -- 100 from the template pointer.
+
+ declare
+ pragma Suppress (All_Checks);
+
+ function To_Source_Buffer_Ptr is new
+ Unchecked_Conversion (Address, Source_Buffer_Ptr);
+
+ begin
+ S.Source_Text :=
+ To_Source_Buffer_Ptr
+ (ST.Source_Text
+ (ST.Source_First - S.Source_First)'Address);
+ end;
+ end;
+
+ -- Normal case (non-instantiation)
+
+ else
+ First_Time_Around := False;
+ S.Lines_Table := null;
+ S.Logical_Lines_Table := null;
+ Alloc_Line_Tables (S, Int (S.Last_Source_Line));
+
+ for J in 1 .. S.Last_Source_Line loop
+ Tree_Read_Int (Int (S.Lines_Table (J)));
+ end loop;
+
+ if S.Num_SRef_Pragmas /= 0 then
+ for J in 1 .. S.Last_Source_Line loop
+ Tree_Read_Int (Int (S.Logical_Lines_Table (J)));
+ end loop;
+ end if;
+
+ -- Allocate source buffer and read in the data and then set the
+ -- virtual origin to point to the logical zero'th element. This
+ -- address must be computed with subscript checks turned off.
+
+ declare
+ subtype B is Text_Buffer (S.Source_First .. S.Source_Last);
+ type Text_Buffer_Ptr is access B;
+ T : Text_Buffer_Ptr;
+
+ pragma Suppress (All_Checks);
+
+ function To_Source_Buffer_Ptr is new
+ Unchecked_Conversion (Address, Source_Buffer_Ptr);
+
+ begin
+ T := new B;
+
+ Tree_Read_Data (T (S.Source_First)'Address,
+ Int (S.Source_Last) - Int (S.Source_First) + 1);
+
+ S.Source_Text := To_Source_Buffer_Ptr (T (0)'Address);
+ end;
+ end if;
+ end;
+ end loop;
+ end Tree_Read;
+
+ ----------------
+ -- Tree_Write --
+ ----------------
+
+ procedure Tree_Write is
+ begin
+ Source_File.Tree_Write;
+
+ -- The pointers we wrote out there for the source buffer and lines
+ -- table pointers are junk, we now write out the actual data that
+ -- is referenced by these two fields.
+
+ for J in Source_File.First .. Source_File.Last loop
+ declare
+ S : Source_File_Record renames Source_File.Table (J);
+
+ begin
+ -- For instantiations, there is nothing to do, since the data is
+ -- shared with the generic template. When the tree is read, the
+ -- pointers must be set, but no extra data needs to be written.
+
+ if S.Instantiation /= No_Location then
+ null;
+
+ -- For the normal case, write out the data of the tables
+
+ else
+ -- Lines table
+
+ for J in 1 .. S.Last_Source_Line loop
+ Tree_Write_Int (Int (S.Lines_Table (J)));
+ end loop;
+
+ -- Logical lines table if present
+
+ if S.Num_SRef_Pragmas /= 0 then
+ for J in 1 .. S.Last_Source_Line loop
+ Tree_Write_Int (Int (S.Logical_Lines_Table (J)));
+ end loop;
+ end if;
+
+ -- Source buffer
+
+ Tree_Write_Data
+ (S.Source_Text (S.Source_First)'Address,
+ Int (S.Source_Last) - Int (S.Source_First) + 1);
+ end if;
+ end;
+ end loop;
+ end Tree_Write;
+
+ --------------------
+ -- Write_Location --
+ --------------------
+
+ procedure Write_Location (P : Source_Ptr) is
+ begin
+ if P = No_Location then
+ Write_Str ("<no location>");
+
+ elsif P <= Standard_Location then
+ Write_Str ("<standard location>");
+
+ else
+ declare
+ SI : constant Source_File_Index := Get_Source_File_Index (P);
+
+ begin
+ Write_Name (Debug_Source_Name (SI));
+ Write_Char (':');
+ Write_Int (Int (Get_Logical_Line_Number (P)));
+ Write_Char (':');
+ Write_Int (Int (Get_Column_Number (P)));
+
+ if Instantiation (SI) /= No_Location then
+ Write_Str (" [");
+ Write_Location (Instantiation (SI));
+ Write_Char (']');
+ end if;
+ end;
+ end if;
+ end Write_Location;
+
+ ----------------------
+ -- Write_Time_Stamp --
+ ----------------------
+
+ procedure Write_Time_Stamp (S : Source_File_Index) is
+ T : constant Time_Stamp_Type := Time_Stamp (S);
+ P : Natural;
+
+ begin
+ if T (1) = '9' then
+ Write_Str ("19");
+ P := 0;
+ else
+ Write_Char (T (1));
+ Write_Char (T (2));
+ P := 2;
+ end if;
+
+ Write_Char (T (P + 1));
+ Write_Char (T (P + 2));
+ Write_Char ('-');
+
+ Write_Char (T (P + 3));
+ Write_Char (T (P + 4));
+ Write_Char ('-');
+
+ Write_Char (T (P + 5));
+ Write_Char (T (P + 6));
+ Write_Char (' ');
+
+ Write_Char (T (P + 7));
+ Write_Char (T (P + 8));
+ Write_Char (':');
+
+ Write_Char (T (P + 9));
+ Write_Char (T (P + 10));
+ Write_Char (':');
+
+ Write_Char (T (P + 11));
+ Write_Char (T (P + 12));
+ end Write_Time_Stamp;
+
+ ----------------------------------------------
+ -- Access Subprograms for Source File Table --
+ ----------------------------------------------
+
+ function Debug_Source_Name (S : SFI) return File_Name_Type is
+ begin
+ return Source_File.Table (S).Debug_Source_Name;
+ end Debug_Source_Name;
+
+ function File_Name (S : SFI) return File_Name_Type is
+ begin
+ return Source_File.Table (S).File_Name;
+ end File_Name;
+
+ function First_Mapped_Line (S : SFI) return Logical_Line_Number is
+ begin
+ return Source_File.Table (S).First_Mapped_Line;
+ end First_Mapped_Line;
+
+ function Full_File_Name (S : SFI) return File_Name_Type is
+ begin
+ return Source_File.Table (S).Full_File_Name;
+ end Full_File_Name;
+
+ function Full_Ref_Name (S : SFI) return File_Name_Type is
+ begin
+ return Source_File.Table (S).Full_Ref_Name;
+ end Full_Ref_Name;
+
+ function Identifier_Casing (S : SFI) return Casing_Type is
+ begin
+ return Source_File.Table (S).Identifier_Casing;
+ end Identifier_Casing;
+
+ function Instantiation (S : SFI) return Source_Ptr is
+ begin
+ return Source_File.Table (S).Instantiation;
+ end Instantiation;
+
+ function Keyword_Casing (S : SFI) return Casing_Type is
+ begin
+ return Source_File.Table (S).Keyword_Casing;
+ end Keyword_Casing;
+
+ function Last_Source_Line (S : SFI) return Physical_Line_Number is
+ begin
+ return Source_File.Table (S).Last_Source_Line;
+ end Last_Source_Line;
+
+ function License (S : SFI) return License_Type is
+ begin
+ return Source_File.Table (S).License;
+ end License;
+
+ function Num_SRef_Pragmas (S : SFI) return Nat is
+ begin
+ return Source_File.Table (S).Num_SRef_Pragmas;
+ end Num_SRef_Pragmas;
+
+ function Reference_Name (S : SFI) return File_Name_Type is
+ begin
+ return Source_File.Table (S).Reference_Name;
+ end Reference_Name;
+
+ function Source_Checksum (S : SFI) return Word is
+ begin
+ return Source_File.Table (S).Source_Checksum;
+ end Source_Checksum;
+
+ function Source_First (S : SFI) return Source_Ptr is
+ begin
+ return Source_File.Table (S).Source_First;
+ end Source_First;
+
+ function Source_Last (S : SFI) return Source_Ptr is
+ begin
+ return Source_File.Table (S).Source_Last;
+ end Source_Last;
+
+ function Source_Text (S : SFI) return Source_Buffer_Ptr is
+ begin
+ return Source_File.Table (S).Source_Text;
+ end Source_Text;
+
+ function Template (S : SFI) return SFI is
+ begin
+ return Source_File.Table (S).Template;
+ end Template;
+
+ function Time_Stamp (S : SFI) return Time_Stamp_Type is
+ begin
+ return Source_File.Table (S).Time_Stamp;
+ end Time_Stamp;
+
+ ------------------------------------------
+ -- Set Procedures for Source File Table --
+ ------------------------------------------
+
+ procedure Set_Identifier_Casing (S : SFI; C : Casing_Type) is
+ begin
+ Source_File.Table (S).Identifier_Casing := C;
+ end Set_Identifier_Casing;
+
+ procedure Set_Keyword_Casing (S : SFI; C : Casing_Type) is
+ begin
+ Source_File.Table (S).Keyword_Casing := C;
+ end Set_Keyword_Casing;
+
+ procedure Set_License (S : SFI; L : License_Type) is
+ begin
+ Source_File.Table (S).License := L;
+ end Set_License;
+
+ --------
+ -- wl --
+ --------
+
+ procedure wl (P : Source_Ptr) is
+ begin
+ Write_Location (P);
+ Write_Eol;
+ end wl;
+
+end Sinput;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S I N P U T --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.69 $
+-- --
+-- 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 other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception 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 package contains the input routines used for reading the
+-- input source file. The actual I/O routines are in OS_Interface,
+-- with this module containing only the system independent processing.
+
+-- General Note: throughout the compiler, we use the term line or source
+-- line to refer to a physical line in the source, terminated by the end of
+-- physical line sequence. See Skip_Line_Terminators procedure for a full
+-- description of the difference between logical and physical lines.
+
+with Alloc;
+with Casing; use Casing;
+with Table;
+with Types; use Types;
+
+package Sinput is
+
+ ----------------------------
+ -- Source License Control --
+ ----------------------------
+
+ -- The following type indicates the license state of a source if it
+ -- is known.
+
+ type License_Type is
+ (Unknown,
+ -- Licensing status of this source unit is unknown
+
+ Restricted,
+ -- This is a non-GPL'ed unit that is restricted from depending
+ -- on GPL'ed units (e.g. proprietary code is in this category)
+
+ GPL,
+ -- This file is licensed under the unmodified GPL. It is not allowed
+ -- to depend on Non_GPL units, and Non_GPL units may not depend on
+ -- this source unit.
+
+ Modified_GPL,
+ -- This file is licensed under the GNAT modified GPL (see header of
+ -- This file for wording of the modification). It may depend on other
+ -- Modified_GPL units or on unrestricted units.
+
+ Unrestricted);
+ -- The license on this file is permitted to depend on any other
+ -- units, or have other units depend on it, without violating the
+ -- license of this unit. Examples are public domain units, and
+ -- units defined in the RM).
+
+ -- The above license status is checked when the appropriate check is
+ -- activated and one source depends on another, and the licensing state
+ -- of both files is known:
+
+ -- The prohibited combinations are:
+
+ -- Restricted file may not depend on GPL file
+
+ -- GPL file may not depend on Restricted file
+
+ -- Modified GPL file may not depend on Restricted file
+ -- Modified_GPL file may not depend on GPL file
+
+ -- The reason for the last restriction here is that a client depending
+ -- on a modified GPL file must be sure that the license condition is
+ -- correct considered transitively.
+
+ -- The licensing status is determined either by the presence of a
+ -- specific pragma License, or by scanning the header for a predefined
+ -- file, or any file if compiling in -gnatg mode.
+
+ -----------------------
+ -- Source File Table --
+ -----------------------
+
+ -- The source file table has an entry for each source file read in for
+ -- this run of the compiler. This table is (default) initialized when
+ -- the compiler is loaded, and simply accumulates entries as compilation
+ -- proceeds and the Sinput.L.Load_Source_File procedure is called to load
+ -- required source files.
+
+ -- Virtual entries are also created for generic templates when they are
+ -- instantiated, as described in a separate section later on.
+
+ -- In the case where there are multiple main units (e.g. in the case of
+ -- the cross-reference tool), this table is not reset between these units,
+ -- so that a given source file is only read once if it is used by two
+ -- separate main units.
+
+ -- The entries in the table are accessed using a Source_File_Index that
+ -- ranges from 1 to Last_Source_File. Each entry has the following fields
+
+ -- Note that entry 1 is always for system.ads (see Targparm for details
+ -- of why we always read this source file first), and we have defined a
+ -- constant Types.System_Source_File_Index as 1 to reflect this fact.
+
+ -- File_Name : File_Name_Type
+ -- Name of the source file (simple name with no directory information).
+ -- Set by Sinput.L.Load_Source_File and cannot be subequently changed.
+
+ -- Full_File_Name : File_Name_Type
+ -- Full file name (full name with directory info), used for generation
+ -- of error messages, etc. Set by Sinput.L.Load_Source_File and cannot
+ -- be subsequently changed.
+
+ -- Reference_Name : File_Name_Type
+ -- Name to be used for source file references in error messages where
+ -- only the simple name of the file is required. Identical to File_Name
+ -- unless pragma Source_Reference is used to change it. Only processing
+ -- for the Source_Reference pragma circuit may set this field.
+
+ -- Full_Ref_Name : File_Name_Type
+ -- Name to be used for source file references in error messages where
+ -- the full name of the file is required. Identical to Full_File_Name
+ -- unless pragma Source_Reference is used to change it. Only processing
+ -- for the Source_Reference pragma may set this field.
+
+ -- Debug_Source_Name : File_Name_Type
+ -- Name to be used for source file references in debugging information
+ -- where only the simple name of the file is required. Identical to
+ -- Full_Ref_Name unless the -gnatD (debug source file) switch is used.
+ -- Only processing in Sprint that generates this file is permitted to
+ -- set this field.
+
+ -- License : License_Type;
+ -- License status of source file
+
+ -- Num_SRef_Pragmas : Nat;
+ -- Number of source reference pragmas present in source file
+
+ -- First_Mapped_Line : Logical_Line_Number;
+ -- This field stores logical line number of the first line in the
+ -- file that is not a Source_Reference pragma. If no source reference
+ -- pragmas are used, then the value is set to No_Line_Number.
+
+ -- Source_Text : Source_Buffer_Ptr
+ -- Text of source file. Note that every source file has a distinct set
+ -- of non-overlapping logical bounds, so it is possible to determine
+ -- which file is referenced from a given subscript (Source_Ptr) value.
+ -- Set by Sinput.L.Load_Source_File and cannot be subsequently changed.
+
+ -- Source_First : Source_Ptr;
+ -- Subscript of first character in Source_Text. Note that this cannot
+ -- be obtained as Source_Text'First, because we use virtual origin
+ -- addressing. Set by Sinput.L procedures when the entry is first
+ -- created and never subsequently changed.
+
+ -- Source_Last : Source_Ptr;
+ -- Subscript of last character in Source_Text. Note that this cannot
+ -- be obtained as Source_Text'Last, because we use virtual origin
+ -- addressing, so this value is always Source_Ptr'Last. Set by
+ -- Sinput.L procedures when the entry is first created and never
+ -- subsequently changed.
+
+ -- Time_Stamp : Time_Stamp_Type;
+ -- Time stamp of the source file. Set by Sinput.L.Load_Source_File,
+ -- and cannot be subsequently changed.
+
+ -- Source_Checksum : Word;
+ -- Computed checksum for contents of source file. See separate section
+ -- later on in this spec for a description of the checksum algorithm.
+
+ -- Last_Source_Line : Physical_Line_Number;
+ -- Physical line number of last source line. Whlie a file is being
+ -- read, this refers to the last line scanned. Once a file has been
+ -- completely scanned, it is the number of the last line in the file,
+ -- and hence also gives the number of source lines in the file.
+
+ -- Keyword_Casing : Casing_Type;
+ -- Casing style used in file for keyword casing. This is initialized
+ -- to Unknown, and then set from the first occurrence of a keyword.
+ -- This value is used only for formatting of error messages.
+
+ -- Identifier_Casing : Casing_Type;
+ -- Casing style used in file for identifier casing. This is initialized
+ -- to Unknown, and then set from an identifier in the program as soon as
+ -- one is found whose casing is sufficiently clear to make a decision.
+ -- This value is used for formatting of error messages, and also is used
+ -- in the detection of keywords misused as identifiers.
+
+ -- Instantiation : Source_Ptr;
+ -- Source file location of the instantiation if this source file entry
+ -- represents a generic instantiation. Set to No_Location for the case
+ -- of a normal non-instantiation entry. See section below for details.
+ -- This field is read-only for clients.
+
+ -- Template : Source_File_Index;
+ -- Source file index of the source file containing the template if this
+ -- is a generic instantiation. Set to No_Source_File for the normal case
+ -- of a non-instantiation entry. See Sinput-L for details. This field is
+ -- read-only for clients.
+
+ -- The source file table is accessed by clients using the following
+ -- subprogram interface:
+
+ subtype SFI is Source_File_Index;
+
+ function Debug_Source_Name (S : SFI) return File_Name_Type;
+ function File_Name (S : SFI) return File_Name_Type;
+ function First_Mapped_Line (S : SFI) return Logical_Line_Number;
+ function Full_File_Name (S : SFI) return File_Name_Type;
+ function Full_Ref_Name (S : SFI) return File_Name_Type;
+ function Identifier_Casing (S : SFI) return Casing_Type;
+ function Instantiation (S : SFI) return Source_Ptr;
+ function Keyword_Casing (S : SFI) return Casing_Type;
+ function Last_Source_Line (S : SFI) return Physical_Line_Number;
+ function License (S : SFI) return License_Type;
+ function Num_SRef_Pragmas (S : SFI) return Nat;
+ function Reference_Name (S : SFI) return File_Name_Type;
+ function Source_Checksum (S : SFI) return Word;
+ function Source_First (S : SFI) return Source_Ptr;
+ function Source_Last (S : SFI) return Source_Ptr;
+ function Source_Text (S : SFI) return Source_Buffer_Ptr;
+ function Template (S : SFI) return Source_File_Index;
+ function Time_Stamp (S : SFI) return Time_Stamp_Type;
+
+ procedure Set_Keyword_Casing (S : SFI; C : Casing_Type);
+ procedure Set_Identifier_Casing (S : SFI; C : Casing_Type);
+ procedure Set_License (S : SFI; L : License_Type);
+
+ function Last_Source_File return Source_File_Index;
+ -- Index of last source file table entry
+
+ function Num_Source_Files return Nat;
+ -- Number of source file table entries
+
+ procedure Initialize;
+ -- Initialize internal tables
+
+ procedure Lock;
+ -- Lock internal tables
+
+ Main_Source_File : Source_File_Index;
+ -- This is set to the source file index of the main unit
+
+ -----------------------
+ -- Checksum Handling --
+ -----------------------
+
+ -- As a source file is scanned, a checksum is computed by taking all the
+ -- non-blank characters in the file, excluding comment characters, the
+ -- minus-minus sequence starting a comment, and all control characters
+ -- except ESC.
+
+ -- These characters are used to compute a 31-bit checksum which is stored
+ -- in the variable Scans.Checksum, as follows:
+
+ -- If a character, C, is not part of a wide character sequence, then
+ -- either the character itself, or its lower case equivalent if it
+ -- is a letter outside a string literal is used in the computation:
+
+ -- Checksum := Checksum + Checksum + Character'Pos (C);
+ -- if Checksum > 16#8000_0000# then
+ -- Checksum := (Checksum + 1) and 16#7FFF_FFFF#;
+ -- end if;
+
+ -- For a wide character sequence, the checksum is computed using the
+ -- corresponding character code value C, as follows:
+
+ -- Checksum := Checksum + Checksum + Char_Code'Pos (C);
+ -- if Checksum > 16#8000_0000# then
+ -- Checksum := (Checksum + 1) and 16#7FFF_FFFF#;
+ -- end if;
+
+ -- This algorithm ensures that the checksum includes all semantically
+ -- significant aspects of the program represented by the source file,
+ -- but is insensitive to layout, presence or contents of comments, wide
+ -- character representation method, or casing conventions outside strings.
+
+ -- Scans.Checksum is initialized to zero at the start of scanning a file,
+ -- and copied into the Source_Checksum field of the file table entry when
+ -- the end of file is encountered.
+
+ -------------------------------------
+ -- Handling Generic Instantiations --
+ -------------------------------------
+
+ -- As described in Sem_Ch12, a generic instantiation involves making a
+ -- copy of the tree of the generic template. The source locations in
+ -- this tree directly reference the source of the template. However it
+ -- is also possible to find the location of the instantiation.
+
+ -- This is achieved as follows. When an instantiation occurs, a new entry
+ -- is made in the source file table. This entry points to the same source
+ -- text, i.e. the file that contains the instantiation, but has a distinct
+ -- set of Source_Ptr index values. The separate range of Sloc values avoids
+ -- confusion, and means that the Sloc values can still be used to uniquely
+ -- identify the source file table entry. It is possible for both entries
+ -- to point to the same text, because of the virtual origin pointers used
+ -- in the source table.
+
+ -- The Instantiation field of this source file index entry, usually set
+ -- to No_Source_File, instead contains the Sloc of the instantiation. In
+ -- the case of nested instantiations, this Sloc may itself refer to an
+ -- instantiation, so the complete chain can be traced.
+
+ -- Two routines are used to build these special entries in the source
+ -- file table. Create_Instantiation_Source is first called to build
+ -- the virtual source table entry for the instantiation, and then the
+ -- Sloc values in the copy are adjusted using Adjust_Instantiation_Sloc.
+ -- See child unit Sinput.L for details on these two routines.
+
+ -----------------
+ -- Global Data --
+ -----------------
+
+ Current_Source_File : Source_File_Index;
+ -- Source_File table index of source file currently being scanned
+
+ Current_Source_Unit : Unit_Number_Type;
+ -- Unit number of source file currently being scanned. The special value
+ -- of No_Unit indicates that the configuration pragma file is currently
+ -- being scanned (this has no entry in the unit table).
+
+ Source_gnat_adc : Source_File_Index := No_Source_File;
+ -- This is set if a gnat.adc file is present to reference this file
+
+ Source : Source_Buffer_Ptr;
+ -- Current source (copy of Source_File.Table (Current_Source_Unit).Source)
+
+ Internal_Source : aliased Source_Buffer (1 .. 81);
+ -- This buffer is used internally in the compiler when the lexical analyzer
+ -- is used to scan a string from within the compiler. The procedure is to
+ -- establish Internal_Source_Ptr as the value of Source, set the string to
+ -- be scanned, appropriately terminated, in this buffer, and set Scan_Ptr
+ -- to point to the start of the buffer. It is a fatal error if the scanner
+ -- signals an error while scanning a token in this internal buffer.
+
+ Internal_Source_Ptr : constant Source_Buffer_Ptr :=
+ Internal_Source'Unrestricted_Access;
+ -- Pointer to internal source buffer
+
+ -----------------
+ -- Subprograms --
+ -----------------
+
+ procedure Backup_Line (P : in out Source_Ptr);
+ -- Back up the argument pointer to the start of the previous line. On
+ -- entry, P points to the start of a physical line in the source buffer.
+ -- On return, P is updated to point to the start of the previous line.
+ -- The caller has checked that a Line_Terminator character precedes P so
+ -- that there definitely is a previous line in the source buffer.
+
+ procedure Build_Location_String (Loc : Source_Ptr);
+ -- This function builds a string literal of the form "name:line",
+ -- where name is the file name corresponding to Loc, and line is
+ -- the line number. In the event that instantiations are involved,
+ -- additional suffixes of the same form are appended after the
+ -- separating string " instantiated at ". The returned string is
+ -- stored in Name_Buffer, terminated by ASCII.Nul, with Name_Length
+ -- indicating the length not including the terminating Nul.
+
+ function Get_Column_Number (P : Source_Ptr) return Column_Number;
+ -- The ones-origin column number of the specified Source_Ptr value is
+ -- determined and returned. Tab characters if present are assumed to
+ -- represent the standard 1,9,17.. spacing pattern.
+
+ function Get_Logical_Line_Number
+ (P : Source_Ptr)
+ return Logical_Line_Number;
+ -- The line number of the specified source position is obtained by
+ -- doing a binary search on the source positions in the lines table
+ -- for the unit containing the given source position. The returned
+ -- value is the logical line number, already adjusted for the effect
+ -- of source reference pragmas. If P refers to the line of a source
+ -- reference pragma itself, then No_Line is returned. If no source
+ -- reference pragmas have been encountered, the value returned is
+ -- the same as the physical line number.
+
+ function Get_Physical_Line_Number
+ (P : Source_Ptr)
+ return Physical_Line_Number;
+ -- The line number of the specified source position is obtained by
+ -- doing a binary search on the source positions in the lines table
+ -- for the unit containing the given source position. The returned
+ -- value is the physical line number in the source being compiled.
+
+ function Get_Source_File_Index (S : Source_Ptr) return Source_File_Index;
+ -- Return file table index of file identified by given source pointer
+ -- value. This call must always succeed, since any valid source pointer
+ -- value belongs to some previously loaded source file.
+
+ function Instantiation_Depth (S : Source_Ptr) return Nat;
+ -- Determine instantiation depth for given Sloc value. A value of
+ -- zero means that the given Sloc is not in an instantiation.
+
+ function Line_Start (P : Source_Ptr) return Source_Ptr;
+ -- Finds the source position of the start of the line containing the
+ -- given source location.
+
+ function Line_Start
+ (L : Physical_Line_Number;
+ S : Source_File_Index)
+ return Source_Ptr;
+ -- Finds the source position of the start of the given line in the
+ -- given source file, using a physical line number to identify the line.
+
+ function Num_Source_Lines (S : Source_File_Index) return Nat;
+ -- Returns the number of source lines (this is equivalent to reading
+ -- the value of Last_Source_Line, but returns Nat rathern than a
+ -- physical line number.
+
+ procedure Register_Source_Ref_Pragma
+ (File_Name : Name_Id;
+ Stripped_File_Name : Name_Id;
+ Mapped_Line : Nat;
+ Line_After_Pragma : Physical_Line_Number);
+ -- Register a source reference pragma, the parameter File_Name is the
+ -- file name from the pragma, and Stripped_File_Name is this name with
+ -- the directory information stripped. Both these parameters are set
+ -- to No_Name if no file name parameter was given in the pragma.
+ -- (which can only happen for the second and subsequent pragmas).
+ -- Mapped_Line is the line number parameter from the pragma, and
+ -- Line_After_Pragma is the physical line number of the line that
+ -- follows the line containing the Source_Reference pragma.
+
+ function Original_Location (S : Source_Ptr) return Source_Ptr;
+ -- Given a source pointer S, returns the corresponding source pointer
+ -- value ignoring instantiation copies. For locations that do not
+ -- correspond to instantiation copies of templates, the argument is
+ -- returned unchanged. For locations that do correspond to copies of
+ -- templates from instantiations, the location within the original
+ -- template is returned. This is useful in canonicalizing locations.
+
+ function Instantiation_Location (S : Source_Ptr) return Source_Ptr;
+ pragma Inline (Instantiation_Location);
+ -- Given a source pointer S, returns the corresponding source pointer
+ -- value of the instantiation if this location is within an instance.
+ -- If S is not within an instance, then this returns No_Location.
+
+ function Top_Level_Location (S : Source_Ptr) return Source_Ptr;
+ -- Given a source pointer S, returns the argument unchanged if it is
+ -- not in an instantiation. If S is in an instantiation, then it returns
+ -- the location of the top level instantiation, i.e. the outer level
+ -- instantiation in the nested case.
+
+ function Physical_To_Logical
+ (Line : Physical_Line_Number;
+ S : Source_File_Index)
+ return Logical_Line_Number;
+ -- Given a physical line number in source file whose source index is S,
+ -- return the corresponding logical line number. If the physical line
+ -- number is one containing a Source_Reference pragma, the result will
+ -- be No_Line_Number.
+
+ procedure Skip_Line_Terminators
+ (P : in out Source_Ptr;
+ Physical : out Boolean);
+ -- On entry, Source (P) points to the line terminator character that
+ -- terminates a line. The result set in P is the location of the first
+ -- character of the following line (after skipping the sequence of line
+ -- terminator characters terminating the current line). In addition, if
+ -- the terminator sequence ends a physical line (the definition of what
+ -- constitutes a physical line is embodied in the implementation of this
+ -- function), and it is the first time this sequence is encountered, then
+ -- an entry is made in the lines table to record the location for further
+ -- use by functions such as Get_Line_Number. Physical is set to True if
+ -- the line terminator was the end of a physical line.
+
+ function Source_Offset (S : Source_Ptr) return Nat;
+ -- Returns the zero-origin offset of the given source location from the
+ -- start of its corresponding unit. This is used for creating canonical
+ -- names in some situations.
+
+ procedure Write_Location (P : Source_Ptr);
+ -- Writes out a string of the form fff:nn:cc, where fff, nn, cc are the
+ -- file name, line number and column corresponding to the given source
+ -- location. No_Location and Standard_Location appear as the strings
+ -- <no location> and <standard location>. If the location is within an
+ -- instantiation, then the instance location is appended, enclosed in
+ -- square brackets (which can nest if necessary). Note that this routine
+ -- is used only for internal compiler debugging output purposes (which
+ -- is why the somewhat cryptic use of brackets is acceptable).
+
+ procedure wl (P : Source_Ptr);
+ -- Equivalent to Write_Location (P); Write_Eol; for calls from GDB
+
+ procedure Write_Time_Stamp (S : Source_File_Index);
+ -- Writes time stamp of specified file in YY-MM-DD HH:MM.SS format
+
+ procedure Tree_Write;
+ -- Writes out internal tables to current tree file using Tree_Write
+
+ procedure Tree_Read;
+ -- Initializes internal tables from current tree file using Tree_Read
+
+private
+ pragma Inline (File_Name);
+ pragma Inline (First_Mapped_Line);
+ pragma Inline (Full_File_Name);
+ pragma Inline (Identifier_Casing);
+ pragma Inline (Instantiation);
+ pragma Inline (Keyword_Casing);
+ pragma Inline (Last_Source_Line);
+ pragma Inline (Last_Source_File);
+ pragma Inline (License);
+ pragma Inline (Num_SRef_Pragmas);
+ pragma Inline (Num_Source_Files);
+ pragma Inline (Num_Source_Lines);
+ pragma Inline (Reference_Name);
+ pragma Inline (Set_Keyword_Casing);
+ pragma Inline (Set_Identifier_Casing);
+ pragma Inline (Source_First);
+ pragma Inline (Source_Last);
+ pragma Inline (Source_Text);
+ pragma Inline (Template);
+ pragma Inline (Time_Stamp);
+
+ -------------------------
+ -- Source_Lines Tables --
+ -------------------------
+
+ type Lines_Table_Type is
+ array (Physical_Line_Number) of Source_Ptr;
+ -- Type used for lines table. The entries are indexed by physical line
+ -- numbers. The values are the starting Source_Ptr values for the start
+ -- of the corresponding physical line. Note that we make this a bogus
+ -- big array, sized as required, so that we avoid the use of fat pointers.
+
+ type Lines_Table_Ptr is access all Lines_Table_Type;
+ -- Type used for pointers to line tables
+
+ type Logical_Lines_Table_Type is
+ array (Physical_Line_Number) of Logical_Line_Number;
+ -- Type used for logical lines table. This table is used if a source
+ -- reference pragma is present. It is indexed by physical line numbers,
+ -- and contains the corresponding logical line numbers. An entry that
+ -- corresponds to a source reference pragma is set to No_Line_Number.
+ -- Note that we make this a bogus big array, sized as required, so that
+ -- we avoid the use of fat pointers.
+
+ type Logical_Lines_Table_Ptr is access all Logical_Lines_Table_Type;
+ -- Type used for pointers to logical line tables.
+
+ -----------------------
+ -- Source_File Table --
+ -----------------------
+
+ -- See earlier descriptions for meanings of public fields
+
+ type Source_File_Record is record
+
+ File_Name : File_Name_Type;
+ Reference_Name : File_Name_Type;
+ Debug_Source_Name : File_Name_Type;
+ Full_File_Name : File_Name_Type;
+ Full_Ref_Name : File_Name_Type;
+ License : License_Type;
+ Num_SRef_Pragmas : Nat;
+ First_Mapped_Line : Logical_Line_Number;
+ Source_Text : Source_Buffer_Ptr;
+ Source_First : Source_Ptr;
+ Source_Last : Source_Ptr;
+ Time_Stamp : Time_Stamp_Type;
+ Source_Checksum : Word;
+ Last_Source_Line : Physical_Line_Number;
+ Keyword_Casing : Casing_Type;
+ Identifier_Casing : Casing_Type;
+ Instantiation : Source_Ptr;
+ Template : Source_File_Index;
+
+ -- The following fields are for internal use only (i.e. only in the
+ -- body of Sinput or its children, with no direct access by clients).
+
+ Sloc_Adjust : Source_Ptr;
+ -- A value to be added to Sloc values for this file to reference the
+ -- corresponding lines table. This is zero for the non-instantiation
+ -- case, and set so that the adition references the ultimate template
+ -- for the instantiation case. See Sinput-L for further details.
+
+ Lines_Table : Lines_Table_Ptr;
+ -- Pointer to lines table for this source. Updated as additional
+ -- lines are accessed using the Skip_Line_Terminators procedure.
+ -- Note: the lines table for an instantiation entry refers to the
+ -- original line numbers of the template see Sinput-L for details.
+
+ Logical_Lines_Table : Logical_Lines_Table_Ptr;
+ -- Pointer to logical lines table for this source. Non-null only if
+ -- a source reference pragma has been processed. Updated as lines
+ -- are accessed using the Skip_Line_Terminators procedure.
+
+ Lines_Table_Max : Physical_Line_Number;
+ -- Maximum subscript values for currently allocated Lines_Table
+ -- and (if present) the allocated Logical_Lines_Table. The value
+ -- Max_Source_Line gives the maximum used value, this gives the
+ -- maximum allocated value.
+
+ end record;
+
+ package Source_File is new Table.Table (
+ Table_Component_Type => Source_File_Record,
+ Table_Index_Type => Source_File_Index,
+ Table_Low_Bound => 1,
+ Table_Initial => Alloc.Source_File_Initial,
+ Table_Increment => Alloc.Source_File_Increment,
+ Table_Name => "Source_File");
+
+ -----------------
+ -- Subprograms --
+ -----------------
+
+ procedure Alloc_Line_Tables
+ (S : in out Source_File_Record;
+ New_Max : Nat);
+ -- Allocate or reallocate the lines table for the given source file so
+ -- that it can accomodate at least New_Max lines. Also allocates or
+ -- reallocates logical lines table if source ref pragmas are present.
+
+ procedure Add_Line_Tables_Entry
+ (S : in out Source_File_Record;
+ P : Source_Ptr);
+ -- Increment line table size by one (reallocating the lines table if
+ -- needed) and set the new entry to contain the value P. Also bumps
+ -- the Source_Line_Count field. If source reference pragmas are
+ -- present, also increments logical lines table size by one, and
+ -- sets new entry.
+
+end Sinput;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S N A M E S --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.205 $ --
+-- --
+-- 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 other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception 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). --
+-- --
+------------------------------------------------------------------------------
+
+with Namet; use Namet;
+
+package body Snames is
+
+ -- Table of names to be set by Initialize. Each name is terminated by a
+ -- single #, and the end of the list is marked by a null entry, i.e. by
+ -- two # marks in succession. Note that the table does not include the
+ -- entries for a-z, since these are initialized by Namet itself.
+
+ Preset_Names : constant String :=
+ "_parent#" &
+ "_tag#" &
+ "off#" &
+ "space#" &
+ "time#" &
+ "_init_proc#" &
+ "_size#" &
+ "_abort_signal#" &
+ "_address_resolver#" &
+ "_assign#" &
+ "_chain#" &
+ "_clean#" &
+ "_controller#" &
+ "_entry_bodies#" &
+ "_expunge#" &
+ "_final_list#" &
+ "_idepth#" &
+ "_init#" &
+ "_local_final_list#" &
+ "_master#" &
+ "_object#" &
+ "_priority#" &
+ "_service#" &
+ "_tags#" &
+ "_task#" &
+ "_task_id#" &
+ "_task_info#" &
+ "_task_name#" &
+ "_trace_sp#" &
+ "initialize#" &
+ "adjust#" &
+ "finalize#" &
+ "next#" &
+ "prev#" &
+ "_deep_adjust#" &
+ "_equality#" &
+ "_deep_finalize#" &
+ "_deep_initialize#" &
+ "_input#" &
+ "_output#" &
+ "_ras_access#" &
+ "_ras_dereference#" &
+ "_read#" &
+ "_rep_to_pos#" &
+ "_write#" &
+ "allocate#" &
+ "deallocate#" &
+ "dereference#" &
+ "decimal_io#" &
+ "enumeration_io#" &
+ "fixed_io#" &
+ "float_io#" &
+ "integer_io#" &
+ "modular_io#" &
+ "a_textio#" &
+ "a_witeio#" &
+ "const#" &
+ "<error>#" &
+ "go#" &
+ "put#" &
+ "put_line#" &
+ "to#" &
+ "finalization#" &
+ "finalization_root#" &
+ "interfaces#" &
+ "standard#" &
+ "system#" &
+ "text_io#" &
+ "wide_text_io#" &
+ "addr#" &
+ "async#" &
+ "get_active_partition_id#" &
+ "get_rci_package_receiver#" &
+ "origin#" &
+ "params#" &
+ "partition#" &
+ "partition_interface#" &
+ "ras#" &
+ "rci_name#" &
+ "receiver#" &
+ "result#" &
+ "rpc#" &
+ "subp_id#" &
+ "Oabs#" &
+ "Oand#" &
+ "Omod#" &
+ "Onot#" &
+ "Oor#" &
+ "Orem#" &
+ "Oxor#" &
+ "Oeq#" &
+ "One#" &
+ "Olt#" &
+ "Ole#" &
+ "Ogt#" &
+ "Oge#" &
+ "Oadd#" &
+ "Osubtract#" &
+ "Oconcat#" &
+ "Omultiply#" &
+ "Odivide#" &
+ "Oexpon#" &
+ "ada_83#" &
+ "ada_95#" &
+ "c_pass_by_copy#" &
+ "component_alignment#" &
+ "discard_names#" &
+ "elaboration_checks#" &
+ "eliminate#" &
+ "extend_system#" &
+ "extensions_allowed#" &
+ "external_name_casing#" &
+ "float_representation#" &
+ "initialize_scalars#" &
+ "license#" &
+ "locking_policy#" &
+ "long_float#" &
+ "no_run_time#" &
+ "normalize_scalars#" &
+ "polling#" &
+ "propagate_exceptions#" &
+ "queuing_policy#" &
+ "ravenscar#" &
+ "restricted_run_time#" &
+ "restrictions#" &
+ "reviewable#" &
+ "source_file_name#" &
+ "style_checks#" &
+ "suppress#" &
+ "task_dispatching_policy#" &
+ "unsuppress#" &
+ "use_vads_size#" &
+ "warnings#" &
+ "validity_checks#" &
+ "abort_defer#" &
+ "all_calls_remote#" &
+ "annotate#" &
+ "assert#" &
+ "asynchronous#" &
+ "atomic#" &
+ "atomic_components#" &
+ "attach_handler#" &
+ "comment#" &
+ "common_object#" &
+ "complex_representation#" &
+ "controlled#" &
+ "convention#" &
+ "cpp_class#" &
+ "cpp_constructor#" &
+ "cpp_virtual#" &
+ "cpp_vtable#" &
+ "debug#" &
+ "elaborate#" &
+ "elaborate_all#" &
+ "elaborate_body#" &
+ "export#" &
+ "export_exception#" &
+ "export_function#" &
+ "export_object#" &
+ "export_procedure#" &
+ "export_valued_procedure#" &
+ "finalize_storage_only#" &
+ "ident#" &
+ "import#" &
+ "import_exception#" &
+ "import_function#" &
+ "import_object#" &
+ "import_procedure#" &
+ "import_valued_procedure#" &
+ "inline#" &
+ "inline_always#" &
+ "inline_generic#" &
+ "inspection_point#" &
+ "interface#" &
+ "interface_name#" &
+ "interrupt_handler#" &
+ "interrupt_priority#" &
+ "java_constructor#" &
+ "java_interface#" &
+ "link_with#" &
+ "linker_alias#" &
+ "linker_options#" &
+ "linker_section#" &
+ "list#" &
+ "machine_attribute#" &
+ "main#" &
+ "main_storage#" &
+ "memory_size#" &
+ "no_return#" &
+ "optimize#" &
+ "pack#" &
+ "page#" &
+ "passive#" &
+ "preelaborate#" &
+ "priority#" &
+ "psect_object#" &
+ "pure#" &
+ "pure_function#" &
+ "remote_call_interface#" &
+ "remote_types#" &
+ "share_generic#" &
+ "shared#" &
+ "shared_passive#" &
+ "source_reference#" &
+ "stream_convert#" &
+ "subtitle#" &
+ "suppress_all#" &
+ "suppress_debug_info#" &
+ "suppress_initialization#" &
+ "system_name#" &
+ "task_info#" &
+ "task_name#" &
+ "task_storage#" &
+ "time_slice#" &
+ "title#" &
+ "unchecked_union#" &
+ "unimplemented_unit#" &
+ "unreserve_all_interrupts#" &
+ "volatile#" &
+ "volatile_components#" &
+ "weak_external#" &
+ "ada#" &
+ "asm#" &
+ "assembler#" &
+ "cobol#" &
+ "cpp#" &
+ "dll#" &
+ "fortran#" &
+ "intrinsic#" &
+ "java#" &
+ "stdcall#" &
+ "stubbed#" &
+ "win32#" &
+ "as_is#" &
+ "body_file_name#" &
+ "casing#" &
+ "code#" &
+ "component#" &
+ "component_size_4#" &
+ "copy#" &
+ "d_float#" &
+ "descriptor#" &
+ "default#" &
+ "dot_replacement#" &
+ "dynamic#" &
+ "entity#" &
+ "external#" &
+ "external_name#" &
+ "first_optional_parameter#" &
+ "form#" &
+ "g_float#" &
+ "gcc#" &
+ "gnat#" &
+ "gpl#" &
+ "ieee_float#" &
+ "internal#" &
+ "link_name#" &
+ "lowercase#" &
+ "max_size#" &
+ "mechanism#" &
+ "mixedcase#" &
+ "modified_gpl#" &
+ "name#" &
+ "nca#" &
+ "no#" &
+ "on#" &
+ "parameter_types#" &
+ "reference#" &
+ "restricted#" &
+ "result_mechanism#" &
+ "result_type#" &
+ "sb#" &
+ "section#" &
+ "semaphore#" &
+ "spec_file_name#" &
+ "static#" &
+ "stack_size#" &
+ "subunit_file_name#" &
+ "task_stack_size_default#" &
+ "task_type#" &
+ "time_slicing_enabled#" &
+ "top_guard#" &
+ "uba#" &
+ "ubs#" &
+ "ubsb#" &
+ "unit_name#" &
+ "unknown#" &
+ "unrestricted#" &
+ "uppercase#" &
+ "vax_float#" &
+ "vms#" &
+ "working_storage#" &
+ "abort_signal#" &
+ "access#" &
+ "address#" &
+ "address_size#" &
+ "aft#" &
+ "alignment#" &
+ "asm_input#" &
+ "asm_output#" &
+ "ast_entry#" &
+ "bit#" &
+ "bit_order#" &
+ "bit_position#" &
+ "body_version#" &
+ "callable#" &
+ "caller#" &
+ "code_address#" &
+ "component_size#" &
+ "compose#" &
+ "constrained#" &
+ "count#" &
+ "default_bit_order#" &
+ "definite#" &
+ "delta#" &
+ "denorm#" &
+ "digits#" &
+ "elaborated#" &
+ "emax#" &
+ "enum_rep#" &
+ "epsilon#" &
+ "exponent#" &
+ "external_tag#" &
+ "first#" &
+ "first_bit#" &
+ "fixed_value#" &
+ "fore#" &
+ "has_discriminants#" &
+ "identity#" &
+ "img#" &
+ "integer_value#" &
+ "large#" &
+ "last#" &
+ "last_bit#" &
+ "leading_part#" &
+ "length#" &
+ "machine_emax#" &
+ "machine_emin#" &
+ "machine_mantissa#" &
+ "machine_overflows#" &
+ "machine_radix#" &
+ "machine_rounds#" &
+ "machine_size#" &
+ "mantissa#" &
+ "max_interrupt_priority#" &
+ "max_priority#" &
+ "max_size_in_storage_elements#" &
+ "maximum_alignment#" &
+ "mechanism_code#" &
+ "model_emin#" &
+ "model_epsilon#" &
+ "model_mantissa#" &
+ "model_small#" &
+ "modulus#" &
+ "null_parameter#" &
+ "object_size#" &
+ "partition_id#" &
+ "passed_by_reference#" &
+ "pos#" &
+ "position#" &
+ "range#" &
+ "range_length#" &
+ "round#" &
+ "safe_emax#" &
+ "safe_first#" &
+ "safe_large#" &
+ "safe_last#" &
+ "safe_small#" &
+ "scale#" &
+ "scaling#" &
+ "signed_zeros#" &
+ "size#" &
+ "small#" &
+ "storage_size#" &
+ "storage_unit#" &
+ "tag#" &
+ "terminated#" &
+ "tick#" &
+ "to_address#" &
+ "type_class#" &
+ "uet_address#" &
+ "unbiased_rounding#" &
+ "unchecked_access#" &
+ "universal_literal_string#" &
+ "unrestricted_access#" &
+ "vads_size#" &
+ "val#" &
+ "valid#" &
+ "value_size#" &
+ "version#" &
+ "wchar_t_size#" &
+ "wide_width#" &
+ "width#" &
+ "word_size#" &
+ "adjacent#" &
+ "ceiling#" &
+ "copy_sign#" &
+ "floor#" &
+ "fraction#" &
+ "image#" &
+ "input#" &
+ "machine#" &
+ "max#" &
+ "min#" &
+ "model#" &
+ "pred#" &
+ "remainder#" &
+ "rounding#" &
+ "succ#" &
+ "truncation#" &
+ "value#" &
+ "wide_image#" &
+ "wide_value#" &
+ "output#" &
+ "read#" &
+ "write#" &
+ "elab_body#" &
+ "elab_spec#" &
+ "storage_pool#" &
+ "base#" &
+ "class#" &
+ "ceiling_locking#" &
+ "inheritance_locking#" &
+ "fifo_queuing#" &
+ "priority_queuing#" &
+ "fifo_within_priorities#" &
+ "access_check#" &
+ "accessibility_check#" &
+ "discriminant_check#" &
+ "division_check#" &
+ "elaboration_check#" &
+ "index_check#" &
+ "length_check#" &
+ "overflow_check#" &
+ "range_check#" &
+ "storage_check#" &
+ "tag_check#" &
+ "all_checks#" &
+ "abort#" &
+ "abs#" &
+ "accept#" &
+ "and#" &
+ "all#" &
+ "array#" &
+ "at#" &
+ "begin#" &
+ "body#" &
+ "case#" &
+ "constant#" &
+ "declare#" &
+ "delay#" &
+ "do#" &
+ "else#" &
+ "elsif#" &
+ "end#" &
+ "entry#" &
+ "exception#" &
+ "exit#" &
+ "for#" &
+ "function#" &
+ "generic#" &
+ "goto#" &
+ "if#" &
+ "in#" &
+ "is#" &
+ "limited#" &
+ "loop#" &
+ "mod#" &
+ "new#" &
+ "not#" &
+ "null#" &
+ "of#" &
+ "or#" &
+ "others#" &
+ "out#" &
+ "package#" &
+ "pragma#" &
+ "private#" &
+ "procedure#" &
+ "raise#" &
+ "record#" &
+ "rem#" &
+ "renames#" &
+ "return#" &
+ "reverse#" &
+ "select#" &
+ "separate#" &
+ "subtype#" &
+ "task#" &
+ "terminate#" &
+ "then#" &
+ "type#" &
+ "use#" &
+ "when#" &
+ "while#" &
+ "with#" &
+ "xor#" &
+ "divide#" &
+ "enclosing_entity#" &
+ "exception_information#" &
+ "exception_message#" &
+ "exception_name#" &
+ "file#" &
+ "import_address#" &
+ "import_largest_value#" &
+ "import_value#" &
+ "is_negative#" &
+ "line#" &
+ "rotate_left#" &
+ "rotate_right#" &
+ "shift_left#" &
+ "shift_right#" &
+ "shift_right_arithmetic#" &
+ "source_location#" &
+ "unchecked_conversion#" &
+ "unchecked_deallocation#" &
+ "abstract#" &
+ "aliased#" &
+ "protected#" &
+ "until#" &
+ "requeue#" &
+ "tagged#" &
+ "raise_exception#" &
+ "project#" &
+ "modifying#" &
+ "naming#" &
+ "object_dir#" &
+ "source_dirs#" &
+ "specification#" &
+ "body_part#" &
+ "specification_append#" &
+ "body_append#" &
+ "separate_append#" &
+ "source_files#" &
+ "source_list_file#" &
+ "switches#" &
+ "library_dir#" &
+ "library_name#" &
+ "library_kind#" &
+ "library_version#" &
+ "library_elaboration#" &
+ "gnatmake#" &
+ "gnatls#" &
+ "gnatxref#" &
+ "gnatfind#" &
+ "gnatbind#" &
+ "gnatlink#" &
+ "compiler#" &
+ "binder#" &
+ "linker#" &
+ "#";
+
+ ---------------------
+ -- Generated Names --
+ ---------------------
+
+ -- This section lists the various cases of generated names which are
+ -- built from existing names by adding unique leading and/or trailing
+ -- upper case letters. In some cases these names are built recursively,
+ -- in particular names built from types may be built from types which
+ -- themselves have generated names. In this list, xxx represents an
+ -- existing name to which identifying letters are prepended or appended,
+ -- and a trailing n represents a serial number in an external name that
+ -- has some semantic significance (e.g. the n'th index type of an array).
+
+ -- xxxA access type for formal xxx in entry param record (Exp_Ch9)
+ -- xxxB tag table for tagged type xxx (Exp_Ch3)
+ -- xxxB task body procedure for task xxx (Exp_Ch9)
+ -- xxxD dispatch table for tagged type xxx (Exp_Ch3)
+ -- xxxD discriminal for discriminant xxx (Sem_Ch3)
+ -- xxxDn n'th discr check function for rec type xxx (Exp_Ch3)
+ -- xxxE elaboration boolean flag for task xxx (Exp_Ch9)
+ -- xxxE dispatch table pointer type for tagged type xxx (Exp_Ch3)
+ -- xxxE parameters for accept body for entry xxx (Exp_Ch9)
+ -- xxxFn n'th primitive of a tagged type (named xxx) (Exp_Ch3)
+ -- xxxI initialization procedure for type xxx (Exp_Ch3)
+ -- xxxJ tag table type index for tagged type xxx (Exp_Ch3)
+ -- xxxM master Id value for access type xxx (Exp_Ch3)
+ -- xxxP tag table pointer type for tagged type xxx (Exp_Ch3)
+ -- xxxP parameter record type for entry xxx (Exp_Ch9)
+ -- xxxPA access to parameter record type for entry xxx (Exp_Ch9)
+ -- xxxPn pointer type for n'th primitive of tagged type xxx (Exp_Ch3)
+ -- xxxR dispatch table pointer for tagged type xxx (Exp_Ch3)
+ -- xxxT tag table type for tagged type xxx (Exp_Ch3)
+ -- xxxT literal table for enumeration type xxx (Sem_Ch3)
+ -- xxxV type for task value record for task xxx (Exp_Ch9)
+ -- xxxX entry index constant (Exp_Ch9)
+ -- xxxY dispatch table type for tagged type xxx (Exp_Ch3)
+ -- xxxZ size variable for task xxx (Exp_Ch9)
+
+ -- Implicit type names
+
+ -- TxxxT type of literal table for enumeration type xxx (Sem_Ch3)
+
+ -- (list not yet complete ???)
+
+ ----------------------
+ -- Get_Attribute_Id --
+ ----------------------
+
+ function Get_Attribute_Id (N : Name_Id) return Attribute_Id is
+ begin
+ return Attribute_Id'Val (N - First_Attribute_Name);
+ end Get_Attribute_Id;
+
+ ------------------
+ -- Get_Check_Id --
+ ------------------
+
+ function Get_Check_Id (N : Name_Id) return Check_Id is
+ begin
+ return Check_Id'Val (N - First_Check_Name);
+ end Get_Check_Id;
+
+ -----------------------
+ -- Get_Convention_Id --
+ -----------------------
+
+ function Get_Convention_Id (N : Name_Id) return Convention_Id is
+ begin
+ case N is
+ when Name_Ada => return Convention_Ada;
+ when Name_Asm => return Convention_Assembler;
+ when Name_Assembler => return Convention_Assembler;
+ when Name_C => return Convention_C;
+ when Name_COBOL => return Convention_COBOL;
+ when Name_CPP => return Convention_CPP;
+ when Name_DLL => return Convention_Stdcall;
+ when Name_Fortran => return Convention_Fortran;
+ when Name_Intrinsic => return Convention_Intrinsic;
+ when Name_Java => return Convention_Java;
+ when Name_Stdcall => return Convention_Stdcall;
+ when Name_Stubbed => return Convention_Stubbed;
+ when Name_Win32 => return Convention_Stdcall;
+ when others =>
+ raise Program_Error;
+ end case;
+ end Get_Convention_Id;
+
+ ---------------------------
+ -- Get_Locking_Policy_Id --
+ ---------------------------
+
+ function Get_Locking_Policy_Id (N : Name_Id) return Locking_Policy_Id is
+ begin
+ return Locking_Policy_Id'Val (N - First_Locking_Policy_Name);
+ end Get_Locking_Policy_Id;
+
+ -------------------
+ -- Get_Pragma_Id --
+ -------------------
+
+ function Get_Pragma_Id (N : Name_Id) return Pragma_Id is
+ begin
+ if N = Name_AST_Entry then
+ return Pragma_AST_Entry;
+ elsif N = Name_Storage_Size then
+ return Pragma_Storage_Size;
+ elsif N = Name_Storage_Unit then
+ return Pragma_Storage_Unit;
+ else
+ return Pragma_Id'Val (N - First_Pragma_Name);
+ end if;
+ end Get_Pragma_Id;
+
+ ---------------------------
+ -- Get_Queuing_Policy_Id --
+ ---------------------------
+
+ function Get_Queuing_Policy_Id (N : Name_Id) return Queuing_Policy_Id is
+ begin
+ return Queuing_Policy_Id'Val (N - First_Queuing_Policy_Name);
+ end Get_Queuing_Policy_Id;
+
+ ------------------------------------
+ -- Get_Task_Dispatching_Policy_Id --
+ ------------------------------------
+
+ function Get_Task_Dispatching_Policy_Id (N : Name_Id)
+ return Task_Dispatching_Policy_Id is
+ begin
+ return Task_Dispatching_Policy_Id'Val
+ (N - First_Task_Dispatching_Policy_Name);
+ end Get_Task_Dispatching_Policy_Id;
+
+ ----------------
+ -- Initialize --
+ ----------------
+
+ procedure Initialize is
+ P_Index : Natural;
+ Discard_Name : Name_Id;
+
+ begin
+ P_Index := Preset_Names'First;
+
+ loop
+ Name_Len := 0;
+
+ while Preset_Names (P_Index) /= '#' loop
+ Name_Len := Name_Len + 1;
+ Name_Buffer (Name_Len) := Preset_Names (P_Index);
+ P_Index := P_Index + 1;
+ end loop;
+
+ -- We do the Name_Find call to enter the name into the table, but
+ -- we don't need to do anything with the result, since we already
+ -- initialized all the preset names to have the right value (we
+ -- are depending on the order of the names and Preset_Names).
+
+ Discard_Name := Name_Find;
+ P_Index := P_Index + 1;
+ exit when Preset_Names (P_Index) = '#';
+ end loop;
+
+ -- Make sure that number of names in standard table is correct. If
+ -- this check fails, run utility program XSNAMES to construct a new
+ -- properly matching version of the body.
+
+ pragma Assert (Discard_Name = Last_Predefined_Name);
+ end Initialize;
+
+ -----------------------
+ -- Is_Attribute_Name --
+ -----------------------
+
+ function Is_Attribute_Name (N : Name_Id) return Boolean is
+ begin
+ return N in First_Attribute_Name .. Last_Attribute_Name;
+ end Is_Attribute_Name;
+
+ -------------------
+ -- Is_Check_Name --
+ -------------------
+
+ function Is_Check_Name (N : Name_Id) return Boolean is
+ begin
+ return N in First_Check_Name .. Last_Check_Name;
+ end Is_Check_Name;
+
+ ------------------------
+ -- Is_Convention_Name --
+ ------------------------
+
+ function Is_Convention_Name (N : Name_Id) return Boolean is
+ begin
+ return N in First_Convention_Name .. Last_Convention_Name
+ or else N = Name_C;
+ end Is_Convention_Name;
+
+ ------------------------------
+ -- Is_Entity_Attribute_Name --
+ ------------------------------
+
+ function Is_Entity_Attribute_Name (N : Name_Id) return Boolean is
+ begin
+ return N in First_Entity_Attribute_Name .. Last_Entity_Attribute_Name;
+ end Is_Entity_Attribute_Name;
+
+ --------------------------------
+ -- Is_Function_Attribute_Name --
+ --------------------------------
+
+ function Is_Function_Attribute_Name (N : Name_Id) return Boolean is
+ begin
+ return N in
+ First_Renamable_Function_Attribute ..
+ Last_Renamable_Function_Attribute;
+ end Is_Function_Attribute_Name;
+
+ ----------------------------
+ -- Is_Locking_Policy_Name --
+ ----------------------------
+
+ function Is_Locking_Policy_Name (N : Name_Id) return Boolean is
+ begin
+ return N in First_Locking_Policy_Name .. Last_Locking_Policy_Name;
+ end Is_Locking_Policy_Name;
+
+ -----------------------------
+ -- Is_Operator_Symbol_Name --
+ -----------------------------
+
+ function Is_Operator_Symbol_Name (N : Name_Id) return Boolean is
+ begin
+ return N in First_Operator_Name .. Last_Operator_Name;
+ end Is_Operator_Symbol_Name;
+
+ --------------------
+ -- Is_Pragma_Name --
+ --------------------
+
+ function Is_Pragma_Name (N : Name_Id) return Boolean is
+ begin
+ return N in First_Pragma_Name .. Last_Pragma_Name
+ or else N = Name_AST_Entry
+ or else N = Name_Storage_Size
+ or else N = Name_Storage_Unit;
+ end Is_Pragma_Name;
+
+ ---------------------------------
+ -- Is_Procedure_Attribute_Name --
+ ---------------------------------
+
+ function Is_Procedure_Attribute_Name (N : Name_Id) return Boolean is
+ begin
+ return N in First_Procedure_Attribute .. Last_Procedure_Attribute;
+ end Is_Procedure_Attribute_Name;
+
+ ----------------------------
+ -- Is_Queuing_Policy_Name --
+ ----------------------------
+
+ function Is_Queuing_Policy_Name (N : Name_Id) return Boolean is
+ begin
+ return N in First_Queuing_Policy_Name .. Last_Queuing_Policy_Name;
+ end Is_Queuing_Policy_Name;
+
+ -------------------------------------
+ -- Is_Task_Dispatching_Policy_Name --
+ -------------------------------------
+
+ function Is_Task_Dispatching_Policy_Name (N : Name_Id) return Boolean is
+ begin
+ return N in First_Task_Dispatching_Policy_Name ..
+ Last_Task_Dispatching_Policy_Name;
+ end Is_Task_Dispatching_Policy_Name;
+
+ ----------------------------
+ -- Is_Type_Attribute_Name --
+ ----------------------------
+
+ function Is_Type_Attribute_Name (N : Name_Id) return Boolean is
+ begin
+ return N in First_Type_Attribute_Name .. Last_Type_Attribute_Name;
+ end Is_Type_Attribute_Name;
+
+end Snames;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S N A M E S --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.209 $
+-- --
+-- 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 other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception 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). --
+-- --
+------------------------------------------------------------------------------
+
+with Types; use Types;
+
+package Snames is
+
+-- This package contains definitions of standard names (i.e. entries in the
+-- Names table) that are used throughout the GNAT compiler). It also contains
+-- the definitions of some enumeration types whose definitions are tied to
+-- the order of these preset names.
+
+-- WARNING: There is a C file, a-snames-h which duplicates some of the
+-- definitions in this file and must be kept properly synchronized.
+
+ ------------------
+ -- Preset Names --
+ ------------------
+
+ -- The following are preset entries in the names table, which are
+ -- entered at the start of every compilation for easy access. Note
+ -- that the order of initialization of these names in the body must
+ -- be coordinated with the order of names in this table.
+
+ -- Note: a name may not appear more than once in the following list.
+ -- If additional pragmas or attributes are introduced which might
+ -- otherwise cause a duplicate, then list it only once in this table,
+ -- and adjust the definition of the functions for testing for pragma
+ -- names and attribute names, and returning their ID values. Of course
+ -- everything is simpler if no such duplications occur!
+
+ -- First we have the one character names used to optimize the lookup
+ -- process for one character identifiers (avoid the hashing in this case)
+ -- There are a full 256 of these, but only the entries for lower case
+ -- and upper case letters have identifiers
+
+ -- The lower case letter entries are used for one character identifiers
+ -- appearing in the source, for example in pragma Interface (C).
+
+ Name_A : constant Name_Id := First_Name_Id + Character'Pos ('a');
+ Name_B : constant Name_Id := First_Name_Id + Character'Pos ('b');
+ Name_C : constant Name_Id := First_Name_Id + Character'Pos ('c');
+ Name_D : constant Name_Id := First_Name_Id + Character'Pos ('d');
+ Name_E : constant Name_Id := First_Name_Id + Character'Pos ('e');
+ Name_F : constant Name_Id := First_Name_Id + Character'Pos ('f');
+ Name_G : constant Name_Id := First_Name_Id + Character'Pos ('g');
+ Name_H : constant Name_Id := First_Name_Id + Character'Pos ('h');
+ Name_I : constant Name_Id := First_Name_Id + Character'Pos ('i');
+ Name_J : constant Name_Id := First_Name_Id + Character'Pos ('j');
+ Name_K : constant Name_Id := First_Name_Id + Character'Pos ('k');
+ Name_L : constant Name_Id := First_Name_Id + Character'Pos ('l');
+ Name_M : constant Name_Id := First_Name_Id + Character'Pos ('m');
+ Name_N : constant Name_Id := First_Name_Id + Character'Pos ('n');
+ Name_O : constant Name_Id := First_Name_Id + Character'Pos ('o');
+ Name_P : constant Name_Id := First_Name_Id + Character'Pos ('p');
+ Name_Q : constant Name_Id := First_Name_Id + Character'Pos ('q');
+ Name_R : constant Name_Id := First_Name_Id + Character'Pos ('r');
+ Name_S : constant Name_Id := First_Name_Id + Character'Pos ('s');
+ Name_T : constant Name_Id := First_Name_Id + Character'Pos ('t');
+ Name_U : constant Name_Id := First_Name_Id + Character'Pos ('u');
+ Name_V : constant Name_Id := First_Name_Id + Character'Pos ('v');
+ Name_W : constant Name_Id := First_Name_Id + Character'Pos ('w');
+ Name_X : constant Name_Id := First_Name_Id + Character'Pos ('x');
+ Name_Y : constant Name_Id := First_Name_Id + Character'Pos ('y');
+ Name_Z : constant Name_Id := First_Name_Id + Character'Pos ('z');
+
+ -- The upper case letter entries are used by expander code for local
+ -- variables that do not require unique names (e.g. formal parameter
+ -- names in constructed procedures)
+
+ Name_uA : constant Name_Id := First_Name_Id + Character'Pos ('A');
+ Name_uB : constant Name_Id := First_Name_Id + Character'Pos ('B');
+ Name_uC : constant Name_Id := First_Name_Id + Character'Pos ('C');
+ Name_uD : constant Name_Id := First_Name_Id + Character'Pos ('D');
+ Name_uE : constant Name_Id := First_Name_Id + Character'Pos ('E');
+ Name_uF : constant Name_Id := First_Name_Id + Character'Pos ('F');
+ Name_uG : constant Name_Id := First_Name_Id + Character'Pos ('G');
+ Name_uH : constant Name_Id := First_Name_Id + Character'Pos ('H');
+ Name_uI : constant Name_Id := First_Name_Id + Character'Pos ('I');
+ Name_uJ : constant Name_Id := First_Name_Id + Character'Pos ('J');
+ Name_uK : constant Name_Id := First_Name_Id + Character'Pos ('K');
+ Name_uL : constant Name_Id := First_Name_Id + Character'Pos ('L');
+ Name_uM : constant Name_Id := First_Name_Id + Character'Pos ('M');
+ Name_uN : constant Name_Id := First_Name_Id + Character'Pos ('N');
+ Name_uO : constant Name_Id := First_Name_Id + Character'Pos ('O');
+ Name_uP : constant Name_Id := First_Name_Id + Character'Pos ('P');
+ Name_uQ : constant Name_Id := First_Name_Id + Character'Pos ('Q');
+ Name_uR : constant Name_Id := First_Name_Id + Character'Pos ('R');
+ Name_uS : constant Name_Id := First_Name_Id + Character'Pos ('S');
+ Name_uT : constant Name_Id := First_Name_Id + Character'Pos ('T');
+ Name_uU : constant Name_Id := First_Name_Id + Character'Pos ('U');
+ Name_uV : constant Name_Id := First_Name_Id + Character'Pos ('V');
+ Name_uW : constant Name_Id := First_Name_Id + Character'Pos ('W');
+ Name_uX : constant Name_Id := First_Name_Id + Character'Pos ('X');
+ Name_uY : constant Name_Id := First_Name_Id + Character'Pos ('Y');
+ Name_uZ : constant Name_Id := First_Name_Id + Character'Pos ('Z');
+
+ -- Note: the following table is read by the utility program XSNAMES and
+ -- its format should not be changed without coordinating with this program.
+
+ N : constant Name_Id := First_Name_Id + 256;
+ -- Synonym used in standard name definitions
+
+ -- Some names that are used by gigi, and whose definitions are reflected
+ -- in the C header file a-snames.h. They are placed at the start so that
+ -- the need to modify a-snames.h is minimized.
+
+ Name_uParent : constant Name_Id := N + 000;
+ Name_uTag : constant Name_Id := N + 001;
+ Name_Off : constant Name_Id := N + 002;
+ Name_Space : constant Name_Id := N + 003;
+ Name_Time : constant Name_Id := N + 004;
+ Name_uInit_Proc : constant Name_Id := N + 005;
+ Name_uSize : constant Name_Id := N + 006;
+
+ -- Some special names used by the expander. Note that the lower case u's
+ -- at the start of these names get translated to extra underscores. These
+ -- names are only referenced internally by expander generated code.
+
+ Name_uAbort_Signal : constant Name_Id := N + 007;
+ Name_uAddress_Resolver : constant Name_Id := N + 008;
+ Name_uAssign : constant Name_Id := N + 009;
+ Name_uChain : constant Name_Id := N + 010;
+ Name_uClean : constant Name_Id := N + 011;
+ Name_uController : constant Name_Id := N + 012;
+ Name_uEntry_Bodies : constant Name_Id := N + 013;
+ Name_uExpunge : constant Name_Id := N + 014;
+ Name_uFinal_List : constant Name_Id := N + 015;
+ Name_uIdepth : constant Name_Id := N + 016;
+ Name_uInit : constant Name_Id := N + 017;
+ Name_uLocal_Final_List : constant Name_Id := N + 018;
+ Name_uMaster : constant Name_Id := N + 019;
+ Name_uObject : constant Name_Id := N + 020;
+ Name_uPriority : constant Name_Id := N + 021;
+ Name_uService : constant Name_Id := N + 022;
+ Name_uTags : constant Name_Id := N + 023;
+ Name_uTask : constant Name_Id := N + 024;
+ Name_uTask_Id : constant Name_Id := N + 025;
+ Name_uTask_Info : constant Name_Id := N + 026;
+ Name_uTask_Name : constant Name_Id := N + 027;
+ Name_uTrace_Sp : constant Name_Id := N + 028;
+
+ -- Names of routines in Ada.Finalization, needed by expander
+
+ Name_Initialize : constant Name_Id := N + 029;
+ Name_Adjust : constant Name_Id := N + 030;
+ Name_Finalize : constant Name_Id := N + 031;
+
+ -- Names of fields declared in System.Finalization_Implementation,
+ -- needed by the expander when generating code for finalization.
+
+ Name_Next : constant Name_Id := N + 032;
+ Name_Prev : constant Name_Id := N + 033;
+
+ -- Names of TSS routines (see Exp_TSS); Name_uInit_Proc above is also
+ -- one of these.
+
+ Name_uDeep_Adjust : constant Name_Id := N + 034;
+ Name_uEquality : constant Name_Id := N + 035;
+ Name_uDeep_Finalize : constant Name_Id := N + 036;
+ Name_uDeep_Initialize : constant Name_Id := N + 037;
+ Name_uInput : constant Name_Id := N + 038;
+ Name_uOutput : constant Name_Id := N + 039;
+ Name_uRAS_Access : constant Name_Id := N + 040;
+ Name_uRAS_Dereference : constant Name_Id := N + 041;
+ Name_uRead : constant Name_Id := N + 042;
+ Name_uRep_To_Pos : constant Name_Id := N + 043;
+ Name_uWrite : constant Name_Id := N + 044;
+
+ -- Names of allocation routines, also needed by expander
+
+ Name_Allocate : constant Name_Id := N + 045;
+ Name_Deallocate : constant Name_Id := N + 046;
+ Name_Dereference : constant Name_Id := N + 047;
+
+ -- Names of Text_IO generic subpackages (see Rtsfind.Text_IO_Kludge)
+
+ First_Text_IO_Package : constant Name_Id := N + 048;
+ Name_Decimal_IO : constant Name_Id := N + 048;
+ Name_Enumeration_IO : constant Name_Id := N + 049;
+ Name_Fixed_IO : constant Name_Id := N + 050;
+ Name_Float_IO : constant Name_Id := N + 051;
+ Name_Integer_IO : constant Name_Id := N + 052;
+ Name_Modular_IO : constant Name_Id := N + 053;
+ Last_Text_IO_Package : constant Name_Id := N + 053;
+
+ subtype Text_IO_Package_Name is Name_Id
+ range First_Text_IO_Package .. Last_Text_IO_Package;
+
+ -- Names of files in library for Ada.Text_IO and Ada.Wide_Text_IO
+
+ Name_a_textio : constant Name_Id := N + 054;
+ Name_a_witeio : constant Name_Id := N + 055;
+
+ -- Some miscellaneous names used for error detection/recovery
+
+ Name_Const : constant Name_Id := N + 056;
+ Name_Error : constant Name_Id := N + 057;
+ Name_Go : constant Name_Id := N + 058;
+ Name_Put : constant Name_Id := N + 059;
+ Name_Put_Line : constant Name_Id := N + 060;
+ Name_To : constant Name_Id := N + 061;
+
+ -- Names for packages that are treated specially by the compiler
+
+ Name_Finalization : constant Name_Id := N + 062;
+ Name_Finalization_Root : constant Name_Id := N + 063;
+ Name_Interfaces : constant Name_Id := N + 064;
+ Name_Standard : constant Name_Id := N + 065;
+ Name_System : constant Name_Id := N + 066;
+ Name_Text_IO : constant Name_Id := N + 067;
+ Name_Wide_Text_IO : constant Name_Id := N + 068;
+
+ -- Names of identifiers used in expanding distribution stubs
+
+ Name_Addr : constant Name_Id := N + 069;
+ Name_Async : constant Name_Id := N + 070;
+ Name_Get_Active_Partition_ID : constant Name_Id := N + 071;
+ Name_Get_RCI_Package_Receiver : constant Name_Id := N + 072;
+ Name_Origin : constant Name_Id := N + 073;
+ Name_Params : constant Name_Id := N + 074;
+ Name_Partition : constant Name_Id := N + 075;
+ Name_Partition_Interface : constant Name_Id := N + 076;
+ Name_Ras : constant Name_Id := N + 077;
+ Name_RCI_Name : constant Name_Id := N + 078;
+ Name_Receiver : constant Name_Id := N + 079;
+ Name_Result : constant Name_Id := N + 080;
+ Name_Rpc : constant Name_Id := N + 081;
+ Name_Subp_Id : constant Name_Id := N + 082;
+
+ -- Operator Symbol entries. The actual names have an upper case O at
+ -- the start in place of the Op_ prefix (e.g. the actual name that
+ -- corresponds to Name_Op_Abs is "Oabs".
+
+ First_Operator_Name : constant Name_Id := N + 083;
+ Name_Op_Abs : constant Name_Id := N + 083; -- "abs"
+ Name_Op_And : constant Name_Id := N + 084; -- "and"
+ Name_Op_Mod : constant Name_Id := N + 085; -- "mod"
+ Name_Op_Not : constant Name_Id := N + 086; -- "not"
+ Name_Op_Or : constant Name_Id := N + 087; -- "or"
+ Name_Op_Rem : constant Name_Id := N + 088; -- "rem"
+ Name_Op_Xor : constant Name_Id := N + 089; -- "xor"
+ Name_Op_Eq : constant Name_Id := N + 090; -- "="
+ Name_Op_Ne : constant Name_Id := N + 091; -- "/="
+ Name_Op_Lt : constant Name_Id := N + 092; -- "<"
+ Name_Op_Le : constant Name_Id := N + 093; -- "<="
+ Name_Op_Gt : constant Name_Id := N + 094; -- ">"
+ Name_Op_Ge : constant Name_Id := N + 095; -- ">="
+ Name_Op_Add : constant Name_Id := N + 096; -- "+"
+ Name_Op_Subtract : constant Name_Id := N + 097; -- "-"
+ Name_Op_Concat : constant Name_Id := N + 098; -- "&"
+ Name_Op_Multiply : constant Name_Id := N + 099; -- "*"
+ Name_Op_Divide : constant Name_Id := N + 100; -- "/"
+ Name_Op_Expon : constant Name_Id := N + 101; -- "**"
+ Last_Operator_Name : constant Name_Id := N + 101;
+
+ -- Names for all pragmas recognized by GNAT. The entries with the comment
+ -- "Ada 83" are pragmas that are defined in Ada 83, but not in Ada 95.
+ -- These pragmas are fully implemented in both Ada 83 and Ada 95 modes
+ -- in GNAT.
+
+ -- The entries marked GNAT are pragmas that are defined by GNAT
+ -- and implemented in both Ada 83 and Ada 95 modes. Full descriptions
+ -- of these implementation dependent pragmas may be found in the
+ -- appropriate section in unit Sem_Prag in file sem-prag.adb.
+
+ -- The entries marked VMS are VMS specific pragmas that are recognized
+ -- only in OpenVMS versions of GNAT. They are ignored in other versions
+ -- with an appropriate warning.
+
+ First_Pragma_Name : constant Name_Id := N + 102;
+
+ -- Configuration pragmas are grouped at start
+
+ Name_Ada_83 : constant Name_Id := N + 102; -- GNAT
+ Name_Ada_95 : constant Name_Id := N + 103; -- GNAT
+ Name_C_Pass_By_Copy : constant Name_Id := N + 104; -- GNAT
+ Name_Component_Alignment : constant Name_Id := N + 105; -- GNAT
+ Name_Discard_Names : constant Name_Id := N + 106;
+ Name_Elaboration_Checks : constant Name_Id := N + 107; -- GNAT
+ Name_Eliminate : constant Name_Id := N + 108; -- GNAT
+ Name_Extend_System : constant Name_Id := N + 109; -- GNAT
+ Name_Extensions_Allowed : constant Name_Id := N + 110; -- GNAT
+ Name_External_Name_Casing : constant Name_Id := N + 111; -- GNAT
+ Name_Float_Representation : constant Name_Id := N + 112; -- GNAT
+ Name_Initialize_Scalars : constant Name_Id := N + 113; -- GNAT
+ Name_License : constant Name_Id := N + 114; -- GNAT
+ Name_Locking_Policy : constant Name_Id := N + 115;
+ Name_Long_Float : constant Name_Id := N + 116; -- VMS
+ Name_No_Run_Time : constant Name_Id := N + 117; -- GNAT
+ Name_Normalize_Scalars : constant Name_Id := N + 118;
+ Name_Polling : constant Name_Id := N + 119; -- GNAT
+ Name_Propagate_Exceptions : constant Name_Id := N + 120; -- GNAT
+ Name_Queuing_Policy : constant Name_Id := N + 121;
+ Name_Ravenscar : constant Name_Id := N + 122;
+ Name_Restricted_Run_Time : constant Name_Id := N + 123;
+ Name_Restrictions : constant Name_Id := N + 124;
+ Name_Reviewable : constant Name_Id := N + 125;
+ Name_Source_File_Name : constant Name_Id := N + 126; -- GNAT
+ Name_Style_Checks : constant Name_Id := N + 127; -- GNAT
+ Name_Suppress : constant Name_Id := N + 128;
+ Name_Task_Dispatching_Policy : constant Name_Id := N + 129;
+ Name_Unsuppress : constant Name_Id := N + 130; -- GNAT
+ Name_Use_VADS_Size : constant Name_Id := N + 131; -- GNAT
+ Name_Warnings : constant Name_Id := N + 132; -- GNAT
+ Name_Validity_Checks : constant Name_Id := N + 133; -- GNAT
+ Last_Configuration_Pragma_Name : constant Name_Id := N + 133;
+
+ -- Remaining pragma names
+
+ Name_Abort_Defer : constant Name_Id := N + 134; -- GNAT
+ Name_All_Calls_Remote : constant Name_Id := N + 135;
+ Name_Annotate : constant Name_Id := N + 136; -- GNAT
+
+ -- Note: AST_Entry is not in this list because its name matches the
+ -- name of the corresponding attribute. However, it is included in the
+ -- definition of the type Attribute_Id, and the functions Get_Pragma_Id
+ -- and Check_Pragma_Id correctly recognize and process Name_AST_Entry.
+ -- AST_Entry is a VMS specific pragma.
+
+ Name_Assert : constant Name_Id := N + 137; -- GNAT
+ Name_Asynchronous : constant Name_Id := N + 138;
+ Name_Atomic : constant Name_Id := N + 139;
+ Name_Atomic_Components : constant Name_Id := N + 140;
+ Name_Attach_Handler : constant Name_Id := N + 141;
+ Name_Comment : constant Name_Id := N + 142; -- GNAT
+ Name_Common_Object : constant Name_Id := N + 143; -- GNAT
+ Name_Complex_Representation : constant Name_Id := N + 144; -- GNAT
+ Name_Controlled : constant Name_Id := N + 145;
+ Name_Convention : constant Name_Id := N + 146;
+ Name_CPP_Class : constant Name_Id := N + 147; -- GNAT
+ Name_CPP_Constructor : constant Name_Id := N + 148; -- GNAT
+ Name_CPP_Virtual : constant Name_Id := N + 149; -- GNAT
+ Name_CPP_Vtable : constant Name_Id := N + 150; -- GNAT
+ Name_Debug : constant Name_Id := N + 151; -- GNAT
+ Name_Elaborate : constant Name_Id := N + 152; -- Ada 83
+ Name_Elaborate_All : constant Name_Id := N + 153;
+ Name_Elaborate_Body : constant Name_Id := N + 154;
+ Name_Export : constant Name_Id := N + 155;
+ Name_Export_Exception : constant Name_Id := N + 156; -- VMS
+ Name_Export_Function : constant Name_Id := N + 157; -- GNAT
+ Name_Export_Object : constant Name_Id := N + 158; -- GNAT
+ Name_Export_Procedure : constant Name_Id := N + 159; -- GNAT
+ Name_Export_Valued_Procedure : constant Name_Id := N + 160; -- GNAT
+ Name_Finalize_Storage_Only : constant Name_Id := N + 161; -- GNAT
+ Name_Ident : constant Name_Id := N + 162; -- VMS
+ Name_Import : constant Name_Id := N + 163;
+ Name_Import_Exception : constant Name_Id := N + 164; -- VMS
+ Name_Import_Function : constant Name_Id := N + 165; -- GNAT
+ Name_Import_Object : constant Name_Id := N + 166; -- GNAT
+ Name_Import_Procedure : constant Name_Id := N + 167; -- GNAT
+ Name_Import_Valued_Procedure : constant Name_Id := N + 168; -- GNAT
+ Name_Inline : constant Name_Id := N + 169;
+ Name_Inline_Always : constant Name_Id := N + 170; -- GNAT
+ Name_Inline_Generic : constant Name_Id := N + 171; -- GNAT
+ Name_Inspection_Point : constant Name_Id := N + 172;
+ Name_Interface : constant Name_Id := N + 173; -- Ada 83
+ Name_Interface_Name : constant Name_Id := N + 174; -- GNAT
+ Name_Interrupt_Handler : constant Name_Id := N + 175;
+ Name_Interrupt_Priority : constant Name_Id := N + 176;
+ Name_Java_Constructor : constant Name_Id := N + 177; -- GNAT
+ Name_Java_Interface : constant Name_Id := N + 178; -- GNAT
+ Name_Link_With : constant Name_Id := N + 179; -- GNAT
+ Name_Linker_Alias : constant Name_Id := N + 180; -- GNAT
+ Name_Linker_Options : constant Name_Id := N + 181;
+ Name_Linker_Section : constant Name_Id := N + 182; -- GNAT
+ Name_List : constant Name_Id := N + 183;
+ Name_Machine_Attribute : constant Name_Id := N + 184; -- GNAT
+ Name_Main : constant Name_Id := N + 185; -- GNAT
+ Name_Main_Storage : constant Name_Id := N + 186; -- GNAT
+ Name_Memory_Size : constant Name_Id := N + 187; -- Ada 83
+ Name_No_Return : constant Name_Id := N + 188; -- GNAT
+ Name_Optimize : constant Name_Id := N + 189;
+ Name_Pack : constant Name_Id := N + 190;
+ Name_Page : constant Name_Id := N + 191;
+ Name_Passive : constant Name_Id := N + 192; -- GNAT
+ Name_Preelaborate : constant Name_Id := N + 193;
+ Name_Priority : constant Name_Id := N + 194;
+ Name_Psect_Object : constant Name_Id := N + 195; -- VMS
+ Name_Pure : constant Name_Id := N + 196;
+ Name_Pure_Function : constant Name_Id := N + 197; -- GNAT
+ Name_Remote_Call_Interface : constant Name_Id := N + 198;
+ Name_Remote_Types : constant Name_Id := N + 199;
+ Name_Share_Generic : constant Name_Id := N + 200; -- GNAT
+ Name_Shared : constant Name_Id := N + 201; -- Ada 83
+ Name_Shared_Passive : constant Name_Id := N + 202;
+
+ -- Note: Storage_Size is not in this list because its name matches the
+ -- name of the corresponding attribute. However, it is included in the
+ -- definition of the type Attribute_Id, and the functions Get_Pragma_Id
+ -- and Check_Pragma_Id correctly recognize and process Name_Storage_Size.
+
+ -- Note: Storage_Unit is also omitted from the list because of a clash
+ -- with an attribute name, and is treated similarly.
+
+ Name_Source_Reference : constant Name_Id := N + 203; -- GNAT
+ Name_Stream_Convert : constant Name_Id := N + 204; -- GNAT
+ Name_Subtitle : constant Name_Id := N + 205; -- GNAT
+ Name_Suppress_All : constant Name_Id := N + 206; -- GNAT
+ Name_Suppress_Debug_Info : constant Name_Id := N + 207; -- GNAT
+ Name_Suppress_Initialization : constant Name_Id := N + 208; -- GNAT
+ Name_System_Name : constant Name_Id := N + 209; -- Ada 83
+ Name_Task_Info : constant Name_Id := N + 210; -- GNAT
+ Name_Task_Name : constant Name_Id := N + 211; -- GNAT
+ Name_Task_Storage : constant Name_Id := N + 212; -- VMS
+ Name_Time_Slice : constant Name_Id := N + 213; -- GNAT
+ Name_Title : constant Name_Id := N + 214; -- GNAT
+ Name_Unchecked_Union : constant Name_Id := N + 215; -- GNAT
+ Name_Unimplemented_Unit : constant Name_Id := N + 216; -- GNAT
+ Name_Unreserve_All_Interrupts : constant Name_Id := N + 217; -- GNAT
+ Name_Volatile : constant Name_Id := N + 218;
+ Name_Volatile_Components : constant Name_Id := N + 219;
+ Name_Weak_External : constant Name_Id := N + 220; -- GNAT
+ Last_Pragma_Name : constant Name_Id := N + 220;
+
+ -- Language convention names for pragma Convention/Export/Import/Interface
+ -- Note that Name_C is not included in this list, since it was already
+ -- declared earlier in the context of one-character identifier names
+ -- (where the order is critical to the fast look up process).
+
+ -- Note: there are no convention names corresponding to the conventions
+ -- Entry and Protected, this is because these conventions cannot be
+ -- specified by a pragma.
+
+ -- Note: The convention name C_Pass_By_Copy is treated as entirely
+ -- equivalent to C except when it is specified on a record type. In
+ -- this case the convention of the record type is set to C, but in
+ -- addition the flag C_Pass_By_Copy is set on the record type.
+
+ First_Convention_Name : constant Name_Id := N + 221;
+ Name_Ada : constant Name_Id := N + 221;
+ Name_Asm : constant Name_Id := N + 222;
+ Name_Assembler : constant Name_Id := N + 223;
+ Name_COBOL : constant Name_Id := N + 224;
+ Name_CPP : constant Name_Id := N + 225;
+ Name_DLL : constant Name_Id := N + 226;
+ Name_Fortran : constant Name_Id := N + 227;
+ Name_Intrinsic : constant Name_Id := N + 228;
+ Name_Java : constant Name_Id := N + 229;
+ Name_Stdcall : constant Name_Id := N + 230;
+ Name_Stubbed : constant Name_Id := N + 231;
+ Name_Win32 : constant Name_Id := N + 232;
+ Last_Convention_Name : constant Name_Id := N + 232;
+
+ -- Other special names used in processing pragma arguments
+
+ Name_As_Is : constant Name_Id := N + 233;
+ Name_Body_File_Name : constant Name_Id := N + 234;
+ Name_Casing : constant Name_Id := N + 235;
+ Name_Code : constant Name_Id := N + 236;
+ Name_Component : constant Name_Id := N + 237;
+ Name_Component_Size_4 : constant Name_Id := N + 238;
+ Name_Copy : constant Name_Id := N + 239;
+ Name_D_Float : constant Name_Id := N + 240;
+ Name_Descriptor : constant Name_Id := N + 241;
+ Name_Default : constant Name_Id := N + 242;
+ Name_Dot_Replacement : constant Name_Id := N + 243;
+ Name_Dynamic : constant Name_Id := N + 244;
+ Name_Entity : constant Name_Id := N + 245;
+ Name_External : constant Name_Id := N + 246;
+ Name_External_Name : constant Name_Id := N + 247;
+ Name_First_Optional_Parameter : constant Name_Id := N + 248;
+ Name_Form : constant Name_Id := N + 249;
+ Name_G_Float : constant Name_Id := N + 250;
+ Name_Gcc : constant Name_Id := N + 251;
+ Name_Gnat : constant Name_Id := N + 252;
+ Name_GPL : constant Name_Id := N + 253;
+ Name_IEEE_Float : constant Name_Id := N + 254;
+ Name_Internal : constant Name_Id := N + 255;
+ Name_Link_Name : constant Name_Id := N + 256;
+ Name_Lowercase : constant Name_Id := N + 257;
+ Name_Max_Size : constant Name_Id := N + 258;
+ Name_Mechanism : constant Name_Id := N + 259;
+ Name_Mixedcase : constant Name_Id := N + 260;
+ Name_Modified_GPL : constant Name_Id := N + 261;
+ Name_Name : constant Name_Id := N + 262;
+ Name_NCA : constant Name_Id := N + 263;
+ Name_No : constant Name_Id := N + 264;
+ Name_On : constant Name_Id := N + 265;
+ Name_Parameter_Types : constant Name_Id := N + 266;
+ Name_Reference : constant Name_Id := N + 267;
+ Name_Restricted : constant Name_Id := N + 268;
+ Name_Result_Mechanism : constant Name_Id := N + 269;
+ Name_Result_Type : constant Name_Id := N + 270;
+ Name_SB : constant Name_Id := N + 271;
+ Name_Section : constant Name_Id := N + 272;
+ Name_Semaphore : constant Name_Id := N + 273;
+ Name_Spec_File_Name : constant Name_Id := N + 274;
+ Name_Static : constant Name_Id := N + 275;
+ Name_Stack_Size : constant Name_Id := N + 276;
+ Name_Subunit_File_Name : constant Name_Id := N + 277;
+ Name_Task_Stack_Size_Default : constant Name_Id := N + 278;
+ Name_Task_Type : constant Name_Id := N + 279;
+ Name_Time_Slicing_Enabled : constant Name_Id := N + 280;
+ Name_Top_Guard : constant Name_Id := N + 281;
+ Name_UBA : constant Name_Id := N + 282;
+ Name_UBS : constant Name_Id := N + 283;
+ Name_UBSB : constant Name_Id := N + 284;
+ Name_Unit_Name : constant Name_Id := N + 285;
+ Name_Unknown : constant Name_Id := N + 286;
+ Name_Unrestricted : constant Name_Id := N + 287;
+ Name_Uppercase : constant Name_Id := N + 288;
+ Name_VAX_Float : constant Name_Id := N + 289;
+ Name_VMS : constant Name_Id := N + 290;
+ Name_Working_Storage : constant Name_Id := N + 291;
+
+ -- Names of recognized attributes. The entries with the comment "Ada 83"
+ -- are attributes that are defined in Ada 83, but not in Ada 95. These
+ -- attributes are implemented in both Ada 83 and Ada 95 modes in GNAT.
+
+ -- The entries marked GNAT are attributes that are defined by GNAT
+ -- and implemented in both Ada 83 and Ada 95 modes. Full descriptions
+ -- of these implementation dependent attributes may be found in the
+ -- appropriate section in package Sem_Attr in file sem-attr.ads.
+
+ -- The entries marked VMS are recognized only in OpenVMS implementations
+ -- of GNAT, and are treated as illegal in all other contexts.
+
+ First_Attribute_Name : constant Name_Id := N + 292;
+ Name_Abort_Signal : constant Name_Id := N + 292; -- GNAT
+ Name_Access : constant Name_Id := N + 293;
+ Name_Address : constant Name_Id := N + 294;
+ Name_Address_Size : constant Name_Id := N + 295; -- GNAT
+ Name_Aft : constant Name_Id := N + 296;
+ Name_Alignment : constant Name_Id := N + 297;
+ Name_Asm_Input : constant Name_Id := N + 298; -- GNAT
+ Name_Asm_Output : constant Name_Id := N + 299; -- GNAT
+ Name_AST_Entry : constant Name_Id := N + 300; -- VMS
+ Name_Bit : constant Name_Id := N + 301; -- GNAT
+ Name_Bit_Order : constant Name_Id := N + 302;
+ Name_Bit_Position : constant Name_Id := N + 303; -- GNAT
+ Name_Body_Version : constant Name_Id := N + 304;
+ Name_Callable : constant Name_Id := N + 305;
+ Name_Caller : constant Name_Id := N + 306;
+ Name_Code_Address : constant Name_Id := N + 307; -- GNAT
+ Name_Component_Size : constant Name_Id := N + 308;
+ Name_Compose : constant Name_Id := N + 309;
+ Name_Constrained : constant Name_Id := N + 310;
+ Name_Count : constant Name_Id := N + 311;
+ Name_Default_Bit_Order : constant Name_Id := N + 312; -- GNAT
+ Name_Definite : constant Name_Id := N + 313;
+ Name_Delta : constant Name_Id := N + 314;
+ Name_Denorm : constant Name_Id := N + 315;
+ Name_Digits : constant Name_Id := N + 316;
+ Name_Elaborated : constant Name_Id := N + 317; -- GNAT
+ Name_Emax : constant Name_Id := N + 318; -- Ada 83
+ Name_Enum_Rep : constant Name_Id := N + 319; -- GNAT
+ Name_Epsilon : constant Name_Id := N + 320; -- Ada 83
+ Name_Exponent : constant Name_Id := N + 321;
+ Name_External_Tag : constant Name_Id := N + 322;
+ Name_First : constant Name_Id := N + 323;
+ Name_First_Bit : constant Name_Id := N + 324;
+ Name_Fixed_Value : constant Name_Id := N + 325; -- GNAT
+ Name_Fore : constant Name_Id := N + 326;
+ Name_Has_Discriminants : constant Name_Id := N + 327; -- GNAT
+ Name_Identity : constant Name_Id := N + 328;
+ Name_Img : constant Name_Id := N + 329; -- GNAT
+ Name_Integer_Value : constant Name_Id := N + 330; -- GNAT
+ Name_Large : constant Name_Id := N + 331; -- Ada 83
+ Name_Last : constant Name_Id := N + 332;
+ Name_Last_Bit : constant Name_Id := N + 333;
+ Name_Leading_Part : constant Name_Id := N + 334;
+ Name_Length : constant Name_Id := N + 335;
+ Name_Machine_Emax : constant Name_Id := N + 336;
+ Name_Machine_Emin : constant Name_Id := N + 337;
+ Name_Machine_Mantissa : constant Name_Id := N + 338;
+ Name_Machine_Overflows : constant Name_Id := N + 339;
+ Name_Machine_Radix : constant Name_Id := N + 340;
+ Name_Machine_Rounds : constant Name_Id := N + 341;
+ Name_Machine_Size : constant Name_Id := N + 342; -- GNAT
+ Name_Mantissa : constant Name_Id := N + 343; -- Ada 83
+ Name_Max_Interrupt_Priority : constant Name_Id := N + 344; -- GNAT
+ Name_Max_Priority : constant Name_Id := N + 345; -- GNAT
+ Name_Max_Size_In_Storage_Elements : constant Name_Id := N + 346;
+ Name_Maximum_Alignment : constant Name_Id := N + 347; -- GNAT
+ Name_Mechanism_Code : constant Name_Id := N + 348; -- GNAT
+ Name_Model_Emin : constant Name_Id := N + 349;
+ Name_Model_Epsilon : constant Name_Id := N + 350;
+ Name_Model_Mantissa : constant Name_Id := N + 351;
+ Name_Model_Small : constant Name_Id := N + 352;
+ Name_Modulus : constant Name_Id := N + 353;
+ Name_Null_Parameter : constant Name_Id := N + 354; -- GNAT
+ Name_Object_Size : constant Name_Id := N + 355; -- GNAT
+ Name_Partition_ID : constant Name_Id := N + 356;
+ Name_Passed_By_Reference : constant Name_Id := N + 357; -- GNAT
+ Name_Pos : constant Name_Id := N + 358;
+ Name_Position : constant Name_Id := N + 359;
+ Name_Range : constant Name_Id := N + 360;
+ Name_Range_Length : constant Name_Id := N + 361; -- GNAT
+ Name_Round : constant Name_Id := N + 362;
+ Name_Safe_Emax : constant Name_Id := N + 363; -- Ada 83
+ Name_Safe_First : constant Name_Id := N + 364;
+ Name_Safe_Large : constant Name_Id := N + 365; -- Ada 83
+ Name_Safe_Last : constant Name_Id := N + 366;
+ Name_Safe_Small : constant Name_Id := N + 367; -- Ada 83
+ Name_Scale : constant Name_Id := N + 368;
+ Name_Scaling : constant Name_Id := N + 369;
+ Name_Signed_Zeros : constant Name_Id := N + 370;
+ Name_Size : constant Name_Id := N + 371;
+ Name_Small : constant Name_Id := N + 372;
+ Name_Storage_Size : constant Name_Id := N + 373;
+ Name_Storage_Unit : constant Name_Id := N + 374; -- GNAT
+ Name_Tag : constant Name_Id := N + 375;
+ Name_Terminated : constant Name_Id := N + 376;
+ Name_Tick : constant Name_Id := N + 377; -- GNAT
+ Name_To_Address : constant Name_Id := N + 378; -- GNAT
+ Name_Type_Class : constant Name_Id := N + 379; -- GNAT
+ Name_UET_Address : constant Name_Id := N + 380; -- GNAT
+ Name_Unbiased_Rounding : constant Name_Id := N + 381;
+ Name_Unchecked_Access : constant Name_Id := N + 382;
+ Name_Universal_Literal_String : constant Name_Id := N + 383; -- GNAT
+ Name_Unrestricted_Access : constant Name_Id := N + 384; -- GNAT
+ Name_VADS_Size : constant Name_Id := N + 385; -- GNAT
+ Name_Val : constant Name_Id := N + 386;
+ Name_Valid : constant Name_Id := N + 387;
+ Name_Value_Size : constant Name_Id := N + 388; -- GNAT
+ Name_Version : constant Name_Id := N + 389;
+ Name_Wchar_T_Size : constant Name_Id := N + 390; -- GNAT
+ Name_Wide_Width : constant Name_Id := N + 391;
+ Name_Width : constant Name_Id := N + 392;
+ Name_Word_Size : constant Name_Id := N + 393; -- GNAT
+
+ -- Attributes that designate attributes returning renamable functions,
+ -- i.e. functions that return other than a universal value.
+
+ First_Renamable_Function_Attribute : constant Name_Id := N + 394;
+ Name_Adjacent : constant Name_Id := N + 394;
+ Name_Ceiling : constant Name_Id := N + 395;
+ Name_Copy_Sign : constant Name_Id := N + 396;
+ Name_Floor : constant Name_Id := N + 397;
+ Name_Fraction : constant Name_Id := N + 398;
+ Name_Image : constant Name_Id := N + 399;
+ Name_Input : constant Name_Id := N + 400;
+ Name_Machine : constant Name_Id := N + 401;
+ Name_Max : constant Name_Id := N + 402;
+ Name_Min : constant Name_Id := N + 403;
+ Name_Model : constant Name_Id := N + 404;
+ Name_Pred : constant Name_Id := N + 405;
+ Name_Remainder : constant Name_Id := N + 406;
+ Name_Rounding : constant Name_Id := N + 407;
+ Name_Succ : constant Name_Id := N + 408;
+ Name_Truncation : constant Name_Id := N + 409;
+ Name_Value : constant Name_Id := N + 410;
+ Name_Wide_Image : constant Name_Id := N + 411;
+ Name_Wide_Value : constant Name_Id := N + 412;
+ Last_Renamable_Function_Attribute : constant Name_Id := N + 412;
+
+ -- Attributes that designate procedures
+
+ First_Procedure_Attribute : constant Name_Id := N + 413;
+ Name_Output : constant Name_Id := N + 413;
+ Name_Read : constant Name_Id := N + 414;
+ Name_Write : constant Name_Id := N + 415;
+ Last_Procedure_Attribute : constant Name_Id := N + 415;
+
+ -- Remaining attributes are ones that return entities
+
+ First_Entity_Attribute_Name : constant Name_Id := N + 416;
+ Name_Elab_Body : constant Name_Id := N + 416; -- GNAT
+ Name_Elab_Spec : constant Name_Id := N + 417; -- GNAT
+ Name_Storage_Pool : constant Name_Id := N + 418;
+
+ -- These attributes are the ones that return types
+
+ First_Type_Attribute_Name : constant Name_Id := N + 419;
+ Name_Base : constant Name_Id := N + 419;
+ Name_Class : constant Name_Id := N + 420;
+ Last_Type_Attribute_Name : constant Name_Id := N + 420;
+ Last_Entity_Attribute_Name : constant Name_Id := N + 420;
+ Last_Attribute_Name : constant Name_Id := N + 420;
+
+ -- Names of recognized locking policy identifiers
+
+ -- Note: policies are identified by the first character of the
+ -- name (e.g. C for Ceiling_Locking). If new policy names are added,
+ -- the first character must be distinct.
+
+ First_Locking_Policy_Name : constant Name_Id := N + 421;
+ Name_Ceiling_Locking : constant Name_Id := N + 421;
+ Name_Inheritance_Locking : constant Name_Id := N + 422;
+ Last_Locking_Policy_Name : constant Name_Id := N + 422;
+
+ -- Names of recognized queuing policy identifiers.
+
+ -- Note: policies are identified by the first character of the
+ -- name (e.g. F for FIFO_Queuing). If new policy names are added,
+ -- the first character must be distinct.
+
+ First_Queuing_Policy_Name : constant Name_Id := N + 423;
+ Name_FIFO_Queuing : constant Name_Id := N + 423;
+ Name_Priority_Queuing : constant Name_Id := N + 424;
+ Last_Queuing_Policy_Name : constant Name_Id := N + 424;
+
+ -- Names of recognized task dispatching policy identifiers
+
+ -- Note: policies are identified by the first character of the
+ -- name (e.g. F for FIFO_WIthinn_Priorities). If new policy names
+ -- are added, the first character must be distinct.
+
+ First_Task_Dispatching_Policy_Name : constant Name_Id := N + 425;
+ Name_Fifo_Within_Priorities : constant Name_Id := N + 425;
+ Last_Task_Dispatching_Policy_Name : constant Name_Id := N + 425;
+
+ -- Names of recognized checks for pragma Suppress
+
+ First_Check_Name : constant Name_Id := N + 426;
+ Name_Access_Check : constant Name_Id := N + 426;
+ Name_Accessibility_Check : constant Name_Id := N + 427;
+ Name_Discriminant_Check : constant Name_Id := N + 428;
+ Name_Division_Check : constant Name_Id := N + 429;
+ Name_Elaboration_Check : constant Name_Id := N + 430;
+ Name_Index_Check : constant Name_Id := N + 431;
+ Name_Length_Check : constant Name_Id := N + 432;
+ Name_Overflow_Check : constant Name_Id := N + 433;
+ Name_Range_Check : constant Name_Id := N + 434;
+ Name_Storage_Check : constant Name_Id := N + 435;
+ Name_Tag_Check : constant Name_Id := N + 436;
+ Name_All_Checks : constant Name_Id := N + 437;
+ Last_Check_Name : constant Name_Id := N + 437;
+
+ -- Names corresponding to reserved keywords, excluding those already
+ -- declared in the attribute list (Access, Delta, Digits, Range).
+
+ Name_Abort : constant Name_Id := N + 438;
+ Name_Abs : constant Name_Id := N + 439;
+ Name_Accept : constant Name_Id := N + 440;
+ Name_And : constant Name_Id := N + 441;
+ Name_All : constant Name_Id := N + 442;
+ Name_Array : constant Name_Id := N + 443;
+ Name_At : constant Name_Id := N + 444;
+ Name_Begin : constant Name_Id := N + 445;
+ Name_Body : constant Name_Id := N + 446;
+ Name_Case : constant Name_Id := N + 447;
+ Name_Constant : constant Name_Id := N + 448;
+ Name_Declare : constant Name_Id := N + 449;
+ Name_Delay : constant Name_Id := N + 450;
+ Name_Do : constant Name_Id := N + 451;
+ Name_Else : constant Name_Id := N + 452;
+ Name_Elsif : constant Name_Id := N + 453;
+ Name_End : constant Name_Id := N + 454;
+ Name_Entry : constant Name_Id := N + 455;
+ Name_Exception : constant Name_Id := N + 456;
+ Name_Exit : constant Name_Id := N + 457;
+ Name_For : constant Name_Id := N + 458;
+ Name_Function : constant Name_Id := N + 459;
+ Name_Generic : constant Name_Id := N + 460;
+ Name_Goto : constant Name_Id := N + 461;
+ Name_If : constant Name_Id := N + 462;
+ Name_In : constant Name_Id := N + 463;
+ Name_Is : constant Name_Id := N + 464;
+ Name_Limited : constant Name_Id := N + 465;
+ Name_Loop : constant Name_Id := N + 466;
+ Name_Mod : constant Name_Id := N + 467;
+ Name_New : constant Name_Id := N + 468;
+ Name_Not : constant Name_Id := N + 469;
+ Name_Null : constant Name_Id := N + 470;
+ Name_Of : constant Name_Id := N + 471;
+ Name_Or : constant Name_Id := N + 472;
+ Name_Others : constant Name_Id := N + 473;
+ Name_Out : constant Name_Id := N + 474;
+ Name_Package : constant Name_Id := N + 475;
+ Name_Pragma : constant Name_Id := N + 476;
+ Name_Private : constant Name_Id := N + 477;
+ Name_Procedure : constant Name_Id := N + 478;
+ Name_Raise : constant Name_Id := N + 479;
+ Name_Record : constant Name_Id := N + 480;
+ Name_Rem : constant Name_Id := N + 481;
+ Name_Renames : constant Name_Id := N + 482;
+ Name_Return : constant Name_Id := N + 483;
+ Name_Reverse : constant Name_Id := N + 484;
+ Name_Select : constant Name_Id := N + 485;
+ Name_Separate : constant Name_Id := N + 486;
+ Name_Subtype : constant Name_Id := N + 487;
+ Name_Task : constant Name_Id := N + 488;
+ Name_Terminate : constant Name_Id := N + 489;
+ Name_Then : constant Name_Id := N + 490;
+ Name_Type : constant Name_Id := N + 491;
+ Name_Use : constant Name_Id := N + 492;
+ Name_When : constant Name_Id := N + 493;
+ Name_While : constant Name_Id := N + 494;
+ Name_With : constant Name_Id := N + 495;
+ Name_Xor : constant Name_Id := N + 496;
+
+ -- Names of intrinsic subprograms
+
+ -- Note: Asm is missing from this list, since Asm is a legitimate
+ -- convention name.
+
+ First_Intrinsic_Name : constant Name_Id := N + 497;
+ Name_Divide : constant Name_Id := N + 497;
+ Name_Enclosing_Entity : constant Name_Id := N + 498;
+ Name_Exception_Information : constant Name_Id := N + 499;
+ Name_Exception_Message : constant Name_Id := N + 500;
+ Name_Exception_Name : constant Name_Id := N + 501;
+ Name_File : constant Name_Id := N + 502;
+ Name_Import_Address : constant Name_Id := N + 503;
+ Name_Import_Largest_Value : constant Name_Id := N + 504;
+ Name_Import_Value : constant Name_Id := N + 505;
+ Name_Is_Negative : constant Name_Id := N + 506;
+ Name_Line : constant Name_Id := N + 507;
+ Name_Rotate_Left : constant Name_Id := N + 508;
+ Name_Rotate_Right : constant Name_Id := N + 509;
+ Name_Shift_Left : constant Name_Id := N + 510;
+ Name_Shift_Right : constant Name_Id := N + 511;
+ Name_Shift_Right_Arithmetic : constant Name_Id := N + 512;
+ Name_Source_Location : constant Name_Id := N + 513;
+ Name_Unchecked_Conversion : constant Name_Id := N + 514;
+ Name_Unchecked_Deallocation : constant Name_Id := N + 515;
+ Last_Intrinsic_Name : constant Name_Id := N + 515;
+
+ -- Reserved words used only in Ada 95
+
+ First_95_Reserved_Word : constant Name_Id := N + 516;
+ Name_Abstract : constant Name_Id := N + 516;
+ Name_Aliased : constant Name_Id := N + 517;
+ Name_Protected : constant Name_Id := N + 518;
+ Name_Until : constant Name_Id := N + 519;
+ Name_Requeue : constant Name_Id := N + 520;
+ Name_Tagged : constant Name_Id := N + 521;
+ Last_95_Reserved_Word : constant Name_Id := N + 521;
+
+ subtype Ada_95_Reserved_Words is
+ Name_Id range First_95_Reserved_Word .. Last_95_Reserved_Word;
+
+ -- Miscellaneous names used in semantic checking
+
+ Name_Raise_Exception : constant Name_Id := N + 522;
+
+ -- Reserved words of GNAT Project Files
+
+ Name_Project : constant Name_Id := N + 523;
+ Name_Modifying : constant Name_Id := N + 524;
+ -- Name_External is already declared as N + 243
+
+ -- Names used in GNAT Project Files
+
+ Name_Naming : constant Name_Id := N + 525;
+ Name_Object_Dir : constant Name_Id := N + 526;
+ Name_Source_Dirs : constant Name_Id := N + 527;
+ Name_Specification : constant Name_Id := N + 528;
+ Name_Body_Part : constant Name_Id := N + 529;
+ Name_Specification_Append : constant Name_Id := N + 530;
+ Name_Body_Append : constant Name_Id := N + 531;
+ Name_Separate_Append : constant Name_Id := N + 532;
+ Name_Source_Files : constant Name_Id := N + 533;
+ Name_Source_List_File : constant Name_Id := N + 534;
+ Name_Switches : constant Name_Id := N + 535;
+ Name_Library_Dir : constant Name_Id := N + 536;
+ Name_Library_Name : constant Name_Id := N + 537;
+ Name_Library_Kind : constant Name_Id := N + 538;
+ Name_Library_Version : constant Name_Id := N + 539;
+ Name_Library_Elaboration : constant Name_Id := N + 540;
+
+ Name_Gnatmake : constant Name_Id := N + 541;
+ Name_Gnatls : constant Name_Id := N + 542;
+ Name_Gnatxref : constant Name_Id := N + 543;
+ Name_Gnatfind : constant Name_Id := N + 544;
+ Name_Gnatbind : constant Name_Id := N + 545;
+ Name_Gnatlink : constant Name_Id := N + 546;
+ Name_Compiler : constant Name_Id := N + 547;
+ Name_Binder : constant Name_Id := N + 548;
+ Name_Linker : constant Name_Id := N + 549;
+
+ -- Mark last defined name for consistency check in Snames body
+
+ Last_Predefined_Name : constant Name_Id := N + 549;
+
+ subtype Any_Operator_Name is Name_Id range
+ First_Operator_Name .. Last_Operator_Name;
+
+ ------------------------------
+ -- Attribute ID Definitions --
+ ------------------------------
+
+ type Attribute_Id is (
+ Attribute_Abort_Signal,
+ Attribute_Access,
+ Attribute_Address,
+ Attribute_Address_Size,
+ Attribute_Aft,
+ Attribute_Alignment,
+ Attribute_Asm_Input,
+ Attribute_Asm_Output,
+ Attribute_AST_Entry,
+ Attribute_Bit,
+ Attribute_Bit_Order,
+ Attribute_Bit_Position,
+ Attribute_Body_Version,
+ Attribute_Callable,
+ Attribute_Caller,
+ Attribute_Code_Address,
+ Attribute_Component_Size,
+ Attribute_Compose,
+ Attribute_Constrained,
+ Attribute_Count,
+ Attribute_Default_Bit_Order,
+ Attribute_Definite,
+ Attribute_Delta,
+ Attribute_Denorm,
+ Attribute_Digits,
+ Attribute_Elaborated,
+ Attribute_Emax,
+ Attribute_Enum_Rep,
+ Attribute_Epsilon,
+ Attribute_Exponent,
+ Attribute_External_Tag,
+ Attribute_First,
+ Attribute_First_Bit,
+ Attribute_Fixed_Value,
+ Attribute_Fore,
+ Attribute_Has_Discriminants,
+ Attribute_Identity,
+ Attribute_Img,
+ Attribute_Integer_Value,
+ Attribute_Large,
+ Attribute_Last,
+ Attribute_Last_Bit,
+ Attribute_Leading_Part,
+ Attribute_Length,
+ Attribute_Machine_Emax,
+ Attribute_Machine_Emin,
+ Attribute_Machine_Mantissa,
+ Attribute_Machine_Overflows,
+ Attribute_Machine_Radix,
+ Attribute_Machine_Rounds,
+ Attribute_Machine_Size,
+ Attribute_Mantissa,
+ Attribute_Max_Interrupt_Priority,
+ Attribute_Max_Priority,
+ Attribute_Max_Size_In_Storage_Elements,
+ Attribute_Maximum_Alignment,
+ Attribute_Mechanism_Code,
+ Attribute_Model_Emin,
+ Attribute_Model_Epsilon,
+ Attribute_Model_Mantissa,
+ Attribute_Model_Small,
+ Attribute_Modulus,
+ Attribute_Null_Parameter,
+ Attribute_Object_Size,
+ Attribute_Partition_ID,
+ Attribute_Passed_By_Reference,
+ Attribute_Pos,
+ Attribute_Position,
+ Attribute_Range,
+ Attribute_Range_Length,
+ Attribute_Round,
+ Attribute_Safe_Emax,
+ Attribute_Safe_First,
+ Attribute_Safe_Large,
+ Attribute_Safe_Last,
+ Attribute_Safe_Small,
+ Attribute_Scale,
+ Attribute_Scaling,
+ Attribute_Signed_Zeros,
+ Attribute_Size,
+ Attribute_Small,
+ Attribute_Storage_Size,
+ Attribute_Storage_Unit,
+ Attribute_Tag,
+ Attribute_Terminated,
+ Attribute_Tick,
+ Attribute_To_Address,
+ Attribute_Type_Class,
+ Attribute_UET_Address,
+ Attribute_Unbiased_Rounding,
+ Attribute_Unchecked_Access,
+ Attribute_Universal_Literal_String,
+ Attribute_Unrestricted_Access,
+ Attribute_VADS_Size,
+ Attribute_Val,
+ Attribute_Valid,
+ Attribute_Value_Size,
+ Attribute_Version,
+ Attribute_Wchar_T_Size,
+ Attribute_Wide_Width,
+ Attribute_Width,
+ Attribute_Word_Size,
+
+ -- Attributes designating renamable functions
+
+ Attribute_Adjacent,
+ Attribute_Ceiling,
+ Attribute_Copy_Sign,
+ Attribute_Floor,
+ Attribute_Fraction,
+ Attribute_Image,
+ Attribute_Input,
+ Attribute_Machine,
+ Attribute_Max,
+ Attribute_Min,
+ Attribute_Model,
+ Attribute_Pred,
+ Attribute_Remainder,
+ Attribute_Rounding,
+ Attribute_Succ,
+ Attribute_Truncation,
+ Attribute_Value,
+ Attribute_Wide_Image,
+ Attribute_Wide_Value,
+
+ -- Attributes designating procedures
+
+ Attribute_Output,
+ Attribute_Read,
+ Attribute_Write,
+
+ -- Entity attributes (includes type attributes)
+
+ Attribute_Elab_Body,
+ Attribute_Elab_Spec,
+ Attribute_Storage_Pool,
+
+ -- Type attributes
+
+ Attribute_Base,
+ Attribute_Class);
+
+ -------------------------------
+ -- Check Name ID Definitions --
+ -------------------------------
+
+ type Check_Id is (
+ Access_Check,
+ Accessibility_Check,
+ Discriminant_Check,
+ Division_Check,
+ Elaboration_Check,
+ Index_Check,
+ Length_Check,
+ Overflow_Check,
+ Range_Check,
+ Storage_Check,
+ Tag_Check,
+ All_Checks);
+
+ ------------------------------------
+ -- Convention Name ID Definitions --
+ ------------------------------------
+
+ type Convention_Id is (
+
+ -- The conventions that are defined by the RM come first
+
+ Convention_Ada,
+ Convention_Intrinsic,
+ Convention_Entry,
+ Convention_Protected,
+
+ -- The remaining conventions are foreign language conventions
+
+ Convention_Assembler,
+ Convention_C,
+ Convention_COBOL,
+ Convention_CPP,
+ Convention_Fortran,
+ Convention_Java,
+ Convention_Stdcall,
+ Convention_Stubbed);
+
+ -- Note: Conventions C_Pass_By_Copy, External, and Default are all
+ -- treated as synonyms for convention C (with an appropriate flag
+ -- being set in a record type in the case of C_Pass_By_Copy). See
+ -- processing in Sem_Prag for details.
+
+ -- Note: convention Win32 has the same effect as convention Stdcall
+ -- and as a special exception to normal rules is considered to be
+ -- conformant with convention Stdcall. Therefore if the convention
+ -- Win32 is encountered, it is translated into Convention_Stdcall.
+
+ for Convention_Id'Size use 8;
+ -- Plenty of space for expansion
+
+ subtype Foreign_Convention is
+ Convention_Id range Convention_Assembler .. Convention_Stdcall;
+
+ -----------------------------------
+ -- Locking Policy ID Definitions --
+ -----------------------------------
+
+ type Locking_Policy_Id is (
+ Locking_Policy_Inheritance_Locking,
+ Locking_Policy_Ceiling_Locking);
+
+ ---------------------------
+ -- Pragma ID Definitions --
+ ---------------------------
+
+ type Pragma_Id is (
+
+ -- Configuration pragmas
+
+ Pragma_Ada_83,
+ Pragma_Ada_95,
+ Pragma_C_Pass_By_Copy,
+ Pragma_Component_Alignment,
+ Pragma_Discard_Names,
+ Pragma_Elaboration_Checks,
+ Pragma_Eliminate,
+ Pragma_Extend_System,
+ Pragma_Extensions_Allowed,
+ Pragma_External_Name_Casing,
+ Pragma_Float_Representation,
+ Pragma_Initialize_Scalars,
+ Pragma_License,
+ Pragma_Locking_Policy,
+ Pragma_Long_Float,
+ Pragma_No_Run_Time,
+ Pragma_Normalize_Scalars,
+ Pragma_Polling,
+ Pragma_Propagate_Exceptions,
+ Pragma_Queuing_Policy,
+ Pragma_Ravenscar,
+ Pragma_Restricted_Run_Time,
+ Pragma_Restrictions,
+ Pragma_Reviewable,
+ Pragma_Source_File_Name,
+ Pragma_Style_Checks,
+ Pragma_Suppress,
+ Pragma_Task_Dispatching_Policy,
+ Pragma_Unsuppress,
+ Pragma_Use_VADS_Size,
+ Pragma_Warnings,
+ Pragma_Validity_Checks,
+
+ -- Remaining (non-configuration) pragmas
+
+ Pragma_Abort_Defer,
+ Pragma_All_Calls_Remote,
+ Pragma_Annotate,
+ Pragma_Assert,
+ Pragma_Asynchronous,
+ Pragma_Atomic,
+ Pragma_Atomic_Components,
+ Pragma_Attach_Handler,
+ Pragma_Comment,
+ Pragma_Common_Object,
+ Pragma_Complex_Representation,
+ Pragma_Controlled,
+ Pragma_Convention,
+ Pragma_CPP_Class,
+ Pragma_CPP_Constructor,
+ Pragma_CPP_Virtual,
+ Pragma_CPP_Vtable,
+ Pragma_Debug,
+ Pragma_Elaborate,
+ Pragma_Elaborate_All,
+ Pragma_Elaborate_Body,
+ Pragma_Export,
+ Pragma_Export_Exception,
+ Pragma_Export_Function,
+ Pragma_Export_Object,
+ Pragma_Export_Procedure,
+ Pragma_Export_Valued_Procedure,
+ Pragma_Finalize_Storage_Only,
+ Pragma_Ident,
+ Pragma_Import,
+ Pragma_Import_Exception,
+ Pragma_Import_Function,
+ Pragma_Import_Object,
+ Pragma_Import_Procedure,
+ Pragma_Import_Valued_Procedure,
+ Pragma_Inline,
+ Pragma_Inline_Always,
+ Pragma_Inline_Generic,
+ Pragma_Inspection_Point,
+ Pragma_Interface,
+ Pragma_Interface_Name,
+ Pragma_Interrupt_Handler,
+ Pragma_Interrupt_Priority,
+ Pragma_Java_Constructor,
+ Pragma_Java_Interface,
+ Pragma_Link_With,
+ Pragma_Linker_Alias,
+ Pragma_Linker_Options,
+ Pragma_Linker_Section,
+ Pragma_List,
+ Pragma_Machine_Attribute,
+ Pragma_Main,
+ Pragma_Main_Storage,
+ Pragma_Memory_Size,
+ Pragma_No_Return,
+ Pragma_Optimize,
+ Pragma_Pack,
+ Pragma_Page,
+ Pragma_Passive,
+ Pragma_Preelaborate,
+ Pragma_Priority,
+ Pragma_Psect_Object,
+ Pragma_Pure,
+ Pragma_Pure_Function,
+ Pragma_Remote_Call_Interface,
+ Pragma_Remote_Types,
+ Pragma_Share_Generic,
+ Pragma_Shared,
+ Pragma_Shared_Passive,
+ Pragma_Source_Reference,
+ Pragma_Stream_Convert,
+ Pragma_Subtitle,
+ Pragma_Suppress_All,
+ Pragma_Suppress_Debug_Info,
+ Pragma_Suppress_Initialization,
+ Pragma_System_Name,
+ Pragma_Task_Info,
+ Pragma_Task_Name,
+ Pragma_Task_Storage,
+ Pragma_Time_Slice,
+ Pragma_Title,
+ Pragma_Unchecked_Union,
+ Pragma_Unimplemented_Unit,
+ Pragma_Unreserve_All_Interrupts,
+ Pragma_Volatile,
+ Pragma_Volatile_Components,
+ Pragma_Weak_External,
+
+ -- The following pragmas are on their own, out of order, because of
+ -- the special processing required to deal with the fact that their
+ -- names match existing attribute names.
+
+ Pragma_AST_Entry,
+ Pragma_Storage_Size,
+ Pragma_Storage_Unit);
+
+ -----------------------------------
+ -- Queuing Policy ID definitions --
+ -----------------------------------
+
+ type Queuing_Policy_Id is (
+ Queuing_Policy_FIFO_Queuing,
+ Queuing_Policy_Priority_Queuing);
+
+ --------------------------------------------
+ -- Task Dispatching Policy ID definitions --
+ --------------------------------------------
+
+ type Task_Dispatching_Policy_Id is (
+ Task_Dispatching_FIFO_Within_Priorities);
+ -- Id values used to identify task dispatching policies
+
+ -----------------
+ -- Subprograms --
+ -----------------
+
+ procedure Initialize;
+ -- Called to initialize the preset names in the names table.
+
+ function Is_Attribute_Name (N : Name_Id) return Boolean;
+ -- Test to see if the name N is the name of a recognized attribute
+
+ function Is_Entity_Attribute_Name (N : Name_Id) return Boolean;
+ -- Test to see if the name N is the name of a recognized entity attribute,
+ -- i.e. an attribute reference that returns an entity.
+
+ function Is_Procedure_Attribute_Name (N : Name_Id) return Boolean;
+ -- Test to see if the name N is the name of a recognized attribute that
+ -- designates a procedure (and can therefore appear as a statement).
+
+ function Is_Function_Attribute_Name (N : Name_Id) return Boolean;
+ -- Test to see if the name N is the name of a recognized attribute
+ -- that designates a renameable function, and can therefore appear in
+ -- a renaming statement. Note that not all attributes designating
+ -- functions are renamable, in particular, thos returning a universal
+ -- value cannot be renamed.
+
+ function Is_Type_Attribute_Name (N : Name_Id) return Boolean;
+ -- Test to see if the name N is the name of a recognized type attribute,
+ -- i.e. an attribute reference that returns a type
+
+ function Is_Check_Name (N : Name_Id) return Boolean;
+ -- Test to see if the name N is the name of a recognized suppress check
+ -- as required by pragma Suppress.
+
+ function Is_Convention_Name (N : Name_Id) return Boolean;
+ -- Test to see if the name N is the name of one of the recognized language
+ -- conventions, as required by pragma Convention, Import, Export, Interface
+
+ function Is_Locking_Policy_Name (N : Name_Id) return Boolean;
+ -- Test to see if the name N is the name of a recognized locking policy
+
+ function Is_Operator_Symbol_Name (N : Name_Id) return Boolean;
+ -- Test to see if the name N is the name of an operator symbol
+
+ function Is_Pragma_Name (N : Name_Id) return Boolean;
+ -- Test to see if the name N is the name of a recognized pragma. Note
+ -- that pragmas AST_Entry, Storage_Size, and Storage_Unit are recognized
+ -- as pragmas by this function even though their names are separate from
+ -- the other pragma names.
+
+ function Is_Queuing_Policy_Name (N : Name_Id) return Boolean;
+ -- Test to see if the name N is the name of a recognized queuing policy
+
+ function Is_Task_Dispatching_Policy_Name (N : Name_Id) return Boolean;
+ -- Test to see if the name N is the name of a recognized
+ -- task dispatching policy
+
+ function Get_Attribute_Id (N : Name_Id) return Attribute_Id;
+ -- Returns Id of attribute corresponding to given name. It is an error to
+ -- call this function with a name that is not the name of a attribute.
+
+ function Get_Convention_Id (N : Name_Id) return Convention_Id;
+ -- Returns Id of language convention corresponding to given name. It is an
+ -- to call this function with a name that is not the name of a check.
+
+ function Get_Check_Id (N : Name_Id) return Check_Id;
+ -- Returns Id of suppress check corresponding to given name. It is an error
+ -- to call this function with a name that is not the name of a check.
+
+ function Get_Locking_Policy_Id (N : Name_Id) return Locking_Policy_Id;
+ -- Returns Id of locking policy corresponding to given name. It is an error
+ -- to call this function with a name that is not the name of a check.
+
+ function Get_Pragma_Id (N : Name_Id) return Pragma_Id;
+ -- Returns Id of pragma corresponding to given name. It is an error to
+ -- call this function with a name that is not the name of a pragma. Note
+ -- that the function also works correctly for names of pragmas that are
+ -- not in the main list of pragma Names (AST_Entry, Storage_Size, and
+ -- Storage_Unit (e.g. Name_Storage_Size returns Pragma_Storage_Size).
+
+ function Get_Queuing_Policy_Id (N : Name_Id) return Queuing_Policy_Id;
+ -- Returns Id of queuing policy corresponding to given name. It is an error
+ -- to call this function with a name that is not the name of a check.
+
+ function Get_Task_Dispatching_Policy_Id
+ (N : Name_Id)
+ return Task_Dispatching_Policy_Id;
+ -- Returns Id of task dispatching policy corresponding to given name. It
+ -- is an error to call this function with a name that is not the name
+ -- of a check.
+
+private
+ pragma Inline (Is_Attribute_Name);
+ pragma Inline (Is_Entity_Attribute_Name);
+ pragma Inline (Is_Type_Attribute_Name);
+ pragma Inline (Is_Check_Name);
+ pragma Inline (Is_Convention_Name);
+ pragma Inline (Is_Locking_Policy_Name);
+ pragma Inline (Is_Operator_Symbol_Name);
+ pragma Inline (Is_Queuing_Policy_Name);
+ pragma Inline (Is_Pragma_Name);
+ pragma Inline (Is_Task_Dispatching_Policy_Name);
+
+end Snames;
--- /dev/null
+/****************************************************************************
+ * *
+ * GNAT COMPILER COMPONENTS *
+ * *
+ * S N A M E S *
+ * *
+ * C Header File *
+ * *
+ * $Revision: 1.2 $
+ * *
+ * 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 is the C file that corresponds to the Ada package specification
+ Snames. It was created manually from the file snames.ads. */
+
+/* Name_Id values */
+
+#define Name_uParent (First_Name_Id + 256 + 0)
+#define Name_uTag (First_Name_Id + 256 + 1)
+#define Name_Off (First_Name_Id + 256 + 2)
+#define Name_Space (First_Name_Id + 256 + 3)
+#define Name_Time (First_Name_Id + 256 + 4)
+#define Name_uInit_Proc (First_Name_Id + 256 + 5)
+#define Name_uSize (First_Name_Id + 256 + 6)
+
+/* Define the function to return one of the numeric values below. Note
+ that it actually returns a char since an enumeration value of less
+ than 256 entries is represented that way in Ada. The operand is a Chars
+ field value. */
+
+#define Get_Attribute_Id snames__get_attribute_id
+extern char Get_Attribute_Id PARAMS ((int));
+
+/* Define the numeric values for the attributes. */
+
+#define Attr_Abort_Signal 0
+#define Attr_Access 1
+#define Attr_Address 2
+#define Attr_Address_Size 3
+#define Attr_Aft 4
+#define Attr_Alignment 5
+#define Attr_Asm_Input 6
+#define Attr_Asm_Output 7
+#define Attr_AST_Entry 8
+#define Attr_Bit 9
+#define Attr_Bit_Order 10
+#define Attr_Bit_Position 11
+#define Attr_Body_Version 12
+#define Attr_Callable 13
+#define Attr_Caller 14
+#define Attr_Code_Address 15
+#define Attr_Component_Size 16
+#define Attr_Compose 17
+#define Attr_Constrained 18
+#define Attr_Count 19
+#define Attr_Default_Bit_Order 20
+#define Attr_Definite 21
+#define Attr_Delta 22
+#define Attr_Denorm 23
+#define Attr_Digits 24
+#define Attr_Elaborated 25
+#define Attr_Emax 26
+#define Attr_Enum_Rep 27
+#define Attr_Epsilon 28
+#define Attr_Exponent 29
+#define Attr_External_Tag 30
+#define Attr_First 31
+#define Attr_First_Bit 32
+#define Attr_Fixed_Value 33
+#define Attr_Fore 34
+#define Attr_Has_Discriminants 35
+#define Attr_Identity 36
+#define Attr_Img 37
+#define Attr_Integer_Value 38
+#define Attr_Large 39
+#define Attr_Last 40
+#define Attr_Last_Bit 41
+#define Attr_Leading_Part 42
+#define Attr_Length 43
+#define Attr_Machine_Emax 44
+#define Attr_Machine_Emin 45
+#define Attr_Machine_Mantissa 46
+#define Attr_Machine_Overflows 47
+#define Attr_Machine_Radix 48
+#define Attr_Machine_Rounds 49
+#define Attr_Machine_Size 50
+#define Attr_Mantissa 51
+#define Attr_Max_Interrupt_Priority 52
+#define Attr_Max_Priority 53
+#define Attr_Max_Size_In_Storage_Elements 54
+#define Attr_Maximum_Alignment 55
+#define Attr_Mechanism_Code 56
+#define Attr_Model_Emin 57
+#define Attr_Model_Epsilon 58
+#define Attr_Model_Mantissa 59
+#define Attr_Model_Small 60
+#define Attr_Modulus 61
+#define Attr_Null_Parameter 62
+#define Attr_Object_Size 63
+#define Attr_Partition_ID 64
+#define Attr_Passed_By_Reference 65
+#define Attr_Pos 66
+#define Attr_Position 67
+#define Attr_Range 68
+#define Attr_Range_Length 69
+#define Attr_Round 70
+#define Attr_Safe_Emax 71
+#define Attr_Safe_First 72
+#define Attr_Safe_Large 73
+#define Attr_Safe_Last 74
+#define Attr_Safe_Small 75
+#define Attr_Scale 76
+#define Attr_Scaling 77
+#define Attr_Signed_Zeros 78
+#define Attr_Size 79
+#define Attr_Small 80
+#define Attr_Storage_Size 81
+#define Attr_Storage_Unit 82
+#define Attr_Tag 83
+#define Attr_Terminated 84
+#define Attr_Tick 85
+#define Attr_To_Address 86
+#define Attr_Type_Class 87
+#define Attr_UET_Address 88
+#define Attr_Unbiased_Rounding 89
+#define Attr_Unchecked_Access 90
+#define Attr_Universal_Literal_String 91
+#define Attr_Unrestricted_Access 92
+#define Attr_VADS_Size 93
+#define Attr_Val 94
+#define Attr_Valid 95
+#define Attr_Value_Size 96
+#define Attr_Version 97
+#define Attr_Wide_Character_Size 98
+#define Attr_Wide_Width 99
+#define Attr_Width 100
+#define Attr_Word_Size 101
+
+#define Attr_Adjacent 102
+#define Attr_Ceiling 103
+#define Attr_Copy_Sign 104
+#define Attr_Floor 105
+#define Attr_Fraction 106
+#define Attr_Image 107
+#define Attr_Input 108
+#define Attr_Machine 109
+#define Attr_Max 110
+#define Attr_Min 111
+#define Attr_Model 112
+#define Attr_Pred 113
+#define Attr_Remainder 114
+#define Attr_Rounding 115
+#define Attr_Succ 116
+#define Attr_Truncation 117
+#define Attr_Value 118
+#define Attr_Wide_Image 119
+#define Attr_Wide_Value 120
+
+#define Attr_Output 121
+#define Attr_Read 122
+#define Attr_Write 123
+
+#define Attr_Elab_Body 124
+#define Attr_Elab_Spec 125
+#define Attr_Storage_Pool 126
+
+#define Attr_Base 127
+#define Attr_Class 128
+
+/* Define the function to check if a Name_Id value is a valid pragma */
+
+#define Is_Pragma_Name snames__is_pragma_name
+extern Boolean Is_Pragma_Name PARAMS ((Name_Id));
+
+/* Define the function to return one of the numeric values below. Note
+ that it actually returns a char since an enumeration value of less
+ than 256 entries is represented that way in Ada. The operand is a Chars
+ field value. */
+
+#define Get_Pragma_Id snames__get_pragma_id
+extern char Get_Pragma_Id PARAMS ((int));
+
+/* Define the numeric values for the pragmas. */
+
+/* Configuration pragmas first */
+
+#define Pragma_Ada_83 0
+#define Pragma_Ada_95 1
+#define Pragma_C_Pass_By_Copy 2
+#define Pragma_Component_Alignment 3
+#define Pragma_Discard_Names 4
+#define Pragma_Elaboration_Checking 5
+#define Pragma_Eliminate 6
+#define Pragma_Extend_System 7
+#define Pragma_Extensions_Allowed 8
+#define Pragma_External_Name_Casing 9
+#define Pragma_Float_Representation 10
+#define Pragma_Initialize 11
+#define Pragma_License 12
+#define Pragma_Locking_Policy 13
+#define Pragma_Long_Float 14
+#define Pragma_No_Run_Time 15
+#define Pragma_Normalize_Scalars 16
+#define Pragma_Polling 17
+#define Pragma_Propagate_Exceptions 18
+#define Pragma_Queuing_Policy 19
+#define Pragma_Ravenscar 20
+#define Pragma_Restricted_Run_Time 21
+#define Pragma_Restrictions 22
+#define Pragma_Reviewable 23
+#define Pragma_Source_File_Name 24
+#define Pragma_Style_Checks 25
+#define Pragma_Suppress 26
+#define Pragma_Task_Dispatching_Policy 27
+#define Pragma_Unsuppress 28
+#define Pragma_Use_VADS_Size 29
+#define Pragma_Validity_Checks 30
+#define Pragma_Warnings 31
+
+/* Remaining pragmas */
+
+#define Pragma_Abort_Defer 32
+#define Pragma_All_Calls_Remote 33
+#define Pragma_Annotate 34
+#define Pragma_Assert 35
+#define Pragma_Asynchronous 36
+#define Pragma_Atomic 37
+#define Pragma_Atomic_Components 38
+#define Pragma_Attach_Handler 39
+#define Pragma_Comment 40
+#define Pragma_Common_Object 41
+#define Pragma_Complex_Representation 42
+#define Pragma_Controlled 43
+#define Pragma_Convention 44
+#define Pragma_CPP_Class 45
+#define Pragma_CPP_Constructor 46
+#define Pragma_CPP_Virtual 47
+#define Pragma_CPP_Vtable 48
+#define Pragma_Debug 49
+#define Pragma_Elaborate 50
+#define Pragma_Elaborate_All 51
+#define Pragma_Elaborate_Body 52
+#define Pragma_Export 53
+#define Pragma_Export_Exception 54
+#define Pragma_Export_Function 55
+#define Pragma_Export_Object 56
+#define Pragma_Export_Procedure 57
+#define Pragma_Export_Valued_Procedure 58
+#define Pragma_Finalize_Storage_Only 59
+#define Pragma_Ident 60
+#define Pragma_Import 61
+#define Pragma_Import_Exception 62
+#define Pragma_Import_Function 63
+#define Pragma_Import_Object 64
+#define Pragma_Import_Procedure 65
+#define Pragma_Import_Valued_Procedure 66
+#define Pragma_Inline 67
+#define Pragma_Inline_Always 68
+#define Pragma_Inline_Generic 69
+#define Pragma_Inspection_Point 70
+#define Pragma_Interface 71
+#define Pragma_Interface_Name 72
+#define Pragma_Interrupt_Handler 73
+#define Pragma_Interrupt_Priority 74
+#define Pragma_Java_Constructor 75
+#define Pragma_Java_Interface 76
+#define Pragma_Link_With 77
+#define Pragma_Linker_Alias 78
+#define Pragma_Linker_Options 79
+#define Pragma_Linker_Section 80
+#define Pragma_List 81
+#define Pragma_Machine_Attribute 82
+#define Pragma_Main 83
+#define Pragma_Main_Storage 84
+#define Pragma_Memory_Size 85
+#define Pragma_No_Return 86
+#define Pragma_Optimize 87
+#define Pragma_Pack 88
+#define Pragma_Page 89
+#define Pragma_Passive 90
+#define Pragma_Preelaborate 91
+#define Pragma_Priority 92
+#define Pragma_Psect_Object 93
+#define Pragma_Pure 94
+#define Pragma_Pure_Function 95
+#define Pragma_Remote_Call_Interface 96
+#define Pragma_Remote_Types 97
+#define Pragma_Share_Generic 98
+#define Pragma_Shared 99
+#define Pragma_Shared_Passive 100
+#define Pragma_Source_Reference 101
+#define Pragma_Stream_Convert 102
+#define Pragma_Subtitle 103
+#define Pragma_Suppress_All 104
+#define Pragma_Suppress_Debug_Info 105
+#define Pragma_Suppress_Initialization 106
+#define Pragma_System_Name 107
+#define Pragma_Task_Info 108
+#define Pragma_Task_Name 109
+#define Pragma_Task_Storage 110
+#define Pragma_Time_Slice 111
+#define Pragma_Title 112
+#define Pragma_Unchecked_Union 113
+#define Pragma_Unimplemented_Unit 114
+#define Pragma_Unreserve_All_Interrupts 115
+#define Pragma_Volatile 116
+#define Pragma_Volatile_Components 117
+#define Pragma_Weak_External 118
+
+/* The following are deliberately out of alphabetical order, see Snames */
+
+#define Pragma_AST_Entry 119
+#define Pragma_Storage_Size 120
+#define Pragma_Storage_Unit 121
+
+/* Define the numeric values for the conventions. */
+
+#define Convention_Ada 0
+#define Convention_Intrinsic 1
+#define Convention_Entry 2
+#define Convention_Protected 3
+#define Convention_Assembler 4
+#define Convention_C 5
+#define Convention_COBOL 6
+#define Convention_CPP 7
+#define Convention_Fortran 8
+#define Convention_Java 9
+#define Convention_Stdcall 10
+#define Convention_Stubbed 11
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S P R I N T --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.205 $
+-- --
+-- 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). --
+-- --
+------------------------------------------------------------------------------
+
+with Atree; use Atree;
+with Casing; use Casing;
+with Debug; use Debug;
+with Einfo; use Einfo;
+with Lib; use Lib;
+with Namet; use Namet;
+with Nlists; use Nlists;
+with Opt; use Opt;
+with Output; use Output;
+with Rtsfind; use Rtsfind;
+with Sinfo; use Sinfo;
+with Sinput; use Sinput;
+with Sinput.L; use Sinput.L;
+with Snames; use Snames;
+with Stand; use Stand;
+with Stringt; use Stringt;
+with Uintp; use Uintp;
+with Uname; use Uname;
+with Urealp; use Urealp;
+
+package body Sprint is
+
+ Debug_Node : Node_Id := Empty;
+ -- If we are in Debug_Generated_Code mode, then this location is set
+ -- to the current node requiring Sloc fixup, until Set_Debug_Sloc is
+ -- called to set the proper value. The call clears it back to Empty.
+
+ Debug_Sloc : Source_Ptr;
+ -- Sloc of first byte of line currently being written if we are
+ -- generating a source debug file.
+
+ Dump_Original_Only : Boolean;
+ -- Set True if the -gnatdo (dump original tree) flag is set
+
+ Dump_Generated_Only : Boolean;
+ -- Set True if the -gnatG (dump generated tree) debug flag is set
+ -- or for Print_Generated_Code (-gnatG) or Dump_Gnerated_Code (-gnatD).
+
+ Dump_Freeze_Null : Boolean;
+ -- Set True if freeze nodes and non-source null statements output
+
+ Indent : Int := 0;
+ -- Number of columns for current line output indentation
+
+ Indent_Annull_Flag : Boolean := False;
+ -- Set True if subsequent Write_Indent call to be ignored, gets reset
+ -- by this call, so it is only active to suppress a single indent call.
+
+ Line_Limit : constant := 72;
+ -- Limit value for chopping long lines
+
+ Freeze_Indent : Int := 0;
+ -- Keep track of freeze indent level (controls blank lines before
+ -- procedures within expression freeze actions)
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ procedure Col_Check (N : Nat);
+ -- Check that at least N characters remain on current line, and if not,
+ -- then start an extra line with two characters extra indentation for
+ -- continuing text on the next line.
+
+ procedure Indent_Annull;
+ -- Causes following call to Write_Indent to be ignored. This is used when
+ -- a higher level node wants to stop a lower level node from starting a
+ -- new line, when it would otherwise be inclined to do so (e.g. the case
+ -- of an accept statement called from an accept alternative with a guard)
+
+ procedure Indent_Begin;
+ -- Increase indentation level
+
+ procedure Indent_End;
+ -- Decrease indentation level
+
+ procedure Print_Eol;
+ -- Terminate current line in line buffer
+
+ procedure Process_TFAI_RR_Flags (Nod : Node_Id);
+ -- Given a divide, multiplication or division node, check the flags
+ -- Treat_Fixed_As_Integer and Rounded_Flags, and if set, output the
+ -- appropriate special syntax characters (# and @).
+
+ procedure Set_Debug_Sloc;
+ -- If Debug_Node is non-empty, this routine sets the appropriate value
+ -- in its Sloc field, from the current location in the debug source file
+ -- that is currently being written. Note that Debug_Node is always empty
+ -- if a debug source file is not being written.
+
+ procedure Sprint_Bar_List (List : List_Id);
+ -- Print the given list with items separated by vertical bars
+
+ procedure Sprint_Node_Actual (Node : Node_Id);
+ -- This routine prints its node argument. It is a lower level routine than
+ -- Sprint_Node, in that it does not bother about rewritten trees.
+
+ procedure Sprint_Node_Sloc (Node : Node_Id);
+ -- Like Sprint_Node, but in addition, in Debug_Generated_Code mode,
+ -- sets the Sloc of the current debug node to be a copy of the Sloc
+ -- of the sprinted node Node. Note that this is done after printing
+ -- Node, so that the Sloc is the proper updated value for the debug file.
+
+ procedure Write_Char_Sloc (C : Character);
+ -- Like Write_Char, except that if C is non-blank, Set_Debug_Sloc is
+ -- called to ensure that the current node has a proper Sloc set.
+
+ procedure Write_Discr_Specs (N : Node_Id);
+ -- Ouput discriminant specification for node, which is any of the type
+ -- declarations that can have discriminants.
+
+ procedure Write_Ekind (E : Entity_Id);
+ -- Write the String corresponding to the Ekind without "E_".
+
+ procedure Write_Id (N : Node_Id);
+ -- N is a node with a Chars field. This procedure writes the name that
+ -- will be used in the generated code associated with the name. For a
+ -- node with no associated entity, this is simply the Chars field. For
+ -- the case where there is an entity associated with the node, we print
+ -- the name associated with the entity (since it may have been encoded).
+ -- One other special case is that an entity has an active external name
+ -- (i.e. an external name present with no address clause), then this
+ -- external name is output.
+
+ function Write_Identifiers (Node : Node_Id) return Boolean;
+ -- Handle node where the grammar has a list of defining identifiers, but
+ -- the tree has a separate declaration for each identifier. Handles the
+ -- printing of the defining identifier, and returns True if the type and
+ -- initialization information is to be printed, False if it is to be
+ -- skipped (the latter case happens when printing defining identifiers
+ -- other than the first in the original tree output case).
+
+ procedure Write_Implicit_Def (E : Entity_Id);
+ pragma Warnings (Off, Write_Implicit_Def);
+ -- Write the definition of the implicit type E according to its Ekind
+ -- For now a debugging procedure, but might be used in the future.
+
+ procedure Write_Indent;
+ -- Start a new line and write indentation spacing
+
+ function Write_Indent_Identifiers (Node : Node_Id) return Boolean;
+ -- Like Write_Identifiers except that each new printed declaration
+ -- is at the start of a new line.
+
+ function Write_Indent_Identifiers_Sloc (Node : Node_Id) return Boolean;
+ -- Like Write_Indent_Identifiers except that in Debug_Generated_Code
+ -- mode, the Sloc of the current debug node is set to point ot the
+ -- first output identifier.
+
+ procedure Write_Indent_Str (S : String);
+ -- Start a new line and write indent spacing followed by given string
+
+ procedure Write_Indent_Str_Sloc (S : String);
+ -- Like Write_Indent_Str, but in addition, in Debug_Generated_Code mode,
+ -- the Sloc of the current node is set to the first non-blank character
+ -- in the string S.
+
+ procedure Write_Name_With_Col_Check (N : Name_Id);
+ -- Write name (using Write_Name) with initial column check, and possible
+ -- initial Write_Indent (to get new line) if current line is too full.
+
+ procedure Write_Name_With_Col_Check_Sloc (N : Name_Id);
+ -- Like Write_Name_With_Col_Check but in addition, in Debug_Generated_Code
+ -- mode, sets Sloc of current debug node to first character of name.
+
+ procedure Write_Operator (N : Node_Id; S : String);
+ -- Like Write_Str_Sloc, used for operators, encloses the string in
+ -- characters {} if the Do_Overflow flag is set on the node N.
+
+ procedure Write_Param_Specs (N : Node_Id);
+ -- Output parameter specifications for node (which is either a function
+ -- or procedure specification with a Parameter_Specifications field)
+
+ procedure Write_Rewrite_Str (S : String);
+ -- Writes out a string (typically containing <<< or >>>}) for a node
+ -- created by rewriting the tree. Suppressed if we are outputting the
+ -- generated code only, since in this case we don't specially mark nodes
+ -- created by rewriting).
+
+ procedure Write_Str_Sloc (S : String);
+ -- Like Write_Str, but sets debug Sloc of current debug node to first
+ -- non-blank character if a current debug node is active.
+
+ procedure Write_Str_With_Col_Check (S : String);
+ -- Write string (using Write_Str) with initial column check, and possible
+ -- initial Write_Indent (to get new line) if current line is too full.
+
+ procedure Write_Str_With_Col_Check_Sloc (S : String);
+ -- Like Write_Str_WIth_Col_Check, but sets debug Sloc of current debug
+ -- node to first non-blank character if a current debug node is active.
+
+ procedure Write_Uint_With_Col_Check_Sloc (U : Uint; Format : UI_Format);
+ -- Write Uint (using UI_Write) with initial column check, and possible
+ -- initial Write_Indent (to get new line) if current line is too full.
+ -- The format parameter determines the output format (see UI_Write).
+ -- In addition, in Debug_Generated_Code mode, sets the current node
+ -- Sloc to the first character of the output value.
+
+ procedure Write_Ureal_With_Col_Check_Sloc (U : Ureal);
+ -- Write Ureal (using same output format as UR_Write) with column checks
+ -- and a possible initial Write_Indent (to get new line) if current line
+ -- is too full. In addition, in Debug_Generated_Code mode, sets the
+ -- current node Sloc to the first character of the output value.
+
+ ---------------
+ -- Col_Check --
+ ---------------
+
+ procedure Col_Check (N : Nat) is
+ begin
+ if N + Column > Line_Limit then
+ Write_Indent_Str (" ");
+ end if;
+ end Col_Check;
+
+ -------------------
+ -- Indent_Annull --
+ -------------------
+
+ procedure Indent_Annull is
+ begin
+ Indent_Annull_Flag := True;
+ end Indent_Annull;
+
+ ------------------
+ -- Indent_Begin --
+ ------------------
+
+ procedure Indent_Begin is
+ begin
+ Indent := Indent + 3;
+ end Indent_Begin;
+
+ ----------------
+ -- Indent_End --
+ ----------------
+
+ procedure Indent_End is
+ begin
+ Indent := Indent - 3;
+ end Indent_End;
+
+ --------
+ -- PG --
+ --------
+
+ procedure PG (Node : Node_Id) is
+ begin
+ Dump_Generated_Only := True;
+ Dump_Original_Only := False;
+ Sprint_Node (Node);
+ Print_Eol;
+ end PG;
+
+ --------
+ -- PO --
+ --------
+
+ procedure PO (Node : Node_Id) is
+ begin
+ Dump_Generated_Only := False;
+ Dump_Original_Only := True;
+ Sprint_Node (Node);
+ Print_Eol;
+ end PO;
+
+ ---------------
+ -- Print_Eol --
+ ---------------
+
+ procedure Print_Eol is
+ begin
+ -- If we are writing a debug source file, then grab it from the
+ -- Output buffer, and reset the column counter (the routines in
+ -- Output never actually write any output for us in this mode,
+ -- they just build line images in Buffer).
+
+ if Debug_Generated_Code then
+ Write_Debug_Line (Buffer (1 .. Natural (Column) - 1), Debug_Sloc);
+ Column := 1;
+
+ -- In normal mode, we call Write_Eol to write the line normally
+
+ else
+ Write_Eol;
+ end if;
+ end Print_Eol;
+
+ ---------------------------
+ -- Process_TFAI_RR_Flags --
+ ---------------------------
+
+ procedure Process_TFAI_RR_Flags (Nod : Node_Id) is
+ begin
+ if Treat_Fixed_As_Integer (Nod) then
+ Write_Char ('#');
+ end if;
+
+ if Rounded_Result (Nod) then
+ Write_Char ('@');
+ end if;
+ end Process_TFAI_RR_Flags;
+
+ --------
+ -- PS --
+ --------
+
+ procedure PS (Node : Node_Id) is
+ begin
+ Dump_Generated_Only := False;
+ Dump_Original_Only := False;
+ Sprint_Node (Node);
+ Print_Eol;
+ end PS;
+
+ --------------------
+ -- Set_Debug_Sloc --
+ --------------------
+
+ procedure Set_Debug_Sloc is
+ begin
+ if Present (Debug_Node) then
+ Set_Sloc (Debug_Node, Debug_Sloc + Source_Ptr (Column - 1));
+ Debug_Node := Empty;
+ end if;
+ end Set_Debug_Sloc;
+
+ -----------------
+ -- Source_Dump --
+ -----------------
+
+ procedure Source_Dump is
+
+ procedure Underline;
+ -- Put underline under string we just printed
+
+ procedure Underline is
+ Col : constant Int := Column;
+
+ begin
+ Print_Eol;
+
+ while Col > Column loop
+ Write_Char ('-');
+ end loop;
+
+ Print_Eol;
+ end Underline;
+
+ -- Start of processing for Tree_Dump.
+
+ begin
+ Dump_Generated_Only := Debug_Flag_G or
+ Print_Generated_Code or
+ Debug_Generated_Code;
+ Dump_Original_Only := Debug_Flag_O;
+ Dump_Freeze_Null := Debug_Flag_S or Debug_Flag_G;
+
+ -- Note that we turn off the tree dump flags immediately, before
+ -- starting the dump. This avoids generating two copies of the dump
+ -- if an abort occurs after printing the dump, and more importantly,
+ -- avoids an infinite loop if an abort occurs during the dump.
+
+ if Debug_Flag_Z then
+ Debug_Flag_Z := False;
+ Print_Eol;
+ Print_Eol;
+ Write_Str ("Source recreated from tree of Standard (spec)");
+ Underline;
+ Sprint_Node (Standard_Package_Node);
+ Print_Eol;
+ Print_Eol;
+ end if;
+
+ if Debug_Flag_S or Dump_Generated_Only or Dump_Original_Only then
+ Debug_Flag_G := False;
+ Debug_Flag_O := False;
+ Debug_Flag_S := False;
+
+ -- Dump requested units
+
+ for U in Main_Unit .. Last_Unit loop
+
+ -- Dump all units if -gnatdf set, otherwise we dump only
+ -- the source files that are in the extended main source.
+
+ if Debug_Flag_F
+ or else In_Extended_Main_Source_Unit (Cunit_Entity (U))
+ then
+ -- If we are generating debug files, setup to write them
+
+ if Debug_Generated_Code then
+ Create_Debug_Source (Source_Index (U), Debug_Sloc);
+ Sprint_Node (Cunit (U));
+ Print_Eol;
+ Close_Debug_Source;
+
+ -- Normal output to standard output file
+
+ else
+ Write_Str ("Source recreated from tree for ");
+ Write_Unit_Name (Unit_Name (U));
+ Underline;
+ Sprint_Node (Cunit (U));
+ Write_Eol;
+ Write_Eol;
+ end if;
+ end if;
+ end loop;
+ end if;
+ end Source_Dump;
+
+ ---------------------
+ -- Sprint_Bar_List --
+ ---------------------
+
+ procedure Sprint_Bar_List (List : List_Id) is
+ Node : Node_Id;
+
+ begin
+ if Is_Non_Empty_List (List) then
+ Node := First (List);
+
+ loop
+ Sprint_Node (Node);
+ Next (Node);
+ exit when Node = Empty;
+ Write_Str (" | ");
+ end loop;
+ end if;
+ end Sprint_Bar_List;
+
+ -----------------------
+ -- Sprint_Comma_List --
+ -----------------------
+
+ procedure Sprint_Comma_List (List : List_Id) is
+ Node : Node_Id;
+
+ begin
+ if Is_Non_Empty_List (List) then
+ Node := First (List);
+
+ loop
+ Sprint_Node (Node);
+ Next (Node);
+ exit when Node = Empty;
+
+ if not Is_Rewrite_Insertion (Node)
+ or else not Dump_Original_Only
+ then
+ Write_Str (", ");
+ end if;
+
+ end loop;
+ end if;
+ end Sprint_Comma_List;
+
+ --------------------------
+ -- Sprint_Indented_List --
+ --------------------------
+
+ procedure Sprint_Indented_List (List : List_Id) is
+ begin
+ Indent_Begin;
+ Sprint_Node_List (List);
+ Indent_End;
+ end Sprint_Indented_List;
+
+ -----------------
+ -- Sprint_Node --
+ -----------------
+
+ procedure Sprint_Node (Node : Node_Id) is
+ begin
+ if Is_Rewrite_Insertion (Node) then
+ if not Dump_Original_Only then
+
+ -- For special cases of nodes that always output <<< >>>
+ -- do not duplicate the output at this point.
+
+ if Nkind (Node) = N_Freeze_Entity
+ or else Nkind (Node) = N_Implicit_Label_Declaration
+ then
+ Sprint_Node_Actual (Node);
+
+ -- Normal case where <<< >>> may be required
+
+ else
+ Write_Rewrite_Str ("<<<");
+ Sprint_Node_Actual (Node);
+ Write_Rewrite_Str (">>>");
+ end if;
+ end if;
+
+ elsif Is_Rewrite_Substitution (Node) then
+
+ -- Case of dump generated only
+
+ if Dump_Generated_Only then
+ Sprint_Node_Actual (Node);
+
+ -- Case of dump original only
+
+ elsif Dump_Original_Only then
+ Sprint_Node_Actual (Original_Node (Node));
+
+ -- Case of both being dumped
+
+ else
+ Sprint_Node_Actual (Original_Node (Node));
+ Write_Rewrite_Str ("<<<");
+ Sprint_Node_Actual (Node);
+ Write_Rewrite_Str (">>>");
+ end if;
+
+ else
+ Sprint_Node_Actual (Node);
+ end if;
+ end Sprint_Node;
+
+ ------------------------
+ -- Sprint_Node_Actual --
+ ------------------------
+
+ procedure Sprint_Node_Actual (Node : Node_Id) is
+ Save_Debug_Node : constant Node_Id := Debug_Node;
+
+ begin
+ if Node = Empty then
+ return;
+ end if;
+
+ for J in 1 .. Paren_Count (Node) loop
+ Write_Str_With_Col_Check ("(");
+ end loop;
+
+ -- Setup node for Sloc fixup if writing a debug source file. Note
+ -- that we take care of any previous node not yet properly set.
+
+ if Debug_Generated_Code then
+ Debug_Node := Node;
+ end if;
+
+ if Nkind (Node) in N_Subexpr
+ and then Do_Range_Check (Node)
+ then
+ Write_Str_With_Col_Check ("{");
+ end if;
+
+ -- Select print circuit based on node kind
+
+ case Nkind (Node) is
+
+ when N_Abort_Statement =>
+ Write_Indent_Str_Sloc ("abort ");
+ Sprint_Comma_List (Names (Node));
+ Write_Char (';');
+
+ when N_Abortable_Part =>
+ Set_Debug_Sloc;
+ Write_Str_Sloc ("abort ");
+ Sprint_Indented_List (Statements (Node));
+
+ when N_Abstract_Subprogram_Declaration =>
+ Write_Indent;
+ Sprint_Node (Specification (Node));
+ Write_Str_With_Col_Check (" is ");
+ Write_Str_Sloc ("abstract;");
+
+ when N_Accept_Alternative =>
+ Sprint_Node_List (Pragmas_Before (Node));
+
+ if Present (Condition (Node)) then
+ Write_Indent_Str ("when ");
+ Sprint_Node (Condition (Node));
+ Write_Str (" => ");
+ Indent_Annull;
+ end if;
+
+ Sprint_Node_Sloc (Accept_Statement (Node));
+ Sprint_Node_List (Statements (Node));
+
+ when N_Accept_Statement =>
+ Write_Indent_Str_Sloc ("accept ");
+ Write_Id (Entry_Direct_Name (Node));
+
+ if Present (Entry_Index (Node)) then
+ Write_Str_With_Col_Check (" (");
+ Sprint_Node (Entry_Index (Node));
+ Write_Char (')');
+ end if;
+
+ Write_Param_Specs (Node);
+
+ if Present (Handled_Statement_Sequence (Node)) then
+ Write_Str_With_Col_Check (" do");
+ Sprint_Node (Handled_Statement_Sequence (Node));
+ Write_Indent_Str ("end ");
+ Write_Id (Entry_Direct_Name (Node));
+ end if;
+
+ Write_Char (';');
+
+ when N_Access_Definition =>
+ Write_Str_With_Col_Check_Sloc ("access ");
+ Sprint_Node (Subtype_Mark (Node));
+
+ when N_Access_Function_Definition =>
+ Write_Str_With_Col_Check_Sloc ("access ");
+
+ if Protected_Present (Node) then
+ Write_Str_With_Col_Check ("protected ");
+ end if;
+
+ Write_Str_With_Col_Check ("function");
+ Write_Param_Specs (Node);
+ Write_Str_With_Col_Check (" return ");
+ Sprint_Node (Subtype_Mark (Node));
+
+ when N_Access_Procedure_Definition =>
+ Write_Str_With_Col_Check_Sloc ("access ");
+
+ if Protected_Present (Node) then
+ Write_Str_With_Col_Check ("protected ");
+ end if;
+
+ Write_Str_With_Col_Check ("procedure");
+ Write_Param_Specs (Node);
+
+ when N_Access_To_Object_Definition =>
+ Write_Str_With_Col_Check_Sloc ("access ");
+
+ if All_Present (Node) then
+ Write_Str_With_Col_Check ("all ");
+ elsif Constant_Present (Node) then
+ Write_Str_With_Col_Check ("constant ");
+ end if;
+
+ Sprint_Node (Subtype_Indication (Node));
+
+ when N_Aggregate =>
+ if Null_Record_Present (Node) then
+ Write_Str_With_Col_Check_Sloc ("(null record)");
+
+ else
+ Write_Str_With_Col_Check_Sloc ("(");
+
+ if Present (Expressions (Node)) then
+ Sprint_Comma_List (Expressions (Node));
+
+ if Present (Component_Associations (Node)) then
+ Write_Str (", ");
+ end if;
+ end if;
+
+ if Present (Component_Associations (Node)) then
+ Indent_Begin;
+
+ declare
+ Nd : Node_Id;
+
+ begin
+ Nd := First (Component_Associations (Node));
+
+ loop
+ Write_Indent;
+ Sprint_Node (Nd);
+ Next (Nd);
+ exit when No (Nd);
+
+ if not Is_Rewrite_Insertion (Nd)
+ or else not Dump_Original_Only
+ then
+ Write_Str (", ");
+ end if;
+ end loop;
+ end;
+
+ Indent_End;
+ end if;
+
+ Write_Char (')');
+ end if;
+
+ when N_Allocator =>
+ Write_Str_With_Col_Check_Sloc ("new ");
+ Sprint_Node (Expression (Node));
+
+ if Present (Storage_Pool (Node)) then
+ Write_Str_With_Col_Check ("[storage_pool = ");
+ Sprint_Node (Storage_Pool (Node));
+ Write_Char (']');
+ end if;
+
+ when N_And_Then =>
+ Sprint_Node (Left_Opnd (Node));
+ Write_Str_Sloc (" and then ");
+ Sprint_Node (Right_Opnd (Node));
+
+ when N_At_Clause =>
+ Write_Indent_Str_Sloc ("for ");
+ Write_Id (Identifier (Node));
+ Write_Str_With_Col_Check (" use at ");
+ Sprint_Node (Expression (Node));
+ Write_Char (';');
+
+ when N_Assignment_Statement =>
+ Write_Indent;
+ Sprint_Node (Name (Node));
+ Write_Str_Sloc (" := ");
+ Sprint_Node (Expression (Node));
+ Write_Char (';');
+
+ when N_Asynchronous_Select =>
+ Write_Indent_Str_Sloc ("select");
+ Indent_Begin;
+ Sprint_Node (Triggering_Alternative (Node));
+ Indent_End;
+
+ -- Note: let the printing of Abortable_Part handle outputting
+ -- the ABORT keyword, so that the Slco can be set correctly.
+
+ Write_Indent_Str ("then ");
+ Sprint_Node (Abortable_Part (Node));
+ Write_Indent_Str ("end select;");
+
+ when N_Attribute_Definition_Clause =>
+ Write_Indent_Str_Sloc ("for ");
+ Sprint_Node (Name (Node));
+ Write_Char (''');
+ Write_Name_With_Col_Check (Chars (Node));
+ Write_Str_With_Col_Check (" use ");
+ Sprint_Node (Expression (Node));
+ Write_Char (';');
+
+ when N_Attribute_Reference =>
+ if Is_Procedure_Attribute_Name (Attribute_Name (Node)) then
+ Write_Indent;
+ end if;
+
+ Sprint_Node (Prefix (Node));
+ Write_Char_Sloc (''');
+ Write_Name_With_Col_Check (Attribute_Name (Node));
+ Sprint_Paren_Comma_List (Expressions (Node));
+
+ if Is_Procedure_Attribute_Name (Attribute_Name (Node)) then
+ Write_Char (';');
+ end if;
+
+ when N_Block_Statement =>
+ Write_Indent;
+
+ if Present (Identifier (Node))
+ and then (not Has_Created_Identifier (Node)
+ or else not Dump_Original_Only)
+ then
+ Write_Rewrite_Str ("<<<");
+ Write_Id (Identifier (Node));
+ Write_Str (" : ");
+ Write_Rewrite_Str (">>>");
+ end if;
+
+ if Present (Declarations (Node)) then
+ Write_Str_With_Col_Check_Sloc ("declare");
+ Sprint_Indented_List (Declarations (Node));
+ Write_Indent;
+ end if;
+
+ Write_Str_With_Col_Check_Sloc ("begin");
+ Sprint_Node (Handled_Statement_Sequence (Node));
+ Write_Indent_Str ("end");
+
+ if Present (Identifier (Node))
+ and then (not Has_Created_Identifier (Node)
+ or else not Dump_Original_Only)
+ then
+ Write_Rewrite_Str ("<<<");
+ Write_Char (' ');
+ Write_Id (Identifier (Node));
+ Write_Rewrite_Str (">>>");
+ end if;
+
+ Write_Char (';');
+
+ when N_Case_Statement =>
+ Write_Indent_Str_Sloc ("case ");
+ Sprint_Node (Expression (Node));
+ Write_Str (" is");
+ Sprint_Indented_List (Alternatives (Node));
+ Write_Indent_Str ("end case;");
+
+ when N_Case_Statement_Alternative =>
+ Write_Indent_Str_Sloc ("when ");
+ Sprint_Bar_List (Discrete_Choices (Node));
+ Write_Str (" => ");
+ Sprint_Indented_List (Statements (Node));
+
+ when N_Character_Literal =>
+ if Column > 70 then
+ Write_Indent_Str (" ");
+ end if;
+
+ Write_Char_Sloc (''');
+ Write_Char_Code (Char_Literal_Value (Node));
+ Write_Char (''');
+
+ when N_Code_Statement =>
+ Write_Indent;
+ Set_Debug_Sloc;
+ Sprint_Node (Expression (Node));
+ Write_Char (';');
+
+ when N_Compilation_Unit =>
+ Sprint_Node_List (Context_Items (Node));
+ Sprint_Opt_Node_List (Declarations (Aux_Decls_Node (Node)));
+
+ if Private_Present (Node) then
+ Write_Indent_Str ("private ");
+ Indent_Annull;
+ end if;
+
+ Sprint_Node_Sloc (Unit (Node));
+
+ if Present (Actions (Aux_Decls_Node (Node)))
+ or else
+ Present (Pragmas_After (Aux_Decls_Node (Node)))
+ then
+ Write_Indent;
+ end if;
+
+ Sprint_Opt_Node_List (Actions (Aux_Decls_Node (Node)));
+ Sprint_Opt_Node_List (Pragmas_After (Aux_Decls_Node (Node)));
+
+ when N_Compilation_Unit_Aux =>
+ null; -- nothing to do, never used, see above
+
+ when N_Component_Association =>
+ Set_Debug_Sloc;
+ Sprint_Bar_List (Choices (Node));
+ Write_Str (" => ");
+ Sprint_Node (Expression (Node));
+
+ when N_Component_Clause =>
+ Write_Indent;
+ Sprint_Node (Component_Name (Node));
+ Write_Str_Sloc (" at ");
+ Sprint_Node (Position (Node));
+ Write_Char (' ');
+ Write_Str_With_Col_Check ("range ");
+ Sprint_Node (First_Bit (Node));
+ Write_Str (" .. ");
+ Sprint_Node (Last_Bit (Node));
+ Write_Char (';');
+
+ when N_Component_Declaration =>
+ if Write_Indent_Identifiers_Sloc (Node) then
+ Write_Str (" : ");
+
+ if Aliased_Present (Node) then
+ Write_Str_With_Col_Check ("aliased ");
+ end if;
+
+ Sprint_Node (Subtype_Indication (Node));
+
+ if Present (Expression (Node)) then
+ Write_Str (" := ");
+ Sprint_Node (Expression (Node));
+ end if;
+
+ Write_Char (';');
+ end if;
+
+ when N_Component_List =>
+ if Null_Present (Node) then
+ Indent_Begin;
+ Write_Indent_Str_Sloc ("null");
+ Write_Char (';');
+ Indent_End;
+
+ else
+ Set_Debug_Sloc;
+ Sprint_Indented_List (Component_Items (Node));
+ Sprint_Node (Variant_Part (Node));
+ end if;
+
+ when N_Conditional_Entry_Call =>
+ Write_Indent_Str_Sloc ("select");
+ Indent_Begin;
+ Sprint_Node (Entry_Call_Alternative (Node));
+ Indent_End;
+ Write_Indent_Str ("else");
+ Sprint_Indented_List (Else_Statements (Node));
+ Write_Indent_Str ("end select;");
+
+ when N_Conditional_Expression =>
+ declare
+ Condition : constant Node_Id := First (Expressions (Node));
+ Then_Expr : constant Node_Id := Next (Condition);
+ Else_Expr : constant Node_Id := Next (Then_Expr);
+
+ begin
+ Write_Str_With_Col_Check_Sloc ("(if ");
+ Sprint_Node (Condition);
+ Write_Str_With_Col_Check (" then ");
+ Sprint_Node (Then_Expr);
+ Write_Str_With_Col_Check (" else ");
+ Sprint_Node (Else_Expr);
+ Write_Char (')');
+ end;
+
+ when N_Constrained_Array_Definition =>
+ Write_Str_With_Col_Check_Sloc ("array ");
+ Sprint_Paren_Comma_List (Discrete_Subtype_Definitions (Node));
+ Write_Str (" of ");
+
+ if Aliased_Present (Node) then
+ Write_Str_With_Col_Check ("aliased ");
+ end if;
+
+ Sprint_Node (Subtype_Indication (Node));
+
+ when N_Decimal_Fixed_Point_Definition =>
+ Write_Str_With_Col_Check_Sloc (" delta ");
+ Sprint_Node (Delta_Expression (Node));
+ Write_Str_With_Col_Check ("digits ");
+ Sprint_Node (Digits_Expression (Node));
+ Sprint_Opt_Node (Real_Range_Specification (Node));
+
+ when N_Defining_Character_Literal =>
+ Write_Name_With_Col_Check_Sloc (Chars (Node));
+
+ when N_Defining_Identifier =>
+ Set_Debug_Sloc;
+ Write_Id (Node);
+
+ when N_Defining_Operator_Symbol =>
+ Write_Name_With_Col_Check_Sloc (Chars (Node));
+
+ when N_Defining_Program_Unit_Name =>
+ Set_Debug_Sloc;
+ Sprint_Node (Name (Node));
+ Write_Char ('.');
+ Write_Id (Defining_Identifier (Node));
+
+ when N_Delay_Alternative =>
+ Sprint_Node_List (Pragmas_Before (Node));
+
+ if Present (Condition (Node)) then
+ Write_Indent;
+ Write_Str_With_Col_Check ("when ");
+ Sprint_Node (Condition (Node));
+ Write_Str (" => ");
+ Indent_Annull;
+ end if;
+
+ Sprint_Node_Sloc (Delay_Statement (Node));
+ Sprint_Node_List (Statements (Node));
+
+ when N_Delay_Relative_Statement =>
+ Write_Indent_Str_Sloc ("delay ");
+ Sprint_Node (Expression (Node));
+ Write_Char (';');
+
+ when N_Delay_Until_Statement =>
+ Write_Indent_Str_Sloc ("delay until ");
+ Sprint_Node (Expression (Node));
+ Write_Char (';');
+
+ when N_Delta_Constraint =>
+ Write_Str_With_Col_Check_Sloc ("delta ");
+ Sprint_Node (Delta_Expression (Node));
+ Sprint_Opt_Node (Range_Constraint (Node));
+
+ when N_Derived_Type_Definition =>
+ if Abstract_Present (Node) then
+ Write_Str_With_Col_Check ("abstract ");
+ end if;
+
+ Write_Str_With_Col_Check_Sloc ("new ");
+ Sprint_Node (Subtype_Indication (Node));
+
+ if Present (Record_Extension_Part (Node)) then
+ Write_Str_With_Col_Check (" with ");
+ Sprint_Node (Record_Extension_Part (Node));
+ end if;
+
+ when N_Designator =>
+ Sprint_Node (Name (Node));
+ Write_Char_Sloc ('.');
+ Write_Id (Identifier (Node));
+
+ when N_Digits_Constraint =>
+ Write_Str_With_Col_Check_Sloc ("digits ");
+ Sprint_Node (Digits_Expression (Node));
+ Sprint_Opt_Node (Range_Constraint (Node));
+
+ when N_Discriminant_Association =>
+ Set_Debug_Sloc;
+
+ if Present (Selector_Names (Node)) then
+ Sprint_Bar_List (Selector_Names (Node));
+ Write_Str (" => ");
+ end if;
+
+ Set_Debug_Sloc;
+ Sprint_Node (Expression (Node));
+
+ when N_Discriminant_Specification =>
+ Set_Debug_Sloc;
+
+ if Write_Identifiers (Node) then
+ Write_Str (" : ");
+ Sprint_Node (Discriminant_Type (Node));
+
+ if Present (Expression (Node)) then
+ Write_Str (" := ");
+ Sprint_Node (Expression (Node));
+ end if;
+ else
+ Write_Str (", ");
+ end if;
+
+ when N_Elsif_Part =>
+ Write_Indent_Str_Sloc ("elsif ");
+ Sprint_Node (Condition (Node));
+ Write_Str_With_Col_Check (" then");
+ Sprint_Indented_List (Then_Statements (Node));
+
+ when N_Empty =>
+ null;
+
+ when N_Entry_Body =>
+ Write_Indent_Str_Sloc ("entry ");
+ Write_Id (Defining_Identifier (Node));
+ Sprint_Node (Entry_Body_Formal_Part (Node));
+ Write_Str_With_Col_Check (" is");
+ Sprint_Indented_List (Declarations (Node));
+ Write_Indent_Str ("begin");
+ Sprint_Node (Handled_Statement_Sequence (Node));
+ Write_Indent_Str ("end ");
+ Write_Id (Defining_Identifier (Node));
+ Write_Char (';');
+
+ when N_Entry_Body_Formal_Part =>
+ if Present (Entry_Index_Specification (Node)) then
+ Write_Str_With_Col_Check_Sloc (" (");
+ Sprint_Node (Entry_Index_Specification (Node));
+ Write_Char (')');
+ end if;
+
+ Write_Param_Specs (Node);
+ Write_Str_With_Col_Check_Sloc (" when ");
+ Sprint_Node (Condition (Node));
+
+ when N_Entry_Call_Alternative =>
+ Sprint_Node_List (Pragmas_Before (Node));
+ Sprint_Node_Sloc (Entry_Call_Statement (Node));
+ Sprint_Node_List (Statements (Node));
+
+ when N_Entry_Call_Statement =>
+ Write_Indent;
+ Sprint_Node_Sloc (Name (Node));
+ Sprint_Opt_Paren_Comma_List (Parameter_Associations (Node));
+ Write_Char (';');
+
+ when N_Entry_Declaration =>
+ Write_Indent_Str_Sloc ("entry ");
+ Write_Id (Defining_Identifier (Node));
+
+ if Present (Discrete_Subtype_Definition (Node)) then
+ Write_Str_With_Col_Check (" (");
+ Sprint_Node (Discrete_Subtype_Definition (Node));
+ Write_Char (')');
+ end if;
+
+ Write_Param_Specs (Node);
+ Write_Char (';');
+
+ when N_Entry_Index_Specification =>
+ Write_Str_With_Col_Check_Sloc ("for ");
+ Write_Id (Defining_Identifier (Node));
+ Write_Str_With_Col_Check (" in ");
+ Sprint_Node (Discrete_Subtype_Definition (Node));
+
+ when N_Enumeration_Representation_Clause =>
+ Write_Indent_Str_Sloc ("for ");
+ Write_Id (Identifier (Node));
+ Write_Str_With_Col_Check (" use ");
+ Sprint_Node (Array_Aggregate (Node));
+ Write_Char (';');
+
+ when N_Enumeration_Type_Definition =>
+ Set_Debug_Sloc;
+
+ -- Skip attempt to print Literals field if it's not there and
+ -- we are in package Standard (case of Character, which is
+ -- handled specially (without an explicit literals list).
+
+ if Sloc (Node) > Standard_Location
+ or else Present (Literals (Node))
+ then
+ Sprint_Paren_Comma_List (Literals (Node));
+ end if;
+
+ when N_Error =>
+ Write_Str_With_Col_Check_Sloc ("<error>");
+
+ when N_Exception_Declaration =>
+ if Write_Indent_Identifiers (Node) then
+ Write_Str_With_Col_Check (" : ");
+ Write_Str_Sloc ("exception;");
+ end if;
+
+ when N_Exception_Handler =>
+ Write_Indent_Str_Sloc ("when ");
+
+ if Present (Choice_Parameter (Node)) then
+ Sprint_Node (Choice_Parameter (Node));
+ Write_Str (" : ");
+ end if;
+
+ Sprint_Bar_List (Exception_Choices (Node));
+ Write_Str (" => ");
+ Sprint_Indented_List (Statements (Node));
+
+ when N_Exception_Renaming_Declaration =>
+ Write_Indent;
+ Set_Debug_Sloc;
+ Sprint_Node (Defining_Identifier (Node));
+ Write_Str_With_Col_Check (" : exception renames ");
+ Sprint_Node (Name (Node));
+ Write_Char (';');
+
+ when N_Exit_Statement =>
+ Write_Indent_Str_Sloc ("exit");
+ Sprint_Opt_Node (Name (Node));
+
+ if Present (Condition (Node)) then
+ Write_Str_With_Col_Check (" when ");
+ Sprint_Node (Condition (Node));
+ end if;
+
+ Write_Char (';');
+
+ when N_Explicit_Dereference =>
+ Sprint_Node (Prefix (Node));
+ Write_Char ('.');
+ Write_Str_Sloc ("all");
+
+ when N_Extension_Aggregate =>
+ Write_Str_With_Col_Check_Sloc ("(");
+ Sprint_Node (Ancestor_Part (Node));
+ Write_Str_With_Col_Check (" with ");
+
+ if Null_Record_Present (Node) then
+ Write_Str_With_Col_Check ("null record");
+ else
+ if Present (Expressions (Node)) then
+ Sprint_Comma_List (Expressions (Node));
+
+ if Present (Component_Associations (Node)) then
+ Write_Str (", ");
+ end if;
+ end if;
+
+ if Present (Component_Associations (Node)) then
+ Sprint_Comma_List (Component_Associations (Node));
+ end if;
+ end if;
+
+ Write_Char (')');
+
+ when N_Floating_Point_Definition =>
+ Write_Str_With_Col_Check_Sloc ("digits ");
+ Sprint_Node (Digits_Expression (Node));
+ Sprint_Opt_Node (Real_Range_Specification (Node));
+
+ when N_Formal_Decimal_Fixed_Point_Definition =>
+ Write_Str_With_Col_Check_Sloc ("delta <> digits <>");
+
+ when N_Formal_Derived_Type_Definition =>
+ Write_Str_With_Col_Check_Sloc ("new ");
+ Sprint_Node (Subtype_Mark (Node));
+
+ if Private_Present (Node) then
+ Write_Str_With_Col_Check (" with private");
+ end if;
+
+ when N_Formal_Discrete_Type_Definition =>
+ Write_Str_With_Col_Check_Sloc ("<>");
+
+ when N_Formal_Floating_Point_Definition =>
+ Write_Str_With_Col_Check_Sloc ("digits <>");
+
+ when N_Formal_Modular_Type_Definition =>
+ Write_Str_With_Col_Check_Sloc ("mod <>");
+
+ when N_Formal_Object_Declaration =>
+ Set_Debug_Sloc;
+
+ if Write_Indent_Identifiers (Node) then
+ Write_Str (" : ");
+
+ if In_Present (Node) then
+ Write_Str_With_Col_Check ("in ");
+ end if;
+
+ if Out_Present (Node) then
+ Write_Str_With_Col_Check ("out ");
+ end if;
+
+ Sprint_Node (Subtype_Mark (Node));
+
+ if Present (Expression (Node)) then
+ Write_Str (" := ");
+ Sprint_Node (Expression (Node));
+ end if;
+
+ Write_Char (';');
+ end if;
+
+ when N_Formal_Ordinary_Fixed_Point_Definition =>
+ Write_Str_With_Col_Check_Sloc ("delta <>");
+
+ when N_Formal_Package_Declaration =>
+ Write_Indent_Str_Sloc ("with package ");
+ Write_Id (Defining_Identifier (Node));
+ Write_Str_With_Col_Check (" is new ");
+ Sprint_Node (Name (Node));
+ Write_Str_With_Col_Check (" (<>);");
+
+ when N_Formal_Private_Type_Definition =>
+ if Abstract_Present (Node) then
+ Write_Str_With_Col_Check ("abstract ");
+ end if;
+
+ if Tagged_Present (Node) then
+ Write_Str_With_Col_Check ("tagged ");
+ end if;
+
+ if Limited_Present (Node) then
+ Write_Str_With_Col_Check ("limited ");
+ end if;
+
+ Write_Str_With_Col_Check_Sloc ("private");
+
+ when N_Formal_Signed_Integer_Type_Definition =>
+ Write_Str_With_Col_Check_Sloc ("range <>");
+
+ when N_Formal_Subprogram_Declaration =>
+ Write_Indent_Str_Sloc ("with ");
+ Sprint_Node (Specification (Node));
+
+ if Box_Present (Node) then
+ Write_Str_With_Col_Check (" is <>");
+ elsif Present (Default_Name (Node)) then
+ Write_Str_With_Col_Check (" is ");
+ Sprint_Node (Default_Name (Node));
+ end if;
+
+ Write_Char (';');
+
+ when N_Formal_Type_Declaration =>
+ Write_Indent_Str_Sloc ("type ");
+ Write_Id (Defining_Identifier (Node));
+
+ if Present (Discriminant_Specifications (Node)) then
+ Write_Discr_Specs (Node);
+ elsif Unknown_Discriminants_Present (Node) then
+ Write_Str_With_Col_Check ("(<>)");
+ end if;
+
+ Write_Str_With_Col_Check (" is ");
+ Sprint_Node (Formal_Type_Definition (Node));
+ Write_Char (';');
+
+ when N_Free_Statement =>
+ Write_Indent_Str_Sloc ("free ");
+ Sprint_Node (Expression (Node));
+ Write_Char (';');
+
+ when N_Freeze_Entity =>
+ if Dump_Original_Only then
+ null;
+
+ elsif Present (Actions (Node)) or else Dump_Freeze_Null then
+ Write_Indent;
+ Write_Rewrite_Str ("<<<");
+ Write_Str_With_Col_Check_Sloc ("freeze ");
+ Write_Id (Entity (Node));
+ Write_Str (" [");
+
+ if No (Actions (Node)) then
+ Write_Char (']');
+
+ else
+ Freeze_Indent := Freeze_Indent + 1;
+ Sprint_Indented_List (Actions (Node));
+ Freeze_Indent := Freeze_Indent - 1;
+ Write_Indent_Str ("]");
+ end if;
+
+ Write_Rewrite_Str (">>>");
+ end if;
+
+ when N_Full_Type_Declaration =>
+ Write_Indent_Str_Sloc ("type ");
+ Write_Id (Defining_Identifier (Node));
+ Write_Discr_Specs (Node);
+ Write_Str_With_Col_Check (" is ");
+ Sprint_Node (Type_Definition (Node));
+ Write_Char (';');
+
+ when N_Function_Call =>
+ Set_Debug_Sloc;
+ Sprint_Node (Name (Node));
+ Sprint_Opt_Paren_Comma_List (Parameter_Associations (Node));
+
+ when N_Function_Instantiation =>
+ Write_Indent_Str_Sloc ("function ");
+ Sprint_Node (Defining_Unit_Name (Node));
+ Write_Str_With_Col_Check (" is new ");
+ Sprint_Node (Name (Node));
+ Sprint_Opt_Paren_Comma_List (Generic_Associations (Node));
+ Write_Char (';');
+
+ when N_Function_Specification =>
+ Write_Str_With_Col_Check_Sloc ("function ");
+ Sprint_Node (Defining_Unit_Name (Node));
+ Write_Param_Specs (Node);
+ Write_Str_With_Col_Check (" return ");
+ Sprint_Node (Subtype_Mark (Node));
+
+ when N_Generic_Association =>
+ Set_Debug_Sloc;
+
+ if Present (Selector_Name (Node)) then
+ Sprint_Node (Selector_Name (Node));
+ Write_Str (" => ");
+ end if;
+
+ Sprint_Node (Explicit_Generic_Actual_Parameter (Node));
+
+ when N_Generic_Function_Renaming_Declaration =>
+ Write_Indent_Str_Sloc ("generic function ");
+ Sprint_Node (Defining_Unit_Name (Node));
+ Write_Str_With_Col_Check (" renames ");
+ Sprint_Node (Name (Node));
+ Write_Char (';');
+
+ when N_Generic_Package_Declaration =>
+ Write_Indent;
+ Write_Indent_Str_Sloc ("generic ");
+ Sprint_Indented_List (Generic_Formal_Declarations (Node));
+ Write_Indent;
+ Sprint_Node (Specification (Node));
+ Write_Char (';');
+
+ when N_Generic_Package_Renaming_Declaration =>
+ Write_Indent_Str_Sloc ("generic package ");
+ Sprint_Node (Defining_Unit_Name (Node));
+ Write_Str_With_Col_Check (" renames ");
+ Sprint_Node (Name (Node));
+ Write_Char (';');
+
+ when N_Generic_Procedure_Renaming_Declaration =>
+ Write_Indent_Str_Sloc ("generic procedure ");
+ Sprint_Node (Defining_Unit_Name (Node));
+ Write_Str_With_Col_Check (" renames ");
+ Sprint_Node (Name (Node));
+ Write_Char (';');
+
+ when N_Generic_Subprogram_Declaration =>
+ Write_Indent;
+ Write_Indent_Str_Sloc ("generic ");
+ Sprint_Indented_List (Generic_Formal_Declarations (Node));
+ Write_Indent;
+ Sprint_Node (Specification (Node));
+ Write_Char (';');
+
+ when N_Goto_Statement =>
+ Write_Indent_Str_Sloc ("goto ");
+ Sprint_Node (Name (Node));
+ Write_Char (';');
+
+ if Nkind (Next (Node)) = N_Label then
+ Write_Indent;
+ end if;
+
+ when N_Handled_Sequence_Of_Statements =>
+ Set_Debug_Sloc;
+ Sprint_Indented_List (Statements (Node));
+
+ if Present (Exception_Handlers (Node)) then
+ Write_Indent_Str ("exception");
+ Indent_Begin;
+ Sprint_Node_List (Exception_Handlers (Node));
+ Indent_End;
+ end if;
+
+ if Present (At_End_Proc (Node)) then
+ Write_Indent_Str ("at end");
+ Indent_Begin;
+ Write_Indent;
+ Sprint_Node (At_End_Proc (Node));
+ Write_Char (';');
+ Indent_End;
+ end if;
+
+ when N_Identifier =>
+ Set_Debug_Sloc;
+ Write_Id (Node);
+
+ when N_If_Statement =>
+ Write_Indent_Str_Sloc ("if ");
+ Sprint_Node (Condition (Node));
+ Write_Str_With_Col_Check (" then");
+ Sprint_Indented_List (Then_Statements (Node));
+ Sprint_Opt_Node_List (Elsif_Parts (Node));
+
+ if Present (Else_Statements (Node)) then
+ Write_Indent_Str ("else");
+ Sprint_Indented_List (Else_Statements (Node));
+ end if;
+
+ Write_Indent_Str ("end if;");
+
+ when N_Implicit_Label_Declaration =>
+ if not Dump_Original_Only then
+ Write_Indent;
+ Write_Rewrite_Str ("<<<");
+ Set_Debug_Sloc;
+ Write_Id (Defining_Identifier (Node));
+ Write_Str (" : ");
+ Write_Str_With_Col_Check ("label");
+ Write_Rewrite_Str (">>>");
+ end if;
+
+ when N_In =>
+ Sprint_Node (Left_Opnd (Node));
+ Write_Str_Sloc (" in ");
+ Sprint_Node (Right_Opnd (Node));
+
+ when N_Incomplete_Type_Declaration =>
+ Write_Indent_Str_Sloc ("type ");
+ Write_Id (Defining_Identifier (Node));
+
+ if Present (Discriminant_Specifications (Node)) then
+ Write_Discr_Specs (Node);
+ elsif Unknown_Discriminants_Present (Node) then
+ Write_Str_With_Col_Check ("(<>)");
+ end if;
+
+ Write_Char (';');
+
+ when N_Index_Or_Discriminant_Constraint =>
+ Set_Debug_Sloc;
+ Sprint_Paren_Comma_List (Constraints (Node));
+
+ when N_Indexed_Component =>
+ Sprint_Node_Sloc (Prefix (Node));
+ Sprint_Opt_Paren_Comma_List (Expressions (Node));
+
+ when N_Integer_Literal =>
+ if Print_In_Hex (Node) then
+ Write_Uint_With_Col_Check_Sloc (Intval (Node), Hex);
+ else
+ Write_Uint_With_Col_Check_Sloc (Intval (Node), Auto);
+ end if;
+
+ when N_Iteration_Scheme =>
+ if Present (Condition (Node)) then
+ Write_Str_With_Col_Check_Sloc ("while ");
+ Sprint_Node (Condition (Node));
+ else
+ Write_Str_With_Col_Check_Sloc ("for ");
+ Sprint_Node (Loop_Parameter_Specification (Node));
+ end if;
+
+ Write_Char (' ');
+
+ when N_Itype_Reference =>
+ Write_Indent_Str_Sloc ("reference ");
+ Write_Id (Itype (Node));
+
+ when N_Label =>
+ Write_Indent_Str_Sloc ("<<");
+ Write_Id (Identifier (Node));
+ Write_Str (">>");
+
+ when N_Loop_Parameter_Specification =>
+ Set_Debug_Sloc;
+ Write_Id (Defining_Identifier (Node));
+ Write_Str_With_Col_Check (" in ");
+
+ if Reverse_Present (Node) then
+ Write_Str_With_Col_Check ("reverse ");
+ end if;
+
+ Sprint_Node (Discrete_Subtype_Definition (Node));
+
+ when N_Loop_Statement =>
+ Write_Indent;
+
+ if Present (Identifier (Node))
+ and then (not Has_Created_Identifier (Node)
+ or else not Dump_Original_Only)
+ then
+ Write_Rewrite_Str ("<<<");
+ Write_Id (Identifier (Node));
+ Write_Str (" : ");
+ Write_Rewrite_Str (">>>");
+ Sprint_Node (Iteration_Scheme (Node));
+ Write_Str_With_Col_Check_Sloc ("loop");
+ Sprint_Indented_List (Statements (Node));
+ Write_Indent_Str ("end loop ");
+ Write_Rewrite_Str ("<<<");
+ Write_Id (Identifier (Node));
+ Write_Rewrite_Str (">>>");
+ Write_Char (';');
+
+ else
+ Sprint_Node (Iteration_Scheme (Node));
+ Write_Str_With_Col_Check_Sloc ("loop");
+ Sprint_Indented_List (Statements (Node));
+ Write_Indent_Str ("end loop;");
+ end if;
+
+ when N_Mod_Clause =>
+ Sprint_Node_List (Pragmas_Before (Node));
+ Write_Str_With_Col_Check_Sloc ("at mod ");
+ Sprint_Node (Expression (Node));
+
+ when N_Modular_Type_Definition =>
+ Write_Str_With_Col_Check_Sloc ("mod ");
+ Sprint_Node (Expression (Node));
+
+ when N_Not_In =>
+ Sprint_Node (Left_Opnd (Node));
+ Write_Str_Sloc (" not in ");
+ Sprint_Node (Right_Opnd (Node));
+
+ when N_Null =>
+ Write_Str_With_Col_Check_Sloc ("null");
+
+ when N_Null_Statement =>
+ if Comes_From_Source (Node)
+ or else Dump_Freeze_Null
+ or else not Is_List_Member (Node)
+ or else (No (Prev (Node)) and then No (Next (Node)))
+ then
+ Write_Indent_Str_Sloc ("null;");
+ end if;
+
+ when N_Number_Declaration =>
+ Set_Debug_Sloc;
+
+ if Write_Indent_Identifiers (Node) then
+ Write_Str_With_Col_Check (" : constant ");
+ Write_Str (" := ");
+ Sprint_Node (Expression (Node));
+ Write_Char (';');
+ end if;
+
+ when N_Object_Declaration =>
+
+ -- Put extra blank line before and after if this is a handler
+ -- record or a subprogram descriptor.
+
+ declare
+ Typ : constant Entity_Id := Etype (Defining_Identifier (Node));
+ Exc : constant Boolean :=
+ Is_RTE (Typ, RE_Handler_Record)
+ or else
+ Is_RTE (Typ, RE_Subprogram_Descriptor);
+
+ begin
+ if Exc then
+ Write_Indent;
+ end if;
+
+ Set_Debug_Sloc;
+
+ if Write_Indent_Identifiers (Node) then
+ Write_Str (" : ");
+
+ if Aliased_Present (Node) then
+ Write_Str_With_Col_Check ("aliased ");
+ end if;
+
+ if Constant_Present (Node) then
+ Write_Str_With_Col_Check ("constant ");
+ end if;
+
+ Sprint_Node (Object_Definition (Node));
+
+ if Present (Expression (Node)) then
+ Write_Str (" := ");
+ Sprint_Node (Expression (Node));
+ end if;
+
+ Write_Char (';');
+ end if;
+
+ if Exc then
+ Write_Indent;
+ end if;
+ end;
+
+ when N_Object_Renaming_Declaration =>
+ Write_Indent;
+ Set_Debug_Sloc;
+ Sprint_Node (Defining_Identifier (Node));
+ Write_Str (" : ");
+ Sprint_Node (Subtype_Mark (Node));
+ Write_Str_With_Col_Check (" renames ");
+ Sprint_Node (Name (Node));
+ Write_Char (';');
+
+ when N_Op_Abs =>
+ Write_Operator (Node, "abs ");
+ Sprint_Node (Right_Opnd (Node));
+
+ when N_Op_Add =>
+ Sprint_Node (Left_Opnd (Node));
+ Write_Operator (Node, " + ");
+ Sprint_Node (Right_Opnd (Node));
+
+ when N_Op_And =>
+ Sprint_Node (Left_Opnd (Node));
+ Write_Operator (Node, " and ");
+ Sprint_Node (Right_Opnd (Node));
+
+ when N_Op_Concat =>
+ Sprint_Node (Left_Opnd (Node));
+ Write_Operator (Node, " & ");
+ Sprint_Node (Right_Opnd (Node));
+
+ when N_Op_Divide =>
+ Sprint_Node (Left_Opnd (Node));
+ Write_Char (' ');
+ Process_TFAI_RR_Flags (Node);
+ Write_Operator (Node, "/ ");
+ Sprint_Node (Right_Opnd (Node));
+
+ when N_Op_Eq =>
+ Sprint_Node (Left_Opnd (Node));
+ Write_Operator (Node, " = ");
+ Sprint_Node (Right_Opnd (Node));
+
+ when N_Op_Expon =>
+ Sprint_Node (Left_Opnd (Node));
+ Write_Operator (Node, " ** ");
+ Sprint_Node (Right_Opnd (Node));
+
+ when N_Op_Ge =>
+ Sprint_Node (Left_Opnd (Node));
+ Write_Operator (Node, " >= ");
+ Sprint_Node (Right_Opnd (Node));
+
+ when N_Op_Gt =>
+ Sprint_Node (Left_Opnd (Node));
+ Write_Operator (Node, " > ");
+ Sprint_Node (Right_Opnd (Node));
+
+ when N_Op_Le =>
+ Sprint_Node (Left_Opnd (Node));
+ Write_Operator (Node, " <= ");
+ Sprint_Node (Right_Opnd (Node));
+
+ when N_Op_Lt =>
+ Sprint_Node (Left_Opnd (Node));
+ Write_Operator (Node, " < ");
+ Sprint_Node (Right_Opnd (Node));
+
+ when N_Op_Minus =>
+ Write_Operator (Node, "-");
+ Sprint_Node (Right_Opnd (Node));
+
+ when N_Op_Mod =>
+ Sprint_Node (Left_Opnd (Node));
+
+ if Treat_Fixed_As_Integer (Node) then
+ Write_Str (" #");
+ end if;
+
+ Write_Operator (Node, " mod ");
+ Sprint_Node (Right_Opnd (Node));
+
+ when N_Op_Multiply =>
+ Sprint_Node (Left_Opnd (Node));
+ Write_Char (' ');
+ Process_TFAI_RR_Flags (Node);
+ Write_Operator (Node, "* ");
+ Sprint_Node (Right_Opnd (Node));
+
+ when N_Op_Ne =>
+ Sprint_Node (Left_Opnd (Node));
+ Write_Operator (Node, " /= ");
+ Sprint_Node (Right_Opnd (Node));
+
+ when N_Op_Not =>
+ Write_Operator (Node, "not ");
+ Sprint_Node (Right_Opnd (Node));
+
+ when N_Op_Or =>
+ Sprint_Node (Left_Opnd (Node));
+ Write_Operator (Node, " or ");
+ Sprint_Node (Right_Opnd (Node));
+
+ when N_Op_Plus =>
+ Write_Operator (Node, "+");
+ Sprint_Node (Right_Opnd (Node));
+
+ when N_Op_Rem =>
+ Sprint_Node (Left_Opnd (Node));
+
+ if Treat_Fixed_As_Integer (Node) then
+ Write_Str (" #");
+ end if;
+
+ Write_Operator (Node, " rem ");
+ Sprint_Node (Right_Opnd (Node));
+
+ when N_Op_Shift =>
+ Set_Debug_Sloc;
+ Write_Id (Node);
+ Write_Char ('!');
+ Write_Str_With_Col_Check ("(");
+ Sprint_Node (Left_Opnd (Node));
+ Write_Str (", ");
+ Sprint_Node (Right_Opnd (Node));
+ Write_Char (')');
+
+ when N_Op_Subtract =>
+ Sprint_Node (Left_Opnd (Node));
+ Write_Operator (Node, " - ");
+ Sprint_Node (Right_Opnd (Node));
+
+ when N_Op_Xor =>
+ Sprint_Node (Left_Opnd (Node));
+ Write_Operator (Node, " xor ");
+ Sprint_Node (Right_Opnd (Node));
+
+ when N_Operator_Symbol =>
+ Write_Name_With_Col_Check_Sloc (Chars (Node));
+
+ when N_Ordinary_Fixed_Point_Definition =>
+ Write_Str_With_Col_Check_Sloc ("delta ");
+ Sprint_Node (Delta_Expression (Node));
+ Sprint_Opt_Node (Real_Range_Specification (Node));
+
+ when N_Or_Else =>
+ Sprint_Node (Left_Opnd (Node));
+ Write_Str_Sloc (" or else ");
+ Sprint_Node (Right_Opnd (Node));
+
+ when N_Others_Choice =>
+ if All_Others (Node) then
+ Write_Str_With_Col_Check ("all ");
+ end if;
+
+ Write_Str_With_Col_Check_Sloc ("others");
+
+ when N_Package_Body =>
+ Write_Indent;
+ Write_Indent_Str_Sloc ("package body ");
+ Sprint_Node (Defining_Unit_Name (Node));
+ Write_Str (" is");
+ Sprint_Indented_List (Declarations (Node));
+
+ if Present (Handled_Statement_Sequence (Node)) then
+ Write_Indent_Str ("begin");
+ Sprint_Node (Handled_Statement_Sequence (Node));
+ end if;
+
+ Write_Indent_Str ("end ");
+ Sprint_Node (Defining_Unit_Name (Node));
+ Write_Char (';');
+
+ when N_Package_Body_Stub =>
+ Write_Indent_Str_Sloc ("package body ");
+ Sprint_Node (Defining_Identifier (Node));
+ Write_Str_With_Col_Check (" is separate;");
+
+ when N_Package_Declaration =>
+ Write_Indent;
+ Write_Indent;
+ Sprint_Node_Sloc (Specification (Node));
+ Write_Char (';');
+
+ when N_Package_Instantiation =>
+ Write_Indent;
+ Write_Indent_Str_Sloc ("package ");
+ Sprint_Node (Defining_Unit_Name (Node));
+ Write_Str (" is new ");
+ Sprint_Node (Name (Node));
+ Sprint_Opt_Paren_Comma_List (Generic_Associations (Node));
+ Write_Char (';');
+
+ when N_Package_Renaming_Declaration =>
+ Write_Indent_Str_Sloc ("package ");
+ Sprint_Node (Defining_Unit_Name (Node));
+ Write_Str_With_Col_Check (" renames ");
+ Sprint_Node (Name (Node));
+ Write_Char (';');
+
+ when N_Package_Specification =>
+ Write_Str_With_Col_Check_Sloc ("package ");
+ Sprint_Node (Defining_Unit_Name (Node));
+ Write_Str (" is");
+ Sprint_Indented_List (Visible_Declarations (Node));
+
+ if Present (Private_Declarations (Node)) then
+ Write_Indent_Str ("private");
+ Sprint_Indented_List (Private_Declarations (Node));
+ end if;
+
+ Write_Indent_Str ("end ");
+ Sprint_Node (Defining_Unit_Name (Node));
+
+ when N_Parameter_Association =>
+ Sprint_Node_Sloc (Selector_Name (Node));
+ Write_Str (" => ");
+ Sprint_Node (Explicit_Actual_Parameter (Node));
+
+ when N_Parameter_Specification =>
+ Set_Debug_Sloc;
+
+ if Write_Identifiers (Node) then
+ Write_Str (" : ");
+
+ if In_Present (Node) then
+ Write_Str_With_Col_Check ("in ");
+ end if;
+
+ if Out_Present (Node) then
+ Write_Str_With_Col_Check ("out ");
+ end if;
+
+ Sprint_Node (Parameter_Type (Node));
+
+ if Present (Expression (Node)) then
+ Write_Str (" := ");
+ Sprint_Node (Expression (Node));
+ end if;
+ else
+ Write_Str (", ");
+ end if;
+
+ when N_Pragma =>
+ Write_Indent_Str_Sloc ("pragma ");
+ Write_Name_With_Col_Check (Chars (Node));
+
+ if Present (Pragma_Argument_Associations (Node)) then
+ Sprint_Opt_Paren_Comma_List
+ (Pragma_Argument_Associations (Node));
+ end if;
+
+ Write_Char (';');
+
+ when N_Pragma_Argument_Association =>
+ Set_Debug_Sloc;
+
+ if Chars (Node) /= No_Name then
+ Write_Name_With_Col_Check (Chars (Node));
+ Write_Str (" => ");
+ end if;
+
+ Sprint_Node (Expression (Node));
+
+ when N_Private_Type_Declaration =>
+ Write_Indent_Str_Sloc ("type ");
+ Write_Id (Defining_Identifier (Node));
+
+ if Present (Discriminant_Specifications (Node)) then
+ Write_Discr_Specs (Node);
+ elsif Unknown_Discriminants_Present (Node) then
+ Write_Str_With_Col_Check ("(<>)");
+ end if;
+
+ Write_Str (" is ");
+
+ if Tagged_Present (Node) then
+ Write_Str_With_Col_Check ("tagged ");
+ end if;
+
+ if Limited_Present (Node) then
+ Write_Str_With_Col_Check ("limited ");
+ end if;
+
+ Write_Str_With_Col_Check ("private;");
+
+ when N_Private_Extension_Declaration =>
+ Write_Indent_Str_Sloc ("type ");
+ Write_Id (Defining_Identifier (Node));
+
+ if Present (Discriminant_Specifications (Node)) then
+ Write_Discr_Specs (Node);
+ elsif Unknown_Discriminants_Present (Node) then
+ Write_Str_With_Col_Check ("(<>)");
+ end if;
+
+ Write_Str_With_Col_Check (" is new ");
+ Sprint_Node (Subtype_Indication (Node));
+ Write_Str_With_Col_Check (" with private;");
+
+ when N_Procedure_Call_Statement =>
+ Write_Indent;
+ Set_Debug_Sloc;
+ Sprint_Node (Name (Node));
+ Sprint_Opt_Paren_Comma_List (Parameter_Associations (Node));
+ Write_Char (';');
+
+ when N_Procedure_Instantiation =>
+ Write_Indent_Str_Sloc ("procedure ");
+ Sprint_Node (Defining_Unit_Name (Node));
+ Write_Str_With_Col_Check (" is new ");
+ Sprint_Node (Name (Node));
+ Sprint_Opt_Paren_Comma_List (Generic_Associations (Node));
+ Write_Char (';');
+
+ when N_Procedure_Specification =>
+ Write_Str_With_Col_Check_Sloc ("procedure ");
+ Sprint_Node (Defining_Unit_Name (Node));
+ Write_Param_Specs (Node);
+
+ when N_Protected_Body =>
+ Write_Indent_Str_Sloc ("protected body ");
+ Write_Id (Defining_Identifier (Node));
+ Write_Str (" is");
+ Sprint_Indented_List (Declarations (Node));
+ Write_Indent_Str ("end ");
+ Write_Id (Defining_Identifier (Node));
+ Write_Char (';');
+
+ when N_Protected_Body_Stub =>
+ Write_Indent_Str_Sloc ("protected body ");
+ Write_Id (Defining_Identifier (Node));
+ Write_Str_With_Col_Check (" is separate;");
+
+ when N_Protected_Definition =>
+ Set_Debug_Sloc;
+ Sprint_Indented_List (Visible_Declarations (Node));
+
+ if Present (Private_Declarations (Node)) then
+ Write_Indent_Str ("private");
+ Sprint_Indented_List (Private_Declarations (Node));
+ end if;
+
+ Write_Indent_Str ("end ");
+
+ when N_Protected_Type_Declaration =>
+ Write_Indent_Str_Sloc ("protected type ");
+ Write_Id (Defining_Identifier (Node));
+ Write_Discr_Specs (Node);
+ Write_Str (" is");
+ Sprint_Node (Protected_Definition (Node));
+ Write_Id (Defining_Identifier (Node));
+ Write_Char (';');
+
+ when N_Qualified_Expression =>
+ Sprint_Node (Subtype_Mark (Node));
+ Write_Char_Sloc (''');
+ Sprint_Node (Expression (Node));
+
+ when N_Raise_Constraint_Error =>
+
+ -- This node can be used either as a subexpression or as a
+ -- statement form. The following test is a reasonably reliable
+ -- way to distinguish the two cases.
+
+ if Is_List_Member (Node)
+ and then Nkind (Parent (Node)) not in N_Subexpr
+ then
+ Write_Indent;
+ end if;
+
+ Write_Str_With_Col_Check_Sloc ("[constraint_error");
+
+ if Present (Condition (Node)) then
+ Write_Str_With_Col_Check (" when ");
+ Sprint_Node (Condition (Node));
+ end if;
+
+ Write_Char (']');
+
+ when N_Raise_Program_Error =>
+ Write_Indent;
+ Write_Str_With_Col_Check_Sloc ("[program_error");
+
+ if Present (Condition (Node)) then
+ Write_Str_With_Col_Check (" when ");
+ Sprint_Node (Condition (Node));
+ end if;
+
+ Write_Char (']');
+
+ when N_Raise_Storage_Error =>
+ Write_Indent;
+ Write_Str_With_Col_Check_Sloc ("[storage_error");
+
+ if Present (Condition (Node)) then
+ Write_Str_With_Col_Check (" when ");
+ Sprint_Node (Condition (Node));
+ end if;
+
+ Write_Char (']');
+
+ when N_Raise_Statement =>
+ Write_Indent_Str_Sloc ("raise ");
+ Sprint_Node (Name (Node));
+ Write_Char (';');
+
+ when N_Range =>
+ Sprint_Node (Low_Bound (Node));
+ Write_Str_Sloc (" .. ");
+ Sprint_Node (High_Bound (Node));
+
+ when N_Range_Constraint =>
+ Write_Str_With_Col_Check_Sloc ("range ");
+ Sprint_Node (Range_Expression (Node));
+
+ when N_Real_Literal =>
+ Write_Ureal_With_Col_Check_Sloc (Realval (Node));
+
+ when N_Real_Range_Specification =>
+ Write_Str_With_Col_Check_Sloc ("range ");
+ Sprint_Node (Low_Bound (Node));
+ Write_Str (" .. ");
+ Sprint_Node (High_Bound (Node));
+
+ when N_Record_Definition =>
+ if Abstract_Present (Node) then
+ Write_Str_With_Col_Check ("abstract ");
+ end if;
+
+ if Tagged_Present (Node) then
+ Write_Str_With_Col_Check ("tagged ");
+ end if;
+
+ if Limited_Present (Node) then
+ Write_Str_With_Col_Check ("limited ");
+ end if;
+
+ if Null_Present (Node) then
+ Write_Str_With_Col_Check_Sloc ("null record");
+
+ else
+ Write_Str_With_Col_Check_Sloc ("record");
+ Sprint_Node (Component_List (Node));
+ Write_Indent_Str ("end record");
+ end if;
+
+ when N_Record_Representation_Clause =>
+ Write_Indent_Str_Sloc ("for ");
+ Sprint_Node (Identifier (Node));
+ Write_Str_With_Col_Check (" use record ");
+
+ if Present (Mod_Clause (Node)) then
+ Sprint_Node (Mod_Clause (Node));
+ end if;
+
+ Sprint_Indented_List (Component_Clauses (Node));
+ Write_Indent_Str ("end record;");
+
+ when N_Reference =>
+ Sprint_Node (Prefix (Node));
+ Write_Str_With_Col_Check_Sloc ("'reference");
+
+ when N_Requeue_Statement =>
+ Write_Indent_Str_Sloc ("requeue ");
+ Sprint_Node (Name (Node));
+
+ if Abort_Present (Node) then
+ Write_Str_With_Col_Check (" with abort");
+ end if;
+
+ Write_Char (';');
+
+ when N_Return_Statement =>
+ if Present (Expression (Node)) then
+ Write_Indent_Str_Sloc ("return ");
+ Sprint_Node (Expression (Node));
+ Write_Char (';');
+ else
+ Write_Indent_Str_Sloc ("return;");
+ end if;
+
+ when N_Selective_Accept =>
+ Write_Indent_Str_Sloc ("select");
+
+ declare
+ Alt_Node : Node_Id;
+
+ begin
+ Alt_Node := First (Select_Alternatives (Node));
+ loop
+ Indent_Begin;
+ Sprint_Node (Alt_Node);
+ Indent_End;
+ Next (Alt_Node);
+ exit when No (Alt_Node);
+ Write_Indent_Str ("or");
+ end loop;
+ end;
+
+ if Present (Else_Statements (Node)) then
+ Write_Indent_Str ("else");
+ Sprint_Indented_List (Else_Statements (Node));
+ end if;
+
+ Write_Indent_Str ("end select;");
+
+ when N_Signed_Integer_Type_Definition =>
+ Write_Str_With_Col_Check_Sloc ("range ");
+ Sprint_Node (Low_Bound (Node));
+ Write_Str (" .. ");
+ Sprint_Node (High_Bound (Node));
+
+ when N_Single_Protected_Declaration =>
+ Write_Indent_Str_Sloc ("protected ");
+ Write_Id (Defining_Identifier (Node));
+ Write_Str (" is");
+ Sprint_Node (Protected_Definition (Node));
+ Write_Id (Defining_Identifier (Node));
+ Write_Char (';');
+
+ when N_Single_Task_Declaration =>
+ Write_Indent_Str_Sloc ("task ");
+ Write_Id (Defining_Identifier (Node));
+
+ if Present (Task_Definition (Node)) then
+ Write_Str (" is");
+ Sprint_Node (Task_Definition (Node));
+ Write_Id (Defining_Identifier (Node));
+ end if;
+
+ Write_Char (';');
+
+ when N_Selected_Component | N_Expanded_Name =>
+ Sprint_Node (Prefix (Node));
+ Write_Char_Sloc ('.');
+ Sprint_Node (Selector_Name (Node));
+
+ when N_Slice =>
+ Set_Debug_Sloc;
+ Sprint_Node (Prefix (Node));
+ Write_Str_With_Col_Check (" (");
+ Sprint_Node (Discrete_Range (Node));
+ Write_Char (')');
+
+ when N_String_Literal =>
+ if String_Length (Strval (Node)) + Column > 75 then
+ Write_Indent_Str (" ");
+ end if;
+
+ Set_Debug_Sloc;
+ Write_String_Table_Entry (Strval (Node));
+
+ when N_Subprogram_Body =>
+ if Freeze_Indent = 0 then
+ Write_Indent;
+ end if;
+
+ Write_Indent;
+ Sprint_Node_Sloc (Specification (Node));
+ Write_Str (" is");
+
+ Sprint_Indented_List (Declarations (Node));
+ Write_Indent_Str ("begin");
+ Sprint_Node (Handled_Statement_Sequence (Node));
+
+ Write_Indent_Str ("end ");
+ Sprint_Node (Defining_Unit_Name (Specification (Node)));
+ Write_Char (';');
+
+ if Is_List_Member (Node)
+ and then Present (Next (Node))
+ and then Nkind (Next (Node)) /= N_Subprogram_Body
+ then
+ Write_Indent;
+ end if;
+
+ when N_Subprogram_Body_Stub =>
+ Write_Indent;
+ Sprint_Node_Sloc (Specification (Node));
+ Write_Str_With_Col_Check (" is separate;");
+
+ when N_Subprogram_Declaration =>
+ Write_Indent;
+ Sprint_Node_Sloc (Specification (Node));
+ Write_Char (';');
+
+ when N_Subprogram_Info =>
+ Sprint_Node (Identifier (Node));
+ Write_Str_With_Col_Check_Sloc ("'subprogram_info");
+
+ when N_Subprogram_Renaming_Declaration =>
+ Write_Indent;
+ Sprint_Node (Specification (Node));
+ Write_Str_With_Col_Check_Sloc (" renames ");
+ Sprint_Node (Name (Node));
+ Write_Char (';');
+
+ when N_Subtype_Declaration =>
+ Write_Indent_Str_Sloc ("subtype ");
+ Write_Id (Defining_Identifier (Node));
+ Write_Str (" is ");
+ Sprint_Node (Subtype_Indication (Node));
+ Write_Char (';');
+
+ when N_Subtype_Indication =>
+ Sprint_Node_Sloc (Subtype_Mark (Node));
+ Write_Char (' ');
+ Sprint_Node (Constraint (Node));
+
+ when N_Subunit =>
+ Write_Indent_Str_Sloc ("separate (");
+ Sprint_Node (Name (Node));
+ Write_Char (')');
+ Print_Eol;
+ Sprint_Node (Proper_Body (Node));
+
+ when N_Task_Body =>
+ Write_Indent_Str_Sloc ("task body ");
+ Write_Id (Defining_Identifier (Node));
+ Write_Str (" is");
+ Sprint_Indented_List (Declarations (Node));
+ Write_Indent_Str ("begin");
+ Sprint_Node (Handled_Statement_Sequence (Node));
+ Write_Indent_Str ("end ");
+ Write_Id (Defining_Identifier (Node));
+ Write_Char (';');
+
+ when N_Task_Body_Stub =>
+ Write_Indent_Str_Sloc ("task body ");
+ Write_Id (Defining_Identifier (Node));
+ Write_Str_With_Col_Check (" is separate;");
+
+ when N_Task_Definition =>
+ Set_Debug_Sloc;
+ Sprint_Indented_List (Visible_Declarations (Node));
+
+ if Present (Private_Declarations (Node)) then
+ Write_Indent_Str ("private");
+ Sprint_Indented_List (Private_Declarations (Node));
+ end if;
+
+ Write_Indent_Str ("end ");
+
+ when N_Task_Type_Declaration =>
+ Write_Indent_Str_Sloc ("task type ");
+ Write_Id (Defining_Identifier (Node));
+ Write_Discr_Specs (Node);
+ if Present (Task_Definition (Node)) then
+ Write_Str (" is");
+ Sprint_Node (Task_Definition (Node));
+ Write_Id (Defining_Identifier (Node));
+ end if;
+
+ Write_Char (';');
+
+ when N_Terminate_Alternative =>
+ Sprint_Node_List (Pragmas_Before (Node));
+
+ Write_Indent;
+
+ if Present (Condition (Node)) then
+ Write_Str_With_Col_Check ("when ");
+ Sprint_Node (Condition (Node));
+ Write_Str (" => ");
+ end if;
+
+ Write_Str_With_Col_Check_Sloc ("terminate;");
+ Sprint_Node_List (Pragmas_After (Node));
+
+ when N_Timed_Entry_Call =>
+ Write_Indent_Str_Sloc ("select");
+ Indent_Begin;
+ Sprint_Node (Entry_Call_Alternative (Node));
+ Indent_End;
+ Write_Indent_Str ("or");
+ Indent_Begin;
+ Sprint_Node (Delay_Alternative (Node));
+ Indent_End;
+ Write_Indent_Str ("end select;");
+
+ when N_Triggering_Alternative =>
+ Sprint_Node_List (Pragmas_Before (Node));
+ Sprint_Node_Sloc (Triggering_Statement (Node));
+ Sprint_Node_List (Statements (Node));
+
+ when N_Type_Conversion =>
+ Set_Debug_Sloc;
+ Sprint_Node (Subtype_Mark (Node));
+ Col_Check (4);
+
+ if Conversion_OK (Node) then
+ Write_Char ('?');
+ end if;
+
+ if Float_Truncate (Node) then
+ Write_Char ('^');
+ end if;
+
+ if Rounded_Result (Node) then
+ Write_Char ('@');
+ end if;
+
+ Write_Char ('(');
+ Sprint_Node (Expression (Node));
+ Write_Char (')');
+
+ when N_Unchecked_Expression =>
+ Col_Check (10);
+ Write_Str ("`(");
+ Sprint_Node_Sloc (Expression (Node));
+ Write_Char (')');
+
+ when N_Unchecked_Type_Conversion =>
+ Sprint_Node (Subtype_Mark (Node));
+ Write_Char ('!');
+ Write_Str_With_Col_Check ("(");
+ Sprint_Node_Sloc (Expression (Node));
+ Write_Char (')');
+
+ when N_Unconstrained_Array_Definition =>
+ Write_Str_With_Col_Check_Sloc ("array (");
+
+ declare
+ Node1 : Node_Id;
+
+ begin
+ Node1 := First (Subtype_Marks (Node));
+ loop
+ Sprint_Node (Node1);
+ Write_Str_With_Col_Check (" range <>");
+ Next (Node1);
+ exit when Node1 = Empty;
+ Write_Str (", ");
+ end loop;
+ end;
+
+ Write_Str (") of ");
+
+ if Aliased_Present (Node) then
+ Write_Str_With_Col_Check ("aliased ");
+ end if;
+
+ Sprint_Node (Subtype_Indication (Node));
+
+ when N_Unused_At_Start | N_Unused_At_End =>
+ Write_Indent_Str ("***** Error, unused node encountered *****");
+ Print_Eol;
+
+ when N_Use_Package_Clause =>
+ Write_Indent_Str_Sloc ("use ");
+ Sprint_Comma_List (Names (Node));
+ Write_Char (';');
+
+ when N_Use_Type_Clause =>
+ Write_Indent_Str_Sloc ("use type ");
+ Sprint_Comma_List (Subtype_Marks (Node));
+ Write_Char (';');
+
+ when N_Validate_Unchecked_Conversion =>
+ Write_Indent_Str_Sloc ("validate unchecked_conversion (");
+ Sprint_Node (Source_Type (Node));
+ Write_Str (", ");
+ Sprint_Node (Target_Type (Node));
+ Write_Str (");");
+
+ when N_Variant =>
+ Write_Indent_Str_Sloc ("when ");
+ Sprint_Bar_List (Discrete_Choices (Node));
+ Write_Str (" => ");
+ Sprint_Node (Component_List (Node));
+
+ when N_Variant_Part =>
+ Indent_Begin;
+ Write_Indent_Str_Sloc ("case ");
+ Sprint_Node (Name (Node));
+ Write_Str (" is ");
+ Sprint_Indented_List (Variants (Node));
+ Write_Indent_Str ("end case");
+ Indent_End;
+
+ when N_With_Clause =>
+
+ -- Special test, if we are dumping the original tree only,
+ -- then we want to eliminate the bogus with clauses that
+ -- correspond to the non-existent children of Text_IO.
+
+ if Dump_Original_Only
+ and then Is_Text_IO_Kludge_Unit (Name (Node))
+ then
+ null;
+
+ -- Normal case, output the with clause
+
+ else
+ if First_Name (Node) or else not Dump_Original_Only then
+ Write_Indent_Str ("with ");
+ else
+ Write_Str (", ");
+ end if;
+
+ Sprint_Node_Sloc (Name (Node));
+
+ if Last_Name (Node) or else not Dump_Original_Only then
+ Write_Char (';');
+ end if;
+ end if;
+
+ when N_With_Type_Clause =>
+
+ Write_Indent_Str ("with type ");
+ Sprint_Node_Sloc (Name (Node));
+
+ if Tagged_Present (Node) then
+ Write_Str (" is tagged;");
+ else
+ Write_Str (" is access;");
+ end if;
+
+ end case;
+
+ if Nkind (Node) in N_Subexpr
+ and then Do_Range_Check (Node)
+ then
+ Write_Str ("}");
+ end if;
+
+ for J in 1 .. Paren_Count (Node) loop
+ Write_Char (')');
+ end loop;
+
+ pragma Assert (No (Debug_Node));
+ Debug_Node := Save_Debug_Node;
+ end Sprint_Node_Actual;
+
+ ----------------------
+ -- Sprint_Node_List --
+ ----------------------
+
+ procedure Sprint_Node_List (List : List_Id) is
+ Node : Node_Id;
+
+ begin
+ if Is_Non_Empty_List (List) then
+ Node := First (List);
+
+ loop
+ Sprint_Node (Node);
+ Next (Node);
+ exit when Node = Empty;
+ end loop;
+ end if;
+ end Sprint_Node_List;
+
+ ----------------------
+ -- Sprint_Node_Sloc --
+ ----------------------
+
+ procedure Sprint_Node_Sloc (Node : Node_Id) is
+ begin
+ Sprint_Node (Node);
+
+ if Present (Debug_Node) then
+ Set_Sloc (Debug_Node, Sloc (Node));
+ Debug_Node := Empty;
+ end if;
+ end Sprint_Node_Sloc;
+
+ ---------------------
+ -- Sprint_Opt_Node --
+ ---------------------
+
+ procedure Sprint_Opt_Node (Node : Node_Id) is
+ begin
+ if Present (Node) then
+ Write_Char (' ');
+ Sprint_Node (Node);
+ end if;
+ end Sprint_Opt_Node;
+
+ --------------------------
+ -- Sprint_Opt_Node_List --
+ --------------------------
+
+ procedure Sprint_Opt_Node_List (List : List_Id) is
+ begin
+ if Present (List) then
+ Sprint_Node_List (List);
+ end if;
+ end Sprint_Opt_Node_List;
+
+ ---------------------------------
+ -- Sprint_Opt_Paren_Comma_List --
+ ---------------------------------
+
+ procedure Sprint_Opt_Paren_Comma_List (List : List_Id) is
+ begin
+ if Is_Non_Empty_List (List) then
+ Write_Char (' ');
+ Sprint_Paren_Comma_List (List);
+ end if;
+ end Sprint_Opt_Paren_Comma_List;
+
+ -----------------------------
+ -- Sprint_Paren_Comma_List --
+ -----------------------------
+
+ procedure Sprint_Paren_Comma_List (List : List_Id) is
+ N : Node_Id;
+ Node_Exists : Boolean := False;
+
+ begin
+
+ if Is_Non_Empty_List (List) then
+
+ if Dump_Original_Only then
+ N := First (List);
+
+ while Present (N) loop
+
+ if not Is_Rewrite_Insertion (N) then
+ Node_Exists := True;
+ exit;
+ end if;
+
+ Next (N);
+ end loop;
+
+ if not Node_Exists then
+ return;
+ end if;
+ end if;
+
+ Write_Str_With_Col_Check ("(");
+ Sprint_Comma_List (List);
+ Write_Char (')');
+ end if;
+ end Sprint_Paren_Comma_List;
+
+ ---------------------
+ -- Write_Char_Sloc --
+ ---------------------
+
+ procedure Write_Char_Sloc (C : Character) is
+ begin
+ if Debug_Generated_Code and then C /= ' ' then
+ Set_Debug_Sloc;
+ end if;
+
+ Write_Char (C);
+ end Write_Char_Sloc;
+
+ ------------------------
+ -- Write_Discr_Specs --
+ ------------------------
+
+ procedure Write_Discr_Specs (N : Node_Id) is
+ Specs : List_Id;
+ Spec : Node_Id;
+
+ begin
+ Specs := Discriminant_Specifications (N);
+
+ if Present (Specs) then
+ Write_Str_With_Col_Check (" (");
+ Spec := First (Specs);
+
+ loop
+ Sprint_Node (Spec);
+ Next (Spec);
+ exit when Spec = Empty;
+
+ -- Add semicolon, unless we are printing original tree and the
+ -- next specification is part of a list (but not the first
+ -- element of that list)
+
+ if not Dump_Original_Only or else not Prev_Ids (Spec) then
+ Write_Str ("; ");
+ end if;
+ end loop;
+
+ Write_Char (')');
+ end if;
+ end Write_Discr_Specs;
+
+ -----------------
+ -- Write_Ekind --
+ -----------------
+
+ procedure Write_Ekind (E : Entity_Id) is
+ S : constant String := Entity_Kind'Image (Ekind (E));
+
+ begin
+ Name_Len := S'Length;
+ Name_Buffer (1 .. Name_Len) := S;
+ Set_Casing (Mixed_Case);
+ Write_Str_With_Col_Check (Name_Buffer (1 .. Name_Len));
+ end Write_Ekind;
+
+ --------------
+ -- Write_Id --
+ --------------
+
+ procedure Write_Id (N : Node_Id) is
+ begin
+ -- Case of a defining identifier
+
+ if Nkind (N) = N_Defining_Identifier then
+
+ -- If defining identifier has an interface name (and no
+ -- address clause), then we output the interface name.
+
+ if (Is_Imported (N) or else Is_Exported (N))
+ and then Present (Interface_Name (N))
+ and then No (Address_Clause (N))
+ then
+ String_To_Name_Buffer (Strval (Interface_Name (N)));
+ Write_Str_With_Col_Check (Name_Buffer (1 .. Name_Len));
+
+ -- If no interface name (or inactive because there was
+ -- an address clause), then just output the Chars name.
+
+ else
+ Write_Name_With_Col_Check (Chars (N));
+ end if;
+
+ -- Case of selector of an expanded name where the expanded name
+ -- has an associated entity, output this entity.
+
+ elsif Nkind (Parent (N)) = N_Expanded_Name
+ and then Selector_Name (Parent (N)) = N
+ and then Present (Entity (Parent (N)))
+ then
+ Write_Id (Entity (Parent (N)));
+
+ -- For any other kind of node with an associated entity, output it.
+
+ elsif Nkind (N) in N_Has_Entity
+ and then Present (Entity (N))
+ then
+ Write_Id (Entity (N));
+
+ -- All other cases, we just print the Chars field
+
+ else
+ Write_Name_With_Col_Check (Chars (N));
+ end if;
+ end Write_Id;
+
+ -----------------------
+ -- Write_Identifiers --
+ -----------------------
+
+ function Write_Identifiers (Node : Node_Id) return Boolean is
+ begin
+ Sprint_Node (Defining_Identifier (Node));
+
+ -- The remainder of the declaration must be printed unless we are
+ -- printing the original tree and this is not the last identifier
+
+ return
+ not Dump_Original_Only or else not More_Ids (Node);
+
+ end Write_Identifiers;
+
+ ------------------------
+ -- Write_Implicit_Def --
+ ------------------------
+
+ procedure Write_Implicit_Def (E : Entity_Id) is
+ Ind : Node_Id;
+
+ begin
+ case Ekind (E) is
+ when E_Array_Subtype =>
+ Write_Str_With_Col_Check ("subtype ");
+ Write_Id (E);
+ Write_Str_With_Col_Check (" is ");
+ Write_Id (Base_Type (E));
+ Write_Str_With_Col_Check (" (");
+
+ Ind := First_Index (E);
+
+ while Present (Ind) loop
+ Sprint_Node (Ind);
+ Next_Index (Ind);
+
+ if Present (Ind) then
+ Write_Str (", ");
+ end if;
+ end loop;
+
+ Write_Str (");");
+
+ when E_Signed_Integer_Subtype | E_Enumeration_Subtype =>
+ Write_Str_With_Col_Check ("subtype ");
+ Write_Id (E);
+ Write_Str (" is ");
+ Write_Id (Etype (E));
+ Write_Str_With_Col_Check (" range ");
+ Sprint_Node (Scalar_Range (E));
+ Write_Str (";");
+
+ when others =>
+ Write_Str_With_Col_Check ("type ");
+ Write_Id (E);
+ Write_Str_With_Col_Check (" is <");
+ Write_Ekind (E);
+ Write_Str (">;");
+ end case;
+
+ end Write_Implicit_Def;
+
+ ------------------
+ -- Write_Indent --
+ ------------------
+
+ procedure Write_Indent is
+ begin
+ if Indent_Annull_Flag then
+ Indent_Annull_Flag := False;
+ else
+ Print_Eol;
+ for J in 1 .. Indent loop
+ Write_Char (' ');
+ end loop;
+ end if;
+ end Write_Indent;
+
+ ------------------------------
+ -- Write_Indent_Identifiers --
+ ------------------------------
+
+ function Write_Indent_Identifiers (Node : Node_Id) return Boolean is
+ begin
+ -- We need to start a new line for every node, except in the case
+ -- where we are printing the original tree and this is not the first
+ -- defining identifier in the list.
+
+ if not Dump_Original_Only or else not Prev_Ids (Node) then
+ Write_Indent;
+
+ -- If printing original tree and this is not the first defining
+ -- identifier in the list, then the previous call to this procedure
+ -- printed only the name, and we add a comma to separate the names.
+
+ else
+ Write_Str (", ");
+ end if;
+
+ Sprint_Node (Defining_Identifier (Node));
+
+ -- The remainder of the declaration must be printed unless we are
+ -- printing the original tree and this is not the last identifier
+
+ return
+ not Dump_Original_Only or else not More_Ids (Node);
+
+ end Write_Indent_Identifiers;
+
+ -----------------------------------
+ -- Write_Indent_Identifiers_Sloc --
+ -----------------------------------
+
+ function Write_Indent_Identifiers_Sloc (Node : Node_Id) return Boolean is
+ begin
+ -- We need to start a new line for every node, except in the case
+ -- where we are printing the original tree and this is not the first
+ -- defining identifier in the list.
+
+ if not Dump_Original_Only or else not Prev_Ids (Node) then
+ Write_Indent;
+
+ -- If printing original tree and this is not the first defining
+ -- identifier in the list, then the previous call to this procedure
+ -- printed only the name, and we add a comma to separate the names.
+
+ else
+ Write_Str (", ");
+ end if;
+
+ Set_Debug_Sloc;
+ Sprint_Node (Defining_Identifier (Node));
+
+ -- The remainder of the declaration must be printed unless we are
+ -- printing the original tree and this is not the last identifier
+
+ return
+ not Dump_Original_Only or else not More_Ids (Node);
+
+ end Write_Indent_Identifiers_Sloc;
+
+ ----------------------
+ -- Write_Indent_Str --
+ ----------------------
+
+ procedure Write_Indent_Str (S : String) is
+ begin
+ Write_Indent;
+ Write_Str (S);
+ end Write_Indent_Str;
+
+ ---------------------------
+ -- Write_Indent_Str_Sloc --
+ ---------------------------
+
+ procedure Write_Indent_Str_Sloc (S : String) is
+ begin
+ Write_Indent;
+ Write_Str_Sloc (S);
+ end Write_Indent_Str_Sloc;
+
+ -------------------------------
+ -- Write_Name_With_Col_Check --
+ -------------------------------
+
+ procedure Write_Name_With_Col_Check (N : Name_Id) is
+ J : Natural;
+
+ begin
+ Get_Name_String (N);
+
+ -- Deal with -gnatI which replaces digits in an internal
+ -- name by three dots (e.g. R7b becomes R...b).
+
+ if Debug_Flag_II and then Name_Buffer (1) in 'A' .. 'Z' then
+
+ J := 2;
+ while J < Name_Len loop
+ exit when Name_Buffer (J) not in 'A' .. 'Z';
+ J := J + 1;
+ end loop;
+
+ if Name_Buffer (J) in '0' .. '9' then
+ Write_Str_With_Col_Check (Name_Buffer (1 .. J - 1));
+ Write_Str ("...");
+
+ while J <= Name_Len loop
+ if Name_Buffer (J) not in '0' .. '9' then
+ Write_Str (Name_Buffer (J .. Name_Len));
+ exit;
+
+ else
+ J := J + 1;
+ end if;
+ end loop;
+
+ return;
+ end if;
+ end if;
+
+ -- Fall through for normal case
+
+ Write_Str_With_Col_Check (Name_Buffer (1 .. Name_Len));
+ end Write_Name_With_Col_Check;
+
+ ------------------------------------
+ -- Write_Name_With_Col_Check_Sloc --
+ ------------------------------------
+
+ procedure Write_Name_With_Col_Check_Sloc (N : Name_Id) is
+ begin
+ Get_Name_String (N);
+ Write_Str_With_Col_Check_Sloc (Name_Buffer (1 .. Name_Len));
+ end Write_Name_With_Col_Check_Sloc;
+
+ --------------------
+ -- Write_Operator --
+ --------------------
+
+ procedure Write_Operator (N : Node_Id; S : String) is
+ F : Natural := S'First;
+ T : Natural := S'Last;
+
+ begin
+ if S (F) = ' ' then
+ Write_Char (' ');
+ F := F + 1;
+ end if;
+
+ if S (T) = ' ' then
+ T := T - 1;
+ end if;
+
+ if Do_Overflow_Check (N) then
+ Write_Char ('{');
+ Write_Str_Sloc (S (F .. T));
+ Write_Char ('}');
+ else
+ Write_Str_Sloc (S);
+ end if;
+
+ if S (S'Last) = ' ' then
+ Write_Char (' ');
+ end if;
+ end Write_Operator;
+
+ -----------------------
+ -- Write_Param_Specs --
+ -----------------------
+
+ procedure Write_Param_Specs (N : Node_Id) is
+ Specs : List_Id;
+ Spec : Node_Id;
+ Formal : Node_Id;
+
+ begin
+ Specs := Parameter_Specifications (N);
+
+ if Is_Non_Empty_List (Specs) then
+ Write_Str_With_Col_Check (" (");
+ Spec := First (Specs);
+
+ loop
+ Sprint_Node (Spec);
+ Formal := Defining_Identifier (Spec);
+ Next (Spec);
+ exit when Spec = Empty;
+
+ -- Add semicolon, unless we are printing original tree and the
+ -- next specification is part of a list (but not the first
+ -- element of that list)
+
+ if not Dump_Original_Only or else not Prev_Ids (Spec) then
+ Write_Str ("; ");
+ end if;
+ end loop;
+
+ -- Write out any extra formals
+
+ while Present (Extra_Formal (Formal)) loop
+ Formal := Extra_Formal (Formal);
+ Write_Str ("; ");
+ Write_Name_With_Col_Check (Chars (Formal));
+ Write_Str (" : ");
+ Write_Name_With_Col_Check (Chars (Etype (Formal)));
+ end loop;
+
+ Write_Char (')');
+ end if;
+ end Write_Param_Specs;
+
+ --------------------------
+ -- Write_Rewrite_Str --
+ --------------------------
+
+ procedure Write_Rewrite_Str (S : String) is
+ begin
+ if not Dump_Generated_Only then
+ if S'Length = 3 and then S = ">>>" then
+ Write_Str (">>>");
+ else
+ Write_Str_With_Col_Check (S);
+ end if;
+ end if;
+ end Write_Rewrite_Str;
+
+ --------------------
+ -- Write_Str_Sloc --
+ --------------------
+
+ procedure Write_Str_Sloc (S : String) is
+ begin
+ for J in S'Range loop
+ Write_Char_Sloc (S (J));
+ end loop;
+ end Write_Str_Sloc;
+
+ ------------------------------
+ -- Write_Str_With_Col_Check --
+ ------------------------------
+
+ procedure Write_Str_With_Col_Check (S : String) is
+ begin
+ if Int (S'Last) + Column > Line_Limit then
+ Write_Indent_Str (" ");
+
+ if S (1) = ' ' then
+ Write_Str (S (2 .. S'Length));
+ else
+ Write_Str (S);
+ end if;
+
+ else
+ Write_Str (S);
+ end if;
+ end Write_Str_With_Col_Check;
+
+ -----------------------------------
+ -- Write_Str_With_Col_Check_Sloc --
+ -----------------------------------
+
+ procedure Write_Str_With_Col_Check_Sloc (S : String) is
+ begin
+ if Int (S'Last) + Column > Line_Limit then
+ Write_Indent_Str (" ");
+
+ if S (1) = ' ' then
+ Write_Str_Sloc (S (2 .. S'Length));
+ else
+ Write_Str_Sloc (S);
+ end if;
+
+ else
+ Write_Str_Sloc (S);
+ end if;
+ end Write_Str_With_Col_Check_Sloc;
+
+ ------------------------------------
+ -- Write_Uint_With_Col_Check_Sloc --
+ ------------------------------------
+
+ procedure Write_Uint_With_Col_Check_Sloc (U : Uint; Format : UI_Format) is
+ begin
+ Col_Check (UI_Decimal_Digits_Hi (U));
+ Set_Debug_Sloc;
+ UI_Write (U, Format);
+ end Write_Uint_With_Col_Check_Sloc;
+
+ -------------------------------------
+ -- Write_Ureal_With_Col_Check_Sloc --
+ -------------------------------------
+
+ procedure Write_Ureal_With_Col_Check_Sloc (U : Ureal) is
+ D : constant Uint := Denominator (U);
+ N : constant Uint := Numerator (U);
+
+ begin
+ Col_Check
+ (UI_Decimal_Digits_Hi (D) + UI_Decimal_Digits_Hi (N) + 4);
+ Set_Debug_Sloc;
+ UR_Write (U);
+ end Write_Ureal_With_Col_Check_Sloc;
+
+end Sprint;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S P R I N T --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.44 $
+-- --
+-- Copyright (C) 1992-1999, 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 (source print) contains routines for printing the source
+-- program corresponding to a specified syntax tree. These routines are
+-- intended for debugging use in the compiler (not as a user level pretty
+-- print tool). Only information present in the tree is output (e.g. no
+-- comments are present in the output), and as far as possible we avoid
+-- making any assumptions about the correctness of the tree, so a bad
+-- tree may either blow up on a debugging check, or list incorrect source.
+
+with Types; use Types;
+package Sprint is
+
+ -----------------------
+ -- Syntax Extensions --
+ -----------------------
+
+ -- When the generated tree is printed, it contains constructs that are not
+ -- pure Ada. For convenience, syntactic extensions to Ada have been defined
+ -- purely for the purposes of this printout (they are not recognized by the
+ -- parser)
+
+ -- Allocator new xxx [storage_pool = xxx]
+ -- Cleanup action at end procedure name;
+ -- Conditional expression (if expr then expr else expr)
+ -- Conversion wi Float_Truncate target^(source)
+ -- Convert wi Conversion_OK target?(source)
+ -- Convert wi Rounded_Result target@(source)
+ -- Divide wi Treat_Fixed_As_Integer x #/ y
+ -- Divide wi Rounded_Result x @/ y
+ -- Expression with range check {expression}
+ -- Operator with range check {operator} (e.g. {+})
+ -- Free statement free expr [storage_pool = xxx]
+ -- Freeze entity with freeze actions freeze entityname [ actions ]
+ -- Interpretation interpretation type [, entity]
+ -- Intrinsic calls function-name!(arg, arg, arg)
+ -- Itype reference reference itype
+ -- Label declaration labelname : label
+ -- Mod wi Treat_Fixed_As_Integer x #mod y
+ -- Multiple concatenation expr && expr && expr ... && expr
+ -- Multiply wi Treat_Fixed_As_Integer x #* y
+ -- Multiply wi Rounded_Result x @* y
+ -- Others choice for cleanup when all others
+ -- Raise xxx error [xxx_error [when condition]]
+ -- Rational literal See UR_Write for details
+ -- Rem wi Treat_Fixed_As_Integer x #rem y
+ -- Reference expression'reference
+ -- Shift nodes shift_name!(expr, count)
+ -- Subprogram_Info subprog'Subprogram_Info
+ -- Unchecked conversion target_type!(source_expression)
+ -- Unchecked expression `(expression)
+ -- Validate_Unchecked_Conversion validate unchecked_conversion
+ -- (src-type, target-typ);
+
+ -- Note: the storage_pool parameters for allocators and the free node
+ -- are omitted if the Storage_Pool field is Empty, indicating use of
+ -- the standard default pool.
+
+ -----------------
+ -- Subprograms --
+ -----------------
+
+ procedure Source_Dump;
+ -- This routine is called from the GNAT main program to dump source as
+ -- requested by debug options. The relevant debug options are:
+ -- -ds print source from tree, both original and generated code
+ -- -dg print source from tree, including only the generated code
+ -- -do print source from tree, including only the original code
+ -- -df modify the above to include all units, not just the main unit
+ -- -sz print source from tree for package Standard
+
+ procedure Sprint_Comma_List (List : List_Id);
+ -- Prints the nodes in a list, with separating commas. If the list
+ -- is empty then no output is generated.
+
+ procedure Sprint_Paren_Comma_List (List : List_Id);
+ -- Prints the nodes in a list, surrounded by parentheses, and separated
+ -- by comas. If the list is empty, then no output is generated. A blank
+ -- is output before the initial left parenthesis.
+
+ procedure Sprint_Opt_Paren_Comma_List (List : List_Id);
+ -- Same as normal Sprint_Paren_Comma_List procedure, except that
+ -- an extra blank is output if List is non-empty, and nothing at all is
+ -- printed it the argument is No_List.
+
+ procedure Sprint_Node_List (List : List_Id);
+ -- Prints the nodes in a list with no separating characters. This is used
+ -- in the case of lists of items which are printed on separate lines using
+ -- the current indentation amount. Note that Sprint_Node_List itself
+ -- does not generate any New_Line calls.
+
+ procedure Sprint_Opt_Node_List (List : List_Id);
+ -- Like Sprint_Node_List, but prints nothing if List = No_List.
+
+ procedure Sprint_Indented_List (List : List_Id);
+ -- Like Sprint_Line_List, except that the indentation level is
+ -- increased before outputting the list of items, and then decremented
+ -- (back to its original level) before returning to the caller.
+
+ procedure Sprint_Node (Node : Node_Id);
+ -- Prints a single node. No new lines are output, except as required for
+ -- splitting lines that are too long to fit on a single physical line.
+ -- No output is generated at all if Node is Empty. No trailing or leading
+ -- blank characters are generated.
+
+ procedure Sprint_Opt_Node (Node : Node_Id);
+ -- Same as normal Sprint_Node procedure, except that one leading
+ -- blank is output before the node if it is non-empty.
+
+ procedure PG (Node : Node_Id);
+ -- Print generated source for node N (like -gnatdg output). This is
+ -- intended only for use from gdb for debugging purposes.
+
+ procedure PO (Node : Node_Id);
+ -- Print original source for node N (like -gnatdo output). This is
+ -- intended only for use from gdb for debugging purposes.
+
+ procedure PS (Node : Node_Id);
+ -- Print generated and original source for node N (like -gnatds output).
+ -- This is intended only for use from gdb for debugging purposes.
+
+end Sprint;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S T A N D --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.6 $ --
+-- --
+-- 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. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception 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). --
+-- --
+------------------------------------------------------------------------------
+
+with System; use System;
+with Tree_IO; use Tree_IO;
+
+package body Stand is
+
+ ---------------
+ -- Tree_Read --
+ ---------------
+
+ procedure Tree_Read is
+ begin
+ Tree_Read_Data (Standard_Entity'Address,
+ Standard_Entity_Array_Type'Size / Storage_Unit);
+
+ Tree_Read_Int (Int (Standard_Package_Node));
+ Tree_Read_Int (Int (Last_Standard_Node_Id));
+ Tree_Read_Int (Int (Last_Standard_List_Id));
+ Tree_Read_Int (Int (Standard_Void_Type));
+ Tree_Read_Int (Int (Standard_Exception_Type));
+ Tree_Read_Int (Int (Standard_A_String));
+ Tree_Read_Int (Int (Any_Id));
+ Tree_Read_Int (Int (Any_Type));
+ Tree_Read_Int (Int (Any_Access));
+ Tree_Read_Int (Int (Any_Array));
+ Tree_Read_Int (Int (Any_Boolean));
+ Tree_Read_Int (Int (Any_Character));
+ Tree_Read_Int (Int (Any_Composite));
+ Tree_Read_Int (Int (Any_Discrete));
+ Tree_Read_Int (Int (Any_Fixed));
+ Tree_Read_Int (Int (Any_Integer));
+ Tree_Read_Int (Int (Any_Numeric));
+ Tree_Read_Int (Int (Any_Real));
+ Tree_Read_Int (Int (Any_Scalar));
+ Tree_Read_Int (Int (Any_String));
+ Tree_Read_Int (Int (Universal_Integer));
+ Tree_Read_Int (Int (Universal_Real));
+ Tree_Read_Int (Int (Universal_Fixed));
+ Tree_Read_Int (Int (Standard_Integer_8));
+ Tree_Read_Int (Int (Standard_Integer_16));
+ Tree_Read_Int (Int (Standard_Integer_32));
+ Tree_Read_Int (Int (Standard_Integer_64));
+ Tree_Read_Int (Int (Abort_Signal));
+ Tree_Read_Int (Int (Standard_Op_Rotate_Left));
+ Tree_Read_Int (Int (Standard_Op_Rotate_Right));
+ Tree_Read_Int (Int (Standard_Op_Shift_Left));
+ Tree_Read_Int (Int (Standard_Op_Shift_Right));
+ Tree_Read_Int (Int (Standard_Op_Shift_Right_Arithmetic));
+
+ end Tree_Read;
+
+ ----------------
+ -- Tree_Write --
+ ----------------
+
+ procedure Tree_Write is
+ begin
+ Tree_Write_Data (Standard_Entity'Address,
+ Standard_Entity_Array_Type'Size / Storage_Unit);
+
+ Tree_Write_Int (Int (Standard_Package_Node));
+ Tree_Write_Int (Int (Last_Standard_Node_Id));
+ Tree_Write_Int (Int (Last_Standard_List_Id));
+ Tree_Write_Int (Int (Standard_Void_Type));
+ Tree_Write_Int (Int (Standard_Exception_Type));
+ Tree_Write_Int (Int (Standard_A_String));
+ Tree_Write_Int (Int (Any_Id));
+ Tree_Write_Int (Int (Any_Type));
+ Tree_Write_Int (Int (Any_Access));
+ Tree_Write_Int (Int (Any_Array));
+ Tree_Write_Int (Int (Any_Boolean));
+ Tree_Write_Int (Int (Any_Character));
+ Tree_Write_Int (Int (Any_Composite));
+ Tree_Write_Int (Int (Any_Discrete));
+ Tree_Write_Int (Int (Any_Fixed));
+ Tree_Write_Int (Int (Any_Integer));
+ Tree_Write_Int (Int (Any_Numeric));
+ Tree_Write_Int (Int (Any_Real));
+ Tree_Write_Int (Int (Any_Scalar));
+ Tree_Write_Int (Int (Any_String));
+ Tree_Write_Int (Int (Universal_Integer));
+ Tree_Write_Int (Int (Universal_Real));
+ Tree_Write_Int (Int (Universal_Fixed));
+ Tree_Write_Int (Int (Standard_Integer_8));
+ Tree_Write_Int (Int (Standard_Integer_16));
+ Tree_Write_Int (Int (Standard_Integer_32));
+ Tree_Write_Int (Int (Standard_Integer_64));
+ Tree_Write_Int (Int (Abort_Signal));
+ Tree_Write_Int (Int (Standard_Op_Rotate_Left));
+ Tree_Write_Int (Int (Standard_Op_Rotate_Right));
+ Tree_Write_Int (Int (Standard_Op_Shift_Left));
+ Tree_Write_Int (Int (Standard_Op_Shift_Right));
+ Tree_Write_Int (Int (Standard_Op_Shift_Right_Arithmetic));
+
+ end Tree_Write;
+
+end Stand;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S T A N D --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.68 $
+-- --
+-- 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 other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception 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 package contains the declarations of entities in package Standard,
+-- These values are initialized either by calling CStand.Create_Standard,
+-- or by calling Stand.Tree_Read.
+
+with Types; use Types;
+
+-- Do we really need the with of Namet?
+
+pragma Warnings (Off);
+with Namet; use Namet;
+pragma Elaborate_All (Namet);
+pragma Warnings (On);
+
+package Stand is
+
+ type Standard_Entity_Type is (
+ -- This enumeration type contains an entry for each name in Standard
+
+ -- Package names
+
+ S_Standard,
+ S_ASCII,
+
+ -- Types defined in package Standard
+
+ S_Boolean,
+ S_Character,
+ S_Wide_Character,
+ S_String,
+ S_Wide_String,
+ S_Duration,
+
+ S_Short_Short_Integer,
+ S_Short_Integer,
+ S_Integer,
+ S_Long_Integer,
+ S_Long_Long_Integer,
+
+ S_Short_Float,
+ S_Float,
+ S_Long_Float,
+ S_Long_Long_Float,
+
+ -- Enumeration literals for type Boolean
+
+ S_False,
+ S_True,
+
+ -- Subtypes declared in package Standard
+
+ S_Natural,
+ S_Positive,
+
+ -- Exceptions declared in package Standard
+
+ S_Constraint_Error,
+ S_Numeric_Error,
+ S_Program_Error,
+ S_Storage_Error,
+ S_Tasking_Error,
+
+ -- Binary Operators declared in package Standard.
+
+ S_Op_Add,
+ S_Op_And,
+ S_Op_Concat,
+ S_Op_Concatw,
+ S_Op_Divide,
+ S_Op_Eq,
+ S_Op_Expon,
+ S_Op_Ge,
+ S_Op_Gt,
+ S_Op_Le,
+ S_Op_Lt,
+ S_Op_Mod,
+ S_Op_Multiply,
+ S_Op_Ne,
+ S_Op_Or,
+ S_Op_Rem,
+ S_Op_Subtract,
+ S_Op_Xor,
+
+ -- Unary operators declared in package Standard
+
+ S_Op_Abs,
+ S_Op_Minus,
+ S_Op_Not,
+ S_Op_Plus,
+
+ -- Constants defined in package ASCII (with value in hex).
+ -- First the thirty-two C0 control characters)
+
+ S_NUL, -- 16#00#
+ S_SOH, -- 16#01#
+ S_STX, -- 16#02#
+ S_ETX, -- 16#03#
+ S_EOT, -- 16#04#
+ S_ENQ, -- 16#05#
+ S_ACK, -- 16#06#
+ S_BEL, -- 16#07#
+ S_BS, -- 16#08#
+ S_HT, -- 16#09#
+ S_LF, -- 16#0A#
+ S_VT, -- 16#0B#
+ S_FF, -- 16#0C#
+ S_CR, -- 16#0D#
+ S_SO, -- 16#0E#
+ S_SI, -- 16#0F#
+ S_DLE, -- 16#10#
+ S_DC1, -- 16#11#
+ S_DC2, -- 16#12#
+ S_DC3, -- 16#13#
+ S_DC4, -- 16#14#
+ S_NAK, -- 16#15#
+ S_SYN, -- 16#16#
+ S_ETB, -- 16#17#
+ S_CAN, -- 16#18#
+ S_EM, -- 16#19#
+ S_SUB, -- 16#1A#
+ S_ESC, -- 16#1B#
+ S_FS, -- 16#1C#
+ S_GS, -- 16#1D#
+ S_RS, -- 16#1E#
+ S_US, -- 16#1F#
+
+ -- Here are the ones for Colonel Whitaker's O26 keypunch!
+
+ S_Exclam, -- 16#21#
+ S_Quotation, -- 16#22#
+ S_Sharp, -- 16#23#
+ S_Dollar, -- 16#24#
+ S_Percent, -- 16#25#
+ S_Ampersand, -- 16#26#
+
+ S_Colon, -- 16#3A#
+ S_Semicolon, -- 16#3B#
+
+ S_Query, -- 16#3F#
+ S_At_Sign, -- 16#40#
+
+ S_L_Bracket, -- 16#5B#
+ S_Back_Slash, -- 16#5C#
+ S_R_Bracket, -- 16#5D#
+ S_Circumflex, -- 16#5E#
+ S_Underline, -- 16#5F#
+ S_Grave, -- 16#60#
+
+ S_LC_A, -- 16#61#
+ S_LC_B, -- 16#62#
+ S_LC_C, -- 16#63#
+ S_LC_D, -- 16#64#
+ S_LC_E, -- 16#65#
+ S_LC_F, -- 16#66#
+ S_LC_G, -- 16#67#
+ S_LC_H, -- 16#68#
+ S_LC_I, -- 16#69#
+ S_LC_J, -- 16#6A#
+ S_LC_K, -- 16#6B#
+ S_LC_L, -- 16#6C#
+ S_LC_M, -- 16#6D#
+ S_LC_N, -- 16#6E#
+ S_LC_O, -- 16#6F#
+ S_LC_P, -- 16#70#
+ S_LC_Q, -- 16#71#
+ S_LC_R, -- 16#72#
+ S_LC_S, -- 16#73#
+ S_LC_T, -- 16#74#
+ S_LC_U, -- 16#75#
+ S_LC_V, -- 16#76#
+ S_LC_W, -- 16#77#
+ S_LC_X, -- 16#78#
+ S_LC_Y, -- 16#79#
+ S_LC_Z, -- 16#7A#
+
+ S_L_BRACE, -- 16#7B#
+ S_BAR, -- 16#7C#
+ S_R_BRACE, -- 16#7D#
+ S_TILDE, -- 16#7E#
+
+ -- And one more control character, all on its own
+
+ S_DEL); -- 16#7F#
+
+ subtype S_Types is
+ Standard_Entity_Type range S_Boolean .. S_Long_Long_Float;
+
+ subtype S_Exceptions is
+ Standard_Entity_Type range S_Constraint_Error .. S_Tasking_Error;
+
+ subtype S_ASCII_Names is
+ Standard_Entity_Type range S_NUL .. S_DEL;
+
+ subtype S_Binary_Ops is
+ Standard_Entity_Type range S_Op_Add .. S_Op_Xor;
+
+ subtype S_Unary_Ops is
+ Standard_Entity_Type range S_Op_Abs .. S_Op_Plus;
+
+ type Standard_Entity_Array_Type is array (Standard_Entity_Type) of Node_Id;
+
+ Standard_Entity : Standard_Entity_Array_Type;
+ -- This array contains pointers to the Defining Identifier nodes
+ -- for each of the entities defined in Standard_Entities_Type. It
+ -- is initialized by the Create_Standard procedure.
+
+ Standard_Package_Node : Node_Id;
+ -- Points to the N_Package_Declaration node for standard. Also
+ -- initialized by the Create_Standard procedure.
+
+ -- The following Entities are the pointers to the Defining Identifier
+ -- nodes for some visible entities defined in Standard_Entities_Type.
+
+ SE : Standard_Entity_Array_Type renames Standard_Entity;
+
+ Standard_Standard : Entity_Id renames SE (S_Standard);
+
+ Standard_ASCII : Entity_Id renames SE (S_ASCII);
+ Standard_Character : Entity_Id renames SE (S_Character);
+ Standard_Wide_Character : Entity_Id renames SE (S_Wide_Character);
+ Standard_String : Entity_Id renames SE (S_String);
+ Standard_Wide_String : Entity_Id renames SE (S_Wide_String);
+
+ Standard_Boolean : Entity_Id renames SE (S_Boolean);
+ Standard_False : Entity_Id renames SE (S_False);
+ Standard_True : Entity_Id renames SE (S_True);
+
+ Standard_Duration : Entity_Id renames SE (S_Duration);
+
+ Standard_Natural : Entity_Id renames SE (S_Natural);
+ Standard_Positive : Entity_Id renames SE (S_Positive);
+
+ Standard_Constraint_Error : Entity_Id renames SE (S_Constraint_Error);
+ Standard_Numeric_Error : Entity_Id renames SE (S_Numeric_Error);
+ Standard_Program_Error : Entity_Id renames SE (S_Program_Error);
+ Standard_Storage_Error : Entity_Id renames SE (S_Storage_Error);
+ Standard_Tasking_Error : Entity_Id renames SE (S_Tasking_Error);
+
+ Standard_Short_Float : Entity_Id renames SE (S_Short_Float);
+ Standard_Float : Entity_Id renames SE (S_Float);
+ Standard_Long_Float : Entity_Id renames SE (S_Long_Float);
+ Standard_Long_Long_Float : Entity_Id renames SE (S_Long_Long_Float);
+
+ Standard_Short_Short_Integer : Entity_Id renames SE (S_Short_Short_Integer);
+ Standard_Short_Integer : Entity_Id renames SE (S_Short_Integer);
+ Standard_Integer : Entity_Id renames SE (S_Integer);
+ Standard_Long_Integer : Entity_Id renames SE (S_Long_Integer);
+ Standard_Long_Long_Integer : Entity_Id renames SE (S_Long_Long_Integer);
+
+ Standard_Op_Add : Entity_Id renames SE (S_Op_Add);
+ Standard_Op_And : Entity_Id renames SE (S_Op_And);
+ Standard_Op_Concat : Entity_Id renames SE (S_Op_Concat);
+ Standard_Op_Concatw : Entity_Id renames SE (S_Op_Concatw);
+ Standard_Op_Divide : Entity_Id renames SE (S_Op_Divide);
+ Standard_Op_Eq : Entity_Id renames SE (S_Op_Eq);
+ Standard_Op_Expon : Entity_Id renames SE (S_Op_Expon);
+ Standard_Op_Ge : Entity_Id renames SE (S_Op_Ge);
+ Standard_Op_Gt : Entity_Id renames SE (S_Op_Gt);
+ Standard_Op_Le : Entity_Id renames SE (S_Op_Le);
+ Standard_Op_Lt : Entity_Id renames SE (S_Op_Lt);
+ Standard_Op_Mod : Entity_Id renames SE (S_Op_Mod);
+ Standard_Op_Multiply : Entity_Id renames SE (S_Op_Multiply);
+ Standard_Op_Ne : Entity_Id renames SE (S_Op_Ne);
+ Standard_Op_Or : Entity_Id renames SE (S_Op_Or);
+ Standard_Op_Rem : Entity_Id renames SE (S_Op_Rem);
+ Standard_Op_Subtract : Entity_Id renames SE (S_Op_Subtract);
+ Standard_Op_Xor : Entity_Id renames SE (S_Op_Xor);
+
+ Standard_Op_Abs : Entity_Id renames SE (S_Op_Abs);
+ Standard_Op_Minus : Entity_Id renames SE (S_Op_Minus);
+ Standard_Op_Not : Entity_Id renames SE (S_Op_Not);
+ Standard_Op_Plus : Entity_Id renames SE (S_Op_Plus);
+
+ Last_Standard_Node_Id : Node_Id;
+ -- Highest Node_Id value used by Standard
+
+ Last_Standard_List_Id : List_Id;
+ -- Highest List_Id value used by Standard (including those used by
+ -- normal list headers, element list headers, and list elements)
+
+ -------------------------------------
+ -- Semantic Phase Special Entities --
+ -------------------------------------
+
+ -- The semantic phase needs a number of entities for internal processing
+ -- that are logically at the level of Standard, and hence defined in this
+ -- package. However, they are never visible to a program, and are not
+ -- chained on to the Decls list of Standard. The names of all these
+ -- types are relevant only in certain debugging and error message
+ -- situations. They have names that are suitable for use in such
+ -- error messages (see body for actual names used).
+
+ Standard_Void_Type : Entity_Id;
+ -- This is a type used to represent the return type of procedures
+
+ Standard_Exception_Type : Entity_Id;
+ -- This is a type used to represent the Etype of exceptions.
+
+ Standard_A_String : Entity_Id;
+ -- An access to String type used for building elements of tables
+ -- carrying the enumeration literal names.
+
+ Standard_A_Char : Entity_Id;
+ -- Access to character, used as a component of the exception type to
+ -- denote a thin pointer component.
+
+ -- The entities labeled Any_xxx are used in situations where the full
+ -- characteristics of an entity are not yet known, e.g. Any_Character
+ -- is used to label a character literal before resolution is complete.
+ -- These entities are also used to construct appropriate references in
+ -- error messages ("expecting an integer type").
+
+ Any_Id : Entity_Id;
+ -- Used to represent some unknown identifier. Used to lable undefined
+ -- identifier references to prevent cascaded errors.
+
+ Any_Type : Entity_Id;
+ -- Used to represent some unknown type. Plays an important role in
+ -- avoiding cascaded errors, since any node that remains labaled with
+ -- this type corresponds to an already issued error message. Any_Type
+ -- is propagated to avoid cascaded errors from a single type error.
+
+ Any_Access : Entity_Id;
+ -- Used to resolve the overloaded literal NULL.
+
+ Any_Array : Entity_Id;
+ -- Used to represent some unknown array type
+
+ Any_Boolean : Entity_Id;
+ -- The context type of conditions in IF and WHILE statements.
+
+ Any_Character : Entity_Id;
+ -- Any_Character is used to label character literals, which in general
+ -- will not have an explicit declaration (this is true of the predefined
+ -- character types).
+
+ Any_Composite : Entity_Id;
+ -- The type Any_Composite is used for aggregates before type resolution.
+ -- It is compatible with any array or non-limited record type.
+
+ Any_Discrete : Entity_Id;
+ -- Used to represent some unknown discrete type
+
+ Any_Fixed : Entity_Id;
+ -- Used to represent some unknown fixed-point type
+
+ Any_Integer : Entity_Id;
+ -- Used to represent some unknown integer type.
+
+ Any_Modular : Entity_Id;
+ -- Used to represent the result type of a boolean operation on an
+ -- integer literal. The result is not Universal_Integer, because it is
+ -- only legal in a modular context.
+
+ Any_Numeric : Entity_Id;
+ -- Used to represent some unknown numeric type.
+
+ Any_Real : Entity_Id;
+ -- Used to represent some unknown real type.
+
+ Any_Scalar : Entity_Id;
+ -- Used to represent some unknown scalar type
+
+ Any_String : Entity_Id;
+ -- The type Any_String is used for string literals before type
+ -- resolution. It corresponds to array (Positive range <>) of character
+ -- where the component type is compatible with any character type,
+ -- not just Standard_Character.
+
+ Universal_Integer : Entity_Id;
+ -- Entity for universal integer type. The bounds of this type correspond
+ -- to the largest supported integer type (i.e. Long_Long_Integer). It is
+ -- the type used for runtime calculations in type universal integer.
+
+ Universal_Real : Entity_Id;
+ -- Entity for universal real type. The bounds of this type correspond to
+ -- to the largest supported real type (i.e. Long_Long_Real). It is the
+ -- type used for runtime calculations in type universal real.
+
+ Universal_Fixed : Entity_Id;
+ -- Entity for universal fixed type. This is a type with arbitrary
+ -- precision that can only appear in a context with a specific type.
+ -- Universal_Fixed labels the result of multiplication or division of
+ -- two fixed point numbers, and has no specified bounds (since, unlike
+ -- universal integer and universal real, it is never used for runtime
+ -- calculations).
+
+ Standard_Integer_8 : Entity_Id;
+ Standard_Integer_16 : Entity_Id;
+ Standard_Integer_32 : Entity_Id;
+ Standard_Integer_64 : Entity_Id;
+ -- These are signed integer types with the indicated sizes, They are
+ -- used for the underlying implementation types for fixed-point and
+ -- enumeration types.
+
+ Standard_Unsigned : Entity_Id;
+ -- An unsigned type of the same size as Standard_Integer
+
+ Abort_Signal : Entity_Id;
+ -- Entity for abort signal exception
+
+ Standard_Op_Rotate_Left : Entity_Id;
+ Standard_Op_Rotate_Right : Entity_Id;
+ Standard_Op_Shift_Left : Entity_Id;
+ Standard_Op_Shift_Right : Entity_Id;
+ Standard_Op_Shift_Right_Arithmetic : Entity_Id;
+ -- These entities are used for shift operators generated by the expander
+
+ -----------------
+ -- Subprograms --
+ -----------------
+
+ procedure Tree_Read;
+ -- Initializes entity values in this package from the current tree
+ -- file using Osint.Tree_Read. Note that Tree_Read includes all the
+ -- initialization that is carried out by Create_Standard.
+
+ procedure Tree_Write;
+ -- Writes out the entity values in this package to the current
+ -- tree file using Osint.Tree_Write.
+
+end Stand;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S T R I N G T --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.43 $
+-- --
+-- 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 other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception 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). --
+-- --
+------------------------------------------------------------------------------
+
+with Alloc;
+with Namet; use Namet;
+with Output; use Output;
+with Table;
+
+package body Stringt is
+
+ -- The following table stores the sequence of character codes for the
+ -- stored string constants. The entries are referenced from the
+ -- separate Strings table.
+
+ package String_Chars is new Table.Table (
+ Table_Component_Type => Char_Code,
+ Table_Index_Type => Int,
+ Table_Low_Bound => 0,
+ Table_Initial => Alloc.String_Chars_Initial,
+ Table_Increment => Alloc.String_Chars_Increment,
+ Table_Name => "String_Chars");
+
+ -- The String_Id values reference entries in the Strings table, which
+ -- contains String_Entry records that record the length of each stored
+ -- string and its starting location in the String_Chars table.
+
+ type String_Entry is record
+ String_Index : Int;
+ Length : Nat;
+ end record;
+
+ package Strings is new Table.Table (
+ Table_Component_Type => String_Entry,
+ Table_Index_Type => String_Id,
+ Table_Low_Bound => First_String_Id,
+ Table_Initial => Alloc.Strings_Initial,
+ Table_Increment => Alloc.Strings_Increment,
+ Table_Name => "Strings");
+
+ -- Note: it is possible that two entries in the Strings table can share
+ -- string data in the String_Chars table, and in particular this happens
+ -- when Start_String is called with a parameter that is the last string
+ -- currently allocated in the table.
+
+ -------------------------------
+ -- Add_String_To_Name_Buffer --
+ -------------------------------
+
+ procedure Add_String_To_Name_Buffer (S : String_Id) is
+ Len : constant Natural := Natural (String_Length (S));
+ begin
+ for J in 1 .. Len loop
+ Name_Buffer (Name_Len + J) :=
+ Get_Character (Get_String_Char (S, Int (J)));
+ end loop;
+
+ Name_Len := Name_Len + Len;
+ end Add_String_To_Name_Buffer;
+
+ ----------------
+ -- End_String --
+ ----------------
+
+ function End_String return String_Id is
+ begin
+ return Strings.Last;
+ end End_String;
+
+ ---------------------
+ -- Get_String_Char --
+ ---------------------
+
+ function Get_String_Char (Id : String_Id; Index : Int) return Char_Code is
+ begin
+ pragma Assert (Id in First_String_Id .. Strings.Last
+ and then Index in 1 .. Strings.Table (Id).Length);
+
+ return String_Chars.Table (Strings.Table (Id).String_Index + Index - 1);
+ end Get_String_Char;
+
+ ----------------
+ -- Initialize --
+ ----------------
+
+ procedure Initialize is
+ begin
+ String_Chars.Init;
+ Strings.Init;
+ end Initialize;
+
+ ----------
+ -- Lock --
+ ----------
+
+ procedure Lock is
+ begin
+ String_Chars.Locked := True;
+ Strings.Locked := True;
+ String_Chars.Release;
+ Strings.Release;
+ end Lock;
+
+ ------------------
+ -- Start_String --
+ ------------------
+
+ -- Version to start completely new string
+
+ procedure Start_String is
+ begin
+ Strings.Increment_Last;
+ Strings.Table (Strings.Last).String_Index := String_Chars.Last + 1;
+ Strings.Table (Strings.Last).Length := 0;
+ end Start_String;
+
+ -- Version to start from initially stored string
+
+ procedure Start_String (S : String_Id) is
+ begin
+ Strings.Increment_Last;
+
+ -- Case of initial string value is at the end of the string characters
+ -- table, so it does not need copying, instead it can be shared.
+
+ if Strings.Table (S).String_Index + Strings.Table (S).Length =
+ String_Chars.Last + 1
+ then
+ Strings.Table (Strings.Last).String_Index :=
+ Strings.Table (S).String_Index;
+
+ -- Case of initial string value must be copied to new string
+
+ else
+ Strings.Table (Strings.Last).String_Index :=
+ String_Chars.Last + 1;
+
+ for J in 1 .. Strings.Table (S).Length loop
+ String_Chars.Increment_Last;
+ String_Chars.Table (String_Chars.Last) :=
+ String_Chars.Table (Strings.Table (S).String_Index + (J - 1));
+ end loop;
+ end if;
+
+ -- In either case the result string length is copied from the argument
+
+ Strings.Table (Strings.Last).Length := Strings.Table (S).Length;
+ end Start_String;
+
+ -----------------------
+ -- Store_String_Char --
+ -----------------------
+
+ procedure Store_String_Char (C : Char_Code) is
+ begin
+ String_Chars.Increment_Last;
+ String_Chars.Table (String_Chars.Last) := C;
+ Strings.Table (Strings.Last).Length :=
+ Strings.Table (Strings.Last).Length + 1;
+ end Store_String_Char;
+
+ procedure Store_String_Char (C : Character) is
+ begin
+ Store_String_Char (Get_Char_Code (C));
+ end Store_String_Char;
+
+ ------------------------
+ -- Store_String_Chars --
+ ------------------------
+
+ procedure Store_String_Chars (S : String) is
+ begin
+ for J in S'First .. S'Last loop
+ Store_String_Char (Get_Char_Code (S (J)));
+ end loop;
+ end Store_String_Chars;
+
+ procedure Store_String_Chars (S : String_Id) is
+ begin
+ for J in 1 .. String_Length (S) loop
+ Store_String_Char (Get_String_Char (S, J));
+ end loop;
+ end Store_String_Chars;
+
+ ----------------------
+ -- Store_String_Int --
+ ----------------------
+
+ procedure Store_String_Int (N : Int) is
+ begin
+ if N < 0 then
+ Store_String_Char ('-');
+ Store_String_Int (-N);
+
+ else
+ if N > 9 then
+ Store_String_Int (N / 10);
+ end if;
+
+ Store_String_Char (Character'Val (Character'Pos ('0') + N mod 10));
+ end if;
+ end Store_String_Int;
+
+ --------------------------
+ -- String_Chars_Address --
+ --------------------------
+
+ function String_Chars_Address return System.Address is
+ begin
+ return String_Chars.Table (0)'Address;
+ end String_Chars_Address;
+
+ ------------------
+ -- String_Equal --
+ ------------------
+
+ function String_Equal (L, R : String_Id) return Boolean is
+ Len : constant Nat := Strings.Table (L).Length;
+
+ begin
+ if Len /= Strings.Table (R).Length then
+ return False;
+ else
+ for J in 1 .. Len loop
+ if Get_String_Char (L, J) /= Get_String_Char (R, J) then
+ return False;
+ end if;
+ end loop;
+
+ return True;
+ end if;
+ end String_Equal;
+
+ -----------------------------
+ -- String_From_Name_Buffer --
+ -----------------------------
+
+ function String_From_Name_Buffer return String_Id is
+ begin
+ Start_String;
+
+ for J in 1 .. Name_Len loop
+ Store_String_Char (Get_Char_Code (Name_Buffer (J)));
+ end loop;
+
+ return End_String;
+ end String_From_Name_Buffer;
+
+ -------------------
+ -- String_Length --
+ -------------------
+
+ function String_Length (Id : String_Id) return Nat is
+ begin
+ return Strings.Table (Id).Length;
+ end String_Length;
+
+ ---------------------------
+ -- String_To_Name_Buffer --
+ ---------------------------
+
+ procedure String_To_Name_Buffer (S : String_Id) is
+ begin
+ Name_Len := Natural (String_Length (S));
+
+ for J in 1 .. Name_Len loop
+ Name_Buffer (J) :=
+ Get_Character (Get_String_Char (S, Int (J)));
+ end loop;
+ end String_To_Name_Buffer;
+
+ ---------------------
+ -- Strings_Address --
+ ---------------------
+
+ function Strings_Address return System.Address is
+ begin
+ return Strings.Table (First_String_Id)'Address;
+ end Strings_Address;
+
+ ---------------
+ -- Tree_Read --
+ ---------------
+
+ procedure Tree_Read is
+ begin
+ String_Chars.Tree_Read;
+ Strings.Tree_Read;
+ end Tree_Read;
+
+ ----------------
+ -- Tree_Write --
+ ----------------
+
+ procedure Tree_Write is
+ begin
+ String_Chars.Tree_Write;
+ Strings.Tree_Write;
+ end Tree_Write;
+
+ ------------
+ -- Unlock --
+ ------------
+
+ procedure Unlock is
+ begin
+ String_Chars.Locked := False;
+ Strings.Locked := False;
+ end Unlock;
+
+ -------------------------
+ -- Unstore_String_Char --
+ -------------------------
+
+ procedure Unstore_String_Char is
+ begin
+ String_Chars.Decrement_Last;
+ Strings.Table (Strings.Last).Length :=
+ Strings.Table (Strings.Last).Length - 1;
+ end Unstore_String_Char;
+
+ ---------------------
+ -- Write_Char_Code --
+ ---------------------
+
+ procedure Write_Char_Code (Code : Char_Code) is
+
+ procedure Write_Hex_Byte (J : Natural);
+ -- Write single hex digit
+
+ procedure Write_Hex_Byte (J : Natural) is
+ Hexd : String := "0123456789abcdef";
+
+ begin
+ Write_Char (Hexd (J / 16 + 1));
+ Write_Char (Hexd (J mod 16 + 1));
+ end Write_Hex_Byte;
+
+ -- Start of processing for Write_Char_Code
+
+ begin
+ if Code in 16#20# .. 16#7E# then
+ Write_Char (Character'Val (Code));
+
+ else
+ Write_Char ('[');
+ Write_Char ('"');
+
+ if Code > 16#FF# then
+ Write_Hex_Byte (Natural (Code / 256));
+ end if;
+
+ Write_Hex_Byte (Natural (Code mod 256));
+ Write_Char ('"');
+ Write_Char (']');
+ end if;
+ end Write_Char_Code;
+
+ ------------------------------
+ -- Write_String_Table_Entry --
+ ------------------------------
+
+ procedure Write_String_Table_Entry (Id : String_Id) is
+ C : Char_Code;
+
+ begin
+ if Id = No_String then
+ Write_Str ("no string");
+
+ else
+ Write_Char ('"');
+
+ for J in 1 .. String_Length (Id) loop
+ C := Get_String_Char (Id, J);
+
+ if Character'Val (C) = '"' then
+ Write_Str ("""""");
+
+ else
+ Write_Char_Code (C);
+ end if;
+ end loop;
+
+ Write_Char ('"');
+ end if;
+ end Write_String_Table_Entry;
+
+end Stringt;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S T R I N G T --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.39 $
+-- --
+-- 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 other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception 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). --
+-- --
+------------------------------------------------------------------------------
+
+with System; use System;
+with Types; use Types;
+
+package Stringt is
+
+-- This package contains routines for handling the strings table which is
+-- used to store string constants encountered in the source, and also those
+-- additional string constants generated by compile time concatenation and
+-- other similar processing.
+
+-- A string constant in this table consists of a series of Char_Code values,
+-- so that 16-bit character codes can be properly handled if this feature
+-- is implemented in the scanner.
+
+-- There is no guarantee that hashing is used in the implementation, although
+-- it maybe. This means that the caller cannot count on having the same Id
+-- value for two identical strings stored separately and also cannot count on
+-- the two Id values being different.
+
+ --------------------------------------
+ -- String Table Access Subprograms --
+ --------------------------------------
+
+ procedure Initialize;
+ -- Initializes the strings table for a new compilation. Note that
+ -- Initialize must not be called if Tree_Read is used.
+
+ procedure Lock;
+ -- Lock internal tables before calling back end
+
+ procedure Unlock;
+ -- Unlock internal tables, in case back end needs to modify them
+
+ procedure Start_String;
+ -- Sets up for storing a new string in the table. To store a string, a
+ -- call is first made to Start_String, then successive calls are
+ -- made to Store_String_Character to store the characters of the string.
+ -- Finally, a call to End_String terminates the entry and returns it Id.
+
+ procedure Start_String (S : String_Id);
+ -- Like Start_String with no parameter, except that the contents of the
+ -- new string is initialized to be a copy of the given string. A test is
+ -- made to see if S is the last created string, and if so it is shared,
+ -- rather than copied, this can be particularly helpful for the case of
+ -- a continued concatenaion of string constants.
+
+ procedure Store_String_Char (C : Char_Code);
+ procedure Store_String_Char (C : Character);
+ -- Store next character of string, see description above for Start_String
+
+ procedure Store_String_Chars (S : String);
+ procedure Store_String_Chars (S : String_Id);
+ -- Store character codes of given string in sequence
+
+ procedure Store_String_Int (N : Int);
+ -- Stored decimal representation of integer with possible leading minus
+
+ procedure Unstore_String_Char;
+ -- Undoes effect of previous Store_String_Char call, used in some error
+ -- situations of unterminated string constants.
+
+ function End_String return String_Id;
+ -- Terminates current string and returns its Id
+
+ function String_Length (Id : String_Id) return Nat;
+ -- Returns length of previously stored string
+
+ function Get_String_Char (Id : String_Id; Index : Int) return Char_Code;
+ -- Obtains the specified character from a stored string. The lower bound
+ -- of stored strings is always 1, so the range is 1 .. String_Length (Id).
+
+ function String_Equal (L, R : String_Id) return Boolean;
+ -- Determines if two string literals represent the same string
+
+ procedure String_To_Name_Buffer (S : String_Id);
+ -- Place characters of given string in Name_Buffer, setting Name_Len
+
+ procedure Add_String_To_Name_Buffer (S : String_Id);
+ -- Append characters of given string to Name_Buffer, updating Name_Len
+
+ function String_Chars_Address return System.Address;
+ -- Return address of String_Chars table (used by Back_End call to Gigi)
+
+ function String_From_Name_Buffer return String_Id;
+ -- Given a name stored in Namet.Name_Buffer (length in Namet.Name_Len),
+ -- returns a string of the corresponding value. The value in Name_Buffer
+ -- is unchanged, and the cases of letters are unchanged.
+
+ function Strings_Address return System.Address;
+ -- Return address of Strings table (used by Back_End call to Gigi)
+
+ procedure Tree_Read;
+ -- Initializes internal tables from current tree file using Tree_Read.
+ -- Note that Initialize should not be called if Tree_Read is used.
+ -- Tree_Read includes all necessary initialization.
+
+ procedure Tree_Write;
+ -- Writes out internal tables to current tree file using Tree_Write
+
+ procedure Write_Char_Code (Code : Char_Code);
+ -- Procedure to write a character code value, used for debugging purposes
+ -- for writing character codes. If the character code is in the range
+ -- 16#20# .. 16#7E#, then the single graphic character corresponding to
+ -- the code is output. For any other codes in the range 16#00# .. 16#FF#,
+ -- the code is output as ["hh"] where hh is the two digit hex value for
+ -- the code. Codes greater than 16#FF# are output as ["hhhh"] where hhhh
+ -- is the four digit hex representation of the code value (high order
+ -- byte first). Hex letters are always in upper case.
+
+ procedure Write_String_Table_Entry (Id : String_Id);
+ -- Writes a string value with enclosing quotes to the current file using
+ -- routines in package Output. Does not write an end of line character.
+ -- This procedure is used for debug output purposes, and also for output
+ -- of strings specified by pragma Linker Option to the ali file. 7-bit
+ -- ASCII graphics (except for double quote and left brace) are output
+ -- literally. The double quote appears as two successive double quotes.
+ -- All other codes, are output as described for Write_Char_Code. For
+ -- example, the string created by folding "A" & ASCII.LF & "Hello" will
+ -- print as "A{0A}Hello". A No_String value prints simply as "no string"
+ -- without surrounding quote marks.
+
+private
+ pragma Inline (End_String);
+ pragma Inline (String_Length);
+
+end Stringt;
--- /dev/null
+/****************************************************************************
+ * *
+ * GNAT COMPILER COMPONENTS *
+ * *
+ * S T R I N G T *
+ * *
+ * 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. *
+ * *
+ * 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 is the C file that corresponds to the Ada package spec
+ Stringt. It was created manually from stringt.ads and stringt.adb
+
+ Note: only the access functions are provided, since the tree transformer
+ is not allowed to modify the tree or its auxiliary structures.
+
+ This package contains routines for handling the strings table which is
+ used to store string constants encountered in the source, and also those
+ additional string constants generated by compile time concatenation and
+ other similar processing.
+
+ A string constant in this table consists of a series of Char_Code values,
+ so that 16-bit character codes can be properly handled if this feature is
+ implemented in the scanner.
+
+ There is no guarantee that hashing is used in the implementation. This
+ means that the caller cannot count on having the same Id value for two
+ identical strings stored separately.
+
+ The String_Id values reference entries in the Strings table, which
+ contains String_Entry records that record the length of each stored string
+ and its starting location in the String_Chars table. */
+
+struct String_Entry
+{
+ Int String_Index;
+ Int Length;
+};
+
+/* Pointer to string entry vector. This pointer is passed to the tree
+ transformer and stored in a global location for access from here after
+ subtracting String_First_Entry, so that String_Id values can be used as
+ subscripts into the vector. */
+extern struct String_Entry *Strings_Ptr;
+
+/* Pointer to name characters table. This pointer is passed to the tree
+ transformer and stored in a global location for access from here. The
+ String_Index values are subscripts into this array. */
+extern Char_Code *String_Chars_Ptr;
+
+
+/* String_Length returns the length of the specified string. */
+INLINE Int String_Length PARAMS ((String_Id));
+
+INLINE Int
+String_Length (Id)
+ String_Id Id;
+{
+ return Strings_Ptr [Id].Length;
+}
+
+
+/* Get_String_Char obtains the specified character from a stored string. The
+ lower bound of stored strings is always 1, so the range of values is 1 to
+ String_Length (Id). */
+INLINE Char_Code Get_String_Char PARAMS ((String_Id, Int));
+
+INLINE Char_Code
+Get_String_Char (Id, Index)
+ String_Id Id;
+ Int Index;
+{
+ return String_Chars_Ptr [Strings_Ptr [Id].String_Index + Index - 1];
+}
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S T Y L E --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.48 $
+-- --
+-- 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 version of the Style package implements the standard GNAT style
+-- checking rules. For documentation of these rules, see comments on the
+-- individual procedures.
+
+with Atree; use Atree;
+with Casing; use Casing;
+with Csets; use Csets;
+with Einfo; use Einfo;
+with Errout; use Errout;
+with Namet; use Namet;
+with Opt; use Opt;
+with Scn; use Scn;
+with Scans; use Scans;
+with Sinfo; use Sinfo;
+with Sinput; use Sinput;
+with Stand; use Stand;
+with Stylesw; use Stylesw;
+
+package body Style is
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ procedure Error_Space_Not_Allowed (S : Source_Ptr);
+ -- Posts an error message indicating that a space is not allowed
+ -- at the given source location.
+
+ procedure Error_Space_Required (S : Source_Ptr);
+ -- Posts an error message indicating that a space is required at
+ -- the given source location.
+
+ procedure Require_Following_Space;
+ pragma Inline (Require_Following_Space);
+ -- Require token to be followed by white space. Used only if in GNAT
+ -- style checking mode.
+
+ procedure Require_Preceding_Space;
+ pragma Inline (Require_Preceding_Space);
+ -- Require token to be preceded by white space. Used only if in GNAT
+ -- style checking mode.
+
+ -----------------------
+ -- Body_With_No_Spec --
+ -----------------------
+
+ -- If the check specs mode (-gnatys) is set, then all subprograms must
+ -- have specs unless they are parameterless procedures that are not child
+ -- units at the library level (i.e. they are possible main programs).
+
+ procedure Body_With_No_Spec (N : Node_Id) is
+ begin
+ if Style_Check_Specs then
+ if Nkind (Parent (N)) = N_Compilation_Unit then
+ declare
+ Spec : constant Node_Id := Specification (N);
+ Defnm : constant Node_Id := Defining_Unit_Name (Spec);
+
+ begin
+ if Nkind (Spec) = N_Procedure_Specification
+ and then Nkind (Defnm) = N_Defining_Identifier
+ and then No (First_Formal (Defnm))
+ then
+ return;
+ end if;
+ end;
+ end if;
+
+ Error_Msg_N ("(style): subprogram body has no previous spec", N);
+ end if;
+ end Body_With_No_Spec;
+
+ ----------------------
+ -- Check_Abs_Or_Not --
+ ----------------------
+
+ -- In check tokens mode (-gnatyt), ABS/NOT must be followed by a space
+
+ procedure Check_Abs_Not is
+ begin
+ if Style_Check_Tokens then
+ if Source (Scan_Ptr) > ' ' then
+ Error_Space_Required (Scan_Ptr);
+ end if;
+ end if;
+ end Check_Abs_Not;
+
+ -----------------
+ -- Check_Arrow --
+ -----------------
+
+ -- In check tokens mode (-gnatys), arrow must be surrounded by spaces
+
+ procedure Check_Arrow is
+ begin
+ if Style_Check_Tokens then
+ Require_Preceding_Space;
+ Require_Following_Space;
+ end if;
+ end Check_Arrow;
+
+ --------------------------
+ -- Check_Attribute_Name --
+ --------------------------
+
+ -- In check attribute casing mode (-gnatya), attribute names must be
+ -- mixed case, i.e. start with an upper case letter, and otherwise
+ -- lower case, except after an underline character.
+
+ procedure Check_Attribute_Name (Reserved : Boolean) is
+ begin
+ if Style_Check_Attribute_Casing then
+ if Determine_Token_Casing /= Mixed_Case then
+ Error_Msg_SC ("(style) bad capitalization, mixed case required");
+ end if;
+ end if;
+ end Check_Attribute_Name;
+
+ ---------------------------
+ -- Check_Binary_Operator --
+ ---------------------------
+
+ -- In check token mode (-gnatyt), binary operators other than the special
+ -- case of exponentiation require surrounding space characters.
+
+ procedure Check_Binary_Operator is
+ begin
+ if Style_Check_Tokens then
+ Require_Preceding_Space;
+ Require_Following_Space;
+ end if;
+ end Check_Binary_Operator;
+
+ ---------------
+ -- Check_Box --
+ ---------------
+
+ -- In check token mode (-gnatyt), box must be preceded by a space or by
+ -- a left parenthesis. Spacing checking on the surrounding tokens takes
+ -- care of the remaining checks.
+
+ procedure Check_Box is
+ begin
+ if Style_Check_Tokens then
+ if Prev_Token /= Tok_Left_Paren then
+ Require_Preceding_Space;
+ end if;
+ end if;
+ end Check_Box;
+
+ -----------------
+ -- Check_Colon --
+ -----------------
+
+ -- In check token mode (-gnatyt), colon must be surrounded by spaces
+
+ procedure Check_Colon is
+ begin
+ if Style_Check_Tokens then
+ Require_Preceding_Space;
+ Require_Following_Space;
+ end if;
+ end Check_Colon;
+
+ -----------------------
+ -- Check_Colon_Equal --
+ -----------------------
+
+ -- In check token mode (-gnatyt), := must be surrounded by spaces
+
+ procedure Check_Colon_Equal is
+ begin
+ if Style_Check_Tokens then
+ Require_Preceding_Space;
+ Require_Following_Space;
+ end if;
+ end Check_Colon_Equal;
+
+ -----------------
+ -- Check_Comma --
+ -----------------
+
+ -- In check token mode (-gnatyt), comma must be either the first
+ -- token on a line, or be preceded by a non-blank character.
+ -- It must also always be followed by a blank.
+
+ procedure Check_Comma is
+ begin
+ if Style_Check_Tokens then
+ if Token_Ptr > First_Non_Blank_Location
+ and then Source (Token_Ptr - 1) = ' '
+ then
+ Error_Space_Not_Allowed (Token_Ptr - 1);
+ end if;
+
+ if Source (Scan_Ptr) > ' ' then
+ Error_Space_Required (Scan_Ptr);
+ end if;
+ end if;
+ end Check_Comma;
+
+ -------------------
+ -- Check_Comment --
+ -------------------
+
+ -- In check comment mode (-gnatyc) there are several requirements on the
+ -- format of comments. The following are permissible comment formats:
+
+ -- 1. Any comment that is not at the start of a line, i.e. where the
+ -- initial minuses are not the first non-blank characters on the
+ -- line must have at least one blank after the second minus.
+
+ -- 2. A row of all minuses of any length is permitted (see procedure
+ -- box above in the source of this routine).
+
+ -- 3. A comment line starting with two minuses and a space, and ending
+ -- with a space and two minuses. Again see the procedure title box
+ -- immediately above in the source.
+
+ -- 4. A full line comment where two spaces follow the two minus signs.
+ -- This is the normal comment format in GNAT style, as typified by
+ -- the comments you are reading now.
+
+ -- 5. A full line comment where the first character after the second
+ -- minus is a special character, i.e. a character in the ASCII
+ -- range 16#21#..16#2F# or 16#3A#..16#3F#. This allows special
+ -- comments, such as those generated by gnatprep, or those that
+ -- appear in the SPARK annotation language to be accepted.
+
+ procedure Check_Comment is
+ S : Source_Ptr;
+ C : Character;
+
+ begin
+ -- Can never have a non-blank character preceding the first minus
+
+ if Style_Check_Comments then
+ if Scan_Ptr > Source_First (Current_Source_File)
+ and then Source (Scan_Ptr - 1) > ' '
+ then
+ Error_Msg_S ("(style) space required");
+ end if;
+ end if;
+
+ -- For a comment that is not at the start of the line, the only
+ -- requirement is that we cannot have a non-blank character after
+ -- the second minus sign.
+
+ if Scan_Ptr /= First_Non_Blank_Location then
+ if Style_Check_Comments then
+ if Source (Scan_Ptr + 2) > ' ' then
+ Error_Msg ("(style) space required", Scan_Ptr + 2);
+ end if;
+ end if;
+
+ return;
+
+ -- Case of a comment that is at the start of a line
+
+ else
+ -- First check, must be in appropriately indented column
+
+ if Style_Check_Indentation /= 0 then
+ if Start_Column rem Style_Check_Indentation /= 0 then
+ Error_Msg_S ("(style) bad column");
+ return;
+ end if;
+ end if;
+
+ -- Now check form of the comment
+
+ if not Style_Check_Comments then
+ return;
+
+ -- Case of not followed by a blank. Usually wrong, but there are
+ -- some exceptions that we permit.
+
+ elsif Source (Scan_Ptr + 2) /= ' ' then
+ C := Source (Scan_Ptr + 2);
+
+ -- Case of -- all on its own on a line is OK
+
+ if C < ' ' then
+ return;
+
+ -- Case of --x, x special character is OK (gnatprep/SPARK/etc.)
+
+ elsif Character'Pos (C) in 16#21# .. 16#2F#
+ or else
+ Character'Pos (C) in 16#3A# .. 16#3F#
+ then
+ return;
+
+ -- Otherwise only cases allowed are when the entire line is
+ -- made up of minus signs (case of a box comment).
+
+ else
+ S := Scan_Ptr + 2;
+
+ while Source (S) >= ' ' loop
+ if Source (S) /= '-' then
+ Error_Space_Required (Scan_Ptr + 2);
+ return;
+ end if;
+
+ S := S + 1;
+ end loop;
+ end if;
+
+ -- If we are followed by a blank, then the comment is OK if the
+ -- character following this blank is another blank or a format
+ -- effector.
+
+ elsif Source (Scan_Ptr + 3) <= ' ' then
+ return;
+
+ -- Here is the case where we only have one blank after the two minus
+ -- signs, which is an error unless the line ends with two blanks, the
+ -- case of a box comment.
+
+ else
+ S := Scan_Ptr + 3;
+
+ while Source (S) not in Line_Terminator loop
+ S := S + 1;
+ end loop;
+
+ if Source (S - 1) /= '-' or else Source (S - 2) /= '-' then
+ Error_Space_Required (Scan_Ptr + 3);
+ end if;
+ end if;
+ end if;
+ end Check_Comment;
+
+ -------------------
+ -- Check_Dot_Dot --
+ -------------------
+
+ -- In check token mode (-gnatyt), colon must be surrounded by spaces
+
+ procedure Check_Dot_Dot is
+ begin
+ if Style_Check_Tokens then
+ Require_Preceding_Space;
+ Require_Following_Space;
+ end if;
+ end Check_Dot_Dot;
+
+ -----------------------------------
+ -- Check_Exponentiation_Operator --
+ -----------------------------------
+
+ -- No spaces are required for the ** operator in GNAT style check mode
+
+ procedure Check_Exponentiation_Operator is
+ begin
+ null;
+ end Check_Exponentiation_Operator;
+
+ --------------
+ -- Check_HT --
+ --------------
+
+ -- In check horizontal tab mode (-gnatyh), tab characters are not allowed
+
+ procedure Check_HT is
+ begin
+ if Style_Check_Horizontal_Tabs then
+ Error_Msg_S ("(style) horizontal tab not allowed");
+ end if;
+ end Check_HT;
+
+ ----------------------
+ -- Check_Identifier --
+ ----------------------
+
+ -- In check references mode (-gnatyr), identifier uses must be cased
+ -- the same way as the corresponding identifier declaration.
+
+ procedure Check_Identifier
+ (Ref : Node_Or_Entity_Id;
+ Def : Node_Or_Entity_Id)
+ is
+ SRef : Source_Ptr := Sloc (Ref);
+ SDef : Source_Ptr := Sloc (Def);
+ TRef : Source_Buffer_Ptr;
+ TDef : Source_Buffer_Ptr;
+ Nlen : Nat;
+ Cas : Casing_Type;
+
+ begin
+ -- If reference does not come from source, nothing to check
+
+ if not Comes_From_Source (Ref) then
+ return;
+
+ -- Case of definition comes from source
+
+ elsif Comes_From_Source (Def) then
+
+ -- Check same casing if we are checking references
+
+ if Style_Check_References then
+ TRef := Source_Text (Get_Source_File_Index (SRef));
+ TDef := Source_Text (Get_Source_File_Index (SDef));
+
+ -- Ignore operator name case completely. This also catches the
+ -- case of where one is an operator and the other is not. This
+ -- is a phenomenon from rewriting of operators as functions,
+ -- and is to be ignored.
+
+ if TRef (SRef) = '"' or else TDef (SDef) = '"' then
+ return;
+
+ else
+ for J in 1 .. Length_Of_Name (Chars (Ref)) loop
+ if TRef (SRef) /= TDef (SDef) then
+ Error_Msg_Node_1 := Def;
+ Error_Msg_Sloc := Sloc (Def);
+ Error_Msg
+ ("(style) bad casing of & declared#", SRef);
+ return;
+ end if;
+
+ SRef := SRef + 1;
+ SDef := SDef + 1;
+ end loop;
+ end if;
+ end if;
+
+ -- Case of definition in package Standard
+
+ elsif SDef = Standard_Location then
+
+ -- Check case of identifiers in Standard
+
+ if Style_Check_Standard then
+ TRef := Source_Text (Get_Source_File_Index (SRef));
+
+ -- Ignore operators
+
+ if TRef (SRef) = '"' then
+ null;
+
+ -- Special case of ASCII
+
+ else
+ if Entity (Ref) = Standard_ASCII then
+ Cas := All_Upper_Case;
+
+ elsif Entity (Ref) in SE (S_LC_A) .. SE (S_LC_Z)
+ or else
+ Entity (Ref) in SE (S_NUL) .. SE (S_US)
+ or else
+ Entity (Ref) = SE (S_DEL)
+ then
+ Cas := All_Upper_Case;
+
+ else
+ Cas := Mixed_Case;
+ end if;
+
+ Nlen := Length_Of_Name (Chars (Ref));
+
+ if Determine_Casing
+ (TRef (SRef .. SRef + Source_Ptr (Nlen) - 1)) = Cas
+ then
+ null;
+ else
+ Error_Msg_N
+ ("(style) bad casing for entity in Standard", Ref);
+ end if;
+ end if;
+ end if;
+ end if;
+ end Check_Identifier;
+
+ -----------------------
+ -- Check_Indentation --
+ -----------------------
+
+ -- In check indentation mode (-gnatyn for n a digit), a new statement or
+ -- declaration is required to start in a column that is a multiple of the
+ -- indentiation amount.
+
+ procedure Check_Indentation is
+ begin
+ if Style_Check_Indentation /= 0 then
+ if Token_Ptr = First_Non_Blank_Location
+ and then Start_Column rem Style_Check_Indentation /= 0
+ then
+ Error_Msg_SC ("(style) bad indentation");
+ end if;
+ end if;
+ end Check_Indentation;
+
+ ----------------------
+ -- Check_Left_Paren --
+ ----------------------
+
+ -- In tone check mode (-gnatyt), left paren must not be preceded by an
+ -- identifier character or digit (a separating space is required) and
+ -- may never be followed by a space.
+
+ procedure Check_Left_Paren is
+ S : Source_Ptr;
+
+ begin
+ if Style_Check_Tokens then
+ if Token_Ptr > Source_First (Current_Source_File)
+ and then Identifier_Char (Source (Token_Ptr - 1))
+ then
+ Error_Space_Required (Token_Ptr);
+ end if;
+
+ if Source (Scan_Ptr) = ' ' then
+
+ -- Allow one or more spaces if followed by comment
+
+ S := Scan_Ptr + 1;
+ loop
+ if Source (S) = '-' and then Source (S + 1) = '-' then
+ return;
+ elsif Source (S) /= ' ' then
+ exit;
+ else
+ S := S + 1;
+ end if;
+ end loop;
+
+ Error_Space_Not_Allowed (Scan_Ptr);
+ end if;
+ end if;
+ end Check_Left_Paren;
+
+ ---------------------------
+ -- Check_Line_Terminator --
+ ---------------------------
+
+ -- In check blanks at end mode (-gnatyb), lines may not end with a
+ -- trailing space.
+
+ -- In check max line length mode (-gnatym), the line length must
+ -- not exceed the permitted maximum value.
+
+ -- In check form feeds mode (-gnatyf), the line terminator may not
+ -- be either of the characters FF or VT.
+
+ procedure Check_Line_Terminator (Len : Int) is
+ S : Source_Ptr;
+
+ begin
+ -- Check FF/VT terminators
+
+ if Style_Check_Form_Feeds then
+ if Source (Scan_Ptr) = ASCII.FF then
+ Error_Msg_S ("(style) form feed not allowed");
+
+ elsif Source (Scan_Ptr) = ASCII.VT then
+ Error_Msg_S ("(style) vertical tab not allowed");
+ end if;
+ end if;
+
+ -- Check trailing space
+
+ if Style_Check_Blanks_At_End then
+ if Scan_Ptr >= First_Non_Blank_Location then
+ if Source (Scan_Ptr - 1) = ' ' then
+ S := Scan_Ptr - 1;
+
+ while Source (S - 1) = ' ' loop
+ S := S - 1;
+ end loop;
+
+ Error_Msg ("(style) trailing spaces not permitted", S);
+ end if;
+ end if;
+ end if;
+
+ -- Check max line length
+
+ if Style_Check_Max_Line_Length then
+ if Len > Style_Max_Line_Length then
+ Error_Msg
+ ("(style) this line is too long",
+ Current_Line_Start + Source_Ptr (Style_Max_Line_Length));
+ end if;
+ end if;
+
+ end Check_Line_Terminator;
+
+ -----------------------
+ -- Check_Pragma_Name --
+ -----------------------
+
+ -- In check pragma casing mode (-gnatyp), pragma names must be mixed
+ -- case, i.e. start with an upper case letter, and otherwise lower case,
+ -- except after an underline character.
+
+ procedure Check_Pragma_Name is
+ begin
+ if Style_Check_Pragma_Casing then
+ if Determine_Token_Casing /= Mixed_Case then
+ Error_Msg_SC ("(style) bad capitalization, mixed case required");
+ end if;
+ end if;
+ end Check_Pragma_Name;
+
+ -----------------------
+ -- Check_Right_Paren --
+ -----------------------
+
+ -- In check tokens mode (-gnatyt), right paren must never be preceded by
+ -- a space unless it is the initial non-blank character on the line.
+
+ procedure Check_Right_Paren is
+ begin
+ if Style_Check_Tokens then
+ if Token_Ptr > First_Non_Blank_Location
+ and then Source (Token_Ptr - 1) = ' '
+ then
+ Error_Space_Not_Allowed (Token_Ptr - 1);
+ end if;
+ end if;
+ end Check_Right_Paren;
+
+ ---------------------
+ -- Check_Semicolon --
+ ---------------------
+
+ -- In check tokens mode (-gnatyt), semicolon does not permit a preceding
+ -- space and a following space is required.
+
+ procedure Check_Semicolon is
+ begin
+ if Style_Check_Tokens then
+ if Scan_Ptr > Source_First (Current_Source_File)
+ and then Source (Token_Ptr - 1) = ' '
+ then
+ Error_Space_Not_Allowed (Token_Ptr - 1);
+
+ elsif Source (Scan_Ptr) > ' ' then
+ Error_Space_Required (Scan_Ptr);
+ end if;
+ end if;
+ end Check_Semicolon;
+
+ ----------------
+ -- Check_Then --
+ ----------------
+
+ -- In check if then layout mode (-gnatyi), we expect a THEN keyword
+ -- to appear either on the same line as the IF, or on a separate line
+ -- after multiple conditions. In any case, it may not appear on the
+ -- line immediately following the line with the IF.
+
+ procedure Check_Then (If_Loc : Source_Ptr) is
+ begin
+ if Style_Check_If_Then_Layout then
+ if Get_Physical_Line_Number (Token_Ptr) =
+ Get_Physical_Line_Number (If_Loc) + 1
+ then
+ Error_Msg_SC ("(style) misplaced THEN");
+ end if;
+ end if;
+ end Check_Then;
+
+ -------------------------------
+ -- Check_Unary_Plus_Or_Minus --
+ -------------------------------
+
+ -- In check tokem mode (-gnatyt), unary plus or minus must not be
+ -- followed by a space.
+
+ procedure Check_Unary_Plus_Or_Minus is
+ begin
+ if Style_Check_Tokens then
+ if Source (Scan_Ptr) = ' ' then
+ Error_Space_Not_Allowed (Scan_Ptr);
+ end if;
+ end if;
+ end Check_Unary_Plus_Or_Minus;
+
+ ------------------------
+ -- Check_Vertical_Bar --
+ ------------------------
+
+ -- In check token mode (-gnatyt), vertical bar must be surrounded by spaces
+
+ procedure Check_Vertical_Bar is
+ begin
+ if Style_Check_Tokens then
+ Require_Preceding_Space;
+ Require_Following_Space;
+ end if;
+ end Check_Vertical_Bar;
+
+ -----------------------------
+ -- Error_Space_Not_Allowed --
+ -----------------------------
+
+ procedure Error_Space_Not_Allowed (S : Source_Ptr) is
+ begin
+ Error_Msg ("(style) space not allowed", S);
+ end Error_Space_Not_Allowed;
+
+ --------------------------
+ -- Error_Space_Required --
+ --------------------------
+
+ procedure Error_Space_Required (S : Source_Ptr) is
+ begin
+ Error_Msg ("(style) space required", S);
+ end Error_Space_Required;
+
+ -----------------
+ -- No_End_Name --
+ -----------------
+
+ -- In check end/exit labels mode (-gnatye), always require the name of
+ -- a subprogram or package to be present on the END, so this is an error.
+
+ procedure No_End_Name (Name : Node_Id) is
+ begin
+ if Style_Check_End_Labels then
+ Error_Msg_Node_1 := Name;
+ Error_Msg_SP ("(style) `END &` required");
+ end if;
+ end No_End_Name;
+
+ ------------------
+ -- No_Exit_Name --
+ ------------------
+
+ -- In check end/exit labels mode (-gnatye), always require the name of
+ -- the loop to be present on the EXIT when exiting a named loop.
+
+ procedure No_Exit_Name (Name : Node_Id) is
+ begin
+ if Style_Check_End_Labels then
+ Error_Msg_Node_1 := Name;
+ Error_Msg_SP ("(style) `EXIT &` required");
+ end if;
+ end No_Exit_Name;
+
+ ----------------------------
+ -- Non_Lower_Case_Keyword --
+ ----------------------------
+
+ -- In check casing mode (-gnatyk), reserved keywords must be be spelled
+ -- in all lower case (excluding keywords range, access, delta and digits
+ -- used as attribute designators).
+
+ procedure Non_Lower_Case_Keyword is
+ begin
+ if Style_Check_Keyword_Casing then
+ Error_Msg_SC ("(style) reserved words must be all lower case");
+ end if;
+ end Non_Lower_Case_Keyword;
+
+ -----------------------------
+ -- Require_Following_Space --
+ -----------------------------
+
+ procedure Require_Following_Space is
+ begin
+ if Source (Scan_Ptr) > ' ' then
+ Error_Space_Required (Scan_Ptr);
+ end if;
+ end Require_Following_Space;
+
+ -----------------------------
+ -- Require_Preceding_Space --
+ -----------------------------
+
+ procedure Require_Preceding_Space is
+ begin
+ if Token_Ptr > Source_First (Current_Source_File)
+ and then Source (Token_Ptr - 1) > ' '
+ then
+ Error_Space_Required (Token_Ptr);
+ end if;
+ end Require_Preceding_Space;
+
+ ---------------------
+ -- RM_Column_Check --
+ ---------------------
+
+ function RM_Column_Check return Boolean is
+ begin
+ return Style_Check and Style_Check_Layout;
+ end RM_Column_Check;
+
+ -----------------------------------
+ -- Subprogram_Not_In_Alpha_Order --
+ -----------------------------------
+
+ procedure Subprogram_Not_In_Alpha_Order (Name : Node_Id) is
+ begin
+ if Style_Check_Subprogram_Order then
+ Error_Msg_N
+ ("(style) subprogram body& not in alphabetical order", Name);
+ end if;
+ end Subprogram_Not_In_Alpha_Order;
+end Style;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S T Y L E --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.12 $
+-- --
+-- 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). --
+-- --
+------------------------------------------------------------------------------
+
+-- This package collects all the routines used for style checking, as
+-- activated by the relevant command line option. These are gathered in
+-- a separate package so that they can more easily be customized. Calls
+-- to these subprograms are only made if Opt.Style_Check is set True.
+
+with Types; use Types;
+
+package Style is
+
+ procedure Body_With_No_Spec (N : Node_Id);
+ -- Called where N is a subprogram body node for a subprogram body
+ -- for which no spec was given, i.e. a body acting as its own spec.
+
+ procedure Check_Abs_Not;
+ -- Called after scanning an ABS or NOT operator to check spacing
+
+ procedure Check_Arrow;
+ -- Called after scanning out an arrow to check spacing
+
+ procedure Check_Attribute_Name (Reserved : Boolean);
+ -- The current token is an attribute designator. Check that it is
+ -- capitalized in an appropriate manner. Reserved is set if the
+ -- attribute designator is a reserved word (access, digits, delta
+ -- or range) to allow differing rules for the two cases.
+
+ procedure Check_Box;
+ -- Called after scanning out a box to check spacing
+
+ procedure Check_Binary_Operator;
+ -- Called after scanning out a binary operator other than a plus, minus
+ -- or exponentiation operator. Intended for checking spacing rules.
+
+ procedure Check_Exponentiation_Operator;
+ -- Called after scanning out an exponentiation operator. Intended for
+ -- checking spacing rules.
+
+ procedure Check_Colon;
+ -- Called after scanning out colon to check spacing
+
+ procedure Check_Colon_Equal;
+ -- Called after scanning out colon equal to check spacing
+
+ procedure Check_Comma;
+ -- Called after scanning out comma to check spacing
+
+ procedure Check_Comment;
+ -- Called with Scan_Ptr pointing to the first minus sign of a comment.
+ -- Intended for checking any specific rules for comment placement/format.
+
+ procedure Check_Dot_Dot;
+ -- Called after scanning out dot dot to check spacing
+
+ procedure Check_HT;
+ -- Called with Scan_Ptr pointing to a horizontal tab character
+
+ procedure Check_Identifier
+ (Ref : Node_Or_Entity_Id;
+ Def : Node_Or_Entity_Id);
+ -- Check style of identifier occurrence. Ref is an N_Identifier node whose
+ -- spelling is to be checked against the Chars spelling in identifier node
+ -- Def (which may be either an N_Identifier, or N_Defining_Identifier node)
+
+ procedure Check_Indentation;
+ -- Called at the start of a new statement or declaration, with Token_Ptr
+ -- pointing to the first token of the statement or declaration. The check
+ -- is that the starting column is appropriate to the indentation rules if
+ -- Token_Ptr is the first token on the line.
+
+ procedure Check_Left_Paren;
+ -- Called after scanning out a left parenthesis to check spacing.
+
+ procedure Check_Line_Terminator (Len : Int);
+ -- Called with Scan_Ptr pointing to the first line terminator terminating
+ -- the current line, used to check for appropriate line terminator and
+ -- to check the line length (Len is the length of the current line).
+ -- Note that the terminator may be the EOF character.
+
+ procedure Check_Pragma_Name;
+ -- The current token is a pragma identifier. Check that it is spelled
+ -- properly (i.e. with an appropriate casing convention).
+
+ procedure Check_Right_Paren;
+ -- Called after scanning out a right parenthesis to check spacing.
+
+ procedure Check_Semicolon;
+ -- Called after scanning out a semicolon to check spacing
+
+ procedure Check_Then (If_Loc : Source_Ptr);
+ -- Called to check that THEN and IF keywords are appropriately positioned.
+ -- The parameters show the first characters of the two keywords. This
+ -- procedure is called only if THEN appears at the start of a line with
+ -- Token_Ptr pointing to the THEN keyword.
+
+ procedure Check_Unary_Plus_Or_Minus;
+ -- Called after scanning a unary plus or minus to check spacing
+
+ procedure Check_Vertical_Bar;
+ -- Called after scanning a vertical bar to check spacing
+
+ procedure No_End_Name (Name : Node_Id);
+ -- Called if an END is encountered where a name is allowed but not present.
+ -- The parameter is the node whose name is the name that is permitted in
+ -- the END line, and the scan pointer is positioned so that if an error
+ -- message is to be generated in this situation, it should be generated
+ -- using Error_Msg_SP.
+
+ procedure No_Exit_Name (Name : Node_Id);
+ -- Called when exiting a named loop, but a name is not present on the EXIT.
+ -- The parameter is the node whose name should have followed EXIT, and the
+ -- scan pointer is positioned so that if an error message is to be
+ -- generated, it should be generated using Error_Msg_SP.
+
+ procedure Non_Lower_Case_Keyword;
+ -- Called if a reserved keyword is scanned which is not spelled in all
+ -- lower case letters. On entry Token_Ptr points to the keyword token.
+ -- This is not used for keywords appearing as attribute designators,
+ -- where instead Check_Attribute_Name (True) is called.
+
+ function RM_Column_Check return Boolean;
+ pragma Inline (RM_Column_Check);
+ -- Determines whether style checking is active and the RM column check
+ -- mode is set requiring checking of RM format layout.
+
+ procedure Subprogram_Not_In_Alpha_Order (Name : Node_Id);
+ -- Called if Name is the name of a subprogram body in a package body
+ -- that is not in alphabetical order.
+
+end Style;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S T Y L E S W --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.14 $
+-- --
+-- 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). --
+-- --
+------------------------------------------------------------------------------
+
+with Hostparm; use Hostparm;
+with Opt; use Opt;
+
+package body Stylesw is
+
+ -------------------------------
+ -- Reset_Style_Check_Options --
+ -------------------------------
+
+ procedure Reset_Style_Check_Options is
+ begin
+ Style_Check_Indentation := 0;
+ Style_Check_Attribute_Casing := False;
+ Style_Check_Blanks_At_End := False;
+ Style_Check_Comments := False;
+ Style_Check_End_Labels := False;
+ Style_Check_Form_Feeds := False;
+ Style_Check_Horizontal_Tabs := False;
+ Style_Check_If_Then_Layout := False;
+ Style_Check_Keyword_Casing := False;
+ Style_Check_Layout := False;
+ Style_Check_Max_Line_Length := False;
+ Style_Check_Pragma_Casing := False;
+ Style_Check_References := False;
+ Style_Check_Specs := False;
+ Style_Check_Standard := False;
+ Style_Check_Subprogram_Order := False;
+ Style_Check_Tokens := False;
+ end Reset_Style_Check_Options;
+
+ ------------------------------
+ -- Save_Style_Check_Options --
+ ------------------------------
+
+ procedure Save_Style_Check_Options (Options : out Style_Check_Options) is
+ P : Natural := 0;
+ J : Natural;
+
+ procedure Add (C : Character; S : Boolean);
+ -- Add given character C to string if switch S is true
+
+ procedure Add (C : Character; S : Boolean) is
+ begin
+ if S then
+ P := P + 1;
+ Options (P) := C;
+ end if;
+ end Add;
+
+ -- Start of processing for Save_Style_Check_Options
+
+ begin
+ for K in Options'Range loop
+ Options (K) := ' ';
+ end loop;
+
+ Add (Character'Val (Style_Check_Indentation + Character'Pos ('0')),
+ Style_Check_Indentation /= 0);
+
+ Add ('a', Style_Check_Attribute_Casing);
+ Add ('b', Style_Check_Blanks_At_End);
+ Add ('c', Style_Check_Comments);
+ Add ('e', Style_Check_End_Labels);
+ Add ('f', Style_Check_Form_Feeds);
+ Add ('h', Style_Check_Horizontal_Tabs);
+ Add ('i', Style_Check_If_Then_Layout);
+ Add ('k', Style_Check_Keyword_Casing);
+ Add ('l', Style_Check_Layout);
+ Add ('m', Style_Check_Max_Line_Length);
+ Add ('n', Style_Check_Standard);
+ Add ('o', Style_Check_Subprogram_Order);
+ Add ('p', Style_Check_Pragma_Casing);
+ Add ('r', Style_Check_References);
+ Add ('s', Style_Check_Specs);
+ Add ('t', Style_Check_Tokens);
+
+ if Style_Check_Max_Line_Length then
+ P := Options'Last;
+ J := Natural (Style_Max_Line_Length);
+
+ loop
+ Options (P) := Character'Val (J mod 10 + Character'Pos ('0'));
+ P := P - 1;
+ J := J / 10;
+ exit when J = 0;
+ end loop;
+
+ Options (P) := 'M';
+ end if;
+
+ end Save_Style_Check_Options;
+
+ -------------------------------------
+ -- Set_Default_Style_Check_Options --
+ -------------------------------------
+
+ procedure Set_Default_Style_Check_Options is
+ begin
+ Reset_Style_Check_Options;
+ Set_Style_Check_Options ("3abcefhiklmnprst");
+ end Set_Default_Style_Check_Options;
+
+ -----------------------------
+ -- Set_Style_Check_Options --
+ -----------------------------
+
+ -- Version used when no error checking is required
+
+ procedure Set_Style_Check_Options (Options : String) is
+ OK : Boolean;
+ EC : Natural;
+
+ begin
+ Set_Style_Check_Options (Options, OK, EC);
+ end Set_Style_Check_Options;
+
+ -- Normal version with error checking
+
+ procedure Set_Style_Check_Options
+ (Options : String;
+ OK : out Boolean;
+ Err_Col : out Natural)
+ is
+ J : Natural;
+ C : Character;
+
+ begin
+ J := Options'First;
+ while J <= Options'Last loop
+ C := Options (J);
+ J := J + 1;
+
+ case C is
+ when '1' .. '9' =>
+ Style_Check_Indentation
+ := Character'Pos (C) - Character'Pos ('0');
+
+ when 'a' =>
+ Style_Check_Attribute_Casing := True;
+
+ when 'b' =>
+ Style_Check_Blanks_At_End := True;
+
+ when 'c' =>
+ Style_Check_Comments := True;
+
+ when 'e' =>
+ Style_Check_End_Labels := True;
+
+ when 'f' =>
+ Style_Check_Form_Feeds := True;
+
+ when 'h' =>
+ Style_Check_Horizontal_Tabs := True;
+
+ when 'i' =>
+ Style_Check_If_Then_Layout := True;
+
+ when 'k' =>
+ Style_Check_Keyword_Casing := True;
+
+ when 'l' =>
+ Style_Check_Layout := True;
+
+ when 'm' =>
+ Style_Check_Max_Line_Length := True;
+ Style_Max_Line_Length := 79;
+
+ when 'n' =>
+ Style_Check_Standard := True;
+
+ when 'M' =>
+ Style_Max_Line_Length := 0;
+
+ if J > Options'Last
+ or else Options (J) not in '0' .. '9'
+ then
+ OK := False;
+ Err_Col := J;
+ return;
+ end if;
+
+ loop
+ Style_Max_Line_Length :=
+ Style_Max_Line_Length * 10 +
+ Character'Pos (Options (J)) - Character'Pos ('0');
+ J := J + 1;
+ exit when J > Options'Last
+ or else Options (J) not in '0' .. '9';
+ end loop;
+
+ Style_Max_Line_Length :=
+ Int'Min (Style_Max_Line_Length, Hostparm.Max_Line_Length);
+
+ Style_Check_Max_Line_Length := Style_Max_Line_Length /= 0;
+
+ when 'o' =>
+ Style_Check_Subprogram_Order := True;
+
+ when 'p' =>
+ Style_Check_Pragma_Casing := True;
+
+ when 'r' =>
+ Style_Check_References := True;
+
+ when 's' =>
+ Style_Check_Specs := True;
+
+ when 't' =>
+ Style_Check_Tokens := True;
+
+ when ' ' =>
+ null;
+
+ when others =>
+ OK := False;
+ Err_Col := J - 1;
+ return;
+ end case;
+ end loop;
+
+ Style_Check := True;
+ OK := True;
+ Err_Col := Options'Last + 1;
+ end Set_Style_Check_Options;
+
+end Stylesw;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S T Y L E S W --
+-- --
+-- 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 contains the style switches used for setting style options.
+-- The only clients of this package are the body of Style and the body of
+-- Switches. All other style checking issues are handled using the public
+-- interfaces in the spec of Style.
+
+with Types; use Types;
+
+package Stylesw is
+
+ --------------------------
+ -- Style Check Switches --
+ --------------------------
+
+ -- These flags are used to control the details of the style checking
+ -- options. The default values shown here correspond to no style
+ -- checking. If any of these values is set to a non-default value,
+ -- then Opt.Style_Check is set True to active calls to this package.
+
+ -- The actual mechanism for setting these switches to other than
+ -- default values is via the Set_Style_Check_Option procedure or
+ -- through a call to Set_Default_Style_Check_Options. They should
+ -- not be set directly in any other manner.
+
+ Style_Check_Attribute_Casing : Boolean := False;
+ -- This can be set True by using the -gnatg or -gnatya switches. If
+ -- it is True, then attribute names (including keywords such as
+ -- digits used as attribute names) must be in mixed case.
+
+ Style_Check_Blanks_At_End : Boolean := False;
+ -- This can be set True by using the -gnatg or -gnatyb switches. If
+ -- it is True, then spaces at the end of lines are not permitted.
+
+ Style_Check_Comments : Boolean := False;
+ -- This can be set True by using the -gnatg or -gnatyc switches. If
+ -- it is True, then comments are style checked as follows:
+ --
+ -- All comments must be at the start of the line, or the first
+ -- minus must be preceded by at least one space.
+ --
+ -- For a comment that is not at the start of a line, the only
+ -- requirement is that a space follow the comment characters.
+ --
+ -- For a coment that is at the start of the line, one of the
+ -- following conditions must hold:
+ --
+ -- The comment characters are the only non-blank characters on the line
+ --
+ -- The comment characters are followed by an exclamation point (the
+ -- sequence --! is used by gnatprep for marking deleted lines).
+ --
+ -- The comment characters are followed by two space characters
+ --
+ -- The line consists entirely of minus signs
+ --
+ -- The comment characters are followed by a single space, and the
+ -- last two characters on the line are also comment characters.
+ --
+ -- Note: the reason for the last two conditions is to allow "boxed"
+ -- comments where only a single space separates the comment characters.
+
+ Style_Check_End_Labels : Boolean := False;
+ -- This can be set True by using the -gnatg or -gnatye switches. If
+ -- it is True, then optional END labels must always be present.
+
+ Style_Check_Form_Feeds : Boolean := False;
+ -- This can be set True by using the -gnatg or -gnatyf switches. If
+ -- it is True, then form feeds and vertical tabs are not allowed in
+ -- the source text.
+
+ Style_Check_Horizontal_Tabs : Boolean := False;
+ -- This can be set True by using the -gnatg or -gnatyh switches. If
+ -- it is True, then horizontal tabs are not allowed in source text.
+
+ Style_Check_If_Then_Layout : Boolean := False;
+ -- This can be set True by using the -gnatg or -gnatyi switches. If
+ -- it is True, then a THEN keyword may not appear on the line that
+ -- immediately follows the line containing the corresponding IF.
+ --
+ -- This permits one of two styles for IF-THEN layout. Either the
+ -- IF and THEN keywords are on the same line, where the condition
+ -- is short enough, or the conditions are continued over to the
+ -- lines following the IF and the THEN stands on its own. For
+ -- example:
+ --
+ -- if X > Y then
+ --
+ -- if X > Y
+ -- and then Y < Z
+ -- then
+ --
+ -- are allowed, but
+ --
+ -- if X > Y
+ -- then
+ --
+ -- is not allowed.
+
+ Style_Check_Indentation : Column_Number range 0 .. 9 := 0;
+ -- This can be set non-zero by using the -gnatg or -gnatyn (n a digit)
+ -- switches. If it is non-zero it activates indentation checking with
+ -- the indicated indentation value. A value of zero turns off checking.
+ -- The requirement is that any new statement, line comment, declaration
+ -- or keyword such as END, start on a column that is a multiple of the
+ -- indentiation value.
+
+ Style_Check_Keyword_Casing : Boolean := False;
+ -- This can be set True by using the -gnatg or -gnatyk switches. If
+ -- it is True, then keywords are required to be in all lower case.
+ -- This rule does not apply to keywords such as digits appearing as
+ -- an attribute name.
+
+ Style_Check_Max_Line_Length : Boolean := False;
+ -- This can be set True by using the -gnatg or -gnatym switches. If
+ -- it is True, it activates checking for a maximum line length of 79
+ -- characters (chosen to fit in standard 80 column displays that don't
+ -- handle the limiting case of 80 characters cleanly).
+
+ Style_Check_Pragma_Casing : Boolean := False;
+ -- This can be set True by using the -gnatg or -gnatyp switches. If
+ -- it is True, then pragma names must use mixed case.
+
+ Style_Check_Layout : Boolean := False;
+ -- This can be set True by using the -gnatg or -gnatyl switches. If
+ -- it is True, it activates checks that constructs are indented as
+ -- suggested by the examples in the RM syntax, e.g. that the ELSE
+ -- keyword must line up with the IF keyword.
+
+ Style_Check_References : Boolean := False;
+ -- This can be set True by using the -gnatg or -gnatyr switches. If
+ -- it is True, then all references to declared identifiers are
+ -- checked. The requirement is that casing of the reference be the
+ -- same as the casing of the corresponding declaration.
+
+ Style_Check_Specs : Boolean := False;
+ -- This can be set True by using the -gnatg or -gnatys switches. If
+ -- it is True, then separate specs are required to be present for
+ -- all procedures except parameterless library level procedures.
+ -- The exception means that typical main programs do not require
+ -- separate specs.
+
+ Style_Check_Standard : Boolean := False;
+ -- This can be set True by using the -gnatg or -gnatyn switches. If
+ -- it is True, then any references to names in Standard have to be
+ -- in mixed case mode (e.g. Integer, Boolean).
+
+ Style_Check_Tokens : Boolean := False;
+ -- This can be set True by using the -gnatg or -gnatyt switches. If
+ -- it is True, then the style check that requires canonical spacing
+ -- between various punctuation tokens as follows:
+ --
+ -- ABS and NOT must be followed by a space
+ --
+ -- => must be surrounded by spaces
+ --
+ -- <> must be preceded by a space or left paren
+ --
+ -- Binary operators other than ** must be surrounded by spaces.
+ -- There is no restriction on the layout of the ** binary operator.
+ --
+ -- Colon must be surrounded by spaces
+ --
+ -- Colon-equal (assignment) must be surrounded by spaces
+ --
+ -- Comma must be the first non-blank character on the line, or be
+ -- immediately preceded by a non-blank character, and must be followed
+ -- by a blank.
+ --
+ -- A space must precede a left paren following a digit or letter,
+ -- and a right paren must not be followed by a space (it can be
+ -- at the end of the line).
+ --
+ -- A right paren must either be the first non-blank character on
+ -- a line, or it must be preceded by a non-blank character.
+ --
+ -- A semicolon must not be preceded by a blank, and must not be
+ -- followed by a non-blank character.
+ --
+ -- A unary plus or minus may not be followed by a space
+ --
+ -- A vertical bar must be surrounded by spaces
+ --
+ -- Note that a requirement that a token be preceded by a space is
+ -- met by placing the token at the start of the line, and similarly
+ -- a requirement that a token be followed by a space is met by
+ -- placing the token at the end of the line. Note that in the case
+ -- where horizontal tabs are permitted, a horizontal tab is acceptable
+ -- for meeting the requirement for a space.
+
+ Style_Check_Subprogram_Order : Boolean := False;
+ -- This can be set True by using the -gnatg or -gnatyo switch. If it
+ -- is True, then names of subprogram bodies must be in alphabetical
+ -- order (not taking casing into account).
+
+ Style_Max_Line_Length : Int := 79;
+ -- Value used to check maximum line length. Can be reset by a call to
+ -- Set_Max_Line_Length. The value here is the default if no such call.
+
+ -----------------
+ -- Subprograms --
+ -----------------
+
+ procedure Set_Default_Style_Check_Options;
+ -- This procedure is called to set the default style checking options
+ -- in response to a -gnatg switch or -gnaty with no suboptions.
+
+ procedure Set_Style_Check_Options
+ (Options : String;
+ OK : out Boolean;
+ Err_Col : out Natural);
+ -- This procedure is called to set the style check options that
+ -- correspond to the characters in the given Options string. If
+ -- all options are valid, they are set in an additive manner:
+ -- any previous options are retained unless overridden. If any
+ -- invalid character is found, then OK is False on exit, and
+ -- Err_Col is the index in options of the bad character. If all
+ -- options are valid, OK is True on return, and Err_Col is set
+ -- to Options'Last + 1.
+
+ procedure Set_Style_Check_Options (Options : String);
+ -- Like the above procedure, except that the call is simply ignored if
+ -- there are any error conditions, this is for example appopriate for
+ -- calls where the string is known to be valid, e.g. because it was
+ -- obtained by Save_Style_Check_Options.
+
+ procedure Reset_Style_Check_Options;
+ -- Sets all style check options to off
+
+ subtype Style_Check_Options is String (1 .. 32);
+ -- Long enough string to hold all options from Save call below
+
+ procedure Save_Style_Check_Options (Options : out Style_Check_Options);
+ -- Sets Options to represent current selection of options. This
+ -- set can be restored by first calling Reset_Style_Check_Options,
+ -- and then calling Set_Style_Check_Options with the Options string.
+
+end Stylesw;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S W I T C H --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.194 $
+-- --
+-- 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). --
+-- --
+------------------------------------------------------------------------------
+
+-- Option switch scanning for both the compiler and the binder
+
+-- Note: this version of the package should be usable in both Unix and DOS
+
+with Debug; use Debug;
+with Osint; use Osint;
+with Opt; use Opt;
+with Validsw; use Validsw;
+with Stylesw; use Stylesw;
+with Types; use Types;
+
+with System.WCh_Con; use System.WCh_Con;
+
+package body Switch is
+
+ Bad_Switch : exception;
+ -- Exception raised if bad switch encountered
+
+ Bad_Switch_Value : exception;
+ -- Exception raised if bad switch value encountered
+
+ Missing_Switch_Value : exception;
+ -- Exception raised if no switch value encountered
+
+ Too_Many_Output_Files : exception;
+ -- Exception raised if the -o switch is encountered more than once
+
+ Switch_Max_Value : constant := 999;
+ -- Maximum value permitted in switches that take a value
+
+ procedure Scan_Nat
+ (Switch_Chars : String;
+ Max : Integer;
+ Ptr : in out Integer;
+ Result : out Nat);
+ -- Scan natural integer parameter for switch. On entry, Ptr points
+ -- just past the switch character, on exit it points past the last
+ -- digit of the integer value.
+
+ procedure Scan_Pos
+ (Switch_Chars : String;
+ Max : Integer;
+ Ptr : in out Integer;
+ Result : out Pos);
+ -- Scan positive integer parameter for switch. On entry, Ptr points
+ -- just past the switch character, on exit it points past the last
+ -- digit of the integer value.
+
+ -------------------------
+ -- Is_Front_End_Switch --
+ -------------------------
+
+ function Is_Front_End_Switch (Switch_Chars : String) return Boolean is
+ Ptr : constant Positive := Switch_Chars'First;
+ begin
+ return Is_Switch (Switch_Chars)
+ and then
+ (Switch_Chars (Ptr + 1) = 'I'
+ or else
+ (Switch_Chars'Length >= 5
+ and then Switch_Chars (Ptr + 1 .. Ptr + 4) = "gnat"));
+ end Is_Front_End_Switch;
+
+ ---------------
+ -- Is_Switch --
+ ---------------
+
+ function Is_Switch (Switch_Chars : String) return Boolean is
+ begin
+ return Switch_Chars'Length > 1
+ and then (Switch_Chars (Switch_Chars'First) = '-'
+ or
+ Switch_Chars (Switch_Chars'First) = Switch_Character);
+ end Is_Switch;
+
+ --------------------------
+ -- Scan_Binder_Switches --
+ --------------------------
+
+ procedure Scan_Binder_Switches (Switch_Chars : String) is
+ Ptr : Integer := Switch_Chars'First;
+ Max : Integer := Switch_Chars'Last;
+ C : Character := ' ';
+
+ begin
+ -- Skip past the initial character (must be the switch character)
+
+ if Ptr = Max then
+ raise Bad_Switch;
+ else
+ Ptr := Ptr + 1;
+ end if;
+
+ -- A little check, "gnat" at the start of a switch is not allowed
+ -- except for the compiler
+
+ if Switch_Chars'Last >= Ptr + 3
+ and then Switch_Chars (Ptr .. Ptr + 3) = "gnat"
+ then
+ Osint.Fail ("invalid switch: """, Switch_Chars, """"
+ & " (gnat not needed here)");
+
+ end if;
+
+ -- Loop to scan through switches given in switch string
+
+ while Ptr <= Max loop
+ C := Switch_Chars (Ptr);
+
+ case C is
+
+ -- Processing for A switch
+
+ when 'A' =>
+ Ptr := Ptr + 1;
+
+ Ada_Bind_File := True;
+
+ -- Processing for b switch
+
+ when 'b' =>
+ Ptr := Ptr + 1;
+ Brief_Output := True;
+
+ -- Processing for c switch
+
+ when 'c' =>
+ Ptr := Ptr + 1;
+
+ Check_Only := True;
+
+ -- Processing for C switch
+
+ when 'C' =>
+ Ptr := Ptr + 1;
+
+ Ada_Bind_File := False;
+
+ -- Processing for d switch
+
+ when 'd' =>
+
+ -- Note: for the debug switch, the remaining characters in this
+ -- switch field must all be debug flags, since all valid switch
+ -- characters are also valid debug characters.
+
+ -- Loop to scan out debug flags
+
+ while Ptr < Max loop
+ Ptr := Ptr + 1;
+ C := Switch_Chars (Ptr);
+ exit when C = ASCII.NUL or else C = '/' or else C = '-';
+
+ if C in '1' .. '9' or else
+ C in 'a' .. 'z' or else
+ C in 'A' .. 'Z'
+ then
+ Set_Debug_Flag (C);
+ else
+ raise Bad_Switch;
+ end if;
+ end loop;
+
+ -- Make sure Zero_Cost_Exceptions is set if gnatdX set. This
+ -- is for backwards compatibility with old versions and usage.
+
+ if Debug_Flag_XX then
+ Zero_Cost_Exceptions_Set := True;
+ Zero_Cost_Exceptions_Val := True;
+ end if;
+
+ return;
+
+ -- Processing for e switch
+
+ when 'e' =>
+ Ptr := Ptr + 1;
+ Elab_Dependency_Output := True;
+
+ -- Processing for E switch
+
+ when 'E' =>
+ Ptr := Ptr + 1;
+ Exception_Tracebacks := True;
+
+ -- Processing for f switch
+
+ when 'f' =>
+ Ptr := Ptr + 1;
+ Force_RM_Elaboration_Order := True;
+
+ -- Processing for g switch
+
+ when 'g' =>
+ Ptr := Ptr + 1;
+ if Ptr <= Max then
+ C := Switch_Chars (Ptr);
+ if C in '0' .. '3' then
+ Debugger_Level :=
+ Character'Pos
+ (Switch_Chars (Ptr)) - Character'Pos ('0');
+ Ptr := Ptr + 1;
+ end if;
+ else
+ Debugger_Level := 2;
+ end if;
+
+ -- Processing for G switch
+
+ when 'G' =>
+ Ptr := Ptr + 1;
+ Print_Generated_Code := True;
+
+ -- Processing for h switch
+
+ when 'h' =>
+ Ptr := Ptr + 1;
+ Usage_Requested := True;
+
+ -- Processing for i switch
+
+ when 'i' =>
+ if Ptr = Max then
+ raise Bad_Switch;
+ end if;
+
+ Ptr := Ptr + 1;
+ C := Switch_Chars (Ptr);
+
+ if C = '1' or else
+ C = '2' or else
+ C = '3' or else
+ C = '4' or else
+ C = '8' or else
+ C = 'p' or else
+ C = 'f' or else
+ C = 'n' or else
+ C = 'w'
+ then
+ Identifier_Character_Set := C;
+ Ptr := Ptr + 1;
+ else
+ raise Bad_Switch;
+ end if;
+
+ -- Processing for K switch
+
+ when 'K' =>
+ Ptr := Ptr + 1;
+
+ if Program = Binder then
+ Output_Linker_Option_List := True;
+ else
+ raise Bad_Switch;
+ end if;
+
+ -- Processing for l switch
+
+ when 'l' =>
+ Ptr := Ptr + 1;
+ Elab_Order_Output := True;
+
+ -- Processing for m switch
+
+ when 'm' =>
+ Ptr := Ptr + 1;
+ Scan_Pos (Switch_Chars, Max, Ptr, Maximum_Errors);
+
+ -- Processing for n switch
+
+ when 'n' =>
+ Ptr := Ptr + 1;
+ Bind_Main_Program := False;
+
+ -- Note: The -L option of the binder also implies -n, so
+ -- any change here must also be reflected in the processing
+ -- for -L that is found in Gnatbind.Scan_Bind_Arg.
+
+ -- Processing for o switch
+
+ when 'o' =>
+ Ptr := Ptr + 1;
+
+ if Output_File_Name_Present then
+ raise Too_Many_Output_Files;
+
+ else
+ Output_File_Name_Present := True;
+ end if;
+
+ -- Processing for O switch
+
+ when 'O' =>
+ Ptr := Ptr + 1;
+ Output_Object_List := True;
+
+ -- Processing for p switch
+
+ when 'p' =>
+ Ptr := Ptr + 1;
+ Pessimistic_Elab_Order := True;
+
+ -- Processing for q switch
+
+ when 'q' =>
+ Ptr := Ptr + 1;
+ Quiet_Output := True;
+
+ -- Processing for s switch
+
+ when 's' =>
+ Ptr := Ptr + 1;
+ All_Sources := True;
+ Check_Source_Files := True;
+
+ -- Processing for t switch
+
+ when 't' =>
+ Ptr := Ptr + 1;
+ Tolerate_Consistency_Errors := True;
+
+ -- Processing for T switch
+
+ when 'T' =>
+ Ptr := Ptr + 1;
+ Time_Slice_Set := True;
+ Scan_Nat (Switch_Chars, Max, Ptr, Time_Slice_Value);
+
+ -- Processing for v switch
+
+ when 'v' =>
+ Ptr := Ptr + 1;
+ Verbose_Mode := True;
+
+ -- Processing for w switch
+
+ when 'w' =>
+
+ -- For the binder we only allow suppress/error cases
+
+ Ptr := Ptr + 1;
+
+ case Switch_Chars (Ptr) is
+
+ when 'e' =>
+ Warning_Mode := Treat_As_Error;
+
+ when 's' =>
+ Warning_Mode := Suppress;
+
+ when others =>
+ raise Bad_Switch;
+ end case;
+
+ Ptr := Ptr + 1;
+
+ -- Processing for W switch
+
+ when 'W' =>
+ Ptr := Ptr + 1;
+
+ for J in WC_Encoding_Method loop
+ if Switch_Chars (Ptr) = WC_Encoding_Letters (J) then
+ Wide_Character_Encoding_Method := J;
+ exit;
+
+ elsif J = WC_Encoding_Method'Last then
+ raise Bad_Switch;
+ end if;
+ end loop;
+
+ Upper_Half_Encoding :=
+ Wide_Character_Encoding_Method in
+ WC_Upper_Half_Encoding_Method;
+
+ Ptr := Ptr + 1;
+
+ -- Processing for x switch
+
+ when 'x' =>
+ Ptr := Ptr + 1;
+ All_Sources := False;
+ Check_Source_Files := False;
+
+ -- Processing for z switch
+
+ when 'z' =>
+ Ptr := Ptr + 1;
+ No_Main_Subprogram := True;
+
+ -- Ignore extra switch character
+
+ when '/' | '-' =>
+ Ptr := Ptr + 1;
+
+ -- Anything else is an error (illegal switch character)
+
+ when others =>
+ raise Bad_Switch;
+ end case;
+ end loop;
+
+ exception
+ when Bad_Switch =>
+ Osint.Fail ("invalid switch: ", (1 => C));
+
+ when Bad_Switch_Value =>
+ Osint.Fail ("numeric value too big for switch: ", (1 => C));
+
+ when Missing_Switch_Value =>
+ Osint.Fail ("missing numeric value for switch: ", (1 => C));
+
+ when Too_Many_Output_Files =>
+ Osint.Fail ("duplicate -o switch");
+ end Scan_Binder_Switches;
+
+ -----------------------------
+ -- Scan_Front_End_Switches --
+ -----------------------------
+
+ procedure Scan_Front_End_Switches (Switch_Chars : String) is
+ Switch_Starts_With_Gnat : Boolean;
+ Ptr : Integer := Switch_Chars'First;
+ Max : constant Integer := Switch_Chars'Last;
+ C : Character := ' ';
+
+ begin
+ -- Skip past the initial character (must be the switch character)
+
+ if Ptr = Max then
+ raise Bad_Switch;
+
+ else
+ Ptr := Ptr + 1;
+ end if;
+
+ -- A little check, "gnat" at the start of a switch is not allowed
+ -- except for the compiler (where it was already removed)
+
+ Switch_Starts_With_Gnat :=
+ Ptr + 3 <= Max and then Switch_Chars (Ptr .. Ptr + 3) = "gnat";
+
+ if Switch_Starts_With_Gnat then
+ Ptr := Ptr + 4;
+ end if;
+
+ -- Loop to scan through switches given in switch string
+
+ while Ptr <= Max loop
+ C := Switch_Chars (Ptr);
+
+ -- Processing for a switch
+
+ case Switch_Starts_With_Gnat is
+
+ when False =>
+ -- There is only one front-end switch that
+ -- does not start with -gnat, namely -I
+
+ case C is
+
+ when 'I' =>
+ Ptr := Ptr + 1;
+
+ if Ptr > Max then
+ raise Bad_Switch;
+ end if;
+
+ -- Find out whether this is a -I- or regular -Ixxx switch
+
+ if Ptr = Max and then Switch_Chars (Ptr) = '-' then
+ Look_In_Primary_Dir := False;
+
+ else
+ Add_Src_Search_Dir (Switch_Chars (Ptr .. Max));
+ end if;
+
+ Ptr := Max + 1;
+
+ when others =>
+ -- Should not happen, as Scan_Switches is supposed
+ -- to be called for front-end switches only.
+ -- Still, it is safest to raise Bad_Switch error.
+
+ raise Bad_Switch;
+ end case;
+
+ when True =>
+ -- Process -gnat* options
+
+ case C is
+
+ when 'a' =>
+ Ptr := Ptr + 1;
+ Assertions_Enabled := True;
+
+ -- Processing for A switch
+
+ when 'A' =>
+ Ptr := Ptr + 1;
+ Config_File := False;
+
+ -- Processing for b switch
+
+ when 'b' =>
+ Ptr := Ptr + 1;
+ Brief_Output := True;
+
+ -- Processing for c switch
+
+ when 'c' =>
+ Ptr := Ptr + 1;
+ Operating_Mode := Check_Semantics;
+
+ -- Processing for C switch
+
+ when 'C' =>
+ Ptr := Ptr + 1;
+ Compress_Debug_Names := True;
+
+ -- Processing for d switch
+
+ when 'd' =>
+
+ -- Note: for the debug switch, the remaining characters in this
+ -- switch field must all be debug flags, since all valid switch
+ -- characters are also valid debug characters.
+
+ -- Loop to scan out debug flags
+
+ while Ptr < Max loop
+ Ptr := Ptr + 1;
+ C := Switch_Chars (Ptr);
+ exit when C = ASCII.NUL or else C = '/' or else C = '-';
+
+ if C in '1' .. '9' or else
+ C in 'a' .. 'z' or else
+ C in 'A' .. 'Z'
+ then
+ Set_Debug_Flag (C);
+
+ else
+ raise Bad_Switch;
+ end if;
+ end loop;
+
+ -- Make sure Zero_Cost_Exceptions is set if gnatdX set. This
+ -- is for backwards compatibility with old versions and usage.
+
+ if Debug_Flag_XX then
+ Zero_Cost_Exceptions_Set := True;
+ Zero_Cost_Exceptions_Val := True;
+ end if;
+
+ return;
+
+ -- Processing for D switch
+
+ when 'D' =>
+ Ptr := Ptr + 1;
+
+ -- Note: -gnatD also sets -gnatx (to turn off cross-reference
+ -- generation in the ali file) since otherwise this generation
+ -- gets confused by the "wrong" Sloc values put in the tree.
+
+ Debug_Generated_Code := True;
+ Xref_Active := False;
+ Set_Debug_Flag ('g');
+
+ -- Processing for e switch
+
+ when 'e' =>
+ Ptr := Ptr + 1;
+
+ if Ptr > Max then
+ raise Bad_Switch;
+ end if;
+
+ case Switch_Chars (Ptr) is
+
+ when 'c' =>
+ Ptr := Ptr + 1;
+ if Ptr > Max then
+ Osint.Fail ("Invalid switch: ", "ec");
+ end if;
+
+ Config_File_Name :=
+ new String'(Switch_Chars (Ptr .. Max));
+
+ return;
+
+ when others =>
+ Osint.Fail ("Invalid switch: ",
+ (1 => 'e', 2 => Switch_Chars (Ptr)));
+ end case;
+
+ -- Processing for E switch
+
+ when 'E' =>
+ Ptr := Ptr + 1;
+ Dynamic_Elaboration_Checks := True;
+
+ -- Processing for f switch
+
+ when 'f' =>
+ Ptr := Ptr + 1;
+ All_Errors_Mode := True;
+
+ -- Processing for F switch
+
+ when 'F' =>
+ Ptr := Ptr + 1;
+ External_Name_Exp_Casing := Uppercase;
+ External_Name_Imp_Casing := Uppercase;
+
+ -- Processing for g switch
+
+ when 'g' =>
+ Ptr := Ptr + 1;
+ GNAT_Mode := True;
+ Identifier_Character_Set := 'n';
+ Warning_Mode := Treat_As_Error;
+ Check_Unreferenced := True;
+ Check_Withs := True;
+
+ Set_Default_Style_Check_Options;
+
+ -- Processing for G switch
+
+ when 'G' =>
+ Ptr := Ptr + 1;
+ Print_Generated_Code := True;
+
+ -- Processing for h switch
+
+ when 'h' =>
+ Ptr := Ptr + 1;
+ Usage_Requested := True;
+
+ -- Processing for H switch
+
+ when 'H' =>
+ Ptr := Ptr + 1;
+ HLO_Active := True;
+
+ -- Processing for i switch
+
+ when 'i' =>
+ if Ptr = Max then
+ raise Bad_Switch;
+ end if;
+
+ Ptr := Ptr + 1;
+ C := Switch_Chars (Ptr);
+
+ if C = '1' or else
+ C = '2' or else
+ C = '3' or else
+ C = '4' or else
+ C = '8' or else
+ C = 'p' or else
+ C = 'f' or else
+ C = 'n' or else
+ C = 'w'
+ then
+ Identifier_Character_Set := C;
+ Ptr := Ptr + 1;
+
+ else
+ raise Bad_Switch;
+ end if;
+
+ -- Processing for k switch
+
+ when 'k' =>
+ Ptr := Ptr + 1;
+ Scan_Pos (Switch_Chars, Max, Ptr, Maximum_File_Name_Length);
+
+ -- Processing for l switch
+
+ when 'l' =>
+ Ptr := Ptr + 1;
+ Full_List := True;
+
+ -- Processing for L switch
+
+ when 'L' =>
+ Ptr := Ptr + 1;
+ Zero_Cost_Exceptions_Set := True;
+ Zero_Cost_Exceptions_Val := False;
+
+ -- Processing for m switch
+
+ when 'm' =>
+ Ptr := Ptr + 1;
+ Scan_Pos (Switch_Chars, Max, Ptr, Maximum_Errors);
+
+ -- Processing for n switch
+
+ when 'n' =>
+ Ptr := Ptr + 1;
+ Inline_Active := True;
+
+ -- Processing for N switch
+
+ when 'N' =>
+ Ptr := Ptr + 1;
+ Inline_Active := True;
+ Front_End_Inlining := True;
+
+ -- Processing for o switch
+
+ when 'o' =>
+ Ptr := Ptr + 1;
+ Suppress_Options.Overflow_Checks := False;
+
+ -- Processing for O switch
+
+ when 'O' =>
+ Ptr := Ptr + 1;
+ Output_File_Name_Present := True;
+
+ -- Processing for p switch
+
+ when 'p' =>
+ Ptr := Ptr + 1;
+ Suppress_Options.Access_Checks := True;
+ Suppress_Options.Accessibility_Checks := True;
+ Suppress_Options.Discriminant_Checks := True;
+ Suppress_Options.Division_Checks := True;
+ Suppress_Options.Elaboration_Checks := True;
+ Suppress_Options.Index_Checks := True;
+ Suppress_Options.Length_Checks := True;
+ Suppress_Options.Overflow_Checks := True;
+ Suppress_Options.Range_Checks := True;
+ Suppress_Options.Division_Checks := True;
+ Suppress_Options.Length_Checks := True;
+ Suppress_Options.Range_Checks := True;
+ Suppress_Options.Storage_Checks := True;
+ Suppress_Options.Tag_Checks := True;
+
+ Validity_Checks_On := False;
+
+ -- Processing for P switch
+
+ when 'P' =>
+ Ptr := Ptr + 1;
+ Polling_Required := True;
+
+ -- Processing for q switch
+
+ when 'q' =>
+ Ptr := Ptr + 1;
+ Try_Semantics := True;
+
+ -- Processing for q switch
+
+ when 'Q' =>
+ Ptr := Ptr + 1;
+ Force_ALI_Tree_File := True;
+ Try_Semantics := True;
+
+ -- Processing for r switch
+
+ when 'r' =>
+ Ptr := Ptr + 1;
+
+ -- Temporarily allow -gnatr to mean -gnatyl (use RM layout)
+ -- for compatibility with pre 3.12 versions of GNAT,
+ -- to be removed for 3.13 ???
+
+ Set_Style_Check_Options ("l");
+
+ -- Processing for R switch
+
+ when 'R' =>
+ Ptr := Ptr + 1;
+ Back_Annotate_Rep_Info := True;
+
+ if Ptr <= Max
+ and then Switch_Chars (Ptr) in '0' .. '9'
+ then
+ C := Switch_Chars (Ptr);
+
+ if C in '4' .. '9' then
+ raise Bad_Switch;
+ else
+ List_Representation_Info :=
+ Character'Pos (C) - Character'Pos ('0');
+ Ptr := Ptr + 1;
+ end if;
+
+ else
+ List_Representation_Info := 1;
+ end if;
+
+ -- Processing for s switch
+
+ when 's' =>
+ Ptr := Ptr + 1;
+ Operating_Mode := Check_Syntax;
+
+ -- Processing for t switch
+
+ when 't' =>
+ Ptr := Ptr + 1;
+ Tree_Output := True;
+ Back_Annotate_Rep_Info := True;
+
+ -- Processing for T switch
+
+ when 'T' =>
+ Ptr := Ptr + 1;
+ Time_Slice_Set := True;
+ Scan_Nat (Switch_Chars, Max, Ptr, Time_Slice_Value);
+
+ -- Processing for u switch
+
+ when 'u' =>
+ Ptr := Ptr + 1;
+ List_Units := True;
+
+ -- Processing for U switch
+
+ when 'U' =>
+ Ptr := Ptr + 1;
+ Unique_Error_Tag := True;
+
+ -- Processing for v switch
+
+ when 'v' =>
+ Ptr := Ptr + 1;
+ Verbose_Mode := True;
+
+ -- Processing for V switch
+
+ when 'V' =>
+ Ptr := Ptr + 1;
+
+ if Ptr > Max then
+ raise Bad_Switch;
+
+ else
+ declare
+ OK : Boolean;
+
+ begin
+ Set_Validity_Check_Options
+ (Switch_Chars (Ptr .. Max), OK, Ptr);
+
+ if not OK then
+ raise Bad_Switch;
+ end if;
+ end;
+ end if;
+
+ -- Processing for w switch
+
+ when 'w' =>
+ Ptr := Ptr + 1;
+
+ if Ptr > Max then
+ raise Bad_Switch;
+ end if;
+
+ while Ptr <= Max loop
+ C := Switch_Chars (Ptr);
+
+ case C is
+
+ when 'a' =>
+ Constant_Condition_Warnings := True;
+ Elab_Warnings := True;
+ Check_Unreferenced := True;
+ Check_Withs := True;
+ Implementation_Unit_Warnings := True;
+ Ineffective_Inline_Warnings := True;
+ Warn_On_Redundant_Constructs := True;
+
+ when 'A' =>
+ Constant_Condition_Warnings := False;
+ Elab_Warnings := False;
+ Check_Unreferenced := False;
+ Check_Withs := False;
+ Implementation_Unit_Warnings := False;
+ Warn_On_Biased_Rounding := False;
+ Warn_On_Hiding := False;
+ Warn_On_Redundant_Constructs := False;
+ Ineffective_Inline_Warnings := False;
+
+ when 'c' =>
+ Constant_Condition_Warnings := True;
+
+ when 'C' =>
+ Constant_Condition_Warnings := False;
+
+ when 'b' =>
+ Warn_On_Biased_Rounding := True;
+
+ when 'B' =>
+ Warn_On_Biased_Rounding := False;
+
+ when 'e' =>
+ Warning_Mode := Treat_As_Error;
+
+ when 'h' =>
+ Warn_On_Hiding := True;
+
+ when 'H' =>
+ Warn_On_Hiding := False;
+
+ when 'i' =>
+ Implementation_Unit_Warnings := True;
+
+ when 'I' =>
+ Implementation_Unit_Warnings := False;
+
+ when 'l' =>
+ Elab_Warnings := True;
+
+ when 'L' =>
+ Elab_Warnings := False;
+
+ when 'o' =>
+ Address_Clause_Overlay_Warnings := True;
+
+ when 'O' =>
+ Address_Clause_Overlay_Warnings := False;
+
+ when 'p' =>
+ Ineffective_Inline_Warnings := True;
+
+ when 'P' =>
+ Ineffective_Inline_Warnings := False;
+
+ when 'r' =>
+ Warn_On_Redundant_Constructs := True;
+
+ when 'R' =>
+ Warn_On_Redundant_Constructs := False;
+
+ when 's' =>
+ Warning_Mode := Suppress;
+
+ when 'u' =>
+ Check_Unreferenced := True;
+ Check_Withs := True;
+
+ when 'U' =>
+ Check_Unreferenced := False;
+ Check_Withs := False;
+
+ -- Allow and ignore 'w' so that the old
+ -- format (e.g. -gnatwuwl) will work.
+
+ when 'w' =>
+ null;
+
+ when others =>
+ raise Bad_Switch;
+ end case;
+
+ Ptr := Ptr + 1;
+ end loop;
+
+ return;
+
+ -- Processing for W switch
+
+ when 'W' =>
+ Ptr := Ptr + 1;
+
+ for J in WC_Encoding_Method loop
+ if Switch_Chars (Ptr) = WC_Encoding_Letters (J) then
+ Wide_Character_Encoding_Method := J;
+ exit;
+
+ elsif J = WC_Encoding_Method'Last then
+ raise Bad_Switch;
+ end if;
+ end loop;
+
+ Upper_Half_Encoding :=
+ Wide_Character_Encoding_Method in
+ WC_Upper_Half_Encoding_Method;
+
+ Ptr := Ptr + 1;
+
+ -- Processing for x switch
+
+ when 'x' =>
+ Ptr := Ptr + 1;
+ Xref_Active := False;
+
+ -- Processing for X switch
+
+ when 'X' =>
+ Ptr := Ptr + 1;
+ Extensions_Allowed := True;
+
+ -- Processing for y switch
+
+ when 'y' =>
+ Ptr := Ptr + 1;
+
+ if Ptr > Max then
+ Set_Default_Style_Check_Options;
+
+ else
+ declare
+ OK : Boolean;
+
+ begin
+ Set_Style_Check_Options
+ (Switch_Chars (Ptr .. Max), OK, Ptr);
+
+ if not OK then
+ raise Bad_Switch;
+ end if;
+ end;
+ end if;
+
+ -- Processing for z switch
+
+ when 'z' =>
+ Ptr := Ptr + 1;
+
+ -- Allowed for compiler, only if this is the only
+ -- -z switch, we do not allow multiple occurrences
+
+ if Distribution_Stub_Mode = No_Stubs then
+ case Switch_Chars (Ptr) is
+ when 'r' =>
+ Distribution_Stub_Mode := Generate_Receiver_Stub_Body;
+
+ when 'c' =>
+ Distribution_Stub_Mode := Generate_Caller_Stub_Body;
+
+ when others =>
+ raise Bad_Switch;
+ end case;
+
+ Ptr := Ptr + 1;
+
+ end if;
+
+ -- Processing for Z switch
+
+ when 'Z' =>
+ Ptr := Ptr + 1;
+ Zero_Cost_Exceptions_Set := True;
+ Zero_Cost_Exceptions_Val := True;
+
+ -- Processing for 83 switch
+
+ when '8' =>
+
+ if Ptr = Max then
+ raise Bad_Switch;
+ end if;
+
+ Ptr := Ptr + 1;
+
+ if Switch_Chars (Ptr) /= '3' then
+ raise Bad_Switch;
+ else
+ Ptr := Ptr + 1;
+ Ada_95 := False;
+ Ada_83 := True;
+ end if;
+
+ -- Ignore extra switch character
+
+ when '/' | '-' =>
+ Ptr := Ptr + 1;
+
+ -- Anything else is an error (illegal switch character)
+
+ when others =>
+ raise Bad_Switch;
+ end case;
+ end case;
+ end loop;
+
+ exception
+ when Bad_Switch =>
+ Osint.Fail ("invalid switch: ", (1 => C));
+
+ when Bad_Switch_Value =>
+ Osint.Fail ("numeric value too big for switch: ", (1 => C));
+
+ when Missing_Switch_Value =>
+ Osint.Fail ("missing numeric value for switch: ", (1 => C));
+
+ end Scan_Front_End_Switches;
+
+ ------------------------
+ -- Scan_Make_Switches --
+ ------------------------
+
+ procedure Scan_Make_Switches (Switch_Chars : String) is
+ Ptr : Integer := Switch_Chars'First;
+ Max : Integer := Switch_Chars'Last;
+ C : Character := ' ';
+
+ begin
+ -- Skip past the initial character (must be the switch character)
+
+ if Ptr = Max then
+ raise Bad_Switch;
+
+ else
+ Ptr := Ptr + 1;
+ end if;
+
+ -- A little check, "gnat" at the start of a switch is not allowed
+ -- except for the compiler (where it was already removed)
+
+ if Switch_Chars'Length >= Ptr + 3
+ and then Switch_Chars (Ptr .. Ptr + 3) = "gnat"
+ then
+ Osint.Fail
+ ("invalid switch: """, Switch_Chars, """ (gnat not needed here)");
+ end if;
+
+ -- Loop to scan through switches given in switch string
+
+ while Ptr <= Max loop
+ C := Switch_Chars (Ptr);
+
+ -- Processing for a switch
+
+ case C is
+
+ when 'a' =>
+ Ptr := Ptr + 1;
+ Check_Readonly_Files := True;
+
+ -- Processing for c switch
+
+ when 'c' =>
+ Ptr := Ptr + 1;
+ Compile_Only := True;
+
+ when 'd' =>
+
+ -- Note: for the debug switch, the remaining characters in this
+ -- switch field must all be debug flags, since all valid switch
+ -- characters are also valid debug characters.
+
+ -- Loop to scan out debug flags
+
+ while Ptr < Max loop
+ Ptr := Ptr + 1;
+ C := Switch_Chars (Ptr);
+ exit when C = ASCII.NUL or else C = '/' or else C = '-';
+
+ if C in '1' .. '9' or else
+ C in 'a' .. 'z' or else
+ C in 'A' .. 'Z'
+ then
+ Set_Debug_Flag (C);
+ else
+ raise Bad_Switch;
+ end if;
+ end loop;
+
+ -- Make sure Zero_Cost_Exceptions is set if gnatdX set. This
+ -- is for backwards compatibility with old versions and usage.
+
+ if Debug_Flag_XX then
+ Zero_Cost_Exceptions_Set := True;
+ Zero_Cost_Exceptions_Val := True;
+ end if;
+
+ return;
+
+ -- Processing for f switch
+
+ when 'f' =>
+ Ptr := Ptr + 1;
+ Force_Compilations := True;
+
+ -- Processing for G switch
+
+ when 'G' =>
+ Ptr := Ptr + 1;
+ Print_Generated_Code := True;
+
+ -- Processing for h switch
+
+ when 'h' =>
+ Ptr := Ptr + 1;
+ Usage_Requested := True;
+
+ -- Processing for i switch
+
+ when 'i' =>
+ Ptr := Ptr + 1;
+ In_Place_Mode := True;
+
+ -- Processing for j switch
+
+ when 'j' =>
+ Ptr := Ptr + 1;
+
+ declare
+ Max_Proc : Pos;
+ begin
+ Scan_Pos (Switch_Chars, Max, Ptr, Max_Proc);
+ Maximum_Processes := Positive (Max_Proc);
+ end;
+
+ -- Processing for k switch
+
+ when 'k' =>
+ Ptr := Ptr + 1;
+ Keep_Going := True;
+
+ when 'M' =>
+ Ptr := Ptr + 1;
+ List_Dependencies := True;
+
+ -- Processing for n switch
+
+ when 'n' =>
+ Ptr := Ptr + 1;
+ Do_Not_Execute := True;
+
+ -- Processing for o switch
+
+ when 'o' =>
+ Ptr := Ptr + 1;
+
+ if Output_File_Name_Present then
+ raise Too_Many_Output_Files;
+ else
+ Output_File_Name_Present := True;
+ end if;
+
+ -- Processing for q switch
+
+ when 'q' =>
+ Ptr := Ptr + 1;
+ Quiet_Output := True;
+
+ -- Processing for s switch
+
+ when 's' =>
+ Ptr := Ptr + 1;
+ Check_Switches := True;
+
+ -- Processing for v switch
+
+ when 'v' =>
+ Ptr := Ptr + 1;
+ Verbose_Mode := True;
+
+ -- Processing for z switch
+
+ when 'z' =>
+ Ptr := Ptr + 1;
+ No_Main_Subprogram := True;
+
+ -- Ignore extra switch character
+
+ when '/' | '-' =>
+ Ptr := Ptr + 1;
+
+ -- Anything else is an error (illegal switch character)
+
+ when others =>
+ raise Bad_Switch;
+
+ end case;
+ end loop;
+
+ exception
+ when Bad_Switch =>
+ Osint.Fail ("invalid switch: ", (1 => C));
+
+ when Bad_Switch_Value =>
+ Osint.Fail ("numeric value too big for switch: ", (1 => C));
+
+ when Missing_Switch_Value =>
+ Osint.Fail ("missing numeric value for switch: ", (1 => C));
+
+ when Too_Many_Output_Files =>
+ Osint.Fail ("duplicate -o switch");
+
+ end Scan_Make_Switches;
+
+ --------------
+ -- Scan_Nat --
+ --------------
+
+ procedure Scan_Nat
+ (Switch_Chars : String;
+ Max : Integer;
+ Ptr : in out Integer;
+ Result : out Nat) is
+ begin
+ Result := 0;
+ if Ptr > Max or else Switch_Chars (Ptr) not in '0' .. '9' then
+ raise Missing_Switch_Value;
+ end if;
+
+ while Ptr <= Max and then Switch_Chars (Ptr) in '0' .. '9' loop
+ Result := Result * 10 +
+ Character'Pos (Switch_Chars (Ptr)) - Character'Pos ('0');
+ Ptr := Ptr + 1;
+
+ if Result > Switch_Max_Value then
+ raise Bad_Switch_Value;
+ end if;
+ end loop;
+ end Scan_Nat;
+
+ --------------
+ -- Scan_Pos --
+ --------------
+
+ procedure Scan_Pos
+ (Switch_Chars : String;
+ Max : Integer;
+ Ptr : in out Integer;
+ Result : out Pos) is
+
+ begin
+ Scan_Nat (Switch_Chars, Max, Ptr, Result);
+ if Result = 0 then
+ raise Bad_Switch_Value;
+ end if;
+ end Scan_Pos;
+
+end Switch;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S W I T C H --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.17 $ --
+-- --
+-- 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 scans switches. Note that the body of Usage must be
+-- coordinated with the switches that are recognized by this package.
+-- The Usage package also acts as the official documentation for the
+-- switches that are recognized. In addition, package Debug documents
+-- the otherwise undocumented debug switches that are also recognized.
+
+package Switch is
+
+ -- Note: The default switch character is indicated by Switch_Character,
+ -- but regardless of what it is, a hyphen is always allowed as an
+ -- (alternative) switch character.
+
+ -- Note: In GNAT, the case of switches is not significant if
+ -- Switches_Case_Sensitive is False. If this is the case, switch
+ -- characters, or letters appearing in the parameter to a switch, may be
+ -- either upper case or lower case.
+
+ -----------------
+ -- Subprograms --
+ -----------------
+
+ function Is_Switch (Switch_Chars : String) return Boolean;
+ -- Returns True iff Switch_Chars is at least two characters long,
+ -- and the first character indicates it is a switch.
+
+ function Is_Front_End_Switch (Switch_Chars : String) return Boolean;
+ -- Returns True iff Switch_Chars represents a front-end switch,
+ -- ie. it starts with -I or -gnat.
+
+ procedure Scan_Front_End_Switches (Switch_Chars : String);
+ procedure Scan_Binder_Switches (Switch_Chars : String);
+ procedure Scan_Make_Switches (Switch_Chars : String);
+ -- Procedures to scan out switches stored in the given string. The first
+ -- character is known to be a valid switch character, and there are no
+ -- blanks or other switch terminator characters in the string, so the
+ -- entire string should consist of valid switch characters, except that
+ -- an optional terminating NUL character is allowed. A bad switch causes
+ -- a fatal error exit and control does not return. The call also sets
+ -- Usage_Requested to True if a ? switch is encountered.
+
+end Switch;
--- /dev/null
+/****************************************************************************
+ * *
+ * GNAT COMPILER COMPONENTS *
+ * *
+ * S Y S D E P *
+ * *
+ * C Implementation File *
+ * *
+ * $Revision: 1.2 $
+ * *
+ * 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). *
+ * *
+ ****************************************************************************/
+
+/* This file contains system dependent symbols that are referenced in the
+ GNAT Run Time Library */
+
+#ifdef __vxworks
+#include "vxWorks.h"
+#endif
+#ifdef IN_RTS
+#define POSIX
+#include "tconfig.h"
+#include "tsystem.h"
+#include <fcntl.h>
+#include <sys/stat.h>
+#include "time.h"
+#else
+#include "config.h"
+#include "system.h"
+#endif
+
+#include "adaint.h"
+
+/*
+ mode_read_text
+ open text file for reading
+ rt for DOS and Windows NT, r for Unix
+
+ mode_write_text
+ truncate to zero length or create text file for writing
+ wt for DOS and Windows NT, w for Unix
+
+ mode_append_text
+ append; open or create text file for writing at end-of-file
+ at for DOS and Windows NT, a for Unix
+
+ mode_read_binary
+ open binary file for reading
+ rb for DOS and Windows NT, r for Unix
+
+ mode_write_binary
+ truncate to zero length or create binary file for writing
+ wb for DOS and Windows NT, w for Unix
+
+ mode_append_binary
+ append; open or create binary file for writing at end-of-file
+ ab for DOS and Windows NT, a for Unix
+
+ mode_read_text_plus
+ open text file for update (reading and writing)
+ r+t for DOS and Windows NT, r+ for Unix
+
+ mode_write_text_plus
+ truncate to zero length or create text file for update
+ w+t for DOS and Windows NT, w+ for Unix
+
+ mode_append_text_plus
+ append; open or create text file for update, writing at end-of-file
+ a+t for DOS and Windows NT, a+ for Unix
+
+ mode_read_binary_plus
+ open binary file for update (reading and writing)
+ r+b for DOS and Windows NT, r+ for Unix
+
+ mode_write_binary_plus
+ truncate to zero length or create binary file for update
+ w+b for DOS and Windows NT, w+ for Unix
+
+ mode_append_binary_plus
+ append; open or create binary file for update, writing at end-of-file
+ a+b for DOS and Windows NT, a+ for Unix
+
+ Notes:
+
+ (1) Opening a file with read mode fails if the file does not exist or
+ cannot be read.
+
+ (2) Opening a file with append mode causes all subsequent writes to the
+ file to be forced to the then current end-of-file, regardless of
+ intervening calls to the fseek function.
+
+ (3) When a file is opened with update mode, both input and output may be
+ performed on the associated stream. However, output may not be directly
+ followed by input without an intervening call to the fflush function or
+ to a file positioning function (fseek, fsetpos, or rewind), and input
+ may not be directly followed by output without an intervening call to a
+ file positioning function, unless the input operation encounters
+ end-of-file.
+
+ The other target dependent declarations here are for the two functions
+ __gnat_set_binary_mode and __gnat_set_text_mode:
+
+ void __gnat_set_binary_mode (int handle);
+ void __gnat_set_text_mode (int handle);
+
+ These functions have no effect in Unix (or similar systems where there is
+ no distinction between binary and text files), but in DOS (and similar
+ systems where text mode does CR/LF translation), these functions allow
+ the mode of the stream with the given handle (fileno can be used to get
+ the handle of a stream) to be changed dynamically. The returned result
+ is 0 if no error occurs and -1 if an error occurs.
+
+ Finally there is a boolean (character) variable
+
+ char __gnat_text_translation_required;
+
+ which is zero (false) in Unix mode, and one (true) in DOS mode, with a
+ true value indicating that text translation is required on text files
+ and that fopen supports the trailing t and b modifiers.
+
+*/
+
+#if defined(WINNT) || defined (MSDOS) || defined (__EMX__)
+const char *mode_read_text = "rt";
+const char *mode_write_text = "wt";
+const char *mode_append_text = "at";
+const char *mode_read_binary = "rb";
+const char *mode_write_binary = "wb";
+const char *mode_append_binary = "ab";
+const char *mode_read_text_plus = "r+t";
+const char *mode_write_text_plus = "w+t";
+const char *mode_append_text_plus = "a+t";
+const char *mode_read_binary_plus = "r+b";
+const char *mode_write_binary_plus = "w+b";
+const char *mode_append_binary_plus = "a+b";
+const char __gnat_text_translation_required = 1;
+
+void
+__gnat_set_binary_mode (handle)
+ int handle;
+{
+ _setmode (handle, O_BINARY);
+}
+
+void
+__gnat_set_text_mode (handle)
+ int handle;
+{
+ _setmode (handle, O_TEXT);
+}
+
+#ifdef __MINGW32__
+#include <windows.h>
+
+/* Return the name of the tty. Under windows there is no name for
+ the tty, so this function, if connected to a tty, returns the generic name
+ "console". */
+
+char *
+__gnat_ttyname (filedes)
+ int filedes;
+{
+ if (isatty (filedes))
+ return "console";
+ else
+ return NULL;
+}
+
+/* This function is needed to fix a bug under Win95/98. Under these plateforms
+ doing :
+ ch1 = getch();
+ ch2 = fgetc (stdin);
+
+ will put the same character into ch1 and ch2. It seem that the character
+ read by getch() is not correctly removed from the buffer. Even a
+ fflush(stdin) does not fix the bug. This bug does not appear under Window
+ NT. So we have two version of this routine below one for 95/98 and one for
+ NT/2000 version of Windows. There is also a special routine (winflushinit)
+ that will be called only the first time to check which version of Windows
+ we are running running on to set the right routine to use.
+
+ This problem occurs when using Text_IO.Get_Line after Text_IO.Get_Immediate
+ for example.
+
+ Calling FlushConsoleInputBuffer just after getch() fix the bug under
+ 95/98. */
+
+static void winflush_init PARAMS ((void));
+
+static void winflush_95 PARAMS ((void));
+
+static void winflush_nt PARAMS ((void));
+
+/* winflusfunction is set first to the winflushinit function which will check
+ the OS version 95/98 or NT/2000 */
+
+static void (*winflush_function) PARAMS ((void)) = winflush_init;
+
+/* This function does the runtime check of the OS version and then sets
+ winflush_function to the appropriate function and then call it. */
+
+static void
+winflush_init ()
+{
+ DWORD dwVersion = GetVersion();
+
+ if (dwVersion < 0x80000000) /* Windows NT/2000 */
+ winflush_function = winflush_nt;
+ else /* Windows 95/98 */
+ winflush_function = winflush_95;
+
+ (*winflush_function)(); /* Perform the 'flush' */
+
+}
+
+static void winflush_95 ()
+{
+ FlushConsoleInputBuffer (GetStdHandle (STD_INPUT_HANDLE));
+}
+
+static void winflush_nt ()
+{
+ /* Does nothing as there is no problem under NT. */
+}
+#endif
+
+#else
+
+const char *mode_read_text = "r";
+const char *mode_write_text = "w";
+const char *mode_append_text = "a";
+const char *mode_read_binary = "r";
+const char *mode_write_binary = "w";
+const char *mode_append_binary = "a";
+const char *mode_read_text_plus = "r+";
+const char *mode_write_text_plus = "w+";
+const char *mode_append_text_plus = "a+";
+const char *mode_read_binary_plus = "r+";
+const char *mode_write_binary_plus = "w+";
+const char *mode_append_binary_plus = "a+";
+const char __gnat_text_translation_required = 0;
+
+/* These functions do nothing in non-DOS systems. */
+
+void
+__gnat_set_binary_mode (stream)
+ FILE *stream ATTRIBUTE_UNUSED;
+{
+}
+
+void
+__gnat_set_text_mode (stream)
+ FILE *stream ATTRIBUTE_UNUSED;
+{
+}
+char *
+__gnat_ttyname (filedes)
+ int filedes;
+{
+#ifndef __vxworks
+ extern char *ttyname PARAMS ((int));
+
+ return ttyname (filedes);
+
+#else
+ return "";
+
+#endif
+}
+#endif
+\f
+#if defined (linux) || defined (sun) || defined (sgi) || defined (__EMX__) \
+ || (defined (__osf__) && ! defined (__alpha_vxworks)) || defined (WINNT) \
+ || defined (__MACHTEN__)
+#include <termios.h>
+
+#elif defined (VMS)
+extern char *decc$ga_stdscr;
+static int initted = 0;
+#endif
+
+/* Implements the common processing for getc_immediate and
+ getc_immediate_nowait. */
+
+extern void getc_immediate PARAMS ((FILE *, int *, int *));
+extern void getc_immediate_nowait PARAMS ((FILE *, int *, int *, int *));
+extern void getc_immediate_common PARAMS ((FILE *, int *, int *,
+ int *, int));
+
+/* Called by Get_Immediate (Foo); */
+
+void
+getc_immediate (stream, ch, end_of_file)
+ FILE *stream;
+ int *ch;
+ int *end_of_file;
+{
+ int avail;
+
+ getc_immediate_common (stream, ch, end_of_file, &avail, 1);
+}
+
+/* Called by Get_Immediate (Foo, Available); */
+
+void
+getc_immediate_nowait (stream, ch, end_of_file, avail)
+ FILE *stream;
+ int *ch;
+ int *end_of_file;
+ int *avail;
+{
+ getc_immediate_common (stream, ch, end_of_file, avail, 0);
+}
+
+/* Called by getc_immediate () and getc_immediate_nowait () */
+
+void
+getc_immediate_common (stream, ch, end_of_file, avail, waiting)
+ FILE *stream;
+ int *ch;
+ int *end_of_file;
+ int *avail;
+ int waiting;
+{
+#if defined (linux) || defined (sun) || defined (sgi) || defined (__EMX__) \
+ || (defined (__osf__) && ! defined (__alpha_vxworks)) \
+ || defined (__CYGWIN32__) || defined (__MACHTEN__)
+ char c;
+ int nread;
+ int good_one = 0;
+ int eof_ch = 4; /* Ctrl-D */
+ int fd = fileno (stream);
+ struct termios otermios_rec, termios_rec;
+
+ if (isatty (fd))
+ {
+ tcgetattr (fd, &termios_rec);
+ memcpy (&otermios_rec, &termios_rec, sizeof (struct termios));
+ while (! good_one)
+ {
+ /* Set RAW mode */
+ termios_rec.c_lflag = termios_rec.c_lflag & ~ICANON;
+#if defined(sgi) || defined (sun) || defined (__EMX__) || defined (__osf__) \
+ || defined (linux) || defined (__MACHTEN__)
+ eof_ch = termios_rec.c_cc[VEOF];
+
+ /* If waiting (i.e. Get_Immediate (Char)), set MIN = 1 and wait for
+ a character forever. This doesn't seem to effect Ctrl-Z or
+ Ctrl-C processing except on OS/2 where Ctrl-C won't work right
+ unless we do a read loop. Luckily we can delay a bit between
+ iterations. If not waiting (i.e. Get_Immediate (Char, Available)),
+ don't wait for anything but timeout immediately. */
+#ifdef __EMX__
+ termios_rec.c_cc[VMIN] = 0;
+ termios_rec.c_cc[VTIME] = waiting;
+#else
+ termios_rec.c_cc[VMIN] = waiting;
+ termios_rec.c_cc[VTIME] = 0;
+#endif
+#endif
+ tcsetattr (fd, TCSANOW, &termios_rec);
+
+ /* Read() is used here instead of fread(), because fread() doesn't
+ work on Solaris5 and Sunos4 in this situation. Maybe because we
+ are mixing calls that use file descriptors and streams. */
+
+ nread = read (fd, &c, 1);
+ if (nread > 0)
+ {
+ /* On Unix terminals, Ctrl-D (EOT) is an End of File. */
+ if (c == eof_ch)
+ {
+ *avail = 0;
+ *end_of_file = 1;
+ good_one = 1;
+ }
+
+ /* Everything else is ok */
+ else if (c != eof_ch)
+ {
+ *avail = 1;
+ *end_of_file = 0;
+ good_one = 1;
+ }
+ }
+
+ else if (! waiting)
+ {
+ *avail = 0;
+ *end_of_file = 0;
+ good_one = 1;
+ }
+ else
+ {
+ good_one = 0;
+ }
+ }
+
+ tcsetattr (fd, TCSANOW, &otermios_rec);
+ *ch = c;
+ }
+
+ else
+#elif defined (VMS)
+ int fd = fileno (stream);
+
+ if (isatty (fd))
+ {
+ if (initted == 0)
+ {
+ decc$bsd_initscr ();
+ initted = 1;
+ }
+ decc$bsd_cbreak ();
+ *ch = decc$bsd_wgetch (decc$ga_stdscr);
+
+ if (*ch == 4)
+ *end_of_file = 1;
+ else
+ *end_of_file = 0;
+
+ *avail = 1;
+ decc$bsd_nocbreak ();
+ }
+ else
+#elif defined (__MINGW32__)
+ int fd = fileno (stream);
+ int char_waiting;
+ int eot_ch = 4; /* Ctrl-D */
+
+ if (isatty (fd))
+ {
+ if (waiting)
+ {
+ *ch = getch();
+ (*winflush_function)();
+
+ if (*ch == eot_ch)
+ *end_of_file = 1;
+ else
+ *end_of_file = 0;
+
+ *avail = 1;
+ }
+ else /* ! waiting */
+ {
+ char_waiting = kbhit();
+
+ if (char_waiting == 1)
+ {
+ *avail = 1;
+ *ch = getch();
+ (*winflush_function)();
+
+ if (*ch == eot_ch)
+ *end_of_file = 1;
+ else
+ *end_of_file = 0;
+ }
+ else
+ {
+ *avail = 0;
+ *end_of_file = 0;
+ }
+ }
+ }
+ else
+#endif
+ {
+ /* If we're not on a terminal, then we don't need any fancy processing.
+ Also this is the only thing that's left if we're not on one of the
+ supported systems. */
+ *ch = fgetc (stream);
+ if (feof (stream))
+ {
+ *end_of_file = 1;
+ *avail = 0;
+ }
+ else
+ {
+ *end_of_file = 0;
+ *avail = 1;
+ }
+ }
+}
+
+/* The following definitions are provided in NT to support Windows based
+ Ada programs. */
+
+#ifdef WINNT
+#include <windows.h>
+
+/* Provide functions to echo the values passed to WinMain (windows bindings
+ will want to import these). We use the same names as the routines used
+ by AdaMagic for compatibility. */
+
+char *rts_get_hInstance (void) { return (GetModuleHandleA (0)); }
+char *rts_get_hPrevInstance (void) { return (0); }
+char *rts_get_lpCommandLine (void) { return (GetCommandLineA ()); }
+int rts_get_nShowCmd (void) { return (1); }
+
+#endif /* WINNT */
+#ifdef VMS
+
+/* This gets around a problem with using the old threads library on VMS 7.0. */
+
+#include <time.h>
+
+extern long get_gmtoff PARAMS ((void));
+
+long
+get_gmtoff ()
+{
+ time_t t;
+ struct tm *ts;
+
+ t = time ((time_t) 0);
+ ts = localtime (&t);
+ return ts->tm_gmtoff;
+}
+#endif
+
+/* Definition of __gnat_locatime_r used by a-calend.adb */
+
+#if defined (_AIX) || defined (__EMX__)
+#define Lock_Task system__soft_links__lock_task
+extern void (*Lock_Task) (void);
+
+#define Unlock_Task system__soft_links__unlock_task
+extern void (*Unlock_Task) (void);
+
+/* Provide reentrant version of localtime on Aix and OS/2. Note that AiX does
+ provide localtime_r, but in the library libc_r which doesn't get included
+ systematically, so we can't use it. */
+
+exrern void struct tm *__gnat_localtime_r PARAMS ((const time_t *,
+ struct tm *));
+
+struct tm *
+__gnat_localtime_r (timer, tp)
+ const time_t *timer;
+ struct tm *tp;
+{
+ struct tm *tmp;
+
+ (*Lock_Task) ();
+ tmp = localtime (timer);
+ memcpy (tp, tmp, sizeof (struct tm));
+ (*Unlock_Task) ();
+ return tp;
+}
+
+#elif defined (__Lynx__)
+
+/* LynxOS provides a non standard localtime_r */
+
+extern struct tm *__gnat_localtime_r PARAMS ((const time_t *, struct tm *));
+
+struct tm *
+__gnat_localtime_r (timer, tp)
+ const time_t *timer;
+ struct tm *tp;
+{
+ return localtime_r (tp, timer);
+}
+
+#elif defined (VMS) || defined (__MINGW32__)
+
+/* __gnat_localtime_r is not needed on NT and VMS */
+
+#else
+
+/* All other targets provide a standard localtime_r */
+
+extern struct tm *__gnat_localtime_r PARAMS ((const time_t *, struct tm *));
+
+struct tm *
+__gnat_localtime_r (timer, tp)
+ const time_t *timer;
+ struct tm *tp;
+{
+ return (struct tm *) localtime_r (timer, tp);
+}
+#endif
projects / platform / upstream / linaro-gcc.git / commitdiff