------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- S E M _ D I M -- -- -- -- B o d y -- -- -- -- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- -- for more details. You should have received a copy of the GNU General -- -- Public License distributed with GNAT; see file COPYING3. If not, go to -- -- http://www.gnu.org/licenses for a complete copy of the license. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ with Aspects; use Aspects; with Atree; use Atree; with Einfo; use Einfo; with Errout; use Errout; with Lib; use Lib; with Namet; use Namet; with Namet.Sp; use Namet.Sp; with Nlists; use Nlists; with Nmake; use Nmake; with Opt; use Opt; with Rtsfind; use Rtsfind; with Sem; use Sem; with Sem_Eval; use Sem_Eval; 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 Table; with Tbuild; use Tbuild; with Uintp; use Uintp; with Urealp; use Urealp; with GNAT.HTable; package body Sem_Dim is -- Maximum number of dimensions in a dimension system Max_Dimensions : constant Int := 7; -- Dim_Id values are used to identify dimensions in a dimension system -- Note that the highest value of Dim_Id is Max_Dimensions subtype Dim_Id is Pos range 1 .. Max_Dimensions; -- Record type for dimension system -- A dimension system is defined by the number and the names of its -- dimensions and its base type. subtype N_Of_Dimensions is Int range 0 .. Max_Dimensions; No_Dimensions : constant N_Of_Dimensions := N_Of_Dimensions'First; type Name_Array is array (Dim_Id) of Name_Id; No_Names : constant Name_Array := (others => No_Name); -- The symbols are used for IO purposes type Symbol_Array is array (Dim_Id) of String_Id; No_Symbols : constant Symbol_Array := (others => No_String); type Dimension_System is record Base_Type : Node_Id; Names : Name_Array; N_Of_Dims : N_Of_Dimensions; Symbols : Symbol_Array; end record; No_Dimension_System : constant Dimension_System := (Empty, No_Names, No_Dimensions, No_Symbols); -- Dim_Sys_Id values are used to identify dimension system in the Table -- Note that the special value No_Dim_Sys has no corresponding component in -- the Table since it represents no dimension system. subtype Dim_Sys_Id is Nat; No_Dim_Sys : constant Dim_Sys_Id := Dim_Sys_Id'First; -- The following table records every dimension system package Dim_Systems is new Table.Table ( Table_Component_Type => Dimension_System, Table_Index_Type => Dim_Sys_Id, Table_Low_Bound => 1, Table_Initial => 5, Table_Increment => 5, Table_Name => "Dim_Systems"); -- Rational (definitions & operations) type Whole is new Int; subtype Positive_Whole is Whole range 1 .. Whole'Last; type Rational is record Numerator : Whole; Denominator : Positive_Whole; end record; Zero_Rational : constant Rational := (0, 1); -- Rational constructors function "+" (Right : Whole) return Rational; function "/" (Left, Right : Whole) return Rational; function GCD (Left, Right : Whole) return Int; function Reduce (X : Rational) return Rational; -- Unary operator for Rational function "-" (Right : Rational) return Rational; -- Rational operations for Rationals function "+" (Left, Right : Rational) return Rational; function "-" (Left, Right : Rational) return Rational; function "*" (Left, Right : Rational) return Rational; -- Operation between Rational and Int function "*" (Left : Rational; Right : Whole) return Rational; --------- -- GCD -- --------- function GCD (Left, Right : Whole) return Int is L : Whole := Left; R : Whole := Right; begin while R /= 0 loop L := L mod R; if L = 0 then return Int (R); end if; R := R mod L; end loop; return Int (L); end GCD; ------------ -- Reduce -- ------------ function Reduce (X : Rational) return Rational is begin if X.Numerator = 0 then return Zero_Rational; end if; declare G : constant Int := GCD (X.Numerator, X.Denominator); begin return Rational'(Numerator => Whole (Int (X.Numerator) / G), Denominator => Whole (Int (X.Denominator) / G)); end; end Reduce; --------- -- "+" -- --------- function "+" (Right : Whole) return Rational is begin return (Right, 1); end "+"; function "+" (Left, Right : Rational) return Rational is R : constant Rational := Rational'(Numerator => Left.Numerator * Right.Denominator + Left.Denominator * Right.Numerator, Denominator => Left.Denominator * Right.Denominator); begin return Reduce (R); end "+"; --------- -- "-" -- --------- function "-" (Right : Rational) return Rational is begin return Rational'(Numerator => -Right.Numerator, Denominator => Right.Denominator); end "-"; function "-" (Left, Right : Rational) return Rational is R : constant Rational := Rational'(Numerator => Left.Numerator * Right.Denominator - Left.Denominator * Right.Numerator, Denominator => Left.Denominator * Right.Denominator); begin return Reduce (R); end "-"; --------- -- "*" -- --------- function "*" (Left, Right : Rational) return Rational is R : constant Rational := Rational'(Numerator => Left.Numerator * Right.Numerator, Denominator => Left.Denominator * Right.Denominator); begin return Reduce (R); end "*"; function "*" (Left : Rational; Right : Whole) return Rational is R : constant Rational := Rational'(Numerator => Left.Numerator * Right, Denominator => Left.Denominator); begin return Reduce (R); end "*"; --------- -- "/" -- --------- function "/" (Left, Right : Whole) return Rational is R : constant Int := abs Int (Right); L : Int := Int (Left); begin if Right < 0 then L := -L; end if; return Reduce (Rational'(Numerator => Whole (L), Denominator => Whole (R))); end "/"; -- Hash Table for aspect dimension. -- The following table provides a relation between nodes and its dimension -- (if not dimensionless). If a node is not stored in the Hash Table, the -- node is considered to be dimensionless. -- A dimension is represented by an array of Max_Dimensions Rationals. -- If the corresponding dimension system has less than Max_Dimensions -- dimensions, the array is filled by as many as Zero_Rationals needed to -- complete the array. -- Here is a list of nodes that can have entries in this Htable: -- N_Attribute_Reference -- N_Defining_Identifier -- N_Function_Call -- N_Identifier -- N_Indexed_Component -- N_Integer_Literal -- N_Op_Abs -- N_Op_Add -- N_Op_Divide -- N_Op_Expon -- N_Op_Minus -- N_Op_Mod -- N_Op_Multiply -- N_Op_Plus -- N_Op_Rem -- N_Op_Subtract -- N_Qualified_Expression -- N_Real_Literal -- N_Selected_Component -- N_Slice -- N_Type_Conversion -- N_Unchecked_Type_Conversion type Dimensions is array (Dim_Id) of Rational; Zero_Dimensions : constant Dimensions := (others => Zero_Rational); type AD_Hash_Range is range 0 .. 511; function AD_Hash (F : Node_Id) return AD_Hash_Range; function AD_Hash (F : Node_Id) return AD_Hash_Range is begin return AD_Hash_Range (F mod 512); end AD_Hash; -- Node_Id --> Dimensions package Aspect_Dimension_Hash_Table is new GNAT.HTable.Simple_HTable (Header_Num => AD_Hash_Range, Element => Dimensions, No_Element => Zero_Dimensions, Key => Node_Id, Hash => AD_Hash, Equal => "="); -- Table to record the string of each subtype declaration -- Note that this table is only used for IO purposes -- Entity_Id --> String_Id package Aspect_Dimension_String_Id_Hash_Table is new GNAT.HTable.Simple_HTable (Header_Num => AD_Hash_Range, Element => String_Id, No_Element => No_String, Key => Entity_Id, Hash => AD_Hash, Equal => "="); ----------------------- -- Local Subprograms -- ----------------------- procedure Analyze_Dimension_Assignment_Statement (N : Node_Id); -- Subroutine of Analyze_Dimension for assignment statement procedure Analyze_Dimension_Binary_Op (N : Node_Id); -- Subroutine of Analyze_Dimension for binary operators procedure Analyze_Dimension_Component_Declaration (N : Node_Id); -- Subroutine of Analyze_Dimension for component declaration procedure Analyze_Dimension_Extended_Return_Statement (N : Node_Id); -- Subroutine of Analyze_Dimension for extended return statement procedure Analyze_Dimension_Function_Call (N : Node_Id); -- Subroutine of Analyze_Dimension for function call procedure Analyze_Dimension_Has_Etype (N : Node_Id); -- Subroutine of Analyze_Dimension for N_Has_Etype nodes: -- N_Attribute_Reference -- N_Indexed_Component -- N_Qualified_Expression -- N_Selected_Component -- N_Slice -- N_Type_Conversion -- N_Unchecked_Type_Conversion procedure Analyze_Dimension_Identifier (N : Node_Id); -- Subroutine of Analyze_Dimension for identifier procedure Analyze_Dimension_Object_Declaration (N : Node_Id); -- Subroutine of Analyze_Dimension for object declaration procedure Analyze_Dimension_Object_Renaming_Declaration (N : Node_Id); -- Subroutine of Analyze_Dimension for object renaming declaration procedure Analyze_Dimension_Simple_Return_Statement (N : Node_Id); -- Subroutine of Analyze_Dimension for simple return statement procedure Analyze_Dimension_Subtype_Declaration (N : Node_Id); -- Subroutine of Analyze_Dimension for subtype declaration procedure Analyze_Dimension_Unary_Op (N : Node_Id); -- Subroutine of Analyze_Dimension for unary operators procedure Copy_Dimensions (From, To : Node_Id); -- Propagate dimensions between two nodes procedure Create_Rational_From_Expr (Expr : Node_Id; R : in out Rational); -- Given an expression, creates a rational number procedure Eval_Op_Expon_With_Rational_Exponent (N : Node_Id; Rat : Rational); -- Evaluate the Expon if the exponent is a rational and the operand has a -- dimension. function From_Dimension_To_String_Id (Dims : Dimensions; Sys : Dim_Sys_Id) return String_Id; -- Given a dimension vector and a dimension system, return the proper -- string of symbols. function Get_Dimensions (N : Node_Id) return Dimensions; -- Return the dimensions for the corresponding node function Get_Dimensions_String_Id (E : Entity_Id) return String_Id; -- Return the String_Id of dimensions for the corresponding entity function Get_Dimension_System_Id (E : Entity_Id) return Dim_Sys_Id; -- Return the Dim_Id of the corresponding dimension system procedure Move_Dimensions (From, To : Node_Id); -- Move Dimensions from 'From' to 'To'. Only called when 'From' has a -- dimension. function Permits_Dimensions (N : Node_Id) return Boolean; -- Return True if a node can have a dimension function Present (Dim : Dimensions) return Boolean; -- Return True if Dim is not equal to Zero_Dimensions. procedure Remove_Dimensions (N : Node_Id); -- Remove the node from the HTable procedure Set_Dimensions (N : Node_Id; Dims : Dimensions); -- Store the dimensions of N in the Hash_Table for Dimensions procedure Set_Dimensions_String_Id (E : Entity_Id; Str : String_Id); -- Store the string of dimensions of E in the Hash_Table for String_Id ------------------------------ -- Analyze_Aspect_Dimension -- ------------------------------ -- with Dimension => DIMENSION_FOR_SUBTYPE -- DIMENSION_FOR_SUBTYPE ::= (DIMENSION_STRING, DIMENSION_RATIONALS) -- DIMENSION_RATIONALS ::= -- RATIONAL, {, RATIONAL} -- | RATIONAL {, RATIONAL}, others => RATIONAL -- | DISCRETE_CHOICE_LIST => RATIONAL -- (see Analyze_Aspect_Dimension_System for DIMENSION_STRING grammar) procedure Analyze_Aspect_Dimension (N : Node_Id; Id : Node_Id; Expr : Node_Id) is Def_Id : constant Entity_Id := Defining_Identifier (N); N_Kind : constant Node_Kind := Nkind (N); Analyzed : array (Dimensions'Range) of Boolean := (others => False); -- This array has been defined in order to deals with Others_Choice -- It is a reminder of the dimensions in the aggregate that have already -- been analyzed. Choice : Node_Id; Comp_Expr : Node_Id; Comp_Assn : Node_Id; Dim : Dim_Id; Dims : Dimensions := Zero_Dimensions; Dim_Str_Lit : Node_Id; D_Sys : Dim_Sys_Id := No_Dim_Sys; N_Of_Dims : N_Of_Dimensions; Str : String_Id := No_String; function Check_Identifier_Is_Dimension (Id : Node_Id; D_Sys : Dim_Sys_Id) return Boolean; -- Return True if the identifier name is the name of a dimension in the -- dimension system D_Sys. function Check_Compile_Time_Known_Expressions_In_Aggregate (Expr : Node_Id) return Boolean; -- Check that each expression in the aggregate is known at compile time function Check_Number_Dimensions_Aggregate (Expr : Node_Id; D_Sys : Dim_Sys_Id; N_Of_Dims : N_Of_Dimensions) return Boolean; -- This routine checks the number of dimensions in the aggregate. function Corresponding_Dimension_System (N : Node_Id) return Dim_Sys_Id; -- Return the Dim_Sys_Id of the corresponding dimension system function Corresponding_Etype_Has_Dimensions (N : Node_Id) return Boolean; -- Return True if the Etype of N has a dimension function Get_Dimension_Id (Id : Node_Id; D_Sys : Dim_Sys_Id) return Dim_Id; -- Given an identifier and the Dim_Sys_Id of the dimension system in the -- Table, returns the Dim_Id that has the same name as the identifier. ------------------------------------ -- Corresponding_Dimension_System -- ------------------------------------ function Corresponding_Dimension_System (N : Node_Id) return Dim_Sys_Id is B_Typ : Node_Id; Sub_Ind : Node_Id; begin -- Aspect_Dimension can only apply for subtypes -- Look for the dimension system corresponding to this -- Aspect_Dimension. if Nkind (N) = N_Subtype_Declaration then Sub_Ind := Subtype_Indication (N); if Nkind (Sub_Ind) /= N_Subtype_Indication then B_Typ := Etype (Sub_Ind); return Get_Dimension_System_Id (B_Typ); else return No_Dim_Sys; end if; else return No_Dim_Sys; end if; end Corresponding_Dimension_System; ---------------------------------------- -- Corresponding_Etype_Has_Dimensions -- ---------------------------------------- function Corresponding_Etype_Has_Dimensions (N : Node_Id) return Boolean is Dims_Typ : Dimensions; Typ : Entity_Id; begin -- Check the type is dimensionless before assigning a dimension if Nkind (N) = N_Subtype_Declaration then declare Sub : constant Node_Id := Subtype_Indication (N); begin if Nkind (Sub) /= N_Subtype_Indication then Typ := Etype (Sub); else Typ := Etype (Subtype_Mark (Sub)); end if; Dims_Typ := Get_Dimensions (Typ); return Present (Dims_Typ); end; else return False; end if; end Corresponding_Etype_Has_Dimensions; --------------------------------------- -- Check_Number_Dimensions_Aggregate -- --------------------------------------- function Check_Number_Dimensions_Aggregate (Expr : Node_Id; D_Sys : Dim_Sys_Id; N_Of_Dims : N_Of_Dimensions) return Boolean is Assoc : Node_Id; Choice : Node_Id; Comp_Expr : Node_Id; N_Dims_Aggr : Int := No_Dimensions; -- The number of dimensions in this aggregate begin -- Check the size of the aggregate match with the size of the -- corresponding dimension system. Comp_Expr := First (Expressions (Expr)); -- Skip the first argument in the aggregate since it's a character or -- a string and not a dimension value. Next (Comp_Expr); if Present (Component_Associations (Expr)) then -- If the aggregate is a positional aggregate with an -- Others_Choice, the number of expressions must be less than or -- equal to N_Of_Dims - 1. if Present (Comp_Expr) then N_Dims_Aggr := List_Length (Expressions (Expr)) - 1; return N_Dims_Aggr <= N_Of_Dims - 1; -- If the aggregate is a named aggregate, N_Dims_Aggr is used to -- count all the dimensions referenced by the aggregate. else Assoc := First (Component_Associations (Expr)); while Present (Assoc) loop if Nkind (Assoc) = N_Range then Choice := First (Choices (Assoc)); declare HB : constant Node_Id := High_Bound (Choice); LB : constant Node_Id := Low_Bound (Choice); LB_Dim : Dim_Id; HB_Dim : Dim_Id; begin if not Check_Identifier_Is_Dimension (HB, D_Sys) or else not Check_Identifier_Is_Dimension (LB, D_Sys) then return False; end if; HB_Dim := Get_Dimension_Id (HB, D_Sys); LB_Dim := Get_Dimension_Id (LB, D_Sys); N_Dims_Aggr := N_Dims_Aggr + HB_Dim - LB_Dim + 1; end; else N_Dims_Aggr := N_Dims_Aggr + List_Length (Choices (Assoc)); end if; Next (Assoc); end loop; -- Check whether an Others_Choice is present or not if Nkind (First (Choices (Last (Component_Associations (Expr))))) = N_Others_Choice then return N_Dims_Aggr <= N_Of_Dims; else return N_Dims_Aggr = N_Of_Dims; end if; end if; -- If the aggregate is a positional aggregate without Others_Choice, -- the number of expressions must match the number of dimensions in -- the dimension system. else N_Dims_Aggr := List_Length (Expressions (Expr)) - 1; return N_Dims_Aggr = N_Of_Dims; end if; end Check_Number_Dimensions_Aggregate; ----------------------------------- -- Check_Identifier_Is_Dimension -- ----------------------------------- function Check_Identifier_Is_Dimension (Id : Node_Id; D_Sys : Dim_Sys_Id) return Boolean is Na_Id : constant Name_Id := Chars (Id); Dim_Name1 : Name_Id; Dim_Name2 : Name_Id; begin for Dim1 in Dim_Id'Range loop Dim_Name1 := Dim_Systems.Table (D_Sys).Names (Dim1); if Dim_Name1 = Na_Id then return True; end if; if Dim1 = Max_Dimensions then -- Check for possible misspelling Error_Msg_N ("& is not a dimension argument for aspect%", Id); for Dim2 in Dim_Id'Range loop Dim_Name2 := Dim_Systems.Table (D_Sys).Names (Dim2); if Is_Bad_Spelling_Of (Na_Id, Dim_Name2) then Error_Msg_Name_1 := Dim_Name2; Error_Msg_N ("\possible misspelling of%", Id); exit; end if; end loop; end if; end loop; return False; end Check_Identifier_Is_Dimension; ---------------------- -- Get_Dimension_Id -- ---------------------- -- Given an identifier, returns the correponding position of the -- dimension in the dimension system. function Get_Dimension_Id (Id : Node_Id; D_Sys : Dim_Sys_Id) return Dim_Id is Na_Id : constant Name_Id := Chars (Id); Dim : Dim_Id; Dim_Name : Name_Id; begin for D in Dim_Id'Range loop Dim_Name := Dim_Systems.Table (D_Sys).Names (D); if Dim_Name = Na_Id then Dim := D; end if; end loop; return Dim; end Get_Dimension_Id; ------------------------------------------------------- -- Check_Compile_Time_Known_Expressions_In_Aggregate -- ------------------------------------------------------- function Check_Compile_Time_Known_Expressions_In_Aggregate (Expr : Node_Id) return Boolean is Comp_Assn : Node_Id; Comp_Expr : Node_Id; begin Comp_Expr := First (Expressions (Expr)); Next (Comp_Expr); while Present (Comp_Expr) loop -- First, analyze the expression Analyze_And_Resolve (Comp_Expr); if not Compile_Time_Known_Value (Comp_Expr) then return False; end if; Next (Comp_Expr); end loop; Comp_Assn := First (Component_Associations (Expr)); while Present (Comp_Assn) loop Comp_Expr := Expression (Comp_Assn); -- First, analyze the expression Analyze_And_Resolve (Comp_Expr); if not Compile_Time_Known_Value (Comp_Expr) then return False; end if; Next (Comp_Assn); end loop; return True; end Check_Compile_Time_Known_Expressions_In_Aggregate; -- Start of processing for Analyze_Aspect_Dimension begin -- Syntax checking Error_Msg_Name_1 := Chars (Id); if N_Kind /= N_Subtype_Declaration then Error_Msg_N ("aspect% doesn't apply here", N); return; end if; if Nkind (Expr) /= N_Aggregate then Error_Msg_N ("wrong syntax for aspect%", Expr); return; end if; D_Sys := Corresponding_Dimension_System (N); if D_Sys = No_Dim_Sys then Error_Msg_N ("dimension system not found for aspect%", N); return; end if; if Corresponding_Etype_Has_Dimensions (N) then Error_Msg_N ("corresponding type already has a dimension", N); return; end if; -- Check the first expression is a string or a character literal and -- skip it. Dim_Str_Lit := First (Expressions (Expr)); if not Present (Dim_Str_Lit) or else not Nkind_In (Dim_Str_Lit, N_String_Literal, N_Character_Literal) then Error_Msg_N ("wrong syntax for aspect%: first argument in the aggregate must " & "be a character or a string", Expr); return; end if; Comp_Expr := Next (Dim_Str_Lit); -- Check the number of dimensions match with the dimension system N_Of_Dims := Dim_Systems.Table (D_Sys).N_Of_Dims; if not Check_Number_Dimensions_Aggregate (Expr, D_Sys, N_Of_Dims) then Error_Msg_N ("wrong number of dimensions for aspect%", Expr); return; end if; Dim := Dim_Id'First; Comp_Assn := First (Component_Associations (Expr)); if Present (Comp_Expr) then if List_Length (Component_Associations (Expr)) > 1 then Error_Msg_N ("named association cannot follow " & "positional association for aspect%", Expr); return; end if; if Present (Comp_Assn) and then Nkind (First (Choices (Comp_Assn))) /= N_Others_Choice then Error_Msg_N ("named association cannot follow " & "positional association for aspect%", Expr); return; end if; end if; -- Check each expression in the aspect Dimension aggregate is known at -- compile time. if not Check_Compile_Time_Known_Expressions_In_Aggregate (Expr) then Error_Msg_N ("wrong syntax for aspect%", Expr); return; end if; -- Get the dimension values and store them in the Hash_Table -- Positional aggregate case while Present (Comp_Expr) loop if Is_Integer_Type (Def_Id) then Dims (Dim) := +Whole (UI_To_Int (Expr_Value (Comp_Expr))); else Create_Rational_From_Expr (Comp_Expr, Dims (Dim)); end if; Analyzed (Dim) := True; exit when Dim = Max_Dimensions; Dim := Dim + 1; Next (Comp_Expr); end loop; -- Named aggregate case while Present (Comp_Assn) loop Comp_Expr := Expression (Comp_Assn); Choice := First (Choices (Comp_Assn)); if List_Length (Choices (Comp_Assn)) = 1 then -- N_Identifier case if Nkind (Choice) = N_Identifier then if not Check_Identifier_Is_Dimension (Choice, D_Sys) then return; end if; Dim := Get_Dimension_Id (Choice, D_Sys); if Is_Integer_Type (Def_Id) then Dims (Dim) := +Whole (UI_To_Int (Expr_Value (Comp_Expr))); else Create_Rational_From_Expr (Comp_Expr, Dims (Dim)); end if; Analyzed (Dim) := True; -- N_Range case elsif Nkind (Choice) = N_Range then declare HB : constant Node_Id := High_Bound (Choice); LB : constant Node_Id := Low_Bound (Choice); LB_Dim : constant Dim_Id := Get_Dimension_Id (LB, D_Sys); HB_Dim : constant Dim_Id := Get_Dimension_Id (HB, D_Sys); begin for Dim in LB_Dim .. HB_Dim loop if Is_Integer_Type (Def_Id) then Dims (Dim) := +Whole (UI_To_Int (Expr_Value (Comp_Expr))); else Create_Rational_From_Expr (Comp_Expr, Dims (Dim)); end if; Analyzed (Dim) := True; end loop; end; -- N_Others_Choice case elsif Nkind (Choice) = N_Others_Choice then -- Check the Others_Choice is alone and last in the aggregate if Present (Next (Comp_Assn)) then Error_Msg_N ("OTHERS must appear alone and last in expression " & "for aspect%", Choice); return; end if; -- End the filling of Dims by the Others_Choice value -- If N_Of_Dims < Max_Dimensions then only the -- positions that haven't been already analyzed from -- Dim_Id'First to N_Of_Dims are filled. for Dim in Dim_Id'First .. N_Of_Dims loop if not Analyzed (Dim) then if Is_Integer_Type (Def_Id) then Dims (Dim) := +Whole (UI_To_Int (Expr_Value (Comp_Expr))); else Create_Rational_From_Expr (Comp_Expr, Dims (Dim)); end if; end if; end loop; else Error_Msg_N ("wrong syntax for aspect%", Id); end if; else while Present (Choice) loop if Nkind (Choice) = N_Identifier then if not Check_Identifier_Is_Dimension (Choice, D_Sys) then return; end if; Dim := Get_Dimension_Id (Choice, D_Sys); if Is_Integer_Type (Def_Id) then Dims (Dim) := +Whole (UI_To_Int (Expr_Value (Comp_Expr))); else Create_Rational_From_Expr (Comp_Expr, Dims (Dim)); end if; Analyzed (Dim) := True; Next (Choice); else Error_Msg_N ("wrong syntax for aspect%", Id); end if; end loop; end if; Next (Comp_Assn); end loop; -- Create the string of dimensions if Nkind (Dim_Str_Lit) = N_Character_Literal then Start_String; Store_String_Char (UI_To_CC (Char_Literal_Value (Dim_Str_Lit))); Str := End_String; else Str := Strval (Dim_Str_Lit); end if; -- Store the dimensions in the Hash Table if not all equal to zero and -- string is empty. if not Present (Dims) then if String_Length (Str) = 0 then Error_Msg_N ("?dimension values all equal to zero for aspect%", Expr); return; end if; else Set_Dimensions (Def_Id, Dims); end if; -- Store the string in the Hash Table -- When the string is empty, don't store the string in the Hash Table if Str /= No_String and then String_Length (Str) /= 0 then Set_Dimensions_String_Id (Def_Id, Str); end if; end Analyze_Aspect_Dimension; ------------------------------------- -- Analyze_Aspect_Dimension_System -- ------------------------------------- -- with Dimension_System => DIMENSION_PAIRS -- DIMENSION_PAIRS ::= -- (DIMENSION_PAIR -- [, DIMENSION_PAIR] -- [, DIMENSION_PAIR] -- [, DIMENSION_PAIR] -- [, DIMENSION_PAIR] -- [, DIMENSION_PAIR] -- [, DIMENSION_PAIR]) -- DIMENSION_PAIR ::= (DIMENSION_IDENTIFIER, DIMENSION_STRING) -- DIMENSION_IDENTIFIER ::= IDENTIFIER -- DIMENSION_STRING ::= STRING_LITERAL | CHARACTER_LITERAL procedure Analyze_Aspect_Dimension_System (N : Node_Id; Id : Node_Id; Expr : Node_Id) is Dim_Name : Node_Id; Dim_Node : Node_Id; Dim_Symbol : Node_Id; D_Sys : Dimension_System := No_Dimension_System; Names : Name_Array := No_Names; N_Of_Dims : N_Of_Dimensions; Symbols : Symbol_Array := No_Symbols; function Derived_From_Numeric_Type (N : Node_Id) return Boolean; -- Return True if the node is a derived type declaration from any -- numeric type. function Check_Dimension_System_Syntax (N : Node_Id) return Boolean; -- Return True if the expression is an aggregate of names function Check_Number_Of_Dimensions (Expr : Node_Id) return Boolean; -- Return True if the number of dimensions in the corresponding -- dimension is positive and lower than Max_Dimensions. ------------------------------- -- Derived_From_Numeric_Type -- ------------------------------- function Derived_From_Numeric_Type (N : Node_Id) return Boolean is begin case (Nkind (N)) is when N_Full_Type_Declaration => declare T_Def : constant Node_Id := Type_Definition (N); Ent : Entity_Id; begin -- Check that the node is a derived type declaration from -- a numeric type. if Nkind (T_Def) /= N_Derived_Type_Definition then return False; else Ent := Entity (Subtype_Indication (T_Def)); if Is_Numeric_Type (Ent) then return True; else return False; end if; end if; end; when others => return False; end case; end Derived_From_Numeric_Type; ----------------------------------- -- Check_Dimension_System_Syntax -- ----------------------------------- -- Check that the expression of aspect Dimension_System is an aggregate -- which contains pairs of identifier and string or character literal. function Check_Dimension_System_Syntax (N : Node_Id) return Boolean is Dim_Node : Node_Id; Expr_Dim : Node_Id; begin -- Chek that the aggregate is a positional array if Present (Component_Associations (N)) then return False; else Dim_Node := First (Expressions (N)); -- Check that each component of the aggregate is an aggregate while Present (Dim_Node) loop -- Verify that the aggregate is a pair of identifier and string -- or character literal. if Nkind (Dim_Node) = N_Aggregate then if not Present (Expressions (Dim_Node)) then return False; end if; if Present (Component_Associations (Dim_Node)) then return False; end if; -- First expression in the aggregate Expr_Dim := First (Expressions (Dim_Node)); if Nkind (Expr_Dim) /= N_Identifier then return False; end if; -- Second expression in the aggregate Next (Expr_Dim); if not Nkind_In (Expr_Dim, N_String_Literal, N_Character_Literal) then return False; end if; -- If the aggregate has a third expression, return False Next (Expr_Dim); if Present (Expr_Dim) then return False; end if; else return False; end if; Next (Dim_Node); end loop; return True; end if; end Check_Dimension_System_Syntax; -------------------------------- -- Check_Number_Of_Dimensions -- -------------------------------- function Check_Number_Of_Dimensions (Expr : Node_Id) return Boolean is List_Expr : constant List_Id := Expressions (Expr); begin if List_Length (List_Expr) < Dim_Id'First or else List_Length (List_Expr) > Max_Dimensions then return False; else return True; end if; end Check_Number_Of_Dimensions; -- Start of processing for Analyze_Aspect_Dimension_System begin Error_Msg_Name_1 := Chars (Id); -- Syntax checking if Nkind (Expr) /= N_Aggregate then Error_Msg_N ("wrong syntax for aspect%", Expr); return; end if; if not Derived_From_Numeric_Type (N) then Error_Msg_N ("aspect% only apply for type derived from numeric type", Id); return; end if; if not Check_Dimension_System_Syntax (Expr) then Error_Msg_N ("wrong syntax for aspect%", Expr); return; end if; if not Check_Number_Of_Dimensions (Expr) then Error_Msg_N ("wrong number of dimensions for aspect%", Expr); return; end if; -- Number of dimensions in the system N_Of_Dims := List_Length (Expressions (Expr)); -- Create the new dimension system D_Sys.Base_Type := N; Dim_Node := First (Expressions (Expr)); for Dim in Dim_Id'First .. N_Of_Dims loop Dim_Name := First (Expressions (Dim_Node)); Names (Dim) := Chars (Dim_Name); Dim_Symbol := Next (Dim_Name); -- N_Character_Literal case if Nkind (Dim_Symbol) = N_Character_Literal then Start_String; Store_String_Char (UI_To_CC (Char_Literal_Value (Dim_Symbol))); Symbols (Dim) := End_String; -- N_String_Literal case else Symbols (Dim) := Strval (Dim_Symbol); end if; Next (Dim_Node); end loop; D_Sys.Names := Names; D_Sys.N_Of_Dims := N_Of_Dims; D_Sys.Symbols := Symbols; -- Store the dimension system in the Table Dim_Systems.Append (D_Sys); end Analyze_Aspect_Dimension_System; ----------------------- -- Analyze_Dimension -- ----------------------- -- This dispatch routine propagates dimensions for each node procedure Analyze_Dimension (N : Node_Id) is begin -- Aspect is an Ada 2012 feature if Ada_Version < Ada_2012 then return; end if; case Nkind (N) is when N_Assignment_Statement => Analyze_Dimension_Assignment_Statement (N); when N_Subtype_Declaration => Analyze_Dimension_Subtype_Declaration (N); when N_Object_Declaration => Analyze_Dimension_Object_Declaration (N); when N_Object_Renaming_Declaration => Analyze_Dimension_Object_Renaming_Declaration (N); when N_Component_Declaration => Analyze_Dimension_Component_Declaration (N); when N_Binary_Op => Analyze_Dimension_Binary_Op (N); when N_Unary_Op => Analyze_Dimension_Unary_Op (N); when N_Identifier => Analyze_Dimension_Identifier (N); when N_Attribute_Reference | N_Indexed_Component | N_Qualified_Expression | N_Selected_Component | N_Slice | N_Type_Conversion | N_Unchecked_Type_Conversion => Analyze_Dimension_Has_Etype (N); when N_Function_Call => Analyze_Dimension_Function_Call (N); when N_Extended_Return_Statement => Analyze_Dimension_Extended_Return_Statement (N); when N_Simple_Return_Statement => Analyze_Dimension_Simple_Return_Statement (N); when others => null; end case; end Analyze_Dimension; -------------------------------------------- -- Analyze_Dimension_Assignment_Statement -- -------------------------------------------- procedure Analyze_Dimension_Assignment_Statement (N : Node_Id) is Lhs : constant Node_Id := Name (N); Dim_Lhs : constant Dimensions := Get_Dimensions (Lhs); Rhs : constant Node_Id := Expression (N); Dim_Rhs : constant Dimensions := Get_Dimensions (Rhs); procedure Analyze_Dimensions_In_Assignment (Dim_Lhs : Dimensions; Dim_Rhs : Dimensions); -- Subroutine to perform the dimensionnality checking for assignment -------------------------------------- -- Analyze_Dimensions_In_Assignment -- -------------------------------------- procedure Analyze_Dimensions_In_Assignment (Dim_Lhs : Dimensions; Dim_Rhs : Dimensions) is begin -- Check the lhs and the rhs have the same dimension if not Present (Dim_Lhs) then if Present (Dim_Rhs) then Error_Msg_N ("?dimensions missmatch in assignment", N); end if; else if Dim_Lhs /= Dim_Rhs then Error_Msg_N ("?dimensions missmatch in assignment", N); end if; end if; end Analyze_Dimensions_In_Assignment; -- Start of processing for Analyze_Dimension_Assignment begin Analyze_Dimensions_In_Assignment (Dim_Lhs, Dim_Rhs); end Analyze_Dimension_Assignment_Statement; --------------------------------- -- Analyze_Dimension_Binary_Op -- --------------------------------- procedure Analyze_Dimension_Binary_Op (N : Node_Id) is N_Kind : constant Node_Kind := Nkind (N); begin if Nkind_In (N_Kind, N_Op_Add, N_Op_Expon, N_Op_Subtract) or else N_Kind in N_Multiplying_Operator or else N_Kind in N_Op_Compare then declare L : constant Node_Id := Left_Opnd (N); L_Dims : constant Dimensions := Get_Dimensions (L); L_Has_Dimensions : constant Boolean := Present (L_Dims); R : constant Node_Id := Right_Opnd (N); R_Dims : constant Dimensions := Get_Dimensions (R); R_Has_Dimensions : constant Boolean := Present (R_Dims); Dims : Dimensions := Zero_Dimensions; begin if Nkind_In (N, N_Op_Add, N_Op_Mod, N_Op_Rem, N_Op_Subtract) then Error_Msg_Name_1 := Chars (N); -- Check both operands dimension if L_Has_Dimensions and R_Has_Dimensions then -- If dimensions missmatch if L_Dims /= R_Dims then Error_Msg_N ("?both operands for operation% must have same " & "dimension", N); else Set_Dimensions (N, L_Dims); end if; elsif not L_Has_Dimensions and R_Has_Dimensions then Error_Msg_N ("?both operands for operation% must have same dimension", N); elsif L_Has_Dimensions and not R_Has_Dimensions then Error_Msg_N ("?both operands for operation% must have same dimension", N); end if; elsif Nkind_In (N_Kind, N_Op_Multiply, N_Op_Divide) then if L_Has_Dimensions and R_Has_Dimensions then -- Get both operands dimension and add them if N_Kind = N_Op_Multiply then for Dim in Dimensions'Range loop Dims (Dim) := L_Dims (Dim) + R_Dims (Dim); end loop; -- Get both operands dimension and subtract them else for Dim in Dimensions'Range loop Dims (Dim) := L_Dims (Dim) - R_Dims (Dim); end loop; end if; elsif L_Has_Dimensions and not R_Has_Dimensions then Dims := L_Dims; elsif not L_Has_Dimensions and R_Has_Dimensions then if N_Kind = N_Op_Multiply then Dims := R_Dims; else for Dim in R_Dims'Range loop Dims (Dim) := -R_Dims (Dim); end loop; end if; end if; if Present (Dims) then Set_Dimensions (N, Dims); end if; -- N_Op_Expon -- Propagation of the dimension and evaluation of the result if -- the exponent is a rational and if the operand has a dimension. elsif N_Kind = N_Op_Expon then declare Rat : Rational := Zero_Rational; begin -- Check exponent is dimensionless if R_Has_Dimensions then Error_Msg_N ("?right operand cannot have a dimension for&", Identifier (N)); else -- Check the left operand is not dimensionless -- Note that the value of the exponent must be know at -- compile time. Otherwise, the exponentiation evaluation -- will return an error message. if Get_Dimension_System_Id (Base_Type (Etype (L))) /= No_Dim_Sys and then Compile_Time_Known_Value (R) then -- Real exponent case if Is_Real_Type (Etype (L)) then -- Define the exponent as a Rational number Create_Rational_From_Expr (R, Rat); if L_Has_Dimensions then for Dim in Dimensions'Range loop Dims (Dim) := L_Dims (Dim) * Rat; end loop; if Present (Dims) then Set_Dimensions (N, Dims); end if; end if; -- Evaluate the operator with rational exponent -- Eval_Op_Expon_With_Rational_Exponent (N, Rat); -- Integer exponent case else for Dim in Dimensions'Range loop Dims (Dim) := L_Dims (Dim) * Whole (UI_To_Int (Expr_Value (R))); end loop; if Present (Dims) then Set_Dimensions (N, Dims); end if; end if; end if; end if; end; -- For relational operations, only a dimension checking is -- performed. -- No propagation elsif N_Kind in N_Op_Compare then Error_Msg_Name_1 := Chars (N); if (L_Has_Dimensions or R_Has_Dimensions) and then L_Dims /= R_Dims then Error_Msg_N ("?both operands for operation% must have same dimension", N); end if; end if; Remove_Dimensions (L); Remove_Dimensions (R); end; end if; end Analyze_Dimension_Binary_Op; --------------------------------------------- -- Analyze_Dimension_Component_Declaration -- --------------------------------------------- procedure Analyze_Dimension_Component_Declaration (N : Node_Id) is Expr : constant Node_Id := Expression (N); Id : constant Entity_Id := Defining_Identifier (N); E_Typ : constant Entity_Id := Etype (Id); Dim_T : constant Dimensions := Get_Dimensions (E_Typ); Dim_E : Dimensions; begin if Present (Dim_T) then -- If the component type has a dimension and there is no expression, -- propagates the dimension. if Present (Expr) then Dim_E := Get_Dimensions (Expr); if Present (Dim_E) then -- Return an error if the dimension of the expression and the -- dimension of the type missmatch. if Dim_E /= Dim_T then Error_Msg_N ("?dimensions missmatch in object " & "declaration", N); end if; -- If the expression is dimensionless else Error_Msg_N ("?dimensions missmatch in component declaration", N); end if; -- For every other cases, propagate the dimensions else Copy_Dimensions (E_Typ, Id); end if; end if; end Analyze_Dimension_Component_Declaration; ------------------------------------------------- -- Analyze_Dimension_Extended_Return_Statement -- ------------------------------------------------- procedure Analyze_Dimension_Extended_Return_Statement (N : Node_Id) is Obj_Decls : constant List_Id := Return_Object_Declarations (N); R_Ent : constant Entity_Id := Return_Statement_Entity (N); R_Etyp : constant Entity_Id := Etype (Return_Applies_To (R_Ent)); Dims_R : constant Dimensions := Get_Dimensions (R_Etyp); Dims_Obj : Dimensions; Obj_Decl : Node_Id; Obj_Id : Entity_Id; begin if Present (Obj_Decls) then Obj_Decl := First (Obj_Decls); while Present (Obj_Decl) loop if Nkind (Obj_Decl) = N_Object_Declaration then Obj_Id := Defining_Identifier (Obj_Decl); if Is_Return_Object (Obj_Id) then Dims_Obj := Get_Dimensions (Obj_Id); if Dims_R /= Dims_Obj then Error_Msg_N ("?dimensions missmatch in return statement", N); return; end if; end if; end if; Next (Obj_Decl); end loop; end if; end Analyze_Dimension_Extended_Return_Statement; ------------------------------------- -- Analyze_Dimension_Function_Call -- ------------------------------------- procedure Analyze_Dimension_Function_Call (N : Node_Id) is Name_Call : constant Node_Id := Name (N); Par_Ass : constant List_Id := Parameter_Associations (N); Dims : Dimensions; Dims_Param : Dimensions; Param : Node_Id; function Is_Elementary_Function_Call (N : Node_Id) return Boolean; -- Return True if the call is a call of an elementary function (see -- Ada.Numerics.Generic_Elementary_Functions). --------------------------------- -- Is_Elementary_Function_Call -- --------------------------------- function Is_Elementary_Function_Call (N : Node_Id) return Boolean is Ent : Entity_Id; begin -- Note that the node must come from source if Comes_From_Source (N) and then Is_Entity_Name (Name_Call) then Ent := Entity (Name_Call); -- Check the procedure is defined in an instantiation of a generic -- package. if Is_Generic_Instance (Scope (Ent)) then Ent := Cunit_Entity (Get_Source_Unit (Ent)); -- Check the name of the generic package is -- Generic_Elementary_Functions if Is_Library_Level_Entity (Ent) and then Chars (Ent) = Name_Generic_Elementary_Functions then return True; end if; end if; end if; return False; end Is_Elementary_Function_Call; -- Start of processing for Analyze_Dimension_Function_Call begin -- Elementary function case if Is_Elementary_Function_Call (N) then -- Sqrt function call case if Chars (Name_Call) = Name_Sqrt then Dims := Get_Dimensions (First (Par_Ass)); if Present (Dims) then for Dim in Dims'Range loop Dims (Dim) := Dims (Dim) * (1, 2); end loop; Set_Dimensions (N, Dims); end if; -- All other functions in Ada.Numerics.Generic_Elementary_Functions -- Note that all parameters here should be dimensionless else Param := First (Par_Ass); while Present (Param) loop Dims_Param := Get_Dimensions (Param); if Present (Dims_Param) then Error_Msg_Name_1 := Chars (Name_Call); Error_Msg_N ("?parameter should be dimensionless for elementary " & "function%", Param); return; end if; Next (Param); end loop; end if; -- General case else Analyze_Dimension_Has_Etype (N); end if; end Analyze_Dimension_Function_Call; --------------------------------- -- Analyze_Dimension_Has_Etype -- --------------------------------- procedure Analyze_Dimension_Has_Etype (N : Node_Id) is E_Typ : constant Entity_Id := Etype (N); Dims : constant Dimensions := Get_Dimensions (E_Typ); N_Kind : constant Node_Kind := Nkind (N); begin -- Propagation of the dimensions from the type if Present (Dims) then Set_Dimensions (N, Dims); end if; -- Removal of dimensions in expression if Nkind_In (N_Kind, N_Attribute_Reference, N_Indexed_Component) then declare Expr : Node_Id; Exprs : constant List_Id := Expressions (N); begin if Present (Exprs) then Expr := First (Exprs); while Present (Expr) loop Remove_Dimensions (Expr); Next (Expr); end loop; end if; end; elsif Nkind_In (N_Kind, N_Qualified_Expression, N_Type_Conversion, N_Unchecked_Type_Conversion) then Remove_Dimensions (Expression (N)); elsif N_Kind = N_Selected_Component then Remove_Dimensions (Selector_Name (N)); end if; end Analyze_Dimension_Has_Etype; ---------------------------------- -- Analyze_Dimension_Identifier -- ---------------------------------- procedure Analyze_Dimension_Identifier (N : Node_Id) is Ent : constant Entity_Id := Entity (N); Dims : constant Dimensions := Get_Dimensions (Ent); begin if Present (Dims) then Set_Dimensions (N, Dims); else Analyze_Dimension_Has_Etype (N); end if; end Analyze_Dimension_Identifier; ------------------------------------------ -- Analyze_Dimension_Object_Declaration -- ------------------------------------------ procedure Analyze_Dimension_Object_Declaration (N : Node_Id) is Expr : constant Node_Id := Expression (N); Id : constant Entity_Id := Defining_Identifier (N); E_Typ : constant Entity_Id := Etype (Id); Dim_T : constant Dimensions := Get_Dimensions (E_Typ); Dim_E : Dimensions; begin if Present (Dim_T) then -- Expression is present if Present (Expr) then Dim_E := Get_Dimensions (Expr); if Present (Dim_E) then -- Return an error if the dimension of the expression and the -- dimension of the type missmatch. if Dim_E /= Dim_T then Error_Msg_N ("?dimensions missmatch in object " & "declaration", N); end if; -- If the expression is dimensionless else -- If the node is not a real constant or an integer constant -- (depending on the dimensioned numeric type), return an error -- message. if not Nkind_In (Original_Node (Expr), N_Real_Literal, N_Integer_Literal) then Error_Msg_N ("?dimensions missmatch in object " & "declaration", N); end if; end if; -- For every other cases, propagate the dimensions else Copy_Dimensions (E_Typ, Id); end if; end if; end Analyze_Dimension_Object_Declaration; --------------------------------------------------- -- Analyze_Dimension_Object_Renaming_Declaration -- --------------------------------------------------- procedure Analyze_Dimension_Object_Renaming_Declaration (N : Node_Id) is Id : constant Entity_Id := Defining_Identifier (N); Ren_Id : constant Node_Id := Name (N); E_Typ : constant Entity_Id := Etype (Ren_Id); Dims_Typ : constant Dimensions := Get_Dimensions (E_Typ); begin if Present (Dims_Typ) then Copy_Dimensions (E_Typ, Id); end if; end Analyze_Dimension_Object_Renaming_Declaration; ----------------------------------------------- -- Analyze_Dimension_Simple_Return_Statement -- ----------------------------------------------- procedure Analyze_Dimension_Simple_Return_Statement (N : Node_Id) is Expr : constant Node_Id := Expression (N); Dims_Expr : constant Dimensions := Get_Dimensions (Expr); R_Ent : constant Entity_Id := Return_Statement_Entity (N); R_Etyp : constant Entity_Id := Etype (Return_Applies_To (R_Ent)); Dims_R : constant Dimensions := Get_Dimensions (R_Etyp); begin if Dims_R /= Dims_Expr then Error_Msg_N ("?dimensions missmatch in return statement", N); Remove_Dimensions (Expr); end if; end Analyze_Dimension_Simple_Return_Statement; ------------------------------------------- -- Analyze_Dimension_Subtype_Declaration -- ------------------------------------------- procedure Analyze_Dimension_Subtype_Declaration (N : Node_Id) is Ent : constant Entity_Id := Defining_Identifier (N); Dims_Ent : constant Dimensions := Get_Dimensions (Ent); E_Typ : Node_Id; begin if Nkind (Subtype_Indication (N)) /= N_Subtype_Indication then E_Typ := Etype (Subtype_Indication (N)); declare Dims_Typ : constant Dimensions := Get_Dimensions (E_Typ); begin if Present (Dims_Typ) then -- If the subtype already has a dimension (from -- Aspect_Dimension), it cannot inherit a dimension from its -- subtype. if Present (Dims_Ent) then Error_Msg_N ("?subtype& already has a dimension", N); else Set_Dimensions (Ent, Dims_Typ); Set_Dimensions_String_Id (Ent, Get_Dimensions_String_Id (E_Typ)); end if; end if; end; else E_Typ := Etype (Subtype_Mark (Subtype_Indication (N))); declare Dims_Typ : constant Dimensions := Get_Dimensions (E_Typ); begin if Present (Dims_Typ) then -- If the subtype already has a dimension (from -- Aspect_Dimension), it cannot inherit a dimension from its -- subtype. if Present (Dims_Ent) then Error_Msg_N ("?subtype& already has a dimension", N); else Set_Dimensions (Ent, Dims_Typ); Set_Dimensions_String_Id (Ent, Get_Dimensions_String_Id (E_Typ)); end if; end if; end; end if; end Analyze_Dimension_Subtype_Declaration; -------------------------------- -- Analyze_Dimension_Unary_Op -- -------------------------------- procedure Analyze_Dimension_Unary_Op (N : Node_Id) is begin case Nkind (N) is when N_Op_Plus | N_Op_Minus | N_Op_Abs => declare R : constant Node_Id := Right_Opnd (N); begin -- Propagate the dimension if the operand is not dimensionless Move_Dimensions (R, N); end; when others => null; end case; end Analyze_Dimension_Unary_Op; --------------------- -- Copy_Dimensions -- --------------------- procedure Copy_Dimensions (From, To : Node_Id) is Dims : constant Dimensions := Aspect_Dimension_Hash_Table.Get (From); begin -- Propagate the dimension from one node to another pragma Assert (Permits_Dimensions (To)); pragma Assert (Present (Dims)); Aspect_Dimension_Hash_Table.Set (To, Dims); end Copy_Dimensions; ------------------------------- -- Create_Rational_From_Expr -- ------------------------------- procedure Create_Rational_From_Expr (Expr : Node_Id; R : in out Rational) is Or_N : constant Node_Id := Original_Node (Expr); Left : Node_Id; Left_Int : Int; Ltype : Entity_Id; Right : Node_Id; Right_Int : Int; R_Opnd_Minus : Node_Id; Rtype : Entity_Id; begin -- A rational number is any number that can be expressed as the quotient -- or fraction a/b of two integers, with the denominator b not equal to -- zero. -- Check the expression is either a division of two integers or an -- integer itself. The check applies to the original node since the -- node could have already been rewritten. -- Numerator is positive if Nkind (Or_N) = N_Op_Divide then Left := Left_Opnd (Or_N); Ltype := Etype (Left); Right := Right_Opnd (Or_N); Rtype := Etype (Right); if Is_Integer_Type (Ltype) and then Is_Integer_Type (Rtype) then Left_Int := UI_To_Int (Expr_Value (Left)); Right_Int := UI_To_Int (Expr_Value (Right)); -- Verify that the denominator of the rational is positive if Right_Int > 0 then if Left_Int mod Right_Int = 0 then R := +Whole (UI_To_Int (Expr_Value (Expr))); else R := Whole (Left_Int) / Whole (Right_Int); end if; else Error_Msg_N ("denominator in a rational number must be positive", Right); end if; else Error_Msg_N ("must be a rational", Expr); end if; -- Numerator is negative elsif Nkind (Or_N) = N_Op_Minus and then Nkind (Original_Node (Right_Opnd (Or_N))) = N_Op_Divide then R_Opnd_Minus := Original_Node (Right_Opnd (Or_N)); Left := Left_Opnd (R_Opnd_Minus); Ltype := Etype (Left); Right := Right_Opnd (R_Opnd_Minus); Rtype := Etype (Right); if Is_Integer_Type (Ltype) and then Is_Integer_Type (Rtype) then Left_Int := UI_To_Int (Expr_Value (Left)); Right_Int := UI_To_Int (Expr_Value (Right)); -- Verify that the denominator of the rational is positive if Right_Int > 0 then if Left_Int mod Right_Int = 0 then R := +Whole (-UI_To_Int (Expr_Value (Expr))); else R := Whole (-Left_Int) / Whole (Right_Int); end if; else Error_Msg_N ("denominator in a rational number must be positive", Right); end if; else Error_Msg_N ("must be a rational", Expr); end if; -- Integer case else if Is_Integer_Type (Etype (Expr)) then Right_Int := UI_To_Int (Expr_Value (Expr)); R := +Whole (Right_Int); else Error_Msg_N ("must be a rational", Expr); end if; end if; end Create_Rational_From_Expr; ---------------------------------------- -- Eval_Op_Expon_For_Dimensioned_Type -- ---------------------------------------- -- Eval the expon operator for dimensioned type -- Note that if the exponent is an integer (denominator equals to 1) the -- node is not evaluated here and must be evaluated by the Eval_Op_Expon -- routine. procedure Eval_Op_Expon_For_Dimensioned_Type (N : Node_Id; B_Typ : Entity_Id) is R : constant Node_Id := Right_Opnd (N); Rat : Rational := Zero_Rational; begin if Compile_Time_Known_Value (R) and then Is_Real_Type (B_Typ) then Create_Rational_From_Expr (R, Rat); Eval_Op_Expon_With_Rational_Exponent (N, Rat); end if; end Eval_Op_Expon_For_Dimensioned_Type; ------------------------------------------ -- Eval_Op_Expon_With_Rational_Exponent -- ------------------------------------------ -- For dimensioned operand in exponentiation, exponent is allowed to be a -- Rational and not only an Integer like for dimensionless operands. For -- that particular case, the left operand is rewritten as a function call -- using the function Expon_LLF from s-llflex.ads. procedure Eval_Op_Expon_With_Rational_Exponent (N : Node_Id; Rat : Rational) is Dims : constant Dimensions := Get_Dimensions (N); L : constant Node_Id := Left_Opnd (N); Etyp : constant Entity_Id := Etype (L); Loc : constant Source_Ptr := Sloc (N); Actual_1 : Node_Id; Actual_2 : Node_Id; Base_Typ : Entity_Id; Dim_Value : Rational; List_Of_Dims : List_Id; New_Aspect : Node_Id; New_Aspects : List_Id; New_E : Entity_Id; New_N : Node_Id; New_Typ_L : Node_Id; Sys : Dim_Sys_Id; begin -- If Rat.Denominator = 1 that means the exponent is an Integer so -- nothing has to be changed. -- Note that the node must come from source if Comes_From_Source (N) and then Rat.Denominator /= 1 then Base_Typ := Base_Type (Etyp); -- Case when the operand is not dimensionless if Present (Dims) then -- Get the corresponding Dim_Sys_Id to know the exact number of -- dimensions in the system. Sys := Get_Dimension_System_Id (Base_Typ); -- Step 1: Generation of a new subtype with the proper dimensions -- In order to rewrite the operator as a function call, a new -- subtype with an aspect dimension using the dimensions of the -- node has to be created. -- Generate: -- Base_Typ : constant Entity_Id := Base_Type (Etyp); -- Sys : constant Dim_Sys_Id := -- Get_Dimension_System_Id (Base_Typ); -- N_Dims : constant N_Of_Dimensions := -- Dim_Systems.Table (Sys).N_Of_Dims; -- Dim_Value : Rational; -- Aspect_Dim_Expr : List; -- Append ("", Aspect_Dim_Expr); -- for Dim in Dims'First .. N_Dims loop -- Dim_Value := Dims (Dim); -- if Dim_Value.Denominator /= 1 then -- Append (Dim_Value.Numerator / Dim_Value.Denominator, -- Aspect_Dim_Expr); -- else -- Append (Dim_Value.Numerator, Aspect_Dim_Expr); -- end if; -- end loop; -- subtype T is Base_Typ with Dimension => Aspect_Dim_Expr; -- Step 1a: Generate the aggregate for the new Aspect_dimension New_Aspects := Empty_List; List_Of_Dims := New_List; Append (Make_String_Literal (Loc, No_String), List_Of_Dims); for Dim in Dims'First .. Dim_Systems.Table (Sys).N_Of_Dims loop Dim_Value := Dims (Dim); if Dim_Value.Denominator /= 1 then Append ( Make_Op_Divide (Loc, Left_Opnd => Make_Integer_Literal (Loc, Int (Dim_Value.Numerator)), Right_Opnd => Make_Integer_Literal (Loc, Int (Dim_Value.Denominator))), List_Of_Dims); else Append ( Make_Integer_Literal (Loc, Int (Dim_Value.Numerator)), List_Of_Dims); end if; end loop; -- Step 1b: Create the new Aspect_Dimension New_Aspect := Make_Aspect_Specification (Loc, Identifier => Make_Identifier (Loc, Name_Dimension), Expression => Make_Aggregate (Loc, Expressions => List_Of_Dims)); -- Step 1c: New identifier for the subtype New_E := Make_Temporary (Loc, 'T'); Set_Is_Internal (New_E); -- Step 1d: Declaration of the new subtype New_Typ_L := Make_Subtype_Declaration (Loc, Defining_Identifier => New_E, Subtype_Indication => New_Occurrence_Of (Base_Typ, Loc)); Append (New_Aspect, New_Aspects); Set_Parent (New_Aspects, New_Typ_L); Set_Aspect_Specifications (New_Typ_L, New_Aspects); Analyze (New_Typ_L); -- Case where the operand is dimensionless else New_E := Base_Typ; end if; -- Step 2: Generation of the function call -- Generate: -- Actual_1 := Long_Long_Float (L), -- Actual_2 := Long_Long_Float (Rat.Numerator) / -- Long_Long_Float (Rat.Denominator); -- (T (Expon_LLF (Actual_1, Actual_2))); -- -- where T is the subtype declared in step 1 -- -- The node is rewritten as a type conversion -- Step 2a: Creation of the two parameters for function Expon_LLF Actual_1 := Make_Type_Conversion (Loc, Subtype_Mark => New_Reference_To (Standard_Long_Long_Float, Loc), Expression => Relocate_Node (L)); Actual_2 := Make_Op_Divide (Loc, Left_Opnd => Make_Real_Literal (Loc, UR_From_Uint (UI_From_Int (Int (Rat.Numerator)))), Right_Opnd => Make_Real_Literal (Loc, UR_From_Uint (UI_From_Int (Int (Rat.Denominator))))); -- Step 2b: New Node N New_N := Make_Type_Conversion (Loc, Subtype_Mark => New_Reference_To (New_E, Loc), Expression => Make_Function_Call (Loc, Name => New_Reference_To (RTE (RE_Expon_LLF), Loc), Parameter_Associations => New_List ( Actual_1, Actual_2))); -- Step 3: Rewitten of N Rewrite (N, New_N); Set_Etype (N, New_E); Analyze_And_Resolve (N, New_E); end if; end Eval_Op_Expon_With_Rational_Exponent; ------------------------------------------- -- Expand_Put_Call_With_Dimension_String -- ------------------------------------------- -- For procedure Put defined in System.Dim_Float_IO and -- System.Dim_Integer_IO, the default string parameter must be rewritten to -- include the dimension symbols in the output of a dimensioned object. -- There are two different cases: -- 1) If the parameter is a variable, the default string parameter is -- replaced by the string defined in the aspect Dimension of the subtype. -- For instance if the user wants to output a speed: -- subtype Speed is Mks_Type with Dimension => -- ("speed", Meter => 1, Second => -1, others => 0); -- v : Speed := 2.1 * m * s**(-1); -- Put (v) returns: -- > 2.1 speed -- 2) If the parameter is an expression, the procedure -- Expand_Put_Call_With_Dimension_String creates the string (for instance -- "m.s**(-1)") and rewrites the default string parameter of Put with the -- corresponding the String_Id. procedure Expand_Put_Call_With_Dimension_String (N : Node_Id) is Actuals : constant List_Id := Parameter_Associations (N); Loc : constant Source_Ptr := Sloc (N); Name_Call : constant Node_Id := Name (N); Actual : Node_Id; Base_Typ : Node_Id; Char_Pack : Name_Id; Dims : Dimensions; Etyp : Entity_Id; First_Actual : Node_Id; New_Par_Ass : List_Id; New_Str_Lit : Node_Id; Sys : Dim_Sys_Id; function Is_Procedure_Put_Call (N : Node_Id) return Boolean; -- Return True if the current call is a call of an instantiation of a -- procedure Put defined in the package System.Dim_Float_IO and -- System.Dim_Integer_IO. function Is_Procedure_Put_Call (N : Node_Id) return Boolean is Name_Call : constant Node_Id := Name (N); Ent : Entity_Id; begin -- There are three different Put routine in each generic package -- Check that the current procedure call is one of them if Is_Entity_Name (Name_Call) then Ent := Entity (Name_Call); -- Check that the name of the procedure is Put if Chars (Name_Call) /= Name_Put then return False; end if; -- Check the procedure is defined in an instantiation of a -- generic package. if Is_Generic_Instance (Scope (Ent)) then Ent := Cunit_Entity (Get_Source_Unit (Ent)); -- Verify that the generic package is System.Dim_Float_IO or -- System.Dim_Integer_IO. if Is_Library_Level_Entity (Ent) then Char_Pack := Chars (Ent); if Char_Pack = Name_Dim_Float_IO or else Char_Pack = Name_Dim_Integer_IO then return True; end if; end if; end if; end if; return False; end Is_Procedure_Put_Call; -- Start of processing for Expand_Put_Call_With_Dimension_String begin if Is_Procedure_Put_Call (N) then -- Get the first parameter First_Actual := First (Actuals); -- Case when the Put routine has four (integer case) or five (float -- case) parameters. if List_Length (Actuals) = 5 or else List_Length (Actuals) = 4 then Actual := Next (First_Actual); if Nkind (Actual) = N_Parameter_Association then -- Get the dimensions and the corresponding dimension system -- from the first actual. Actual := First_Actual; end if; -- Case when the Put routine has six parameters else Actual := Next (First_Actual); end if; Base_Typ := Base_Type (Etype (Actual)); Sys := Get_Dimension_System_Id (Base_Typ); if Sys /= No_Dim_Sys then Dims := Get_Dimensions (Actual); Etyp := Etype (Actual); -- Add the string as a suffix of the value if the subtype has a -- string of dimensions or if the parameter is not dimensionless. if Present (Dims) or else Get_Dimensions_String_Id (Etyp) /= No_String then New_Par_Ass := New_List; -- Add to the list First_Actual and Actual if they differ if Actual /= First_Actual then Append (New_Copy (First_Actual), New_Par_Ass); end if; Append (New_Copy (Actual), New_Par_Ass); -- Look to the next parameter Next (Actual); -- Check if the type of N is a subtype that has a string of -- dimensions in Aspect_Dimension_String_Id_Hash_Table. if Get_Dimensions_String_Id (Etyp) /= No_String then Start_String; -- Put a space between the value and the dimension Store_String_Char (' '); Store_String_Chars (Get_Dimensions_String_Id (Etyp)); New_Str_Lit := Make_String_Literal (Loc, End_String); -- Rewrite the String_Literal of the second actual with the -- new String_Id created by the routine -- From_Dimension_To_String. else New_Str_Lit := Make_String_Literal (Loc, From_Dimension_To_String_Id (Dims, Sys)); end if; Append (New_Str_Lit, New_Par_Ass); -- Rewrite the procedure call with the new list of parameters Rewrite (N, Make_Procedure_Call_Statement (Loc, Name => New_Copy (Name_Call), Parameter_Associations => New_Par_Ass)); Analyze (N); end if; end if; end if; end Expand_Put_Call_With_Dimension_String; --------------------------------- -- From_Dimension_To_String_Id -- --------------------------------- -- Given a dimension vector and the corresponding dimension system, create -- a String_Id to output the dimension symbols corresponding to the -- dimensions Dims. function From_Dimension_To_String_Id (Dims : Dimensions; Sys : Dim_Sys_Id) return String_Id is Dim_Rat : Rational; First_Dim_In_Str : Boolean := True; begin -- Initialization of the new String_Id Start_String; -- Put a space between the value and the dimensions Store_String_Char (' '); for Dim in Dimensions'Range loop Dim_Rat := Dims (Dim); if Dim_Rat /= Zero_Rational then if First_Dim_In_Str then First_Dim_In_Str := False; else Store_String_Char ('.'); end if; -- Positive dimension case if Dim_Rat.Numerator > 0 then if Dim_Systems.Table (Sys).Symbols (Dim) = No_String then Store_String_Chars (Get_Name_String (Dim_Systems.Table (Sys).Names (Dim))); else Store_String_Chars (Dim_Systems.Table (Sys).Symbols (Dim)); end if; -- Integer case if Dim_Rat.Denominator = 1 then if Dim_Rat.Numerator /= 1 then Store_String_Chars ("**"); Store_String_Int (Int (Dim_Rat.Numerator)); end if; -- Rational case when denominator /= 1 else Store_String_Chars ("**"); Store_String_Char ('('); Store_String_Int (Int (Dim_Rat.Numerator)); Store_String_Char ('/'); Store_String_Int (Int (Dim_Rat.Denominator)); Store_String_Char (')'); end if; -- Negative dimension case else if Dim_Systems.Table (Sys).Symbols (Dim) = No_String then Store_String_Chars (Get_Name_String (Dim_Systems.Table (Sys).Names (Dim))); else Store_String_Chars (Dim_Systems.Table (Sys).Symbols (Dim)); end if; Store_String_Chars ("**"); Store_String_Char ('('); Store_String_Char ('-'); Store_String_Int (Int (-Dim_Rat.Numerator)); -- Integer case if Dim_Rat.Denominator = 1 then Store_String_Char (')'); -- Rational case when denominator /= 1 else Store_String_Char ('/'); Store_String_Int (Int (Dim_Rat.Denominator)); Store_String_Char (')'); end if; end if; end if; end loop; return End_String; end From_Dimension_To_String_Id; -------------------- -- Get_Dimensions -- -------------------- function Get_Dimensions (N : Node_Id) return Dimensions is begin return Aspect_Dimension_Hash_Table.Get (N); end Get_Dimensions; ------------------------------ -- Get_Dimensions_String_Id -- ------------------------------ function Get_Dimensions_String_Id (E : Entity_Id) return String_Id is begin return Aspect_Dimension_String_Id_Hash_Table.Get (E); end Get_Dimensions_String_Id; ----------------------------- -- Get_Dimension_System_Id -- ----------------------------- function Get_Dimension_System_Id (E : Entity_Id) return Dim_Sys_Id is D_Sys : Dim_Sys_Id := No_Dim_Sys; begin -- Scan the Table in order to find N for Dim_Sys in 1 .. Dim_Systems.Last loop if Parent (E) = Dim_Systems.Table (Dim_Sys).Base_Type then D_Sys := Dim_Sys; end if; end loop; return D_Sys; end Get_Dimension_System_Id; -------------------------- -- Is_Dimensioned_Type -- -------------------------- function Is_Dimensioned_Type (E : Entity_Id) return Boolean is begin if Get_Dimension_System_Id (E) /= No_Dim_Sys then return True; end if; return False; end Is_Dimensioned_Type; --------------------- -- Move_Dimensions -- --------------------- procedure Move_Dimensions (From, To : Node_Id) is Dims : constant Dimensions := Get_Dimensions (From); begin -- Copy the dimension of 'From to 'To' and remove the dimension of -- 'From'. if Present (Dims) then Set_Dimensions (To, Dims); Remove_Dimensions (From); end if; end Move_Dimensions; ------------------------ -- Permits_Dimensions -- ------------------------ -- Here is the list of node that permits a dimension Dimensions_Permission : constant array (Node_Kind) of Boolean := (N_Attribute_Reference => True, N_Defining_Identifier => True, N_Function_Call => True, N_Identifier => True, N_Indexed_Component => True, N_Integer_Literal => True, N_Op_Abs => True, N_Op_Add => True, N_Op_Divide => True, N_Op_Expon => True, N_Op_Minus => True, N_Op_Mod => True, N_Op_Multiply => True, N_Op_Plus => True, N_Op_Rem => True, N_Op_Subtract => True, N_Qualified_Expression => True, N_Real_Literal => True, N_Selected_Component => True, N_Slice => True, N_Type_Conversion => True, N_Unchecked_Type_Conversion => True, others => False); function Permits_Dimensions (N : Node_Id) return Boolean is begin return Dimensions_Permission (Nkind (N)); end Permits_Dimensions; ------------- -- Present -- ------------- function Present (Dim : Dimensions) return Boolean is begin return Dim /= Zero_Dimensions; end Present; ----------------------- -- Remove_Dimensions -- ----------------------- procedure Remove_Dimensions (N : Node_Id) is Dims : constant Dimensions := Get_Dimensions (N); begin if Present (Dims) then Aspect_Dimension_Hash_Table.Remove (N); end if; end Remove_Dimensions; ------------------------------ -- Remove_Dimension_In_Call -- ------------------------------ procedure Remove_Dimension_In_Call (N : Node_Id) is Actual : Node_Id; Par_Ass : constant List_Id := Parameter_Associations (N); begin if Ada_Version < Ada_2012 then return; end if; if Present (Par_Ass) then Actual := First (Par_Ass); while Present (Actual) loop Remove_Dimensions (Actual); Next (Actual); end loop; end if; end Remove_Dimension_In_Call; ------------------------------------- -- Remove_Dimension_In_Declaration -- ------------------------------------- -- Removal of dimension in expressions of N_Object_Declaration and -- N_Component_Declaration as part of the Analyze_Declarations routine -- (see package Sem_Ch3). procedure Remove_Dimension_In_Declaration (D : Node_Id) is begin if Ada_Version < Ada_2012 then return; end if; if Nkind_In (D, N_Object_Declaration, N_Component_Declaration) then if Present (Expression (D)) then Remove_Dimensions (Expression (D)); end if; end if; end Remove_Dimension_In_Declaration; ----------------------------------- -- Remove_Dimension_In_Statement -- ----------------------------------- -- Removal of dimension in statement as part of the Analyze_Statements -- routine (see package Sem_Ch5). procedure Remove_Dimension_In_Statement (S : Node_Id) is S_Kind : constant Node_Kind := Nkind (S); begin if Ada_Version < Ada_2012 then return; end if; -- Remove dimension in parameter specifications for accept statement if S_Kind = N_Accept_Statement then declare Param : Node_Id := First (Parameter_Specifications (S)); begin while Present (Param) loop Remove_Dimensions (Param); Next (Param); end loop; end; -- Remove dimension of name and expression in assignments elsif S_Kind = N_Assignment_Statement then Remove_Dimensions (Expression (S)); Remove_Dimensions (Name (S)); end if; end Remove_Dimension_In_Statement; -------------------- -- Set_Dimensions -- -------------------- procedure Set_Dimensions (N : Node_Id; Dims : Dimensions) is begin pragma Assert (Permits_Dimensions (N)); pragma Assert (Present (Dims)); Aspect_Dimension_Hash_Table.Set (N, Dims); end Set_Dimensions; ------------------------------ -- Set_Dimensions_String_Id -- ------------------------------ procedure Set_Dimensions_String_Id (E : Entity_Id; Str : String_Id) is begin Aspect_Dimension_String_Id_Hash_Table.Set (E, Str); end Set_Dimensions_String_Id; end Sem_Dim;