| ------------------------------------------------------------------------------ |
| -- -- |
| -- GNAT COMPILER COMPONENTS -- |
| -- -- |
| -- S E M _ D I M -- |
| -- -- |
| -- B o d y -- |
| -- -- |
| -- Copyright (C) 2011-2022, 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 Einfo.Entities; use Einfo.Entities; |
| with Einfo.Utils; use Einfo.Utils; |
| with Errout; use Errout; |
| with Exp_Util; use Exp_Util; |
| with Lib; use Lib; |
| with Namet; use Namet; |
| with Nlists; use Nlists; |
| with Nmake; use Nmake; |
| with Opt; use Opt; |
| with Rtsfind; use Rtsfind; |
| with Sem; use Sem; |
| with Sem_Aux; use Sem_Aux; |
| with Sem_Eval; use Sem_Eval; |
| with Sem_Res; use Sem_Res; |
| with Sem_Util; use Sem_Util; |
| with Sinfo; use Sinfo; |
| with Sinfo.Nodes; use Sinfo.Nodes; |
| with Sinfo.Utils; use Sinfo.Utils; |
| 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 |
| |
| ------------------------- |
| -- Rational Arithmetic -- |
| ------------------------- |
| |
| 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 : constant Rational := Rational'(Numerator => 0, |
| Denominator => 1); |
| |
| No_Rational : constant Rational := Rational'(Numerator => 0, |
| Denominator => 2); |
| -- Used to indicate an expression that cannot be interpreted as a rational |
| -- Returned value of the Create_Rational_From routine when parameter Expr |
| -- is not a static representation of a rational. |
| |
| -- Rational constructors |
| |
| function "+" (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; |
| function "abs" (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; |
| function "/" (Left, Right : Rational) return Rational; |
| |
| ------------------ |
| -- System Types -- |
| ------------------ |
| |
| Max_Number_Of_Dimensions : constant := 7; |
| -- Maximum number of dimensions in a dimension system |
| |
| High_Position_Bound : constant := Max_Number_Of_Dimensions; |
| Invalid_Position : constant := 0; |
| Low_Position_Bound : constant := 1; |
| |
| subtype Dimension_Position is |
| Nat range Invalid_Position .. High_Position_Bound; |
| |
| type Name_Array is |
| array (Dimension_Position range |
| Low_Position_Bound .. High_Position_Bound) of Name_Id; |
| -- Store the names of all units within a system |
| |
| No_Names : constant Name_Array := (others => No_Name); |
| |
| type Symbol_Array is |
| array (Dimension_Position range |
| Low_Position_Bound .. High_Position_Bound) of String_Id; |
| -- Store the symbols of all units within a system |
| |
| No_Symbols : constant Symbol_Array := (others => No_String); |
| |
| -- The following record should be documented field by field |
| |
| type System_Type is record |
| Type_Decl : Node_Id; |
| Unit_Names : Name_Array; |
| Unit_Symbols : Symbol_Array; |
| Dim_Symbols : Symbol_Array; |
| Count : Dimension_Position; |
| end record; |
| |
| Null_System : constant System_Type := |
| (Empty, No_Names, No_Symbols, No_Symbols, Invalid_Position); |
| |
| subtype System_Id is Nat; |
| |
| -- The following table maps types to systems |
| |
| package System_Table is new Table.Table ( |
| Table_Component_Type => System_Type, |
| Table_Index_Type => System_Id, |
| Table_Low_Bound => 1, |
| Table_Initial => 5, |
| Table_Increment => 5, |
| Table_Name => "System_Table"); |
| |
| -------------------- |
| -- Dimension Type -- |
| -------------------- |
| |
| type Dimension_Type is |
| array (Dimension_Position range |
| Low_Position_Bound .. High_Position_Bound) of Rational; |
| |
| Null_Dimension : constant Dimension_Type := (others => Zero); |
| |
| type Dimension_Table_Range is range 0 .. 510; |
| function Dimension_Table_Hash (Key : Node_Id) return Dimension_Table_Range; |
| |
| -- The following table associates nodes with dimensions |
| |
| package Dimension_Table is new |
| GNAT.HTable.Simple_HTable |
| (Header_Num => Dimension_Table_Range, |
| Element => Dimension_Type, |
| No_Element => Null_Dimension, |
| Key => Node_Id, |
| Hash => Dimension_Table_Hash, |
| Equal => "="); |
| |
| ------------------ |
| -- Symbol Types -- |
| ------------------ |
| |
| type Symbol_Table_Range is range 0 .. 510; |
| function Symbol_Table_Hash (Key : Entity_Id) return Symbol_Table_Range; |
| |
| -- Each subtype with a dimension has a symbolic representation of the |
| -- related unit. This table establishes a relation between the subtype |
| -- and the symbol. |
| |
| package Symbol_Table is new |
| GNAT.HTable.Simple_HTable |
| (Header_Num => Symbol_Table_Range, |
| Element => String_Id, |
| No_Element => No_String, |
| Key => Entity_Id, |
| Hash => Symbol_Table_Hash, |
| Equal => "="); |
| |
| -- The following array enumerates all contexts which may contain or |
| -- produce a dimension. |
| |
| OK_For_Dimension : constant array (Node_Kind) of Boolean := |
| (N_Attribute_Reference => True, |
| N_Case_Expression => True, |
| N_Expanded_Name => True, |
| N_Explicit_Dereference => True, |
| N_Defining_Identifier => True, |
| N_Function_Call => True, |
| N_Identifier => True, |
| N_If_Expression => 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); |
| |
| ----------------------- |
| -- Local Subprograms -- |
| ----------------------- |
| |
| procedure Analyze_Dimension_Assignment_Statement (N : Node_Id); |
| -- Subroutine of Analyze_Dimension for assignment statement. Check that the |
| -- dimensions of the left-hand side and the right-hand side of N match. |
| |
| procedure Analyze_Dimension_Binary_Op (N : Node_Id); |
| -- Subroutine of Analyze_Dimension for binary operators. Check the |
| -- dimensions of the right and the left operand permit the operation. |
| -- Then, evaluate the resulting dimensions for each binary operator. |
| |
| procedure Analyze_Dimension_Component_Declaration (N : Node_Id); |
| -- Subroutine of Analyze_Dimension for component declaration. Check that |
| -- the dimensions of the type of N and of the expression match. |
| |
| procedure Analyze_Dimension_Extended_Return_Statement (N : Node_Id); |
| -- Subroutine of Analyze_Dimension for extended return statement. Check |
| -- that the dimensions of the returned type and of the returned object |
| -- match. |
| |
| procedure Analyze_Dimension_Has_Etype (N : Node_Id); |
| -- Subroutine of Analyze_Dimension for a subset of N_Has_Etype denoted by |
| -- the list below: |
| -- N_Attribute_Reference |
| -- N_Identifier |
| -- N_Indexed_Component |
| -- N_Qualified_Expression |
| -- N_Selected_Component |
| -- N_Slice |
| -- N_Type_Conversion |
| -- N_Unchecked_Type_Conversion |
| |
| procedure Analyze_Dimension_Case_Expression (N : Node_Id); |
| -- Verify that all alternatives have the same dimension |
| |
| procedure Analyze_Dimension_If_Expression (N : Node_Id); |
| -- Verify that all alternatives have the same dimension |
| |
| procedure Analyze_Dimension_Number_Declaration (N : Node_Id); |
| -- Procedure to analyze dimension of expression in a number declaration. |
| -- This allows a named number to have nontrivial dimensions, while by |
| -- default a named number is dimensionless. |
| |
| procedure Analyze_Dimension_Object_Declaration (N : Node_Id); |
| -- Subroutine of Analyze_Dimension for object declaration. Check that |
| -- the dimensions of the object type and the dimensions of the expression |
| -- (if expression is present) match. Note that when the expression is |
| -- a literal, no error is returned. This special case allows object |
| -- declaration such as: m : constant Length := 1.0; |
| |
| procedure Analyze_Dimension_Object_Renaming_Declaration (N : Node_Id); |
| -- Subroutine of Analyze_Dimension for object renaming declaration. Check |
| -- the dimensions of the type and of the renamed object name of N match. |
| |
| procedure Analyze_Dimension_Simple_Return_Statement (N : Node_Id); |
| -- Subroutine of Analyze_Dimension for simple return statement |
| -- Check that the dimensions of the returned type and of the returned |
| -- expression match. |
| |
| procedure Analyze_Dimension_Subtype_Declaration (N : Node_Id); |
| -- Subroutine of Analyze_Dimension for subtype declaration. Propagate the |
| -- dimensions from the parent type to the identifier of N. Note that if |
| -- both the identifier and the parent type of N are not dimensionless, |
| -- return an error. |
| |
| procedure Analyze_Dimension_Type_Conversion (N : Node_Id); |
| -- Type conversions handle conversions between literals and dimensioned |
| -- types, from dimensioned types to their base type, and between different |
| -- dimensioned systems. Dimensions of the conversion are obtained either |
| -- from those of the expression, or from the target type, and dimensional |
| -- consistency must be checked when converting between values belonging |
| -- to different dimensioned systems. |
| |
| procedure Analyze_Dimension_Unary_Op (N : Node_Id); |
| -- Subroutine of Analyze_Dimension for unary operators. For Plus, Minus and |
| -- Abs operators, propagate the dimensions from the operand to N. |
| |
| function Create_Rational_From |
| (Expr : Node_Id; |
| Complain : Boolean) return Rational; |
| -- Given an arbitrary expression Expr, return a valid rational if Expr can |
| -- be interpreted as a rational. Otherwise return No_Rational and also an |
| -- error message if Complain is set to True. |
| |
| function Dimensions_Of (N : Node_Id) return Dimension_Type; |
| -- Return the dimension vector of node N |
| |
| function Dimensions_Msg_Of |
| (N : Node_Id; |
| Description_Needed : Boolean := False) return String; |
| -- Given a node N, return the dimension symbols of N, preceded by "has |
| -- dimension" if Description_Needed. If N is dimensionless, return "'[']", |
| -- or "is dimensionless" if Description_Needed. |
| |
| function Dimension_System_Root (T : Entity_Id) return Entity_Id; |
| -- Given a type that has dimension information, return the type that is the |
| -- root of its dimension system, e.g. Mks_Type. If T is not a dimensioned |
| -- type, i.e. a standard numeric type, return Empty. |
| |
| procedure Dim_Warning_For_Numeric_Literal (N : Node_Id; Typ : Entity_Id); |
| -- Issue a warning on the given numeric literal N to indicate that the |
| -- compiler made the assumption that the literal is not dimensionless |
| -- but has the dimension of Typ. |
| |
| procedure Eval_Op_Expon_With_Rational_Exponent |
| (N : Node_Id; |
| Exponent_Value : Rational); |
| -- Evaluate the exponent it is a rational and the operand has a dimension |
| |
| function Exists (Dim : Dimension_Type) return Boolean; |
| -- Returns True iff Dim does not denote the null dimension |
| |
| function Exists (Str : String_Id) return Boolean; |
| -- Returns True iff Str does not denote No_String |
| |
| function Exists (Sys : System_Type) return Boolean; |
| -- Returns True iff Sys does not denote the null system |
| |
| function From_Dim_To_Str_Of_Dim_Symbols |
| (Dims : Dimension_Type; |
| System : System_Type; |
| In_Error_Msg : Boolean := False) return String_Id; |
| -- Given a dimension vector and a dimension system, return the proper |
| -- string of dimension symbols. If In_Error_Msg is True (i.e. the String_Id |
| -- will be used to issue an error message) then this routine has a special |
| -- handling for the insertion characters * or [ which must be preceded by |
| -- a quote ' to be placed literally into the message. |
| |
| function From_Dim_To_Str_Of_Unit_Symbols |
| (Dims : Dimension_Type; |
| System : System_Type) return String_Id; |
| -- Given a dimension vector and a dimension system, return the proper |
| -- string of unit symbols. |
| |
| function Is_Dim_IO_Package_Entity (E : Entity_Id) return Boolean; |
| -- Return True if E is the package entity of System.Dim.Float_IO or |
| -- System.Dim.Integer_IO. |
| |
| function Is_Invalid (Position : Dimension_Position) return Boolean; |
| -- Return True if Pos denotes the invalid position |
| |
| procedure Move_Dimensions (From : Node_Id; To : Node_Id); |
| -- Copy dimension vector of From to To and delete dimension vector of From |
| |
| procedure Remove_Dimensions (N : Node_Id); |
| -- Remove the dimension vector of node N |
| |
| procedure Set_Dimensions (N : Node_Id; Val : Dimension_Type); |
| -- Associate a dimension vector with a node |
| |
| procedure Set_Symbol (E : Entity_Id; Val : String_Id); |
| -- Associate a symbol representation of a dimension vector with a subtype |
| |
| function Symbol_Of (E : Entity_Id) return String_Id; |
| -- E denotes a subtype with a dimension. Return the symbol representation |
| -- of the dimension vector. |
| |
| function System_Of (E : Entity_Id) return System_Type; |
| -- E denotes a type, return associated system of the type if it has one |
| |
| --------- |
| -- "+" -- |
| --------- |
| |
| function "+" (Right : Whole) return Rational is |
| begin |
| return Rational'(Numerator => Right, Denominator => 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, Right : Rational) return Rational is |
| R : constant Rational := abs Right; |
| L : Rational := Left; |
| |
| begin |
| if Right.Numerator < 0 then |
| L.Numerator := Whole (-Integer (L.Numerator)); |
| end if; |
| |
| return Reduce (Rational'(Numerator => L.Numerator * R.Denominator, |
| Denominator => L.Denominator * R.Numerator)); |
| end "/"; |
| |
| ----------- |
| -- "abs" -- |
| ----------- |
| |
| function "abs" (Right : Rational) return Rational is |
| begin |
| return Rational'(Numerator => abs Right.Numerator, |
| Denominator => Right.Denominator); |
| end "abs"; |
| |
| ------------------------------ |
| -- Analyze_Aspect_Dimension -- |
| ------------------------------ |
| |
| -- with Dimension => |
| -- ([Symbol =>] SYMBOL, DIMENSION_VALUE {, DIMENSION_Value}) |
| -- |
| -- SYMBOL ::= STRING_LITERAL | CHARACTER_LITERAL |
| |
| -- DIMENSION_VALUE ::= |
| -- RATIONAL |
| -- | others => RATIONAL |
| -- | DISCRETE_CHOICE_LIST => RATIONAL |
| |
| -- RATIONAL ::= [-] NUMERIC_LITERAL [/ NUMERIC_LITERAL] |
| |
| -- Note that when the dimensioned type is an integer type, then any |
| -- dimension value must be an integer literal. |
| |
| procedure Analyze_Aspect_Dimension |
| (N : Node_Id; |
| Id : Entity_Id; |
| Aggr : Node_Id) |
| is |
| Def_Id : constant Entity_Id := Defining_Identifier (N); |
| |
| Processed : array (Dimension_Type'Range) of Boolean := (others => False); |
| -- This array is used when processing ranges or Others_Choice as part of |
| -- the dimension aggregate. |
| |
| Dimensions : Dimension_Type := Null_Dimension; |
| |
| procedure Extract_Power |
| (Expr : Node_Id; |
| Position : Dimension_Position); |
| -- Given an expression with denotes a rational number, read the number |
| -- and associate it with Position in Dimensions. |
| |
| function Position_In_System |
| (Id : Node_Id; |
| System : System_Type) return Dimension_Position; |
| -- Given an identifier which denotes a dimension, return the position of |
| -- that dimension within System. |
| |
| ------------------- |
| -- Extract_Power -- |
| ------------------- |
| |
| procedure Extract_Power |
| (Expr : Node_Id; |
| Position : Dimension_Position) |
| is |
| begin |
| Dimensions (Position) := Create_Rational_From (Expr, True); |
| Processed (Position) := True; |
| |
| -- If the dimensioned root type is an integer type, it is not |
| -- particularly useful, and fractional dimensions do not make |
| -- much sense for such types, so previously we used to reject |
| -- dimensions of integer types that were not integer literals. |
| -- However, the manipulation of dimensions does not depend on |
| -- the kind of root type, so we can accept this usage for rare |
| -- cases where dimensions are specified for integer values. |
| |
| end Extract_Power; |
| |
| ------------------------ |
| -- Position_In_System -- |
| ------------------------ |
| |
| function Position_In_System |
| (Id : Node_Id; |
| System : System_Type) return Dimension_Position |
| is |
| Dimension_Name : constant Name_Id := Chars (Id); |
| |
| begin |
| for Position in System.Unit_Names'Range loop |
| if Dimension_Name = System.Unit_Names (Position) then |
| return Position; |
| end if; |
| end loop; |
| |
| return Invalid_Position; |
| end Position_In_System; |
| |
| -- Local variables |
| |
| Assoc : Node_Id; |
| Choice : Node_Id; |
| Expr : Node_Id; |
| Num_Choices : Nat := 0; |
| Num_Dimensions : Nat := 0; |
| Others_Seen : Boolean := False; |
| Position : Nat := 0; |
| Sub_Ind : Node_Id; |
| Symbol : String_Id := No_String; |
| Symbol_Expr : Node_Id; |
| System : System_Type; |
| Typ : Entity_Id; |
| |
| Errors_Count : Nat; |
| -- Errors_Count is a count of errors detected by the compiler so far |
| -- just before the extraction of symbol, names and values in the |
| -- aggregate (Step 2). |
| -- |
| -- At the end of the analysis, there is a check to verify that this |
| -- count equals to Serious_Errors_Detected i.e. no erros have been |
| -- encountered during the process. Otherwise the Dimension_Table is |
| -- not filled. |
| |
| -- Start of processing for Analyze_Aspect_Dimension |
| |
| begin |
| -- STEP 1: Legality of aspect |
| |
| if Nkind (N) /= N_Subtype_Declaration then |
| Error_Msg_NE ("aspect& must apply to subtype declaration", N, Id); |
| return; |
| end if; |
| |
| Sub_Ind := Subtype_Indication (N); |
| Typ := Etype (Sub_Ind); |
| System := System_Of (Typ); |
| |
| if Nkind (Sub_Ind) = N_Subtype_Indication then |
| Error_Msg_NE |
| ("constraint not allowed with aspect&", Constraint (Sub_Ind), Id); |
| return; |
| end if; |
| |
| -- The dimension declarations are useless if the parent type does not |
| -- declare a valid system. |
| |
| if not Exists (System) then |
| Error_Msg_NE |
| ("parent type of& lacks dimension system", Sub_Ind, Def_Id); |
| return; |
| end if; |
| |
| if Nkind (Aggr) /= N_Aggregate then |
| Error_Msg_N ("aggregate expected", Aggr); |
| return; |
| end if; |
| |
| -- STEP 2: Symbol, Names and values extraction |
| |
| -- Get the number of errors detected by the compiler so far |
| |
| Errors_Count := Serious_Errors_Detected; |
| |
| -- STEP 2a: Symbol extraction |
| |
| -- The first entry in the aggregate may be the symbolic representation |
| -- of the quantity. |
| |
| -- Positional symbol argument |
| |
| Symbol_Expr := First (Expressions (Aggr)); |
| |
| -- Named symbol argument |
| |
| if No (Symbol_Expr) |
| or else Nkind (Symbol_Expr) not in |
| N_Character_Literal | N_String_Literal |
| then |
| Symbol_Expr := Empty; |
| |
| -- Component associations present |
| |
| if Present (Component_Associations (Aggr)) then |
| Assoc := First (Component_Associations (Aggr)); |
| Choice := First (Choices (Assoc)); |
| |
| if No (Next (Choice)) and then Nkind (Choice) = N_Identifier then |
| |
| -- Symbol component association is present |
| |
| if Chars (Choice) = Name_Symbol then |
| Num_Choices := Num_Choices + 1; |
| Symbol_Expr := Expression (Assoc); |
| |
| -- Verify symbol expression is a string or a character |
| |
| if Nkind (Symbol_Expr) not in |
| N_Character_Literal | N_String_Literal |
| then |
| Symbol_Expr := Empty; |
| Error_Msg_N |
| ("symbol expression must be character or string", |
| Symbol_Expr); |
| end if; |
| |
| -- Special error if no Symbol choice but expression is string |
| -- or character. |
| |
| elsif Nkind (Expression (Assoc)) in |
| N_Character_Literal | N_String_Literal |
| then |
| Num_Choices := Num_Choices + 1; |
| Error_Msg_N |
| ("optional component Symbol expected, found&", Choice); |
| end if; |
| end if; |
| end if; |
| end if; |
| |
| -- STEP 2b: Names and values extraction |
| |
| -- Positional elements |
| |
| Expr := First (Expressions (Aggr)); |
| |
| -- Skip the symbol expression when present |
| |
| if Present (Symbol_Expr) and then Num_Choices = 0 then |
| Next (Expr); |
| end if; |
| |
| Position := Low_Position_Bound; |
| while Present (Expr) loop |
| if Position > High_Position_Bound then |
| Error_Msg_N |
| ("type& has more dimensions than system allows", Def_Id); |
| exit; |
| end if; |
| |
| Extract_Power (Expr, Position); |
| |
| Position := Position + 1; |
| Num_Dimensions := Num_Dimensions + 1; |
| |
| Next (Expr); |
| end loop; |
| |
| -- Named elements |
| |
| Assoc := First (Component_Associations (Aggr)); |
| |
| -- Skip the symbol association when present |
| |
| if Num_Choices = 1 then |
| Next (Assoc); |
| end if; |
| |
| while Present (Assoc) loop |
| Expr := Expression (Assoc); |
| |
| Choice := First (Choices (Assoc)); |
| while Present (Choice) loop |
| |
| -- Identifier case: NAME => EXPRESSION |
| |
| if Nkind (Choice) = N_Identifier then |
| Position := Position_In_System (Choice, System); |
| |
| if Is_Invalid (Position) then |
| Error_Msg_N ("dimension name& not part of system", Choice); |
| else |
| Extract_Power (Expr, Position); |
| end if; |
| |
| -- Range case: NAME .. NAME => EXPRESSION |
| |
| elsif Nkind (Choice) = N_Range then |
| declare |
| Low : constant Node_Id := Low_Bound (Choice); |
| High : constant Node_Id := High_Bound (Choice); |
| Low_Pos : Dimension_Position; |
| High_Pos : Dimension_Position; |
| |
| begin |
| if Nkind (Low) /= N_Identifier then |
| Error_Msg_N ("bound must denote a dimension name", Low); |
| |
| elsif Nkind (High) /= N_Identifier then |
| Error_Msg_N ("bound must denote a dimension name", High); |
| |
| else |
| Low_Pos := Position_In_System (Low, System); |
| High_Pos := Position_In_System (High, System); |
| |
| if Is_Invalid (Low_Pos) then |
| Error_Msg_N ("dimension name& not part of system", |
| Low); |
| |
| elsif Is_Invalid (High_Pos) then |
| Error_Msg_N ("dimension name& not part of system", |
| High); |
| |
| elsif Low_Pos > High_Pos then |
| Error_Msg_N ("expected low to high range", Choice); |
| |
| else |
| for Position in Low_Pos .. High_Pos loop |
| Extract_Power (Expr, Position); |
| end loop; |
| end if; |
| end if; |
| end; |
| |
| -- Others case: OTHERS => EXPRESSION |
| |
| elsif Nkind (Choice) = N_Others_Choice then |
| if Present (Next (Choice)) or else Present (Prev (Choice)) then |
| Error_Msg_N |
| ("OTHERS must appear alone in a choice list", Choice); |
| |
| elsif Present (Next (Assoc)) then |
| Error_Msg_N |
| ("OTHERS must appear last in an aggregate", Choice); |
| |
| elsif Others_Seen then |
| Error_Msg_N ("multiple OTHERS not allowed", Choice); |
| |
| else |
| -- Fill the non-processed dimensions with the default value |
| -- supplied by others. |
| |
| for Position in Processed'Range loop |
| if not Processed (Position) then |
| Extract_Power (Expr, Position); |
| end if; |
| end loop; |
| end if; |
| |
| Others_Seen := True; |
| |
| -- All other cases are illegal declarations of dimension names |
| |
| else |
| Error_Msg_NE ("wrong syntax for aspect&", Choice, Id); |
| end if; |
| |
| Num_Choices := Num_Choices + 1; |
| Next (Choice); |
| end loop; |
| |
| Num_Dimensions := Num_Dimensions + 1; |
| Next (Assoc); |
| end loop; |
| |
| -- STEP 3: Consistency of system and dimensions |
| |
| if Present (First (Expressions (Aggr))) |
| and then (First (Expressions (Aggr)) /= Symbol_Expr |
| or else Present (Next (Symbol_Expr))) |
| and then (Num_Choices > 1 |
| or else (Num_Choices = 1 and then not Others_Seen)) |
| then |
| Error_Msg_N |
| ("named associations cannot follow positional associations", Aggr); |
| end if; |
| |
| if Num_Dimensions > System.Count then |
| Error_Msg_N ("type& has more dimensions than system allows", Def_Id); |
| |
| elsif Num_Dimensions < System.Count and then not Others_Seen then |
| Error_Msg_N ("type& has less dimensions than system allows", Def_Id); |
| end if; |
| |
| -- STEP 4: Dimension symbol extraction |
| |
| if Present (Symbol_Expr) then |
| if Nkind (Symbol_Expr) = N_Character_Literal then |
| Start_String; |
| Store_String_Char (UI_To_CC (Char_Literal_Value (Symbol_Expr))); |
| Symbol := End_String; |
| |
| else |
| Symbol := Strval (Symbol_Expr); |
| end if; |
| |
| if String_Length (Symbol) = 0 then |
| Error_Msg_N ("empty string not allowed here", Symbol_Expr); |
| end if; |
| end if; |
| |
| -- STEP 5: Storage of extracted values |
| |
| -- Check that no errors have been detected during the analysis |
| |
| if Errors_Count = Serious_Errors_Detected then |
| |
| -- Check for useless declaration |
| |
| if Symbol = No_String and then not Exists (Dimensions) then |
| Error_Msg_N ("useless dimension declaration", Aggr); |
| end if; |
| |
| if Symbol /= No_String then |
| Set_Symbol (Def_Id, Symbol); |
| end if; |
| |
| if Exists (Dimensions) then |
| Set_Dimensions (Def_Id, Dimensions); |
| end if; |
| end if; |
| end Analyze_Aspect_Dimension; |
| |
| ------------------------------------- |
| -- Analyze_Aspect_Dimension_System -- |
| ------------------------------------- |
| |
| -- with Dimension_System => (DIMENSION {, DIMENSION}); |
| |
| -- DIMENSION ::= ( |
| -- [Unit_Name =>] IDENTIFIER, |
| -- [Unit_Symbol =>] SYMBOL, |
| -- [Dim_Symbol =>] SYMBOL) |
| |
| procedure Analyze_Aspect_Dimension_System |
| (N : Node_Id; |
| Id : Entity_Id; |
| Aggr : Node_Id) |
| is |
| function Is_Derived_Numeric_Type (N : Node_Id) return Boolean; |
| -- Determine whether type declaration N denotes a numeric derived type |
| |
| ------------------------------- |
| -- Is_Derived_Numeric_Type -- |
| ------------------------------- |
| |
| function Is_Derived_Numeric_Type (N : Node_Id) return Boolean is |
| begin |
| return |
| Nkind (N) = N_Full_Type_Declaration |
| and then Nkind (Type_Definition (N)) = N_Derived_Type_Definition |
| and then Is_Numeric_Type |
| (Entity (Subtype_Indication (Type_Definition (N)))); |
| end Is_Derived_Numeric_Type; |
| |
| -- Local variables |
| |
| Assoc : Node_Id; |
| Choice : Node_Id; |
| Dim_Aggr : Node_Id; |
| Dim_Symbol : Node_Id; |
| Dim_Symbols : Symbol_Array := No_Symbols; |
| Dim_System : System_Type := Null_System; |
| Position : Dimension_Position := Invalid_Position; |
| Unit_Name : Node_Id; |
| Unit_Names : Name_Array := No_Names; |
| Unit_Symbol : Node_Id; |
| Unit_Symbols : Symbol_Array := No_Symbols; |
| |
| Errors_Count : Nat; |
| -- Errors_Count is a count of errors detected by the compiler so far |
| -- just before the extraction of names and symbols in the aggregate |
| -- (Step 3). |
| -- |
| -- At the end of the analysis, there is a check to verify that this |
| -- count equals Serious_Errors_Detected i.e. no errors have been |
| -- encountered during the process. Otherwise the System_Table is |
| -- not filled. |
| |
| -- Start of processing for Analyze_Aspect_Dimension_System |
| |
| begin |
| -- STEP 1: Legality of aspect |
| |
| if not Is_Derived_Numeric_Type (N) then |
| Error_Msg_NE |
| ("aspect& must apply to numeric derived type declaration", N, Id); |
| return; |
| end if; |
| |
| if Nkind (Aggr) /= N_Aggregate then |
| Error_Msg_N ("aggregate expected", Aggr); |
| return; |
| end if; |
| |
| -- STEP 2: Structural verification of the dimension aggregate |
| |
| if Present (Component_Associations (Aggr)) then |
| Error_Msg_N ("expected positional aggregate", Aggr); |
| return; |
| end if; |
| |
| -- STEP 3: Name and Symbol extraction |
| |
| Dim_Aggr := First (Expressions (Aggr)); |
| Errors_Count := Serious_Errors_Detected; |
| while Present (Dim_Aggr) loop |
| if Position = High_Position_Bound then |
| Error_Msg_N ("too many dimensions in system", Aggr); |
| exit; |
| end if; |
| |
| Position := Position + 1; |
| |
| if Nkind (Dim_Aggr) /= N_Aggregate then |
| Error_Msg_N ("aggregate expected", Dim_Aggr); |
| |
| else |
| if Present (Component_Associations (Dim_Aggr)) |
| and then Present (Expressions (Dim_Aggr)) |
| then |
| Error_Msg_N |
| ("mixed positional/named aggregate not allowed here", |
| Dim_Aggr); |
| |
| -- Verify each dimension aggregate has three arguments |
| |
| elsif List_Length (Component_Associations (Dim_Aggr)) /= 3 |
| and then List_Length (Expressions (Dim_Aggr)) /= 3 |
| then |
| Error_Msg_N |
| ("three components expected in aggregate", Dim_Aggr); |
| |
| else |
| -- Named dimension aggregate |
| |
| if Present (Component_Associations (Dim_Aggr)) then |
| |
| -- Check first argument denotes the unit name |
| |
| Assoc := First (Component_Associations (Dim_Aggr)); |
| Choice := First (Choices (Assoc)); |
| Unit_Name := Expression (Assoc); |
| |
| if Present (Next (Choice)) |
| or else Nkind (Choice) /= N_Identifier |
| then |
| Error_Msg_NE ("wrong syntax for aspect&", Choice, Id); |
| |
| elsif Chars (Choice) /= Name_Unit_Name then |
| Error_Msg_N ("expected Unit_Name, found&", Choice); |
| end if; |
| |
| -- Check the second argument denotes the unit symbol |
| |
| Next (Assoc); |
| Choice := First (Choices (Assoc)); |
| Unit_Symbol := Expression (Assoc); |
| |
| if Present (Next (Choice)) |
| or else Nkind (Choice) /= N_Identifier |
| then |
| Error_Msg_NE ("wrong syntax for aspect&", Choice, Id); |
| |
| elsif Chars (Choice) /= Name_Unit_Symbol then |
| Error_Msg_N ("expected Unit_Symbol, found&", Choice); |
| end if; |
| |
| -- Check the third argument denotes the dimension symbol |
| |
| Next (Assoc); |
| Choice := First (Choices (Assoc)); |
| Dim_Symbol := Expression (Assoc); |
| |
| if Present (Next (Choice)) |
| or else Nkind (Choice) /= N_Identifier |
| then |
| Error_Msg_NE ("wrong syntax for aspect&", Choice, Id); |
| elsif Chars (Choice) /= Name_Dim_Symbol then |
| Error_Msg_N ("expected Dim_Symbol, found&", Choice); |
| end if; |
| |
| -- Positional dimension aggregate |
| |
| else |
| Unit_Name := First (Expressions (Dim_Aggr)); |
| Unit_Symbol := Next (Unit_Name); |
| Dim_Symbol := Next (Unit_Symbol); |
| end if; |
| |
| -- Check the first argument for each dimension aggregate is |
| -- a name. |
| |
| if Nkind (Unit_Name) = N_Identifier then |
| Unit_Names (Position) := Chars (Unit_Name); |
| else |
| Error_Msg_N ("expected unit name", Unit_Name); |
| end if; |
| |
| -- Check the second argument for each dimension aggregate is |
| -- a string or a character. |
| |
| if Nkind (Unit_Symbol) not in |
| N_String_Literal | N_Character_Literal |
| then |
| Error_Msg_N |
| ("expected unit symbol (string or character)", |
| Unit_Symbol); |
| |
| else |
| -- String case |
| |
| if Nkind (Unit_Symbol) = N_String_Literal then |
| Unit_Symbols (Position) := Strval (Unit_Symbol); |
| |
| -- Character case |
| |
| else |
| Start_String; |
| Store_String_Char |
| (UI_To_CC (Char_Literal_Value (Unit_Symbol))); |
| Unit_Symbols (Position) := End_String; |
| end if; |
| |
| -- Verify that the string is not empty |
| |
| if String_Length (Unit_Symbols (Position)) = 0 then |
| Error_Msg_N |
| ("empty string not allowed here", Unit_Symbol); |
| end if; |
| end if; |
| |
| -- Check the third argument for each dimension aggregate is |
| -- a string or a character. |
| |
| if Nkind (Dim_Symbol) not in |
| N_String_Literal | N_Character_Literal |
| then |
| Error_Msg_N |
| ("expected dimension symbol (string or character)", |
| Dim_Symbol); |
| |
| else |
| -- String case |
| |
| if Nkind (Dim_Symbol) = N_String_Literal then |
| Dim_Symbols (Position) := Strval (Dim_Symbol); |
| |
| -- Character case |
| |
| else |
| Start_String; |
| Store_String_Char |
| (UI_To_CC (Char_Literal_Value (Dim_Symbol))); |
| Dim_Symbols (Position) := End_String; |
| end if; |
| |
| -- Verify that the string is not empty |
| |
| if String_Length (Dim_Symbols (Position)) = 0 then |
| Error_Msg_N ("empty string not allowed here", Dim_Symbol); |
| end if; |
| end if; |
| end if; |
| end if; |
| |
| Next (Dim_Aggr); |
| end loop; |
| |
| -- STEP 4: Storage of extracted values |
| |
| -- Check that no errors have been detected during the analysis |
| |
| if Errors_Count = Serious_Errors_Detected then |
| Dim_System.Type_Decl := N; |
| Dim_System.Unit_Names := Unit_Names; |
| Dim_System.Unit_Symbols := Unit_Symbols; |
| Dim_System.Dim_Symbols := Dim_Symbols; |
| Dim_System.Count := Position; |
| System_Table.Append (Dim_System); |
| end if; |
| 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. Note that there is no need to check |
| -- dimensions for nodes that don't come from source, except for subtype |
| -- declarations where the dimensions are inherited from the base type, |
| -- for explicit dereferences generated when expanding iterators, and |
| -- for object declarations generated for inlining. |
| |
| if Ada_Version < Ada_2012 then |
| return; |
| |
| -- Inlined bodies have already been checked for dimensionality |
| |
| elsif In_Inlined_Body then |
| return; |
| |
| elsif not Comes_From_Source (N) then |
| if Nkind (N) not in N_Explicit_Dereference |
| | N_Identifier |
| | N_Object_Declaration |
| | N_Subtype_Declaration |
| then |
| return; |
| end if; |
| end if; |
| |
| case Nkind (N) is |
| when N_Assignment_Statement => |
| Analyze_Dimension_Assignment_Statement (N); |
| |
| when N_Binary_Op => |
| Analyze_Dimension_Binary_Op (N); |
| |
| when N_Case_Expression => |
| Analyze_Dimension_Case_Expression (N); |
| |
| when N_Component_Declaration => |
| Analyze_Dimension_Component_Declaration (N); |
| |
| when N_Extended_Return_Statement => |
| Analyze_Dimension_Extended_Return_Statement (N); |
| |
| when N_Attribute_Reference |
| | N_Expanded_Name |
| | N_Explicit_Dereference |
| | N_Function_Call |
| | N_Indexed_Component |
| | N_Qualified_Expression |
| | N_Selected_Component |
| | N_Slice |
| | N_Unchecked_Type_Conversion |
| => |
| Analyze_Dimension_Has_Etype (N); |
| |
| -- In the presence of a repaired syntax error, an identifier may be |
| -- introduced without a usable type. |
| |
| when N_Identifier => |
| if Present (Etype (N)) then |
| Analyze_Dimension_Has_Etype (N); |
| end if; |
| |
| when N_If_Expression => |
| Analyze_Dimension_If_Expression (N); |
| |
| when N_Number_Declaration => |
| Analyze_Dimension_Number_Declaration (N); |
| |
| when N_Object_Declaration => |
| Analyze_Dimension_Object_Declaration (N); |
| |
| when N_Object_Renaming_Declaration => |
| Analyze_Dimension_Object_Renaming_Declaration (N); |
| |
| when N_Simple_Return_Statement => |
| if not Comes_From_Extended_Return_Statement (N) then |
| Analyze_Dimension_Simple_Return_Statement (N); |
| end if; |
| |
| when N_Subtype_Declaration => |
| Analyze_Dimension_Subtype_Declaration (N); |
| |
| when N_Type_Conversion => |
| Analyze_Dimension_Type_Conversion (N); |
| |
| when N_Unary_Op => |
| Analyze_Dimension_Unary_Op (N); |
| |
| when others => |
| null; |
| end case; |
| end Analyze_Dimension; |
| |
| --------------------------------------- |
| -- Analyze_Dimension_Array_Aggregate -- |
| --------------------------------------- |
| |
| procedure Analyze_Dimension_Array_Aggregate |
| (N : Node_Id; |
| Comp_Typ : Entity_Id) |
| is |
| Comp_Ass : constant List_Id := Component_Associations (N); |
| Dims_Of_Comp_Typ : constant Dimension_Type := Dimensions_Of (Comp_Typ); |
| Exps : constant List_Id := Expressions (N); |
| |
| Comp : Node_Id; |
| Dims_Of_Expr : Dimension_Type; |
| Expr : Node_Id; |
| |
| Error_Detected : Boolean := False; |
| -- This flag is used in order to indicate if an error has been detected |
| -- so far by the compiler in this routine. |
| |
| begin |
| -- Aspect is an Ada 2012 feature. Nothing to do here if the component |
| -- base type is not a dimensioned type. |
| |
| -- Inlined bodies have already been checked for dimensionality. |
| |
| -- Note that here the original node must come from source since the |
| -- original array aggregate may not have been entirely decorated. |
| |
| if Ada_Version < Ada_2012 |
| or else In_Inlined_Body |
| or else not Comes_From_Source (Original_Node (N)) |
| or else not Has_Dimension_System (Base_Type (Comp_Typ)) |
| then |
| return; |
| end if; |
| |
| -- Check whether there is any positional component association |
| |
| if Is_Empty_List (Exps) then |
| Comp := First (Comp_Ass); |
| else |
| Comp := First (Exps); |
| end if; |
| |
| while Present (Comp) loop |
| |
| -- Get the expression from the component |
| |
| if Nkind (Comp) = N_Component_Association then |
| Expr := Expression (Comp); |
| else |
| Expr := Comp; |
| end if; |
| |
| -- Issue an error if the dimensions of the component type and the |
| -- dimensions of the component mismatch. |
| |
| -- Note that we must ensure the expression has been fully analyzed |
| -- since it may not be decorated at this point. We also don't want to |
| -- issue the same error message multiple times on the same expression |
| -- (may happen when an aggregate is converted into a positional |
| -- aggregate). We also must verify that this is a scalar component, |
| -- and not a subaggregate of a multidimensional aggregate. |
| -- The expression may be an identifier that has been copied several |
| -- times during expansion, its dimensions are those of its type. |
| |
| if Is_Entity_Name (Expr) then |
| Dims_Of_Expr := Dimensions_Of (Etype (Expr)); |
| else |
| Dims_Of_Expr := Dimensions_Of (Expr); |
| end if; |
| |
| if Comes_From_Source (Original_Node (Expr)) |
| and then Present (Etype (Expr)) |
| and then Is_Numeric_Type (Etype (Expr)) |
| and then Dims_Of_Expr /= Dims_Of_Comp_Typ |
| and then Sloc (Comp) /= Sloc (Prev (Comp)) |
| then |
| -- Check if an error has already been encountered so far |
| |
| if not Error_Detected then |
| Error_Msg_N ("dimensions mismatch in array aggregate", N); |
| Error_Detected := True; |
| end if; |
| |
| Error_Msg_N |
| ("\expected dimension " & Dimensions_Msg_Of (Comp_Typ) |
| & ", found " & Dimensions_Msg_Of (Expr), Expr); |
| end if; |
| |
| -- Look at the named components right after the positional components |
| |
| if not Present (Next (Comp)) |
| and then List_Containing (Comp) = Exps |
| then |
| Comp := First (Comp_Ass); |
| else |
| Next (Comp); |
| end if; |
| end loop; |
| end Analyze_Dimension_Array_Aggregate; |
| |
| -------------------------------------------- |
| -- Analyze_Dimension_Assignment_Statement -- |
| -------------------------------------------- |
| |
| procedure Analyze_Dimension_Assignment_Statement (N : Node_Id) is |
| Lhs : constant Node_Id := Name (N); |
| Dims_Of_Lhs : constant Dimension_Type := Dimensions_Of (Lhs); |
| Rhs : constant Node_Id := Expression (N); |
| Dims_Of_Rhs : constant Dimension_Type := Dimensions_Of (Rhs); |
| |
| procedure Error_Dim_Msg_For_Assignment_Statement |
| (N : Node_Id; |
| Lhs : Node_Id; |
| Rhs : Node_Id); |
| -- Error using Error_Msg_N at node N. Output the dimensions of left |
| -- and right hand sides. |
| |
| -------------------------------------------- |
| -- Error_Dim_Msg_For_Assignment_Statement -- |
| -------------------------------------------- |
| |
| procedure Error_Dim_Msg_For_Assignment_Statement |
| (N : Node_Id; |
| Lhs : Node_Id; |
| Rhs : Node_Id) |
| is |
| begin |
| Error_Msg_N ("dimensions mismatch in assignment", N); |
| Error_Msg_N ("\left-hand side " & Dimensions_Msg_Of (Lhs, True), N); |
| Error_Msg_N ("\right-hand side " & Dimensions_Msg_Of (Rhs, True), N); |
| end Error_Dim_Msg_For_Assignment_Statement; |
| |
| -- Start of processing for Analyze_Dimension_Assignment |
| |
| begin |
| if Dims_Of_Lhs /= Dims_Of_Rhs then |
| Error_Dim_Msg_For_Assignment_Statement (N, Lhs, Rhs); |
| end if; |
| end Analyze_Dimension_Assignment_Statement; |
| |
| --------------------------------- |
| -- Analyze_Dimension_Binary_Op -- |
| --------------------------------- |
| |
| -- Check and propagate the dimensions for binary operators |
| -- Note that when the dimensions mismatch, no dimension is propagated to N. |
| |
| procedure Analyze_Dimension_Binary_Op (N : Node_Id) is |
| N_Kind : constant Node_Kind := Nkind (N); |
| |
| function Dimensions_Of_Operand (N : Node_Id) return Dimension_Type; |
| -- If the operand is a numeric literal that comes from a declared |
| -- constant, use the dimensions of the constant which were computed |
| -- from the expression of the constant declaration. Otherwise the |
| -- dimensions are those of the operand, or the type of the operand. |
| -- This takes care of node rewritings from validity checks, where the |
| -- dimensions of the operand itself may not be preserved, while the |
| -- type comes from context and must have dimension information. |
| |
| procedure Error_Dim_Msg_For_Binary_Op (N, L, R : Node_Id); |
| -- Error using Error_Msg_NE and Error_Msg_N at node N. Output the |
| -- dimensions of both operands. |
| |
| --------------------------- |
| -- Dimensions_Of_Operand -- |
| --------------------------- |
| |
| function Dimensions_Of_Operand (N : Node_Id) return Dimension_Type is |
| Dims : constant Dimension_Type := Dimensions_Of (N); |
| |
| begin |
| if Exists (Dims) then |
| return Dims; |
| |
| elsif Is_Entity_Name (N) then |
| return Dimensions_Of (Etype (Entity (N))); |
| |
| elsif Nkind (N) = N_Real_Literal then |
| |
| if Present (Original_Entity (N)) then |
| return Dimensions_Of (Original_Entity (N)); |
| |
| else |
| return Dimensions_Of (Etype (N)); |
| end if; |
| |
| -- Otherwise return the default dimensions |
| |
| else |
| return Dims; |
| end if; |
| end Dimensions_Of_Operand; |
| |
| --------------------------------- |
| -- Error_Dim_Msg_For_Binary_Op -- |
| --------------------------------- |
| |
| procedure Error_Dim_Msg_For_Binary_Op (N, L, R : Node_Id) is |
| begin |
| Error_Msg_NE |
| ("both operands for operation& must have same dimensions", |
| N, Entity (N)); |
| Error_Msg_N ("\left operand " & Dimensions_Msg_Of (L, True), N); |
| Error_Msg_N ("\right operand " & Dimensions_Msg_Of (R, True), N); |
| end Error_Dim_Msg_For_Binary_Op; |
| |
| -- Start of processing for Analyze_Dimension_Binary_Op |
| |
| begin |
| -- If the node is already analyzed, do not examine the operands. At the |
| -- end of the analysis their dimensions have been removed, and the node |
| -- itself may have been rewritten. |
| |
| if Analyzed (N) then |
| return; |
| end if; |
| |
| if N_Kind in N_Op_Add | N_Op_Expon | N_Op_Subtract |
| | N_Multiplying_Operator | N_Op_Compare |
| then |
| declare |
| L : constant Node_Id := Left_Opnd (N); |
| Dims_Of_L : constant Dimension_Type := |
| Dimensions_Of_Operand (L); |
| L_Has_Dimensions : constant Boolean := Exists (Dims_Of_L); |
| R : constant Node_Id := Right_Opnd (N); |
| Dims_Of_R : constant Dimension_Type := |
| Dimensions_Of_Operand (R); |
| R_Has_Dimensions : constant Boolean := Exists (Dims_Of_R); |
| Dims_Of_N : Dimension_Type := Null_Dimension; |
| |
| begin |
| -- N_Op_Add, N_Op_Mod, N_Op_Rem or N_Op_Subtract case |
| |
| if N_Kind in N_Op_Add | N_Op_Mod | N_Op_Rem | N_Op_Subtract then |
| |
| -- Check both operands have same dimension |
| |
| if Dims_Of_L /= Dims_Of_R then |
| Error_Dim_Msg_For_Binary_Op (N, L, R); |
| else |
| -- Check both operands are not dimensionless |
| |
| if Exists (Dims_Of_L) then |
| Set_Dimensions (N, Dims_Of_L); |
| end if; |
| end if; |
| |
| -- N_Op_Multiply or N_Op_Divide case |
| |
| elsif N_Kind in N_Op_Multiply | N_Op_Divide then |
| |
| -- Check at least one operand is not dimensionless |
| |
| if L_Has_Dimensions or R_Has_Dimensions then |
| |
| -- Multiplication case |
| |
| -- Get both operands dimensions and add them |
| |
| if N_Kind = N_Op_Multiply then |
| for Position in Dimension_Type'Range loop |
| Dims_Of_N (Position) := |
| Dims_Of_L (Position) + Dims_Of_R (Position); |
| end loop; |
| |
| -- Division case |
| |
| -- Get both operands dimensions and subtract them |
| |
| else |
| for Position in Dimension_Type'Range loop |
| Dims_Of_N (Position) := |
| Dims_Of_L (Position) - Dims_Of_R (Position); |
| end loop; |
| end if; |
| |
| if Exists (Dims_Of_N) then |
| Set_Dimensions (N, Dims_Of_N); |
| end if; |
| end if; |
| |
| -- Exponentiation case |
| |
| -- Note: a rational exponent is allowed for dimensioned operand |
| |
| elsif N_Kind = N_Op_Expon then |
| |
| -- Check the left operand is not dimensionless. Note that the |
| -- value of the exponent must be known compile time. Otherwise, |
| -- the exponentiation evaluation will return an error message. |
| |
| if L_Has_Dimensions then |
| if not Compile_Time_Known_Value (R) then |
| Error_Msg_N |
| ("exponent of dimensioned operand must be " |
| & "known at compile time", N); |
| end if; |
| |
| declare |
| Exponent_Value : Rational := Zero; |
| |
| begin |
| -- Real operand case |
| |
| if Is_Real_Type (Etype (L)) then |
| |
| -- Define the exponent as a Rational number |
| |
| Exponent_Value := Create_Rational_From (R, False); |
| |
| -- Verify that the exponent cannot be interpreted |
| -- as a rational, otherwise interpret the exponent |
| -- as an integer. |
| |
| if Exponent_Value = No_Rational then |
| Exponent_Value := |
| +Whole (UI_To_Int (Expr_Value (R))); |
| end if; |
| |
| -- Integer operand case. |
| |
| -- For integer operand, the exponent cannot be |
| -- interpreted as a rational. |
| |
| else |
| Exponent_Value := +Whole (UI_To_Int (Expr_Value (R))); |
| end if; |
| |
| for Position in Dimension_Type'Range loop |
| Dims_Of_N (Position) := |
| Dims_Of_L (Position) * Exponent_Value; |
| end loop; |
| |
| if Exists (Dims_Of_N) then |
| Set_Dimensions (N, Dims_Of_N); |
| end if; |
| end; |
| end if; |
| |
| -- Comparison cases |
| |
| -- For relational operations, only dimension checking is |
| -- performed (no propagation). If one operand is the result |
| -- of constant folding the dimensions may have been lost |
| -- in a tree copy, so assume that preanalysis has verified |
| -- that dimensions are correct. |
| |
| elsif N_Kind in N_Op_Compare then |
| if (L_Has_Dimensions or R_Has_Dimensions) |
| and then Dims_Of_L /= Dims_Of_R |
| then |
| if Nkind (L) = N_Real_Literal |
| and then not (Comes_From_Source (L)) |
| and then Expander_Active |
| then |
| null; |
| |
| elsif Nkind (R) = N_Real_Literal |
| and then not (Comes_From_Source (R)) |
| and then Expander_Active |
| then |
| null; |
| |
| -- Numeric literal case. Issue a warning to indicate the |
| -- literal is treated as if its dimension matches the type |
| -- dimension. |
| |
| elsif Nkind (Original_Node (L)) in |
| N_Integer_Literal | N_Real_Literal |
| then |
| Dim_Warning_For_Numeric_Literal (L, Etype (R)); |
| |
| elsif Nkind (Original_Node (R)) in |
| N_Integer_Literal | N_Real_Literal |
| then |
| Dim_Warning_For_Numeric_Literal (R, Etype (L)); |
| |
| else |
| Error_Dim_Msg_For_Binary_Op (N, L, R); |
| end if; |
| end if; |
| end if; |
| |
| -- If expander is active, remove dimension information from each |
| -- operand, as only dimensions of result are relevant. |
| |
| if Expander_Active then |
| Remove_Dimensions (L); |
| Remove_Dimensions (R); |
| end if; |
| end; |
| end if; |
| end Analyze_Dimension_Binary_Op; |
| |
| ---------------------------- |
| -- Analyze_Dimension_Call -- |
| ---------------------------- |
| |
| procedure Analyze_Dimension_Call (N : Node_Id; Nam : Entity_Id) is |
| Actuals : constant List_Id := Parameter_Associations (N); |
| Actual : Node_Id; |
| Dims_Of_Formal : Dimension_Type; |
| Formal : Node_Id; |
| Formal_Typ : Entity_Id; |
| |
| Error_Detected : Boolean := False; |
| -- This flag is used in order to indicate if an error has been detected |
| -- so far by the compiler in this routine. |
| |
| begin |
| -- Aspect is an Ada 2012 feature. Note that there is no need to check |
| -- dimensions for calls in inlined bodies, or calls that don't come |
| -- from source, or those that may have semantic errors. |
| |
| if Ada_Version < Ada_2012 |
| or else In_Inlined_Body |
| or else not Comes_From_Source (N) |
| or else Error_Posted (N) |
| then |
| return; |
| end if; |
| |
| -- Check the dimensions of the actuals, if any |
| |
| if not Is_Empty_List (Actuals) then |
| |
| -- Special processing for elementary functions |
| |
| -- For Sqrt call, the resulting dimensions equal to half the |
| -- dimensions of the actual. For all other elementary calls, this |
| -- routine check that every actual is dimensionless. |
| |
| if Nkind (N) = N_Function_Call then |
| Elementary_Function_Calls : declare |
| Dims_Of_Call : Dimension_Type; |
| Ent : Entity_Id := Nam; |
| |
| function Is_Elementary_Function_Entity |
| (Sub_Id : Entity_Id) return Boolean; |
| -- Given Sub_Id, the original subprogram entity, return True |
| -- if call is to an elementary function (see Ada.Numerics. |
| -- Generic_Elementary_Functions). |
| |
| ----------------------------------- |
| -- Is_Elementary_Function_Entity -- |
| ----------------------------------- |
| |
| function Is_Elementary_Function_Entity |
| (Sub_Id : Entity_Id) return Boolean |
| is |
| Loc : constant Source_Ptr := Sloc (Sub_Id); |
| |
| begin |
| -- Is entity in Ada.Numerics.Generic_Elementary_Functions? |
| |
| return |
| Loc > No_Location |
| and then |
| Is_RTU |
| (Cunit_Entity (Get_Source_Unit (Loc)), |
| Ada_Numerics_Generic_Elementary_Functions); |
| end Is_Elementary_Function_Entity; |
| |
| -- Start of processing for Elementary_Function_Calls |
| |
| begin |
| -- Get original subprogram entity following the renaming chain |
| |
| if Present (Alias (Ent)) then |
| Ent := Alias (Ent); |
| end if; |
| |
| -- Check the call is an Elementary function call |
| |
| if Is_Elementary_Function_Entity (Ent) then |
| |
| -- Sqrt function call case |
| |
| if Chars (Ent) = Name_Sqrt then |
| Dims_Of_Call := Dimensions_Of (First_Actual (N)); |
| |
| -- Evaluates the resulting dimensions (i.e. half the |
| -- dimensions of the actual). |
| |
| if Exists (Dims_Of_Call) then |
| for Position in Dims_Of_Call'Range loop |
| Dims_Of_Call (Position) := |
| Dims_Of_Call (Position) * |
| Rational'(Numerator => 1, Denominator => 2); |
| end loop; |
| |
| Set_Dimensions (N, Dims_Of_Call); |
| end if; |
| |
| -- All other elementary functions case. Note that every |
| -- actual here should be dimensionless. |
| |
| else |
| Actual := First_Actual (N); |
| while Present (Actual) loop |
| if Exists (Dimensions_Of (Actual)) then |
| |
| -- Check if error has already been encountered |
| |
| if not Error_Detected then |
| Error_Msg_NE |
| ("dimensions mismatch in call of&", |
| N, Name (N)); |
| Error_Detected := True; |
| end if; |
| |
| Error_Msg_N |
| ("\expected dimension '['], found " |
| & Dimensions_Msg_Of (Actual), Actual); |
| end if; |
| |
| Next_Actual (Actual); |
| end loop; |
| end if; |
| |
| -- Nothing more to do for elementary functions |
| |
| return; |
| end if; |
| end Elementary_Function_Calls; |
| end if; |
| |
| -- General case. Check, for each parameter, the dimensions of the |
| -- actual and its corresponding formal match. Otherwise, complain. |
| |
| Actual := First_Actual (N); |
| Formal := First_Formal (Nam); |
| while Present (Formal) loop |
| |
| -- A missing corresponding actual indicates that the analysis of |
| -- the call was aborted due to a previous error. |
| |
| if No (Actual) then |
| Check_Error_Detected; |
| return; |
| end if; |
| |
| Formal_Typ := Etype (Formal); |
| Dims_Of_Formal := Dimensions_Of (Formal_Typ); |
| |
| -- If the formal is not dimensionless, check dimensions of formal |
| -- and actual match. Otherwise, complain. |
| |
| if Exists (Dims_Of_Formal) |
| and then Dimensions_Of (Actual) /= Dims_Of_Formal |
| then |
| -- Check if an error has already been encountered so far |
| |
| if not Error_Detected then |
| Error_Msg_NE ("dimensions mismatch in& call", N, Name (N)); |
| Error_Detected := True; |
| end if; |
| |
| Error_Msg_N |
| ("\expected dimension " & Dimensions_Msg_Of (Formal_Typ) |
| & ", found " & Dimensions_Msg_Of (Actual), Actual); |
| end if; |
| |
| Next_Actual (Actual); |
| Next_Formal (Formal); |
| end loop; |
| end if; |
| |
| -- For function calls, propagate the dimensions from the returned type |
| |
| if Nkind (N) = N_Function_Call then |
| Analyze_Dimension_Has_Etype (N); |
| end if; |
| end Analyze_Dimension_Call; |
| |
| --------------------------------------- |
| -- Analyze_Dimension_Case_Expression -- |
| --------------------------------------- |
| |
| procedure Analyze_Dimension_Case_Expression (N : Node_Id) is |
| Frst : constant Node_Id := First (Alternatives (N)); |
| Frst_Expr : constant Node_Id := Expression (Frst); |
| Dims : constant Dimension_Type := Dimensions_Of (Frst_Expr); |
| |
| Alt : Node_Id; |
| |
| begin |
| Alt := Next (Frst); |
| while Present (Alt) loop |
| if Dimensions_Of (Expression (Alt)) /= Dims then |
| Error_Msg_N ("dimension mismatch in case expression", Alt); |
| exit; |
| end if; |
| |
| Next (Alt); |
| end loop; |
| |
| Copy_Dimensions (Frst_Expr, N); |
| end Analyze_Dimension_Case_Expression; |
| |
| --------------------------------------------- |
| -- 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); |
| Etyp : constant Entity_Id := Etype (Id); |
| Dims_Of_Etyp : constant Dimension_Type := Dimensions_Of (Etyp); |
| Dims_Of_Expr : Dimension_Type; |
| |
| procedure Error_Dim_Msg_For_Component_Declaration |
| (N : Node_Id; |
| Etyp : Entity_Id; |
| Expr : Node_Id); |
| -- Error using Error_Msg_N at node N. Output the dimensions of the |
| -- type Etyp and the expression Expr of N. |
| |
| --------------------------------------------- |
| -- Error_Dim_Msg_For_Component_Declaration -- |
| --------------------------------------------- |
| |
| procedure Error_Dim_Msg_For_Component_Declaration |
| (N : Node_Id; |
| Etyp : Entity_Id; |
| Expr : Node_Id) is |
| begin |
| Error_Msg_N ("dimensions mismatch in component declaration", N); |
| Error_Msg_N |
| ("\expected dimension " & Dimensions_Msg_Of (Etyp) & ", found " |
| & Dimensions_Msg_Of (Expr), Expr); |
| end Error_Dim_Msg_For_Component_Declaration; |
| |
| -- Start of processing for Analyze_Dimension_Component_Declaration |
| |
| begin |
| -- Expression is present |
| |
| if Present (Expr) then |
| Dims_Of_Expr := Dimensions_Of (Expr); |
| |
| -- Check dimensions match |
| |
| if Dims_Of_Etyp /= Dims_Of_Expr then |
| |
| -- Numeric literal case. Issue a warning if the object type is not |
| -- dimensionless to indicate the literal is treated as if its |
| -- dimension matches the type dimension. |
| |
| if Nkind (Original_Node (Expr)) in |
| N_Real_Literal | N_Integer_Literal |
| then |
| Dim_Warning_For_Numeric_Literal (Expr, Etyp); |
| |
| -- Issue a dimension mismatch error for all other cases |
| |
| else |
| Error_Dim_Msg_For_Component_Declaration (N, Etyp, Expr); |
| end if; |
| end if; |
| end if; |
| end Analyze_Dimension_Component_Declaration; |
| |
| ------------------------------------------------- |
| -- Analyze_Dimension_Extended_Return_Statement -- |
| ------------------------------------------------- |
| |
| procedure Analyze_Dimension_Extended_Return_Statement (N : Node_Id) is |
| Return_Ent : constant Entity_Id := Return_Statement_Entity (N); |
| Return_Etyp : constant Entity_Id := |
| Etype (Return_Applies_To (Return_Ent)); |
| Return_Obj_Decls : constant List_Id := Return_Object_Declarations (N); |
| Return_Obj_Decl : Node_Id; |
| Return_Obj_Id : Entity_Id; |
| Return_Obj_Typ : Entity_Id; |
| |
| procedure Error_Dim_Msg_For_Extended_Return_Statement |
| (N : Node_Id; |
| Return_Etyp : Entity_Id; |
| Return_Obj_Typ : Entity_Id); |
| -- Error using Error_Msg_N at node N. Output dimensions of the returned |
| -- type Return_Etyp and the returned object type Return_Obj_Typ of N. |
| |
| ------------------------------------------------- |
| -- Error_Dim_Msg_For_Extended_Return_Statement -- |
| ------------------------------------------------- |
| |
| procedure Error_Dim_Msg_For_Extended_Return_Statement |
| (N : Node_Id; |
| Return_Etyp : Entity_Id; |
| Return_Obj_Typ : Entity_Id) |
| is |
| begin |
| Error_Msg_N ("dimensions mismatch in extended return statement", N); |
| Error_Msg_N |
| ("\expected dimension " & Dimensions_Msg_Of (Return_Etyp) |
| & ", found " & Dimensions_Msg_Of (Return_Obj_Typ), N); |
| end Error_Dim_Msg_For_Extended_Return_Statement; |
| |
| -- Start of processing for Analyze_Dimension_Extended_Return_Statement |
| |
| begin |
| if Present (Return_Obj_Decls) then |
| Return_Obj_Decl := First (Return_Obj_Decls); |
| while Present (Return_Obj_Decl) loop |
| if Nkind (Return_Obj_Decl) = N_Object_Declaration then |
| Return_Obj_Id := Defining_Identifier (Return_Obj_Decl); |
| |
| if Is_Return_Object (Return_Obj_Id) then |
| Return_Obj_Typ := Etype (Return_Obj_Id); |
| |
| -- Issue an error message if dimensions mismatch |
| |
| if Dimensions_Of (Return_Etyp) /= |
| Dimensions_Of (Return_Obj_Typ) |
| then |
| Error_Dim_Msg_For_Extended_Return_Statement |
| (N, Return_Etyp, Return_Obj_Typ); |
| return; |
| end if; |
| end if; |
| end if; |
| |
| Next (Return_Obj_Decl); |
| end loop; |
| end if; |
| end Analyze_Dimension_Extended_Return_Statement; |
| |
| ----------------------------------------------------- |
| -- Analyze_Dimension_Extension_Or_Record_Aggregate -- |
| ----------------------------------------------------- |
| |
| procedure Analyze_Dimension_Extension_Or_Record_Aggregate (N : Node_Id) is |
| Comp : Node_Id; |
| Comp_Id : Entity_Id; |
| Comp_Typ : Entity_Id; |
| Expr : Node_Id; |
| |
| Error_Detected : Boolean := False; |
| -- This flag is used in order to indicate if an error has been detected |
| -- so far by the compiler in this routine. |
| |
| begin |
| -- Aspect is an Ada 2012 feature. Note that there is no need to check |
| -- dimensions in inlined bodies, or for aggregates that don't come |
| -- from source, or if we are within an initialization procedure, whose |
| -- expressions have been checked at the point of record declaration. |
| |
| if Ada_Version < Ada_2012 |
| or else In_Inlined_Body |
| or else not Comes_From_Source (N) |
| or else Inside_Init_Proc |
| then |
| return; |
| end if; |
| |
| Comp := First (Component_Associations (N)); |
| while Present (Comp) loop |
| Comp_Id := Entity (First (Choices (Comp))); |
| Comp_Typ := Etype (Comp_Id); |
| |
| -- Check the component type is either a dimensioned type or a |
| -- dimensioned subtype. |
| |
| if Has_Dimension_System (Base_Type (Comp_Typ)) then |
| Expr := Expression (Comp); |
| |
| -- A box-initialized component needs no checking. |
| |
| if No (Expr) and then Box_Present (Comp) then |
| null; |
| |
| -- Issue an error if the dimensions of the component type and the |
| -- dimensions of the component mismatch. |
| |
| elsif Dimensions_Of (Expr) /= Dimensions_Of (Comp_Typ) then |
| |
| -- Check if an error has already been encountered so far |
| |
| if not Error_Detected then |
| |
| -- Extension aggregate case |
| |
| if Nkind (N) = N_Extension_Aggregate then |
| Error_Msg_N |
| ("dimensions mismatch in extension aggregate", N); |
| |
| -- Record aggregate case |
| |
| else |
| Error_Msg_N |
| ("dimensions mismatch in record aggregate", N); |
| end if; |
| |
| Error_Detected := True; |
| end if; |
| |
| Error_Msg_N |
| ("\expected dimension " & Dimensions_Msg_Of (Comp_Typ) |
| & ", found " & Dimensions_Msg_Of (Expr), Comp); |
| end if; |
| end if; |
| |
| Next (Comp); |
| end loop; |
| end Analyze_Dimension_Extension_Or_Record_Aggregate; |
| |
| ------------------------------- |
| -- Analyze_Dimension_Formals -- |
| ------------------------------- |
| |
| procedure Analyze_Dimension_Formals (N : Node_Id; Formals : List_Id) is |
| Dims_Of_Typ : Dimension_Type; |
| Formal : Node_Id; |
| Typ : Entity_Id; |
| |
| begin |
| -- Aspect is an Ada 2012 feature. Note that there is no need to check |
| -- dimensions for sub specs that don't come from source. |
| |
| if Ada_Version < Ada_2012 or else not Comes_From_Source (N) then |
| return; |
| end if; |
| |
| Formal := First (Formals); |
| while Present (Formal) loop |
| Typ := Parameter_Type (Formal); |
| Dims_Of_Typ := Dimensions_Of (Typ); |
| |
| if Exists (Dims_Of_Typ) then |
| declare |
| Expr : constant Node_Id := Expression (Formal); |
| |
| begin |
| -- Issue a warning if Expr is a numeric literal and if its |
| -- dimensions differ with the dimensions of the formal type. |
| |
| if Present (Expr) |
| and then Dims_Of_Typ /= Dimensions_Of (Expr) |
| and then Nkind (Original_Node (Expr)) in |
| N_Real_Literal | N_Integer_Literal |
| then |
| Dim_Warning_For_Numeric_Literal (Expr, Etype (Typ)); |
| end if; |
| end; |
| end if; |
| |
| Next (Formal); |
| end loop; |
| end Analyze_Dimension_Formals; |
| |
| --------------------------------- |
| -- Analyze_Dimension_Has_Etype -- |
| --------------------------------- |
| |
| procedure Analyze_Dimension_Has_Etype (N : Node_Id) is |
| Etyp : constant Entity_Id := Etype (N); |
| Dims_Of_Etyp : Dimension_Type := Dimensions_Of (Etyp); |
| |
| begin |
| -- General case. Propagation of the dimensions from the type |
| |
| if Exists (Dims_Of_Etyp) then |
| Set_Dimensions (N, Dims_Of_Etyp); |
| |
| -- Identifier case. Propagate the dimensions from the entity for |
| -- identifier whose entity is a non-dimensionless constant. |
| |
| elsif Nkind (N) = N_Identifier then |
| Analyze_Dimension_Identifier : declare |
| Id : constant Entity_Id := Entity (N); |
| |
| begin |
| -- If Id is missing, abnormal tree, assume previous error |
| |
| if No (Id) then |
| Check_Error_Detected; |
| return; |
| |
| elsif Ekind (Id) in E_Constant | E_Named_Real |
| and then Exists (Dimensions_Of (Id)) |
| then |
| Set_Dimensions (N, Dimensions_Of (Id)); |
| end if; |
| end Analyze_Dimension_Identifier; |
| |
| -- Attribute reference case. Propagate the dimensions from the prefix. |
| |
| elsif Nkind (N) = N_Attribute_Reference |
| and then Has_Dimension_System (Base_Type (Etyp)) |
| then |
| Dims_Of_Etyp := Dimensions_Of (Prefix (N)); |
| |
| -- Check the prefix is not dimensionless |
| |
| if Exists (Dims_Of_Etyp) then |
| Set_Dimensions (N, Dims_Of_Etyp); |
| end if; |
| end if; |
| |
| -- Remove dimensions from inner expressions, to prevent dimensions |
| -- table from growing uselessly. |
| |
| case Nkind (N) is |
| when N_Attribute_Reference |
| | N_Indexed_Component |
| => |
| declare |
| Exprs : constant List_Id := Expressions (N); |
| Expr : Node_Id; |
| |
| begin |
| if Present (Exprs) then |
| Expr := First (Exprs); |
| while Present (Expr) loop |
| Remove_Dimensions (Expr); |
| Next (Expr); |
| end loop; |
| end if; |
| end; |
| |
| when N_Qualified_Expression |
| | N_Type_Conversion |
| | N_Unchecked_Type_Conversion |
| => |
| Remove_Dimensions (Expression (N)); |
| |
| when N_Selected_Component => |
| Remove_Dimensions (Selector_Name (N)); |
| |
| when others => |
| null; |
| end case; |
| end Analyze_Dimension_Has_Etype; |
| |
| ------------------------------------- |
| -- Analyze_Dimension_If_Expression -- |
| ------------------------------------- |
| |
| procedure Analyze_Dimension_If_Expression (N : Node_Id) is |
| Then_Expr : constant Node_Id := Next (First (Expressions (N))); |
| Else_Expr : constant Node_Id := Next (Then_Expr); |
| |
| begin |
| if Dimensions_Of (Then_Expr) /= Dimensions_Of (Else_Expr) then |
| Error_Msg_N ("dimensions mismatch in conditional expression", N); |
| else |
| Copy_Dimensions (Then_Expr, N); |
| end if; |
| end Analyze_Dimension_If_Expression; |
| |
| ------------------------------------------ |
| -- Analyze_Dimension_Number_Declaration -- |
| ------------------------------------------ |
| |
| procedure Analyze_Dimension_Number_Declaration (N : Node_Id) is |
| Expr : constant Node_Id := Expression (N); |
| Id : constant Entity_Id := Defining_Identifier (N); |
| Dim_Of_Expr : constant Dimension_Type := Dimensions_Of (Expr); |
| |
| begin |
| if Exists (Dim_Of_Expr) then |
| Set_Dimensions (Id, Dim_Of_Expr); |
| Set_Etype (Id, Etype (Expr)); |
| end if; |
| end Analyze_Dimension_Number_Declaration; |
| |
| ------------------------------------------ |
| -- 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); |
| Etyp : constant Entity_Id := Etype (Id); |
| Dim_Of_Etyp : constant Dimension_Type := Dimensions_Of (Etyp); |
| Dim_Of_Expr : Dimension_Type; |
| |
| procedure Error_Dim_Msg_For_Object_Declaration |
| (N : Node_Id; |
| Etyp : Entity_Id; |
| Expr : Node_Id); |
| -- Error using Error_Msg_N at node N. Output the dimensions of the |
| -- type Etyp and of the expression Expr. |
| |
| ------------------------------------------ |
| -- Error_Dim_Msg_For_Object_Declaration -- |
| ------------------------------------------ |
| |
| procedure Error_Dim_Msg_For_Object_Declaration |
| (N : Node_Id; |
| Etyp : Entity_Id; |
| Expr : Node_Id) is |
| begin |
| Error_Msg_N ("dimensions mismatch in object declaration", N); |
| Error_Msg_N |
| ("\expected dimension " & Dimensions_Msg_Of (Etyp) & ", found " |
| & Dimensions_Msg_Of (Expr), Expr); |
| end Error_Dim_Msg_For_Object_Declaration; |
| |
| -- Start of processing for Analyze_Dimension_Object_Declaration |
| |
| begin |
| -- Expression is present |
| |
| if Present (Expr) then |
| Dim_Of_Expr := Dimensions_Of (Expr); |
| |
| -- Check dimensions match |
| |
| if Dim_Of_Expr /= Dim_Of_Etyp then |
| |
| -- Numeric literal case. Issue a warning if the object type is |
| -- not dimensionless to indicate the literal is treated as if |
| -- its dimension matches the type dimension. |
| |
| if Nkind (Original_Node (Expr)) in |
| N_Real_Literal | N_Integer_Literal |
| then |
| Dim_Warning_For_Numeric_Literal (Expr, Etyp); |
| |
| -- Case of object is a constant whose type is a dimensioned type |
| |
| elsif Constant_Present (N) and then not Exists (Dim_Of_Etyp) then |
| |
| -- Propagate dimension from expression to object entity |
| |
| Set_Dimensions (Id, Dim_Of_Expr); |
| |
| -- Expression may have been constant-folded. If nominal type has |
| -- dimensions, verify that expression has same type. |
| |
| elsif Exists (Dim_Of_Etyp) and then Etype (Expr) = Etyp then |
| null; |
| |
| -- For all other cases, issue an error message |
| |
| else |
| Error_Dim_Msg_For_Object_Declaration (N, Etyp, Expr); |
| end if; |
| end if; |
| |
| -- Remove dimensions in expression after checking consistency with |
| -- given type. |
| |
| Remove_Dimensions (Expr); |
| end if; |
| end Analyze_Dimension_Object_Declaration; |
| |
| --------------------------------------------------- |
| -- Analyze_Dimension_Object_Renaming_Declaration -- |
| --------------------------------------------------- |
| |
| procedure Analyze_Dimension_Object_Renaming_Declaration (N : Node_Id) is |
| Renamed_Name : constant Node_Id := Name (N); |
| Sub_Mark : constant Node_Id := Subtype_Mark (N); |
| |
| procedure Error_Dim_Msg_For_Object_Renaming_Declaration |
| (N : Node_Id; |
| Sub_Mark : Node_Id; |
| Renamed_Name : Node_Id); |
| -- Error using Error_Msg_N at node N. Output the dimensions of |
| -- Sub_Mark and of Renamed_Name. |
| |
| --------------------------------------------------- |
| -- Error_Dim_Msg_For_Object_Renaming_Declaration -- |
| --------------------------------------------------- |
| |
| procedure Error_Dim_Msg_For_Object_Renaming_Declaration |
| (N : Node_Id; |
| Sub_Mark : Node_Id; |
| Renamed_Name : Node_Id) is |
| begin |
| Error_Msg_N ("dimensions mismatch in object renaming declaration", N); |
| Error_Msg_N |
| ("\expected dimension " & Dimensions_Msg_Of (Sub_Mark) & ", found " |
| & Dimensions_Msg_Of (Renamed_Name), Renamed_Name); |
| end Error_Dim_Msg_For_Object_Renaming_Declaration; |
| |
| -- Start of processing for Analyze_Dimension_Object_Renaming_Declaration |
| |
| begin |
| if Dimensions_Of (Renamed_Name) /= Dimensions_Of (Sub_Mark) then |
| Error_Dim_Msg_For_Object_Renaming_Declaration |
| (N, Sub_Mark, Renamed_Name); |
| 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); |
| Return_Ent : constant Entity_Id := Return_Statement_Entity (N); |
| Return_Etyp : constant Entity_Id := |
| Etype (Return_Applies_To (Return_Ent)); |
| Dims_Of_Return_Etyp : constant Dimension_Type := |
| Dimensions_Of (Return_Etyp); |
| |
| procedure Error_Dim_Msg_For_Simple_Return_Statement |
| (N : Node_Id; |
| Return_Etyp : Entity_Id; |
| Expr : Node_Id); |
| -- Error using Error_Msg_N at node N. Output the dimensions of the |
| -- returned type Return_Etyp and the returned expression Expr of N. |
| |
| ----------------------------------------------- |
| -- Error_Dim_Msg_For_Simple_Return_Statement -- |
| ----------------------------------------------- |
| |
| procedure Error_Dim_Msg_For_Simple_Return_Statement |
| (N : Node_Id; |
| Return_Etyp : Entity_Id; |
| Expr : Node_Id) |
| is |
| begin |
| Error_Msg_N ("dimensions mismatch in return statement", N); |
| Error_Msg_N |
| ("\expected dimension " & Dimensions_Msg_Of (Return_Etyp) |
| & ", found " & Dimensions_Msg_Of (Expr), Expr); |
| end Error_Dim_Msg_For_Simple_Return_Statement; |
| |
| -- Start of processing for Analyze_Dimension_Simple_Return_Statement |
| |
| begin |
| if Dims_Of_Return_Etyp /= Dimensions_Of (Expr) then |
| Error_Dim_Msg_For_Simple_Return_Statement (N, Return_Etyp, Expr); |
| Remove_Dimensions (Expr); |
| end if; |
| end Analyze_Dimension_Simple_Return_Statement; |
| |
| ------------------------------------------- |
| -- Analyze_Dimension_Subtype_Declaration -- |
| ------------------------------------------- |
| |
| procedure Analyze_Dimension_Subtype_Declaration (N : Node_Id) is |
| Id : constant Entity_Id := Defining_Identifier (N); |
| Dims_Of_Id : constant Dimension_Type := Dimensions_Of (Id); |
| Dims_Of_Etyp : Dimension_Type; |
| Etyp : Node_Id; |
| |
| begin |
| -- No constraint case in subtype declaration |
| |
| if Nkind (Subtype_Indication (N)) /= N_Subtype_Indication then |
| Etyp := Etype (Subtype_Indication (N)); |
| Dims_Of_Etyp := Dimensions_Of (Etyp); |
| |
| if Exists (Dims_Of_Etyp) then |
| |
| -- If subtype already has a dimension (from Aspect_Dimension), it |
| -- cannot inherit different dimensions from its subtype. |
| |
| if Exists (Dims_Of_Id) and then Dims_Of_Etyp /= Dims_Of_Id then |
| Error_Msg_NE |
| ("subtype& already " & Dimensions_Msg_Of (Id, True), N, Id); |
| else |
| Set_Dimensions (Id, Dims_Of_Etyp); |
| Set_Symbol (Id, Symbol_Of (Etyp)); |
| end if; |
| end if; |
| |
| -- Constraint present in subtype declaration |
| |
| else |
| Etyp := Etype (Subtype_Mark (Subtype_Indication (N))); |
| Dims_Of_Etyp := Dimensions_Of (Etyp); |
| |
| if Exists (Dims_Of_Etyp) then |
| Set_Dimensions (Id, Dims_Of_Etyp); |
| Set_Symbol (Id, Symbol_Of (Etyp)); |
| end if; |
| end if; |
| end Analyze_Dimension_Subtype_Declaration; |
| |
| --------------------------------------- |
| -- Analyze_Dimension_Type_Conversion -- |
| --------------------------------------- |
| |
| procedure Analyze_Dimension_Type_Conversion (N : Node_Id) is |
| Expr_Root : constant Entity_Id := |
| Dimension_System_Root (Etype (Expression (N))); |
| Target_Root : constant Entity_Id := |
| Dimension_System_Root (Etype (N)); |
| |
| begin |
| -- If the expression has dimensions and the target type has dimensions, |
| -- the conversion has the dimensions of the expression. Consistency is |
| -- checked below. Converting to a non-dimensioned type such as Float |
| -- ignores the dimensions of the expression. |
| |
| if Exists (Dimensions_Of (Expression (N))) |
| and then Present (Target_Root) |
| then |
| Set_Dimensions (N, Dimensions_Of (Expression (N))); |
| |
| -- Otherwise the dimensions are those of the target type. |
| |
| else |
| Analyze_Dimension_Has_Etype (N); |
| end if; |
| |
| -- A conversion between types in different dimension systems (e.g. MKS |
| -- and British units) must respect the dimensions of expression and |
| -- type, It is up to the user to provide proper conversion factors. |
| |
| -- Upward conversions to root type of a dimensioned system are legal, |
| -- and correspond to "view conversions", i.e. preserve the dimensions |
| -- of the expression; otherwise conversion must be between types with |
| -- then same dimensions. Conversions to a non-dimensioned type such as |
| -- Float lose the dimensions of the expression. |
| |
| if Present (Expr_Root) |
| and then Present (Target_Root) |
| and then Etype (N) /= Target_Root |
| and then Dimensions_Of (Expression (N)) /= Dimensions_Of (Etype (N)) |
| then |
| Error_Msg_N ("dimensions mismatch in conversion", N); |
| Error_Msg_N |
| ("\expression " & Dimensions_Msg_Of (Expression (N), True), N); |
| Error_Msg_N |
| ("\target type " & Dimensions_Msg_Of (Etype (N), True), N); |
| end if; |
| end Analyze_Dimension_Type_Conversion; |
| |
| -------------------------------- |
| -- Analyze_Dimension_Unary_Op -- |
| -------------------------------- |
| |
| procedure Analyze_Dimension_Unary_Op (N : Node_Id) is |
| begin |
| case Nkind (N) is |
| |
| -- Propagate the dimension if the operand is not dimensionless |
| |
| when N_Op_Abs |
| | N_Op_Minus |
| | N_Op_Plus |
| => |
| declare |
| R : constant Node_Id := Right_Opnd (N); |
| begin |
| Move_Dimensions (R, N); |
| end; |
| |
| when others => |
| null; |
| end case; |
| end Analyze_Dimension_Unary_Op; |
| |
| --------------------------------- |
| -- Check_Expression_Dimensions -- |
| --------------------------------- |
| |
| procedure Check_Expression_Dimensions |
| (Expr : Node_Id; |
| Typ : Entity_Id) |
| is |
| begin |
| if Is_Floating_Point_Type (Etype (Expr)) then |
| Analyze_Dimension (Expr); |
| |
| if Dimensions_Of (Expr) /= Dimensions_Of (Typ) then |
| Error_Msg_N ("dimensions mismatch in array aggregate", Expr); |
| Error_Msg_N |
| ("\expected dimension " & Dimensions_Msg_Of (Typ) |
| & ", found " & Dimensions_Msg_Of (Expr), Expr); |
| end if; |
| end if; |
| end Check_Expression_Dimensions; |
| |
| --------------------- |
| -- Copy_Dimensions -- |
| --------------------- |
| |
| procedure Copy_Dimensions (From : Node_Id; To : Node_Id) is |
| Dims_Of_From : constant Dimension_Type := Dimensions_Of (From); |
| |
| begin |
| -- Ignore if not Ada 2012 or beyond |
| |
| if Ada_Version < Ada_2012 then |
| return; |
| |
| -- For Ada 2012, Copy the dimension of 'From to 'To' |
| |
| elsif Exists (Dims_Of_From) then |
| Set_Dimensions (To, Dims_Of_From); |
| end if; |
| end Copy_Dimensions; |
| |
| ----------------------------------- |
| -- Copy_Dimensions_Of_Components -- |
| ----------------------------------- |
| |
| procedure Copy_Dimensions_Of_Components (Rec : Entity_Id) is |
| C : Entity_Id; |
| |
| begin |
| C := First_Component (Rec); |
| while Present (C) loop |
| if Nkind (Parent (C)) = N_Component_Declaration then |
| Copy_Dimensions |
| (Expression (Parent (Corresponding_Record_Component (C))), |
| Expression (Parent (C))); |
| end if; |
| Next_Component (C); |
| end loop; |
| end Copy_Dimensions_Of_Components; |
| |
| -------------------------- |
| -- Create_Rational_From -- |
| -------------------------- |
| |
| -- RATIONAL ::= [-] NUMERAL [/ NUMERAL] |
| |
| -- A rational number is a number that can be expressed as the quotient or |
| -- fraction a/b of two integers, where b is non-zero positive. |
| |
| function Create_Rational_From |
| (Expr : Node_Id; |
| Complain : Boolean) return Rational |
| is |
| Or_Node_Of_Expr : constant Node_Id := Original_Node (Expr); |
| Result : Rational := No_Rational; |
| |
| function Process_Minus (N : Node_Id) return Rational; |
| -- Create a rational from a N_Op_Minus node |
| |
| function Process_Divide (N : Node_Id) return Rational; |
| -- Create a rational from a N_Op_Divide node |
| |
| function Process_Literal (N : Node_Id) return Rational; |
| -- Create a rational from a N_Integer_Literal node |
| |
| ------------------- |
| -- Process_Minus -- |
| ------------------- |
| |
| function Process_Minus (N : Node_Id) return Rational is |
| Right : constant Node_Id := Original_Node (Right_Opnd (N)); |
| Result : Rational; |
| |
| begin |
| -- Operand is an integer literal |
| |
| if Nkind (Right) = N_Integer_Literal then |
| Result := -Process_Literal (Right); |
| |
| -- Operand is a divide operator |
| |
| elsif Nkind (Right) = N_Op_Divide then |
| Result := -Process_Divide (Right); |
| |
| else |
| Result := No_Rational; |
| end if; |
| |
| return Result; |
| end Process_Minus; |
| |
| -------------------- |
| -- Process_Divide -- |
| -------------------- |
| |
| function Process_Divide (N : Node_Id) return Rational is |
| Left : constant Node_Id := Original_Node (Left_Opnd (N)); |
| Right : constant Node_Id := Original_Node (Right_Opnd (N)); |
| Left_Rat : Rational; |
| Result : Rational := No_Rational; |
| Right_Rat : Rational; |
| |
| begin |
| -- Both left and right operands are integer literals |
| |
| if Nkind (Left) = N_Integer_Literal |
| and then |
| Nkind (Right) = N_Integer_Literal |
| then |
| Left_Rat := Process_Literal (Left); |
| Right_Rat := Process_Literal (Right); |
| Result := Left_Rat / Right_Rat; |
| end if; |
| |
| return Result; |
| end Process_Divide; |
| |
| --------------------- |
| -- Process_Literal -- |
| --------------------- |
| |
| function Process_Literal (N : Node_Id) return Rational is |
| begin |
| return +Whole (UI_To_Int (Intval (N))); |
| end Process_Literal; |
| |
| -- Start of processing for Create_Rational_From |
| |
| begin |
| -- Check the expression is either a division of two integers or an |
| -- integer itself. Note that the check applies to the original node |
| -- since the node could have already been rewritten. |
| |
| -- Integer literal case |
| |
| if Nkind (Or_Node_Of_Expr) = N_Integer_Literal then |
| Result := Process_Literal (Or_Node_Of_Expr); |
| |
| -- Divide operator case |
| |
| elsif Nkind (Or_Node_Of_Expr) = N_Op_Divide then |
| Result := Process_Divide (Or_Node_Of_Expr); |
| |
| -- Minus operator case |
| |
| elsif Nkind (Or_Node_Of_Expr) = N_Op_Minus then |
| Result := Process_Minus (Or_Node_Of_Expr); |
| end if; |
| |
| -- When Expr cannot be interpreted as a rational and Complain is true, |
| -- generate an error message. |
| |
| if Complain and then Result = No_Rational then |
| Error_Msg_N ("rational expected", Expr); |
| end if; |
| |
| return Result; |
| end Create_Rational_From; |
| |
| ------------------- |
| -- Dimensions_Of -- |
| ------------------- |
| |
| function Dimensions_Of (N : Node_Id) return Dimension_Type is |
| begin |
| return Dimension_Table.Get (N); |
| end Dimensions_Of; |
| |
| ----------------------- |
| -- Dimensions_Msg_Of -- |
| ----------------------- |
| |
| function Dimensions_Msg_Of |
| (N : Node_Id; |
| Description_Needed : Boolean := False) return String |
| is |
| Dims_Of_N : constant Dimension_Type := Dimensions_Of (N); |
| Dimensions_Msg : Name_Id; |
| System : System_Type; |
| |
| begin |
| -- Initialization of Name_Buffer |
| |
| Name_Len := 0; |
| |
| -- N is not dimensionless |
| |
| if Exists (Dims_Of_N) then |
| System := System_Of (Base_Type (Etype (N))); |
| |
| -- When Description_Needed, add to string "has dimension " before the |
| -- actual dimension. |
| |
| if Description_Needed then |
| Add_Str_To_Name_Buffer ("has dimension "); |
| end if; |
| |
| Append |
| (Global_Name_Buffer, |
| From_Dim_To_Str_Of_Dim_Symbols (Dims_Of_N, System, True)); |
| |
| -- N is dimensionless |
| |
| -- When Description_Needed, return "is dimensionless" |
| |
| elsif Description_Needed then |
| Add_Str_To_Name_Buffer ("is dimensionless"); |
| |
| -- Otherwise, return "'[']" |
| |
| else |
| Add_Str_To_Name_Buffer ("'[']"); |
| end if; |
| |
| Dimensions_Msg := Name_Find; |
| return Get_Name_String (Dimensions_Msg); |
| end Dimensions_Msg_Of; |
| |
| -------------------------- |
| -- Dimension_Table_Hash -- |
| -------------------------- |
| |
| function Dimension_Table_Hash |
| (Key : Node_Id) return Dimension_Table_Range |
| is |
| begin |
| return Dimension_Table_Range (Key mod 511); |
| end Dimension_Table_Hash; |
| |
| ------------------------------------- |
| -- Dim_Warning_For_Numeric_Literal -- |
| ------------------------------------- |
| |
| procedure Dim_Warning_For_Numeric_Literal (N : Node_Id; Typ : Entity_Id) is |
| begin |
| -- Consider the literal zero (integer 0 or real 0.0) to be of any |
| -- dimension. |
| |
| case Nkind (Original_Node (N)) is |
| when N_Real_Literal => |
| if Expr_Value_R (N) = Ureal_0 then |
| return; |
| end if; |
| |
| when N_Integer_Literal => |
| if Expr_Value (N) = Uint_0 then |
| return; |
| end if; |
| |
| when others => |
| null; |
| end case; |
| |
| -- Initialize name buffer |
| |
| Name_Len := 0; |
| |
| Append (Global_Name_Buffer, String_From_Numeric_Literal (N)); |
| |
| -- Insert a blank between the literal and the symbol |
| |
| Add_Char_To_Name_Buffer (' '); |
| Append (Global_Name_Buffer, Symbol_Of (Typ)); |
| |
| Error_Msg_Name_1 := Name_Find; |
| Error_Msg_N ("assumed to be%%??", N); |
| end Dim_Warning_For_Numeric_Literal; |
| |
| ---------------------- |
| -- Dimensions_Match -- |
| ---------------------- |
| |
| function Dimensions_Match (T1 : Entity_Id; T2 : Entity_Id) return Boolean is |
| begin |
| return |
| not Has_Dimension_System (Base_Type (T1)) |
| or else Dimensions_Of (T1) = Dimensions_Of (T2); |
| end Dimensions_Match; |
| |
| --------------------------- |
| -- Dimension_System_Root -- |
| --------------------------- |
| |
| function Dimension_System_Root (T : Entity_Id) return Entity_Id is |
| Root : Entity_Id; |
| |
| begin |
| Root := Base_Type (T); |
| |
| if Has_Dimension_System (Root) then |
| return First_Subtype (Root); -- for example Dim_Mks |
| |
| else |
| return Empty; |
| end if; |
| end Dimension_System_Root; |
| |
| ---------------------------------------- |
| -- Eval_Op_Expon_For_Dimensioned_Type -- |
| ---------------------------------------- |
| |
| -- Evaluate the expon operator for real dimensioned type. |
| |
| -- Note that if the exponent is an integer (denominator = 1) the node is |
| -- evaluated by the regular Eval_Op_Expon routine (see Sem_Eval). |
| |
| procedure Eval_Op_Expon_For_Dimensioned_Type |
| (N : Node_Id; |
| Btyp : Entity_Id) |
| is |
| R : constant Node_Id := Right_Opnd (N); |
| R_Value : Rational := No_Rational; |
| |
| begin |
| if Is_Real_Type (Btyp) then |
| R_Value := Create_Rational_From (R, False); |
| end if; |
| |
| -- Check that the exponent is not an integer |
| |
| if R_Value /= No_Rational and then R_Value.Denominator /= 1 then |
| Eval_Op_Expon_With_Rational_Exponent (N, R_Value); |
| else |
| Eval_Op_Expon (N); |
| 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; |
| Exponent_Value : Rational) |
| is |
| Loc : constant Source_Ptr := Sloc (N); |
| Dims_Of_N : constant Dimension_Type := Dimensions_Of (N); |
| L : constant Node_Id := Left_Opnd (N); |
| Etyp_Of_L : constant Entity_Id := Etype (L); |
| Btyp_Of_L : constant Entity_Id := Base_Type (Etyp_Of_L); |
| Actual_1 : Node_Id; |
| Actual_2 : Node_Id; |
| Dim_Power : Rational; |
| List_Of_Dims : List_Id; |
| New_Aspect : Node_Id; |
| New_Aspects : List_Id; |
| New_Id : Entity_Id; |
| New_N : Node_Id; |
| New_Subtyp_Decl_For_L : Node_Id; |
| System : System_Type; |
| |
| begin |
| -- Case when the operand is not dimensionless |
| |
| if Exists (Dims_Of_N) then |
| |
| -- Get the corresponding System_Type to know the exact number of |
| -- dimensions in the system. |
| |
| System := System_Of (Btyp_Of_L); |
| |
| -- Generation of a new subtype with the proper dimensions |
| |
| -- In order to rewrite the operator as a type conversion, a new |
| -- dimensioned subtype with the resulting dimensions of the |
| -- exponentiation must be created. |
| |
| -- Generate: |
| |
| -- Btyp_Of_L : constant Entity_Id := Base_Type (Etyp_Of_L); |
| -- System : constant System_Id := |
| -- Get_Dimension_System_Id (Btyp_Of_L); |
| -- Num_Of_Dims : constant Number_Of_Dimensions := |
| -- Dimension_Systems.Table (System).Dimension_Count; |
| |
| -- subtype T is Btyp_Of_L |
| -- with |
| -- Dimension => ( |
| -- Dims_Of_N (1).Numerator / Dims_Of_N (1).Denominator, |
| -- Dims_Of_N (2).Numerator / Dims_Of_N (2).Denominator, |
| -- ... |
| -- Dims_Of_N (Num_Of_Dims).Numerator / |
| -- Dims_Of_N (Num_Of_Dims).Denominator); |
| |
| -- Step 1: Generate the new aggregate for the aspect Dimension |
| |
| New_Aspects := Empty_List; |
| |
| List_Of_Dims := New_List; |
| for Position in Dims_Of_N'First .. System.Count loop |
| Dim_Power := Dims_Of_N (Position); |
| Append_To (List_Of_Dims, |
| Make_Op_Divide (Loc, |
| Left_Opnd => |
| Make_Integer_Literal (Loc, Int (Dim_Power.Numerator)), |
| Right_Opnd => |
| Make_Integer_Literal (Loc, Int (Dim_Power.Denominator)))); |
| end loop; |
| |
| -- Step 2: Create the new Aspect Specification for Aspect Dimension |
| |
| New_Aspect := |
| Make_Aspect_Specification (Loc, |
| Identifier => Make_Identifier (Loc, Name_Dimension), |
| Expression => Make_Aggregate (Loc, Expressions => List_Of_Dims)); |
| |
| -- Step 3: Make a temporary identifier for the new subtype |
| |
| New_Id := Make_Temporary (Loc, 'T'); |
| Set_Is_Internal (New_Id); |
| |
| -- Step 4: Declaration of the new subtype |
| |
| New_Subtyp_Decl_For_L := |
| Make_Subtype_Declaration (Loc, |
| Defining_Identifier => New_Id, |
| Subtype_Indication => New_Occurrence_Of (Btyp_Of_L, Loc)); |
| |
| Append (New_Aspect, New_Aspects); |
| Set_Parent (New_Aspects, New_Subtyp_Decl_For_L); |
| Set_Aspect_Specifications (New_Subtyp_Decl_For_L, New_Aspects); |
| |
| Analyze (New_Subtyp_Decl_For_L); |
| |
| -- Case where the operand is dimensionless |
| |
| else |
| New_Id := Btyp_Of_L; |
| end if; |
| |
| -- Replacement of N by New_N |
| |
| -- Generate: |
| |
| -- Actual_1 := Long_Long_Float (L), |
| |
| -- Actual_2 := Long_Long_Float (Exponent_Value.Numerator) / |
| -- Long_Long_Float (Exponent_Value.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 1: Creation of the two parameters of Expon_LLF function call |
| |
| Actual_1 := |
| Make_Type_Conversion (Loc, |
| Subtype_Mark => New_Occurrence_Of (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 (Exponent_Value.Numerator)))), |
| Right_Opnd => |
| Make_Real_Literal (Loc, |
| UR_From_Uint (UI_From_Int (Int (Exponent_Value.Denominator))))); |
| |
| -- Step 2: Creation of New_N |
| |
| New_N := |
| Make_Type_Conversion (Loc, |
| Subtype_Mark => New_Occurrence_Of (New_Id, Loc), |
| Expression => |
| Make_Function_Call (Loc, |
| Name => New_Occurrence_Of (RTE (RE_Expon_LLF), Loc), |
| Parameter_Associations => New_List ( |
| Actual_1, Actual_2))); |
| |
| -- Step 3: Rewrite N with the result |
| |
| Rewrite (N, New_N); |
| Set_Etype (N, New_Id); |
| Analyze_And_Resolve (N, New_Id); |
| end Eval_Op_Expon_With_Rational_Exponent; |
| |
| ------------ |
| -- Exists -- |
| ------------ |
| |
| function Exists (Dim : Dimension_Type) return Boolean is |
| begin |
| return Dim /= Null_Dimension; |
| end Exists; |
| |
| function Exists (Str : String_Id) return Boolean is |
| begin |
| return Str /= No_String; |
| end Exists; |
| |
| function Exists (Sys : System_Type) return Boolean is |
| begin |
| return Sys /= Null_System; |
| end Exists; |
| |
| --------------------------------- |
| -- Expand_Put_Call_With_Symbol -- |
| --------------------------------- |
| |
| -- For procedure Put (resp. Put_Dim_Of) and function Image, defined in |
| -- System.Dim.Float_IO or System.Dim.Integer_IO, the default string |
| -- parameter is rewritten to include the unit symbol (or the dimension |
| -- symbols if not a defined quantity) in the output of a dimensioned |
| -- object. If a value is already supplied by the user for the parameter |
| -- Symbol, it is used as is. |
| |
| -- Case 1. Item is dimensionless |
| |
| -- * Put : Item appears without a suffix |
| |
| -- * Put_Dim_Of : the output is [] |
| |
| -- Obj : Mks_Type := 2.6; |
| -- Put (Obj, 1, 1, 0); |
| -- Put_Dim_Of (Obj); |
| |
| -- The corresponding outputs are: |
| -- $2.6 |
| -- $[] |
| |
| -- Case 2. Item has a dimension |
| |
| -- * Put : If the type of Item is a dimensioned subtype whose |
| -- symbol is not empty, then the symbol appears as a |
| -- suffix. Otherwise, a new string is created and appears |
| -- as a suffix of Item. This string results in the |
| -- successive concatenations between each unit symbol |
| -- raised by its corresponding dimension power from the |
| -- dimensions of Item. |
| |
| -- * Put_Dim_Of : The output is a new string resulting in the successive |
| -- concatenations between each dimension symbol raised by |
| -- its corresponding dimension power from the dimensions of |
| -- Item. |
| |
| -- subtype Random is Mks_Type |
| -- with |
| -- Dimension => ( |
| -- Meter => 3, |
| -- Candela => -1, |
| -- others => 0); |
| |
| -- Obj : Random := 5.0; |
| -- Put (Obj); |
| -- Put_Dim_Of (Obj); |
| |
| -- The corresponding outputs are: |
| -- $5.0 m**3.cd**(-1) |
| -- $[l**3.J**(-1)] |
| |
| -- The function Image returns the string identical to that produced by |
| -- a call to Put whose first parameter is a string. |
| |
| procedure Expand_Put_Call_With_Symbol (N : Node_Id) is |
| Actuals : constant List_Id := Parameter_Associations (N); |
| Loc : constant Source_Ptr := Sloc (N); |
| Name_Call : constant Node_Id := Name (N); |
| New_Actuals : constant List_Id := New_List; |
| Actual : Node_Id; |
| Dims_Of_Actual : Dimension_Type; |
| Etyp : Entity_Id; |
| New_Str_Lit : Node_Id := Empty; |
| Symbols : String_Id; |
| |
| Is_Put_Dim_Of : Boolean := False; |
| -- This flag is used in order to differentiate routines Put and |
| -- Put_Dim_Of. Set to True if the procedure is one of the Put_Dim_Of |
| -- defined in System.Dim.Float_IO or System.Dim.Integer_IO. |
| |
| function Has_Symbols return Boolean; |
| -- Return True if the current Put call already has a parameter |
| -- association for parameter "Symbols" with the correct string of |
| -- symbols. |
| |
| function Is_Procedure_Put_Call 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 Item_Actual return Node_Id; |
| -- Return the item actual parameter node in the output call |
| |
| ----------------- |
| -- Has_Symbols -- |
| ----------------- |
| |
| function Has_Symbols return Boolean is |
| Actual : Node_Id; |
| Actual_Str : Node_Id; |
| |
| begin |
| -- Look for a symbols parameter association in the list of actuals |
| |
| Actual := First (Actuals); |
| while Present (Actual) loop |
| |
| -- Positional parameter association case when the actual is a |
| -- string literal. |
| |
| if Nkind (Actual) = N_String_Literal then |
| Actual_Str := Actual; |
| |
| -- Named parameter association case when selector name is Symbol |
| |
| elsif Nkind (Actual) = N_Parameter_Association |
| and then Chars (Selector_Name (Actual)) = Name_Symbol |
| then |
| Actual_Str := Explicit_Actual_Parameter (Actual); |
| |
| -- Ignore all other cases |
| |
| else |
| Actual_Str := Empty; |
| end if; |
| |
| if Present (Actual_Str) then |
| |
| -- Return True if the actual comes from source or if the string |
| -- of symbols doesn't have the default value (i.e. it is ""), |
| -- in which case it is used as suffix of the generated string. |
| |
| if Comes_From_Source (Actual) |
| or else String_Length (Strval (Actual_Str)) /= 0 |
| then |
| return True; |
| |
| else |
| return False; |
| end if; |
| end if; |
| |
| Next (Actual); |
| end loop; |
| |
| -- At this point, the call has no parameter association. Look to the |
| -- last actual since the symbols parameter is the last one. |
| |
| return Nkind (Last (Actuals)) = N_String_Literal; |
| end Has_Symbols; |
| |
| --------------------------- |
| -- Is_Procedure_Put_Call -- |
| --------------------------- |
| |
| function Is_Procedure_Put_Call return Boolean is |
| Ent : Entity_Id; |
| Loc : Source_Ptr; |
| |
| begin |
| -- There are three different Put (resp. Put_Dim_Of) routines in each |
| -- generic dim IO package. Verify the current procedure call is one |
| -- of them. |
| |
| if Is_Entity_Name (Name_Call) then |
| Ent := Entity (Name_Call); |
| |
| -- Get the original subprogram entity following the renaming chain |
| |
| if Present (Alias (Ent)) then |
| Ent := Alias (Ent); |
| end if; |
| |
| Loc := Sloc (Ent); |
| |
| -- Check the name of the entity subprogram is Put (resp. |
| -- Put_Dim_Of) and verify this entity is located in either |
| -- System.Dim.Float_IO or System.Dim.Integer_IO. |
| |
| if Loc > No_Location |
| and then Is_Dim_IO_Package_Entity |
| (Cunit_Entity (Get_Source_Unit (Loc))) |
| then |
| if Chars (Ent) = Name_Put_Dim_Of then |
| Is_Put_Dim_Of := True; |
| return True; |
| |
| elsif Chars (Ent) = Name_Put |
| or else Chars (Ent) = Name_Image |
| then |
| return True; |
| end if; |
| end if; |
| end if; |
| |
| return False; |
| end Is_Procedure_Put_Call; |
| |
| ----------------- |
| -- Item_Actual -- |
| ----------------- |
| |
| function Item_Actual return Node_Id is |
| Actual : Node_Id; |
| |
| begin |
| -- Look for the item actual as a parameter association |
| |
| Actual := First (Actuals); |
| while Present (Actual) loop |
| if Nkind (Actual) = N_Parameter_Association |
| and then Chars (Selector_Name (Actual)) = Name_Item |
| then |
| return Explicit_Actual_Parameter (Actual); |
| end if; |
| |
| Next (Actual); |
| end loop; |
| |
| -- Case where the item has been defined without an association |
| |
| Actual := First (Actuals); |
| |
| -- Depending on the procedure Put, Item actual could be first or |
| -- second in the list of actuals. |
| |
| if Has_Dimension_System (Base_Type (Etype (Actual))) then |
| return Actual; |
| else |
| return Next (Actual); |
| end if; |
| end Item_Actual; |
| |
| -- Start of processing for Expand_Put_Call_With_Symbol |
| |
| begin |
| if Is_Procedure_Put_Call and then not Has_Symbols then |
| Actual := Item_Actual; |
| Dims_Of_Actual := Dimensions_Of (Actual); |
| Etyp := Etype (Actual); |
| |
| -- Put_Dim_Of case |
| |
| if Is_Put_Dim_Of then |
| |
| -- Check that the item is not dimensionless |
| |
| -- Create the new String_Literal with the new String_Id generated |
| -- by the routine From_Dim_To_Str_Of_Dim_Symbols. |
| |
| if Exists (Dims_Of_Actual) then |
| New_Str_Lit := |
| Make_String_Literal (Loc, |
| From_Dim_To_Str_Of_Dim_Symbols |
| (Dims_Of_Actual, System_Of (Base_Type (Etyp)))); |
| |
| -- If dimensionless, the output is [] |
| |
| else |
| New_Str_Lit := |
| Make_String_Literal (Loc, "[]"); |
| end if; |
| |
| -- Put case |
| |
| else |
| -- Add the symbol as a suffix of the value if the subtype has a |
| -- unit symbol or if the parameter is not dimensionless. |
| |
| if Exists (Symbol_Of (Etyp)) then |
| Symbols := Symbol_Of (Etyp); |
| else |
| Symbols := From_Dim_To_Str_Of_Unit_Symbols |
| (Dims_Of_Actual, System_Of (Base_Type (Etyp))); |
| end if; |
| |
| -- Check Symbols exists |
| |
| if Exists (Symbols) then |
| Start_String; |
| |
| -- Put a space between the value and the dimension |
| |
| Store_String_Char (' '); |
| Store_String_Chars (Symbols); |
| New_Str_Lit := Make_String_Literal (Loc, End_String); |
| end if; |
| end if; |
| |
| if Present (New_Str_Lit) then |
| |
| -- Insert all actuals in New_Actuals |
| |
| Actual := First (Actuals); |
| while Present (Actual) loop |
| |
| -- Copy every actuals in New_Actuals except the Symbols |
| -- parameter association. |
| |
| if Nkind (Actual) = N_Parameter_Association |
| and then Chars (Selector_Name (Actual)) /= Name_Symbol |
| then |
| Append_To (New_Actuals, |
| Make_Parameter_Association (Loc, |
| Selector_Name => New_Copy (Selector_Name (Actual)), |
| Explicit_Actual_Parameter => |
| New_Copy (Explicit_Actual_Parameter (Actual)))); |
| |
| elsif Nkind (Actual) /= N_Parameter_Association then |
| Append_To (New_Actuals, New_Copy (Actual)); |
| end if; |
| |
| Next (Actual); |
| end loop; |
| |
| -- Create new Symbols param association and append to New_Actuals |
| |
| Append_To (New_Actuals, |
| Make_Parameter_Association (Loc, |
| Selector_Name => Make_Identifier (Loc, Name_Symbol), |
| Explicit_Actual_Parameter => New_Str_Lit)); |
| |
| -- Rewrite and analyze the procedure call |
| |
| if Chars (Name_Call) = Name_Image then |
| Rewrite (N, |
| Make_Function_Call (Loc, |
| Name => New_Copy (Name_Call), |
| Parameter_Associations => New_Actuals)); |
| Analyze_And_Resolve (N); |
| else |
| Rewrite (N, |
| Make_Procedure_Call_Statement (Loc, |
| Name => New_Copy (Name_Call), |
| Parameter_Associations => New_Actuals)); |
| Analyze (N); |
| end if; |
| |
| end if; |
| end if; |
| end Expand_Put_Call_With_Symbol; |
| |
| ------------------------------------ |
| -- From_Dim_To_Str_Of_Dim_Symbols -- |
| ------------------------------------ |
| |
| -- Given a dimension vector and the corresponding dimension system, create |
| -- a String_Id to output dimension symbols corresponding to the dimensions |
| -- Dims. If In_Error_Msg is True, there is a special handling for character |
| -- asterisk * which is an insertion character in error messages. |
| |
| function From_Dim_To_Str_Of_Dim_Symbols |
| (Dims : Dimension_Type; |
| System : System_Type; |
| In_Error_Msg : Boolean := False) return String_Id |
| is |
| Dim_Power : Rational; |
| First_Dim : Boolean := True; |
| |
| procedure Store_String_Oexpon; |
| -- Store the expon operator symbol "**" in the string. In error |
| -- messages, asterisk * is a special character and must be quoted |
| -- to be placed literally into the message. |
| |
| ------------------------- |
| -- Store_String_Oexpon -- |
| ------------------------- |
| |
| procedure Store_String_Oexpon is |
| begin |
| if In_Error_Msg then |
| Store_String_Chars ("'*'*"); |
| else |
| Store_String_Chars ("**"); |
| end if; |
| end Store_String_Oexpon; |
| |
| -- Start of processing for From_Dim_To_Str_Of_Dim_Symbols |
| |
| begin |
| -- Initialization of the new String_Id |
| |
| Start_String; |
| |
| -- Store the dimension symbols inside boxes |
| |
| if In_Error_Msg then |
| Store_String_Chars ("'["); |
| else |
| Store_String_Char ('['); |
| end if; |
| |
| for Position in Dimension_Type'Range loop |
| Dim_Power := Dims (Position); |
| if Dim_Power /= Zero then |
| |
| if First_Dim then |
| First_Dim := False; |
| else |
| Store_String_Char ('.'); |
| end if; |
| |
| Store_String_Chars (System.Dim_Symbols (Position)); |
| |
| -- Positive dimension case |
| |
| if Dim_Power.Numerator > 0 then |
| |
| -- Integer case |
| |
| if Dim_Power.Denominator = 1 then |
| if Dim_Power.Numerator /= 1 then |
| Store_String_Oexpon; |
| Store_String_Int (Int (Dim_Power.Numerator)); |
| end if; |
| |
| -- Rational case when denominator /= 1 |
| |
| else |
| Store_String_Oexpon; |
| Store_String_Char ('('); |
| Store_String_Int (Int (Dim_Power.Numerator)); |
| Store_String_Char ('/'); |
| Store_String_Int (Int (Dim_Power.Denominator)); |
| Store_String_Char (')'); |
| end if; |
| |
| -- Negative dimension case |
| |
| else |
| Store_String_Oexpon; |
| Store_String_Char ('('); |
| Store_String_Char ('-'); |
| Store_String_Int (Int (-Dim_Power.Numerator)); |
| |
| -- Integer case |
| |
| if Dim_Power.Denominator = 1 then |
| Store_String_Char (')'); |
| |
| -- Rational case when denominator /= 1 |
| |
| else |
| Store_String_Char ('/'); |
| Store_String_Int (Int (Dim_Power.Denominator)); |
| Store_String_Char (')'); |
| end if; |
| end if; |
| end if; |
| end loop; |
| |
| if In_Error_Msg then |
| Store_String_Chars ("']"); |
| else |
| Store_String_Char (']'); |
| end if; |
| |
| return End_String; |
| end From_Dim_To_Str_Of_Dim_Symbols; |
| |
| ------------------------------------- |
| -- From_Dim_To_Str_Of_Unit_Symbols -- |
| ------------------------------------- |
| |
| -- Given a dimension vector and the corresponding dimension system, |
| -- create a String_Id to output the unit symbols corresponding to the |
| -- dimensions Dims. |
| |
| function From_Dim_To_Str_Of_Unit_Symbols |
| (Dims : Dimension_Type; |
| System : System_Type) return String_Id |
| is |
| Dim_Power : Rational; |
| First_Dim : Boolean := True; |
| |
| begin |
| -- Return No_String if dimensionless |
| |
| if not Exists (Dims) then |
| return No_String; |
| end if; |
| |
| -- Initialization of the new String_Id |
| |
| Start_String; |
| |
| for Position in Dimension_Type'Range loop |
| Dim_Power := Dims (Position); |
| |
| if Dim_Power /= Zero then |
| if First_Dim then |
| First_Dim := False; |
| else |
| Store_String_Char ('.'); |
| end if; |
| |
| Store_String_Chars (System.Unit_Symbols (Position)); |
| |
| -- Positive dimension case |
| |
| if Dim_Power.Numerator > 0 then |
| |
| -- Integer case |
| |
| if Dim_Power.Denominator = 1 then |
| if Dim_Power.Numerator /= 1 then |
| Store_String_Chars ("**"); |
| Store_String_Int (Int (Dim_Power.Numerator)); |
| end if; |
| |
| -- Rational case when denominator /= 1 |
| |
| else |
| Store_String_Chars ("**"); |
| Store_String_Char ('('); |
| Store_String_Int (Int (Dim_Power.Numerator)); |
| Store_String_Char ('/'); |
| Store_String_Int (Int (Dim_Power.Denominator)); |
| Store_String_Char (')'); |
| end if; |
| |
| -- Negative dimension case |
| |
| else |
| Store_String_Chars ("**"); |
| Store_String_Char ('('); |
| Store_String_Char ('-'); |
| Store_String_Int (Int (-Dim_Power.Numerator)); |
| |
| -- Integer case |
| |
| if Dim_Power.Denominator = 1 then |
| Store_String_Char (')'); |
| |
| -- Rational case when denominator /= 1 |
| |
| else |
| Store_String_Char ('/'); |
| Store_String_Int (Int (Dim_Power.Denominator)); |
| Store_String_Char (')'); |
| end if; |
| end if; |
| end if; |
| end loop; |
| |
| return End_String; |
| end From_Dim_To_Str_Of_Unit_Symbols; |
| |
| --------- |
| -- GCD -- |
| --------- |
| |
| function GCD (Left, Right : Whole) return Int is |
| L : Whole; |
| R : Whole; |
| |
| begin |
| L := Left; |
| R := Right; |
| 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; |
| |
| -------------------------- |
| -- Has_Dimension_System -- |
| -------------------------- |
| |
| function Has_Dimension_System (Typ : Entity_Id) return Boolean is |
| begin |
| return Exists (System_Of (Typ)); |
| end Has_Dimension_System; |
| |
| ------------------------------ |
| -- Is_Dim_IO_Package_Entity -- |
| ------------------------------ |
| |
| function Is_Dim_IO_Package_Entity (E : Entity_Id) return Boolean is |
| begin |
| -- Check the package entity corresponds to System.Dim.Float_IO or |
| -- System.Dim.Integer_IO. |
| |
| return |
| Is_RTU (E, System_Dim_Float_IO) |
| or else |
| Is_RTU (E, System_Dim_Integer_IO); |
| end Is_Dim_IO_Package_Entity; |
| |
| ------------------------------------- |
| -- Is_Dim_IO_Package_Instantiation -- |
| ------------------------------------- |
| |
| function Is_Dim_IO_Package_Instantiation (N : Node_Id) return Boolean is |
| Gen_Id : constant Node_Id := Name (N); |
| |
| begin |
| -- Check that the instantiated package is either System.Dim.Float_IO |
| -- or System.Dim.Integer_IO. |
| |
| return |
| Is_Entity_Name (Gen_Id) |
| and then Is_Dim_IO_Package_Entity (Entity (Gen_Id)); |
| end Is_Dim_IO_Package_Instantiation; |
| |
| ---------------- |
| -- Is_Invalid -- |
| ---------------- |
| |
| function Is_Invalid (Position : Dimension_Position) return Boolean is |
| begin |
| return Position = Invalid_Position; |
| end Is_Invalid; |
| |
| --------------------- |
| -- Move_Dimensions -- |
| --------------------- |
| |
| procedure Move_Dimensions (From, To : Node_Id) is |
| begin |
| if Ada_Version < Ada_2012 then |
| return; |
| end if; |
| |
| -- Copy the dimension of 'From to 'To' and remove dimension of 'From' |
| |
| Copy_Dimensions (From, To); |
| Remove_Dimensions (From); |
| end Move_Dimensions; |
| |
| --------------------------------------- |
| -- New_Copy_Tree_And_Copy_Dimensions -- |
| --------------------------------------- |
| |
| function New_Copy_Tree_And_Copy_Dimensions |
| (Source : Node_Id; |
| Map : Elist_Id := No_Elist; |
| New_Sloc : Source_Ptr := No_Location; |
| New_Scope : Entity_Id := Empty) return Node_Id |
| is |
| New_Copy : constant Node_Id := |
| New_Copy_Tree (Source, Map, New_Sloc, New_Scope); |
| |
| begin |
| -- Move the dimensions of Source to New_Copy |
| |
| Copy_Dimensions (Source, New_Copy); |
| return New_Copy; |
| end New_Copy_Tree_And_Copy_Dimensions; |
| |
| ------------ |
| -- Reduce -- |
| ------------ |
| |
| function Reduce (X : Rational) return Rational is |
| begin |
| if X.Numerator = 0 then |
| return Zero; |
| 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; |
| |
| ----------------------- |
| -- Remove_Dimensions -- |
| ----------------------- |
| |
| procedure Remove_Dimensions (N : Node_Id) is |
| Dims_Of_N : constant Dimension_Type := Dimensions_Of (N); |
| begin |
| if Exists (Dims_Of_N) then |
| Dimension_Table.Remove (N); |
| end if; |
| end Remove_Dimensions; |
| |
| ----------------------------------- |
| -- 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 (Stmt : Node_Id) is |
| begin |
| if Ada_Version < Ada_2012 then |
| return; |
| end if; |
| |
| -- Remove dimension in parameter specifications for accept statement |
| |
| if Nkind (Stmt) = N_Accept_Statement then |
| declare |
| Param : Node_Id := First (Parameter_Specifications (Stmt)); |
| begin |
| while Present (Param) loop |
| Remove_Dimensions (Param); |
| Next (Param); |
| end loop; |
| end; |
| |
| -- Remove dimension of name and expression in assignments |
| |
| elsif Nkind (Stmt) = N_Assignment_Statement then |
| Remove_Dimensions (Expression (Stmt)); |
| Remove_Dimensions (Name (Stmt)); |
| end if; |
| end Remove_Dimension_In_Statement; |
| |
| -------------------- |
| -- Set_Dimensions -- |
| -------------------- |
| |
| procedure Set_Dimensions (N : Node_Id; Val : Dimension_Type) is |
| begin |
| pragma Assert (OK_For_Dimension (Nkind (N))); |
| pragma Assert (Exists (Val)); |
| |
| Dimension_Table.Set (N, Val); |
| end Set_Dimensions; |
| |
| ---------------- |
| -- Set_Symbol -- |
| ---------------- |
| |
| procedure Set_Symbol (E : Entity_Id; Val : String_Id) is |
| begin |
| Symbol_Table.Set (E, Val); |
| end Set_Symbol; |
| |
| --------------- |
| -- Symbol_Of -- |
| --------------- |
| |
| function Symbol_Of (E : Entity_Id) return String_Id is |
| Subtype_Symbol : constant String_Id := Symbol_Table.Get (E); |
| begin |
| if Subtype_Symbol /= No_String then |
| return Subtype_Symbol; |
| else |
| return From_Dim_To_Str_Of_Unit_Symbols |
| (Dimensions_Of (E), System_Of (Base_Type (E))); |
| end if; |
| end Symbol_Of; |
| |
| ----------------------- |
| -- Symbol_Table_Hash -- |
| ----------------------- |
| |
| function Symbol_Table_Hash (Key : Entity_Id) return Symbol_Table_Range is |
| begin |
| return Symbol_Table_Range (Key mod 511); |
| end Symbol_Table_Hash; |
| |
| --------------- |
| -- System_Of -- |
| --------------- |
| |
| function System_Of (E : Entity_Id) return System_Type is |
| begin |
| if Present (E) then |
| declare |
| Type_Decl : constant Node_Id := Parent (E); |
| begin |
| -- Look for Type_Decl in System_Table |
| |
| for Dim_Sys in 1 .. System_Table.Last loop |
| if Type_Decl = System_Table.Table (Dim_Sys).Type_Decl then |
| return System_Table.Table (Dim_Sys); |
| end if; |
| end loop; |
| end; |
| end if; |
| |
| return Null_System; |
| end System_Of; |
| |
| end Sem_Dim; |