Geek Gadgets 1

home *** CD-ROM | disk | FTP | other *** search

/ Geek Gadgets 1 / ADE-1.bin / ade-dist / gnat-2.06-src.tgz / tar.out / fsf / gnat / ada / sem_eval.adb < prev next >

Wrap

Text File | 1996-09-28 | 68KB | 2,108 lines

------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- S E M _ E V A L -- -- -- -- B o d y -- -- -- -- $Revision: 1.158 $ -- -- -- -- Copyright (c) 1992,1993,1994,1995 NYU, All Rights Reserved -- -- -- -- 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, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ with Atree; use Atree; with Checks; use Checks; with Einfo; use Einfo; with Elists; use Elists; with Errout; use Errout; 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_Dist; use Sem_Dist; with Sem_Res; use Sem_Res; with Sem_Util; use Sem_Util; with Sinfo; use Sinfo; with Stand; use Stand; with Stringt; use Stringt; with Tbuild; use Tbuild; 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 Compile_Time_Constraint_Error -- is used to rewrite the node 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 Expression_Is_Foldable (N : Node_Id; Op1 : Node_Id) return Boolean; -- Returns True if operation N whose single operand is Op1 is foldable, -- i.e. Op1 has Is_Static_Expression True, and Raises_Constraint_Error -- False. In this case the Is_Static_Expression flag on N is set. If -- these conditions are not met, then False is returned, and the -- Is_Static_Expression and Raises_Constraint_Error flags are set -- appropriately in N. If the result is non-static, then a call is -- made to Check_Non_Static_Context on the operand. If False is -- returned, then all processing is complete, and the caller should -- return, since there is nothing else to do. function Expression_Is_Foldable (N : Node_Id; Op1 : Node_Id; Op2 : Node_Id) return Boolean; -- Returns True if operation N, whose two operands are Op1 and Op2, -- is foldable, i.e. if both operands have Is_Static_Expression set -- and neither has Raises_Constraint_Error set. In this case, the -- Is_Static_Expression flag is set on N. In all other cases, False -- is returned, and the Is_Static_Expression and Raises_Constraint_Error -- flags are set appropriately in N. If the result is non-static, then -- calls are made to Check_Non_Static_Context on the operands. If False -- is returned, then all processing is complete, and the caller should -- return, since there is nothing else to do. 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 folded in the earlier analysis of the operands). 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 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); 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; -- Check is required else -- Case of outside base range if Is_Out_Of_Range (N, Base_Type (T)) then Compile_Time_Constraint_Error (N, "value not in range of}"); -- 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 Is_Out_Of_Range (N, T) and then Nkind (Parent (N)) /= N_Range then Compile_Time_Constraint_Error (N, "value not in range of}?"); end if; end if; end Check_Non_Static_Context; ----------------- -- 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_Aggregate -- -------------------- procedure Eval_Aggregate (N : Node_Id) is begin null; -- ??? end Eval_Aggregate; -------------------- -- 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); begin -- If not foldable we are done if not Expression_Is_Foldable (N, Left, Right) 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 => Result := Left_Int * Right_Int; 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 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 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 Compile_Time_Constraint_Error (N, "rem with zero divisor"); return; else Result := Left_Int rem Right_Int; end if; when others => pragma Assert (False); null; 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; elsif Nkind (N) = N_Op_Divide then if UR_Is_Zero (Right_Real) then Compile_Time_Constraint_Error (N, "division by zero"); return; end if; Result := Left_Real / Right_Real; else pragma Assert (False); null; end if; Fold_Ureal (N, Result); end; end if; 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 a static functions, 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); 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 if not Expression_Is_Foldable (N, Left, Right) then return; end if; -- Compile time string concatenation. Note that operands that are -- aggregates were never marked as static, so we don't attempt -- to fold concatenations with such aggregates (see Eval_Aggregate). -- Needs some more thought ??? 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; Fold_Str (N, End_String); 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 Val := Constant_Value (Def_Id); if Present (Val) then Set_Is_Static_Expression (N, Is_Static_Expression (Val)); Set_Raises_Constraint_Error (N, Raises_Constraint_Error (Val)); return; end if; end if; -- Fall through if the name is not static. -- 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)). 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); 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 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; 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); begin -- If not foldable nothing to do if not Expression_Is_Foldable (N, Left, Right) 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; 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 : Uint; Hi : Uint; 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 if not Expression_Is_Foldable (N, Left) then return; end if; else Check_Non_Static_Context (Left); return; end if; -- Here we deal with the bizarre case of a string type -- For now, just never fold, we will worry about this later ??? if Is_String_Type (Def_Id) then Check_Non_Static_Context (Left); return; end if; Lo := Expr_Value (Type_Low_Bound (Def_Id)); Hi := Expr_Value (Type_High_Bound (Def_Id)); -- Case of right operand is a range else if Is_Static_Range (Right) then if not Expression_Is_Foldable (N, Left) 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 := Expr_Value (Low_Bound (Right)); Hi := Expr_Value (High_Bound (Right)); end if; -- Fold the membership test. We know we have a static range and Lo -- and Hi are set to the values of the end points of this range. declare Left_Int : constant Uint := Expr_Value (Left); Result : Boolean; begin Result := (Lo <= Left_Int and then Left_Int <= Hi); if Nkind (N) = N_Not_In then Result := not Result; end if; Fold_Uint (N, Test (Result)); end; 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); begin -- If not foldable, then nothing to do if not Expression_Is_Foldable (N, Left, Right) 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 Compile_Time_Constraint_Error (N, "integer exponent negative"); return; else Result := Left_Int ** Right_Int; 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 Right_Int < 0 and then UR_Is_Zero (Left_Real) then Compile_Time_Constraint_Error (N, "zero ** negative integer"); return; else Fold_Ureal (N, Left_Real ** Right_Int); end if; end; end if; 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); begin -- If not foldable, then nothing to do if not Expression_Is_Foldable (N, Right) then return; end if; -- Fold not operation declare Rint : constant Uint := Expr_Value (Right); begin if Is_Modular_Integer_Type (Etype (N)) then declare Right_Bits : Bits (0 .. UI_To_Int (Esize (Etype (N))) - 1); begin To_Bits (Rint, Right_Bits); for J in Right_Bits'Range loop Right_Bits (J) := not Right_Bits (J); end loop; Fold_Uint (N, From_Bits (Right_Bits, Etype (N))); end; else pragma Assert (Is_Boolean_Type (Etype (N))); Fold_Uint (N, Test (not Is_True (Rint))); end if; 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 : Node_Id := Expression (N); Target_Type : Entity_Id := Etype (N); begin if Is_Array_Type (Target_Type) and then Is_Constrained (Target_Type) then Apply_Length_Check (Operand, Target_Type); end if; -- Can only fold if target is string or scalar and subtype is static if (not Is_Scalar_Type (Target_Type) and then not Is_String_Type (Target_Type)) or else not Is_Static_Subtype (Target_Type) then Check_Non_Static_Context (Operand); return; end if; -- Nothing to do if not foldable if not Expression_Is_Foldable (N, Operand) then return; end if; -- Don't try fold if target type has constraint error bounds if 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)); elsif Is_Real_Type (Target_Type) then Fold_Ureal (N, Expr_Value_R (Operand)); else Fold_Str (N, Strval (Get_String_Val (Operand))); end if; if Is_Out_Of_Range (N, Etype (N)) then Compile_Time_Constraint_Error (N, "value out of range"); 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; begin -- 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, nothing to do if not Expression_Is_Foldable (N, Left, Right) 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 => pragma Assert (False); null; 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 => pragma Assert (False); null; end case; Fold_Uint (N, Test (Result)); end; end if; 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. 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 -- 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_Substitute_Tree (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 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_Substitute_Tree (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 -- ------------------------- -- String literals are static if the subtype is static (RM 4.9(2)), so -- reset the static expression flag (it was set in Analyze_String_Literal) -- if the subtype is non-static. procedure Eval_String_Literal (N : Node_Id) is begin if not Is_Static_Subtype (Component_Type (Etype (N))) then Set_Is_Static_Expression (N, False); 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); begin -- Can only fold if type is static and scalar if not Is_Scalar_Type (Target_Type) or else not Is_Static_Subtype (Target_Type) then Check_Non_Static_Context (Operand); return; end if; -- Nothing to do if not foldable if not Expression_Is_Foldable (N, Operand) then return; end if; -- Don't try fold if target type has constraint error bounds if not Is_OK_Static_Subtype (Target_Type) then Set_Raises_Constraint_Error (N); return; end if; -- Fold conversion, case of integer target type if Is_Integer_Type (Target_Type) then declare Result : Uint; begin if Is_Integer_Type (Source_Type) then Result := Expr_Value (Operand); else pragma Assert (Is_Real_Type (Source_Type)); Result := UR_To_Uint (Expr_Value_R (Operand)); end if; Fold_Uint (N, Result); end; -- Fold conversion, case of real target type elsif Is_Real_Type (Target_Type) then declare Result : Ureal; begin if Is_Real_Type (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; if Is_Out_Of_Range (N, Etype (N)) then Compile_Time_Constraint_Error (N, "value out of range"); end if; end Eval_Type_Conversion; ------------------------------- -- 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; ------------------- -- 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); begin -- If not foldable, nothing to do if not Expression_Is_Foldable (N, Right) 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; end Eval_Unary_Op; ---------------- -- 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 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. 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; begin if 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)); else pragma Assert (Kind = N_Real_Literal); return Realval (N); end if; end Expr_Value_R; ------------------ -- Expr_Value_S -- ------------------ function Expr_Value_S (N : Node_Id) return String_Id is begin if Nkind (N) = N_String_Literal then return Strval (N); else pragma Assert (Ekind (Entity (N)) = E_Constant); return Expr_Value_S (Constant_Value (Entity (N))); end if; end Expr_Value_S; ---------------------------- -- Expression_Is_Foldable -- ---------------------------- -- One operand case function Expression_Is_Foldable (N : Node_Id; Op1 : Node_Id) return Boolean is begin -- 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); return False; -- 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_Substitute_Tree (N, Op1); return False; -- 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); return False; -- 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); return True; end if; end Expression_Is_Foldable; -- Two operand case function Expression_Is_Foldable (N : Node_Id; Op1 : Node_Id; Op2 : Node_Id) return Boolean is Rstat : constant Boolean := Is_Static_Expression (Op1) and then Is_Static_Expression (Op2); begin -- 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); return False; -- 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_Substitute_Tree (N, Op1); Set_Is_Static_Expression (N, Rstat); return False; -- 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_Substitute_Tree (N, Op2); Set_Is_Static_Expression (N, Rstat); return False; -- 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); return False; -- 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); return True; end if; end Expression_Is_Foldable; -------------- -- 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_Substitute_Tree (N, Make_String_Literal (Loc, Strval => Val)); Analyze (N); 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); Lit : Entity_Id; Pos : Int; 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_Substitute_Tree (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. elsif Is_Enumeration_Type (Etype (N)) then Pos := UI_To_Int (Val); -- 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 (Etype (N)) = Standard_Character or else Root_Type (Etype (N)) = Standard_Wide_Character then Set_Character_Literal_Name (Char_Code (Pos)); Rewrite_Substitute_Tree (N, Make_Character_Literal (Loc, Chars => Name_Find, Char_Literal_Value => Char_Code (Pos))); -- 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 (Etype (N))); for J in 1 .. Pos loop Lit := Next_Literal (Lit); end loop; Rewrite_Substitute_Tree (N, New_Occurrence_Of (Lit, Loc)); end if; -- Anything other than an integer type or enumeration type is wrong else pragma Assert (False); null; 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_Substitute_Tree (N, Make_Real_Literal (Loc, Realval => Val)); -- 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. Note that for real literals, the distinction -- between actual and expected type is significant, since the check -- for extraneous Analyze (N); 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; ----------------------------- -- 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 -- -------------------------- -- A static subtype is either a scalar base type, other than a generic -- formal type; or a scalar subtype formed by imposing on a static -- subtype either a static range constraint, or a floating or fixed -- point constraint whose range constraint, if any, is static (RM 4.9(26)) function Is_OK_Static_Subtype (Typ : Entity_Id) return Boolean is Base_T : constant Entity_Id := Base_Type (Typ); begin if Is_Generic_Type (Base_T) or else not Is_Scalar_Type (Base_T) or else Is_Generic_Actual_Type (Base_T) then return False; elsif Base_T = Typ then return True; else return Is_OK_Static_Subtype (Base_T) and then Is_OK_Static_Expression (Type_Low_Bound (Typ)) and then Is_OK_Static_Expression (Type_High_Bound (Typ)); end if; end Is_OK_Static_Subtype; --------------------- -- Is_Out_Of_Range -- --------------------- function Is_Out_Of_Range (N : Node_Id; Typ : Entity_Id) 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 unless we have an OK static value, since -- otherwise we have no known value to compare against. elsif not Is_OK_Static_Expression (N) then return False; else declare Lo : constant Node_Id := Type_Low_Bound (Typ); Hi : constant Node_Id := Type_High_Bound (Typ); LB_Static : constant Boolean := Is_OK_Static_Expression (Lo); UB_Static : constant Boolean := Is_OK_Static_Expression (Hi); begin -- For floating point types, do check against the bounds if Is_Floating_Point_Type (Typ) then Valr := Expr_Value_R (N); if LB_Static and then Valr < Expr_Value_R (Lo) then return True; elsif UB_Static and then Expr_Value_R (Hi) < Valr then return True; else return False; end if; -- For discrete types, do the check against the integer bounds. -- Also do a check against the integer bounds for fixed-point -- types (in this case we are dealing with the corresponding -- integer value, both for the bounds, and for the value of -- the expression). else Val := Expr_Value (N); if LB_Static and then Val < Expr_Value (Lo) then return True; elsif UB_Static 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_In_Range -- ----------------- function Is_In_Range (N : Node_Id; Typ : Entity_Id) 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 an OK static value, since -- otherwise we have no known value to compare against. elsif not Is_OK_Static_Expression (N) then return False; else declare Lo : constant Node_Id := Type_Low_Bound (Typ); Hi : constant Node_Id := Type_High_Bound (Typ); LB_Static : constant Boolean := Is_OK_Static_Expression (Lo); UB_Static : constant Boolean := Is_OK_Static_Expression (Hi); begin -- For floating point types, do check against the bounds if Is_Floating_Point_Type (Typ) then Valr := Expr_Value_R (N); if LB_Static and then Valr >= Expr_Value_R (Lo) and then UB_Static and then Valr <= Expr_Value_R (Hi) then return True; else return False; end if; -- For discrete types, do the check against the integer bounds. -- Also do a check against the integer bounds for fixed-point -- types (in this case we are dealing with the corresponding -- integer value, both for the bounds, and for the value of -- the expression). else Val := Expr_Value (N); if LB_Static and then Val >= Expr_Value (Lo) and then UB_Static and then Val <= Expr_Value (Hi) then return True; else return False; end if; end if; end; end if; end Is_In_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 -- ----------------------- -- A static subtype is either a scalar base type, other than a generic -- formal type; or a scalar subtype formed by imposing on a static -- subtype either a static range constraint, or a floating or fixed -- point constraint whose range constraint, if any, is static. [LRM 4.9] -- Is this definition right??? function Is_Static_Subtype (Typ : Entity_Id) return Boolean is Base_T : constant Entity_Id := Base_Type (Typ); begin if Is_Generic_Type (Root_Type (Base_T)) or else not Is_Scalar_Type (Base_T) or else Is_Generic_Actual_Type (Base_T) then return False; elsif Base_T = Typ then return True; else return Is_Static_Subtype (Base_T) and then Is_Static_Expression (Type_Low_Bound (Typ)) and then Is_Static_Expression (Type_High_Bound (Typ)); end if; end Is_Static_Subtype; ------------------------------- -- 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 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 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; 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) then 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; 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; DA1 := Next_Elmt (DA1); DA2 := Next_Elmt (DA2); end loop; end; return True; -- Array type elsif Is_Array_Type (T1) then 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; Index1 := Next_Index (Index1); Index2 := Next_Index (Index2); end loop; return True; end; -- 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; -------------- -- 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;