diff options
| author | Arnaud Charlet <charlet@gcc.gnu.org> | 2011-12-21 12:53:33 +0100 |
|---|---|---|
| committer | Arnaud Charlet <charlet@gcc.gnu.org> | 2011-12-21 12:53:33 +0100 |
| commit | 6c57023b0cdc7fccc7db3963f847dbef53d43de8 (patch) | |
| tree | 9ec76b82be58b48862686ea14e152c094cd33dea /gcc | |
| parent | 26cd9add744f5649af087552808b388c3109b53a (diff) | |
| download | gcc-6c57023b0cdc7fccc7db3963f847dbef53d43de8.zip gcc-6c57023b0cdc7fccc7db3963f847dbef53d43de8.tar.gz gcc-6c57023b0cdc7fccc7db3963f847dbef53d43de8.tar.bz2 | |
[multiple changes]
2011-12-21 Gary Dismukes <dismukes@adacore.com>
* gnat_ugn.texi: Minor reformatting.
2011-12-21 Ed Schonberg <schonberg@adacore.com>
* exp_ch5.adb (Expand_Iterator_Loop): The cursor operation
Has_Element is the formal of Iterator_Interfaces, and within
the instantion of this package it is a renaming of some local
function with an unrelated name. Retrieve the operation from
the instance itself, not from the container package.
2011-12-21 Vincent Pucci <pucci@adacore.com>
* exp_ch6.adb (Expand_Call): Expand_Put_Call_With_Dimension_String
replaced by Expand_Put_Call_With_Dimension_Symbol
* sem_ch12.adb (Analyze_Package_Instantiation): New check for
System.Dim_Float_IO and System.Dim_Integer_IO instantiation.
* sem_ch3.adb (Analyze_Declarations): Removed
Remove_Dimension_In_Declaration call.
* sem_dim.adb: Update comments. Redefine the
representation of a Rational. Propagate all changes involving
data structures and types throughout the pakage. Output the
dimension aggregates for each error messages.
("/"): Rational constructor "/" removed for Whole operands.
("/"): New rational operation "/" for Rational operands.
("*"): Operation "*" between Rational and Int removed.
("abs"): New unary operator "abs" for Rational.
(Analyze_Aspect_Dimension_System): Reorganized.
(Analyze_Dimension_Identifier): Removed.
(Copy_Dimensions): Removed.
(Create_Rational_From_Expr): New Boolean parameter.
(Dimensions_Msg_Of): New routine. Return
a string with the dimensions of the parameter.
(From_Dimension_To_String_Of_Symbols): Renaming of
From_Dimension_To_String_Id.
* sem_dim.ads: Update comments.
(Is_Dim_IO_Package_Instantiation): New routine.
(Remove_Dimension_In_Declaration): Removed.
* sem_res.adb (Resolve_Op_Expon): Reorganized calls of
Eval_Op_Expon_For_Dimensioned_Type and Eval_Op_Expon.
* s-diflio.ads, s-diinio.ads: Update comments.
From-SVN: r182575
Diffstat (limited to 'gcc')
| -rw-r--r-- | gcc/ada/ChangeLog | 43 | ||||
| -rw-r--r-- | gcc/ada/exp_ch5.adb | 80 | ||||
| -rw-r--r-- | gcc/ada/exp_ch6.adb | 2 | ||||
| -rw-r--r-- | gcc/ada/gnat_ugn.texi | 10 | ||||
| -rw-r--r-- | gcc/ada/s-diflio.ads | 3 | ||||
| -rw-r--r-- | gcc/ada/s-diinio.ads | 3 | ||||
| -rw-r--r-- | gcc/ada/sem_ch12.adb | 18 | ||||
| -rw-r--r-- | gcc/ada/sem_ch3.adb | 5 | ||||
| -rw-r--r-- | gcc/ada/sem_dim.adb | 2066 | ||||
| -rw-r--r-- | gcc/ada/sem_dim.ads | 37 | ||||
| -rw-r--r-- | gcc/ada/sem_res.adb | 15 |
11 files changed, 1219 insertions, 1063 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 50a0ba8..3850fa6 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,46 @@ +2011-12-21 Gary Dismukes <dismukes@adacore.com> + + * gnat_ugn.texi: Minor reformatting. + +2011-12-21 Ed Schonberg <schonberg@adacore.com> + + * exp_ch5.adb (Expand_Iterator_Loop): The cursor operation + Has_Element is the formal of Iterator_Interfaces, and within + the instantion of this package it is a renaming of some local + function with an unrelated name. Retrieve the operation from + the instance itself, not from the container package. + +2011-12-21 Vincent Pucci <pucci@adacore.com> + + * exp_ch6.adb (Expand_Call): Expand_Put_Call_With_Dimension_String + replaced by Expand_Put_Call_With_Dimension_Symbol + * sem_ch12.adb (Analyze_Package_Instantiation): New check for + System.Dim_Float_IO and System.Dim_Integer_IO instantiation. + * sem_ch3.adb (Analyze_Declarations): Removed + Remove_Dimension_In_Declaration call. + * sem_dim.adb: Update comments. Redefine the + representation of a Rational. Propagate all changes involving + data structures and types throughout the pakage. Output the + dimension aggregates for each error messages. + ("/"): Rational constructor "/" removed for Whole operands. + ("/"): New rational operation "/" for Rational operands. + ("*"): Operation "*" between Rational and Int removed. + ("abs"): New unary operator "abs" for Rational. + (Analyze_Aspect_Dimension_System): Reorganized. + (Analyze_Dimension_Identifier): Removed. + (Copy_Dimensions): Removed. + (Create_Rational_From_Expr): New Boolean parameter. + (Dimensions_Msg_Of): New routine. Return + a string with the dimensions of the parameter. + (From_Dimension_To_String_Of_Symbols): Renaming of + From_Dimension_To_String_Id. + * sem_dim.ads: Update comments. + (Is_Dim_IO_Package_Instantiation): New routine. + (Remove_Dimension_In_Declaration): Removed. + * sem_res.adb (Resolve_Op_Expon): Reorganized calls of + Eval_Op_Expon_For_Dimensioned_Type and Eval_Op_Expon. + * s-diflio.ads, s-diinio.ads: Update comments. + 2011-12-21 Pascal Obry <obry@adacore.com> * prj-attr.adb, snames.ads-tmpl: Add Library_Standalone, diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb index d7f3099..a09eb08 100644 --- a/gcc/ada/exp_ch5.adb +++ b/gcc/ada/exp_ch5.adb @@ -3049,10 +3049,6 @@ package body Exp_Ch5 is Iter_Type := Etype (Name (I_Spec)); - if Is_Iterator (Iter_Type) then - Pack := Scope (Pack); - end if; - -- The "of" case uses an internally generated cursor whose type -- is found in the container package. The domain of iteration -- is expanded into a call to the default Iterator function, but @@ -3074,41 +3070,41 @@ package body Exp_Ch5 is begin Cursor := Make_Temporary (Loc, 'I'); - if Is_Iterator (Iter_Type) then - null; - - else - Iter_Type := Etype (Default_Iter); + -- For an container element iterator, the iterator type + -- is obtained from the corresponding aspect. - -- Rewrite domain of iteration as a call to the default - -- iterator for the container type. If the container is - -- a derived type and the aspect is inherited, convert - -- container to parent type. The Cursor type is also - -- inherited from the scope of the parent. + Iter_Type := Etype (Default_Iter); + Pack := Scope (Iter_Type); - if Base_Type (Etype (Container)) = - Base_Type (Etype (First_Formal (Default_Iter))) - then - Container_Arg := New_Copy_Tree (Container); + -- Rewrite domain of iteration as a call to the default + -- iterator for the container type. If the container is + -- a derived type and the aspect is inherited, convert + -- container to parent type. The Cursor type is also + -- inherited from the scope of the parent. - else - Container_Arg := - Make_Type_Conversion (Loc, - Subtype_Mark => - New_Occurrence_Of - (Etype (First_Formal (Default_Iter)), Loc), - Expression => New_Copy_Tree (Container)); - end if; + if Base_Type (Etype (Container)) = + Base_Type (Etype (First_Formal (Default_Iter))) + then + Container_Arg := New_Copy_Tree (Container); - Rewrite (Name (I_Spec), - Make_Function_Call (Loc, - Name => New_Occurrence_Of (Default_Iter, Loc), - Parameter_Associations => - New_List (Container_Arg))); - Analyze_And_Resolve (Name (I_Spec)); + else + Container_Arg := + Make_Type_Conversion (Loc, + Subtype_Mark => + New_Occurrence_Of + (Etype (First_Formal (Default_Iter)), Loc), + Expression => New_Copy_Tree (Container)); end if; - -- Find cursor type in proper container package. + Rewrite (Name (I_Spec), + Make_Function_Call (Loc, + Name => New_Occurrence_Of (Default_Iter, Loc), + Parameter_Associations => + New_List (Container_Arg))); + Analyze_And_Resolve (Name (I_Spec)); + + -- Find cursor type in proper iterator package, which + -- is an instantiation of Iterator_Interfaces. Ent := First_Entity (Pack); while Present (Ent) loop @@ -3145,7 +3141,7 @@ package body Exp_Ch5 is -- Generate: -- declare - -- Id : Element_Type := Pack.Element (curosr); + -- Id : Element_Type := Element (curosr); -- begin -- <original loop statements> -- end; @@ -3222,6 +3218,8 @@ package body Exp_Ch5 is -- while Iterator.Has_Element loop -- <Stats> -- end loop; + -- + -- Has_Element is the second actual in the iterator package New_Loop := Make_Loop_Statement (Loc, @@ -3230,16 +3228,18 @@ package body Exp_Ch5 is Condition => Make_Function_Call (Loc, Name => - Make_Selected_Component (Loc, - Prefix => New_Occurrence_Of (Pack, Loc), - Selector_Name => - Make_Identifier (Loc, Name_Has_Element)), - + New_Occurrence_Of ( + Next_Entity (First_Entity (Pack)), Loc), Parameter_Associations => New_List ( New_Reference_To (Cursor, Loc)))), + Statements => Stats, End_Label => Empty); + -- Make_Selected_Component (Loc, + -- Prefix => New_Reference_To (Cursor, Loc), + -- Selector_Name => + -- Make_Identifier (Loc, Name_Has_Element))), -- Create the declarations for Iterator and cursor and insert then -- before the source loop. Given that the domain of iteration is @@ -3248,7 +3248,7 @@ package body Exp_Ch5 is -- Generate: -- I : Iterator_Type renames Container; - -- C : Pack.Cursor_Type := Container.[First | Last]; + -- C : Cursor_Type := Container.[First | Last]; Insert_Action (N, Make_Object_Renaming_Declaration (Loc, diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index 7a55ad8..227dcd9 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -2111,7 +2111,7 @@ package body Exp_Ch6 is and then Nkind (Call_Node) = N_Procedure_Call_Statement and then Present (Parameter_Associations (Call_Node)) then - Expand_Put_Call_With_Dimension_String (Call_Node); + Expand_Put_Call_With_Dimension_Symbol (Call_Node); end if; -- Remove the dimensions of every parameters in call diff --git a/gcc/ada/gnat_ugn.texi b/gcc/ada/gnat_ugn.texi index 02a577c..16b9acc 100644 --- a/gcc/ada/gnat_ugn.texi +++ b/gcc/ada/gnat_ugn.texi @@ -16360,12 +16360,12 @@ imported from Ada units outside of the library. If other units are imported, the binding phase will fail. @noindent -It is also possible to build a fully standalone library where not only +It is also possible to build a fully stand-alone library where not only the code to elaborate and finalize the library is embedded but also ensuring that the library is linked only against static -libraries. So a fully standalone library only depends on system +libraries. So a fully stand-alone library only depends on system libraries, all other code, including the GNAT runtime, is embedded. To -build a fully standalone library the attribute +build a fully stand-alone library the attribute @code{Library_Standalone} must be set to @code{full}: @smallexample @c projectfile @@ -16379,7 +16379,7 @@ build a fully standalone library the attribute @noindent The default value for this attribute is @code{standard} in which case -a not fully standalone library is built. +a not fully stand-alone library is built. The attribute @code{Library_Src_Dir} may be specified for a Stand-Alone Library. @code{Library_Src_Dir} is a simple attribute that has a @@ -18530,7 +18530,7 @@ g++ -c -fdump-ada-spec -DXLIB_ILLEGAL_ACCESS -C /usr/include/X11/Xlib.h The above will generate more complete bindings than a straight call without the @option{-DXLIB_ILLEGAL_ACCESS} switch. -In other cases, it is not possible to parse a header file in a stand alone +In other cases, it is not possible to parse a header file in a stand-alone manner, because other include files need to be included first. In this case, the solution is to create a small header file including the needed @code{#include} and possible @code{#define} directives. For example, to diff --git a/gcc/ada/s-diflio.ads b/gcc/ada/s-diflio.ads index 1b00d27..0a952de 100644 --- a/gcc/ada/s-diflio.ads +++ b/gcc/ada/s-diflio.ads @@ -29,9 +29,6 @@ -- -- ------------------------------------------------------------------------------ --- Note that this package should only be instantiated with a float dimensioned --- type. Shouldn't this be checked??? - -- This package is a generic package that provides IO facilities for float -- dimensioned types. diff --git a/gcc/ada/s-diinio.ads b/gcc/ada/s-diinio.ads index ca29d3c..098b880 100644 --- a/gcc/ada/s-diinio.ads +++ b/gcc/ada/s-diinio.ads @@ -29,9 +29,6 @@ -- -- ------------------------------------------------------------------------------ --- Note that this package should only be instantiated with an integer --- dimensioned type. Shouldn't this be checked ??? - -- This package is a generic package that provides IO facilities for integer -- dimensioned types. diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index 315b795..c83c101 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -54,6 +54,7 @@ with Sem_Ch7; use Sem_Ch7; with Sem_Ch8; use Sem_Ch8; with Sem_Ch10; use Sem_Ch10; with Sem_Ch13; use Sem_Ch13; +with Sem_Dim; use Sem_Dim; with Sem_Disp; use Sem_Disp; with Sem_Elab; use Sem_Elab; with Sem_Elim; use Sem_Elim; @@ -3786,6 +3787,23 @@ package body Sem_Ch12 is Style_Check := Save_Style_Check; + -- Check that if N is an instantiation of System.Dim_Float_IO or + -- System.Dim_Integer_IO, the formal type has a dimension system. + + if Nkind (N) = N_Package_Instantiation + and then Is_Dim_IO_Package_Instantiation (N) + then + declare + Assoc : constant Node_Id := First (Generic_Associations (N)); + + begin + if not Has_Dimension_System + (Etype (Explicit_Generic_Actual_Parameter (Assoc))) then + Error_Msg_N ("type with a dimension system expected", Assoc); + end if; + end; + end if; + <<Leave>> if Has_Aspects (N) then Analyze_Aspect_Specifications (N, Act_Decl_Id); diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index d468c73..69c5ebf 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -2092,11 +2092,6 @@ package body Sem_Ch3 is -- Complete analysis of declaration Analyze (D); - - -- Removal of the dimension in the expression for object & component - -- declaration. - - Remove_Dimension_In_Declaration (D); Next_Node := Next (D); if No (Freeze_From) then diff --git a/gcc/ada/sem_dim.adb b/gcc/ada/sem_dim.adb index 341ceda..18fbbf6 100644 --- a/gcc/ada/sem_dim.adb +++ b/gcc/ada/sem_dim.adb @@ -62,28 +62,32 @@ package body Sem_Dim is Denominator : Positive_Whole; end record; - Zero : constant Rational := (0, 1); + 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 "/" (Left, Right : Whole) return Rational; function GCD (Left, Right : Whole) return Int; function Reduce (X : Rational) return Rational; -- Unary operator for Rational function "-" (Right : Rational) return Rational; + 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; - - -- Operation between Rational and Int - - function "*" (Left : Rational; Right : Whole) return Rational; + function "/" (Left, Right : Rational) return Rational; ------------------ -- System types -- @@ -214,73 +218,89 @@ package body Sem_Dim is procedure Analyze_Dimension_Assignment_Statement (N : Node_Id); -- Subroutine of Analyze_Dimension for assignment statement - -- ??? what does this routine do? + -- 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 - -- ??? same here + -- 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 - -- ??? same here + -- 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 - -- ??? same here + -- Check that the dimensions of the returned type and of the returned + -- object match. procedure Analyze_Dimension_Function_Call (N : Node_Id); -- Subroutine of Analyze_Dimension for function call - -- ??? same here + -- General case: propagate the dimensions from the returned type to N. + -- Elementary function case (Ada.Numerics.Generic_Elementary_Functions): + -- If N is a Sqrt call, then evaluate the resulting dimensions as half the + -- dimensions of the parameter. Otherwise, verify that each parameters are + -- dimensionless. procedure Analyze_Dimension_Has_Etype (N : Node_Id); - -- Subroutine of Analyze_Dimension for N_Has_Etype nodes: + -- 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 - -- ??? poor comment, N_Has_Etype contains Node_Ids not listed above, what - -- about those? - - procedure Analyze_Dimension_Identifier (N : Node_Id); - -- Subroutine of Analyze_Dimension for identifier - -- ??? what does this routine do? procedure Analyze_Dimension_Object_Declaration (N : Node_Id); -- Subroutine of Analyze_Dimension for object declaration - -- ??? same here + -- 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 warning 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 - -- ??? same here + -- 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 - -- ??? same here + -- 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 - -- ??? same here + -- 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 message. procedure Analyze_Dimension_Unary_Op (N : Node_Id); -- Subroutine of Analyze_Dimension for unary operators - -- ??? same here + -- For Plus, Minus and Abs operators, propagate the dimensions from the + -- operand to N. - procedure Copy_Dimensions (From : Node_Id; To : Node_Id); - -- Copy the dimension vector from one node to another - - function Create_Rational_From_Expr (Expr : Node_Id) return Rational; - -- Given an expression, creates a rational number - -- ??? what does this expression represent? + 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) return String; + -- Given a node, return "has dimension" followed by the dimension vector of + -- N or "is dimensionless" if N is dimensionless. + procedure Eval_Op_Expon_With_Rational_Exponent - (N : Node_Id; - Rat : Rational); + (N : Node_Id; + Exponent_Value : Rational); -- Evaluate the Expon if the exponent is a rational and the operand has a -- dimension. @@ -290,7 +310,7 @@ package body Sem_Dim is function Exists (Sys : System_Type) return Boolean; -- Determine whether Sys does not denote the null system - function From_Dimension_To_String_Id + function From_Dimension_To_String_Of_Symbols (Dims : Dimension_Type; System : System_Type) return String_Id; -- Given a dimension vector and a dimension system, return the proper @@ -324,12 +344,13 @@ package body Sem_Dim is function "+" (Right : Whole) return Rational is begin - return (Right, 1); + return Rational'(Numerator => Right, + Denominator => 1); end "+"; function "+" (Left, Right : Rational) return Rational is R : constant Rational := - Rational'(Numerator => Left.Numerator * Right.Denominator + + Rational'(Numerator => Left.Numerator * Right.Denominator + Left.Denominator * Right.Numerator, Denominator => Left.Denominator * Right.Denominator); begin @@ -342,13 +363,13 @@ package body Sem_Dim is function "-" (Right : Rational) return Rational is begin - return Rational'(Numerator => -Right.Numerator, + 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 - + Rational'(Numerator => Left.Numerator * Right.Denominator - Left.Denominator * Right.Numerator, Denominator => Left.Denominator * Right.Denominator); @@ -362,38 +383,38 @@ package body Sem_Dim is function "*" (Left, Right : Rational) return Rational is R : constant Rational := - Rational'(Numerator => Left.Numerator * Right.Numerator, + Rational'(Numerator => Left.Numerator * Right.Numerator, Denominator => Left.Denominator * Right.Denominator); begin return Reduce (R); end "*"; - function "*" (Left : Rational; Right : Whole) return Rational is - R : constant Rational := - Rational'(Numerator => Left.Numerator * Right, - Denominator => Left.Denominator); - - begin - return Reduce (R); - end "*"; - --------- -- "/" -- --------- - function "/" (Left, Right : Whole) return Rational is - R : constant Int := abs Int (Right); - L : Int := Int (Left); + function "/" (Left, Right : Rational) return Rational is + R : constant Rational := abs Right; + L : Rational := Left; begin - if Right < 0 then - L := -L; + if Right.Numerator < 0 then + L.Numerator := Whole (-Integer (L.Numerator)); end if; - return Reduce (Rational'(Numerator => Whole (L), - Denominator => Whole (R))); + 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 -- @@ -405,18 +426,16 @@ package body Sem_Dim is -- RATIONAL, {, RATIONAL} -- | RATIONAL {, RATIONAL}, others => RATIONAL -- | DISCRETE_CHOICE_LIST => RATIONAL + -- RATIONAL ::= [-] NUMERAL [/ NUMERAL] -- (see Analyze_Aspect_Dimension_System for DIMENSION_STRING grammar) procedure Analyze_Aspect_Dimension (N : Node_Id; - Id : Node_Id; + Id : Entity_Id; Aggr : Node_Id) is - Def_Id : constant Entity_Id := Defining_Identifier (N); - Typ : constant Entity_Id := Etype (Def_Id); - Base_Typ : constant Entity_Id := Base_Type (Typ); - System : constant System_Type := System_Of (Base_Typ); + 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 @@ -453,7 +472,7 @@ package body Sem_Dim is if Is_Integer_Type (Def_Id) then Dimensions (Position) := +Whole (UI_To_Int (Expr_Value (Expr))); else - Dimensions (Position) := Create_Rational_From_Expr (Expr); + Dimensions (Position) := Create_Rational_From (Expr, True); end if; Processed (Position) := True; @@ -533,8 +552,20 @@ package body Sem_Dim is Num_Dimensions : Nat := 0; Others_Seen : Boolean := False; Position : Nat := 0; + Sub_Ind : Node_Id; Symbol : String_Id; Symbol_Decl : 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 names and values in the aggregate + -- (Step 3). + -- 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 @@ -542,7 +573,18 @@ package body Sem_Dim is -- STEP 1: Legality of aspect if Nkind (N) /= N_Subtype_Declaration then - Error_Msg_NE ("aspect % must apply to subtype declaration", N, Id); + 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; @@ -562,7 +604,9 @@ package body Sem_Dim is -- declare a valid system. if not Exists (System) then - Error_Msg_NE ("parent type of % lacks dimension system", N, Def_Id); + Error_Msg_NE ("parent type of& lacks dimension system", + Sub_Ind, + Def_Id); return; end if; @@ -583,6 +627,10 @@ package body Sem_Dim is -- STEP 3: Name and value extraction + -- Get the number of errors detected by the compiler so far + + Errors_Count := Serious_Errors_Detected; + -- Positional elements Expr := Next (Symbol_Decl); @@ -590,8 +638,8 @@ package body Sem_Dim is while Present (Expr) loop if Position > High_Position_Bound then Error_Msg_N - ("type has more dimensions than system allows", Def_Id); - return; + ("type& has more dimensions than system allows", Def_Id); + exit; end if; Extract_Power (Expr, Position); @@ -617,12 +665,11 @@ package body Sem_Dim is Position := Position_In_System (Choice, System); if Is_Invalid (Position) then - Error_Msg_N ("dimension name not part of system", Choice); - return; + Error_Msg_N ("dimension name& not part of system", Choice); + else + Extract_Power (Expr, Position); end if; - Extract_Power (Expr, Position); - -- Range case: NAME .. NAME => EXPRESSION elsif Nkind (Choice) = N_Range then @@ -635,67 +682,64 @@ package body Sem_Dim is begin if Nkind (Low) /= N_Identifier then Error_Msg_N ("bound must denote a dimension name", Low); - return; elsif Nkind (High) /= N_Identifier then Error_Msg_N ("bound must denote a dimension name", High); - return; - end if; + else + Low_Pos := Position_In_System (Low, System); + High_Pos := Position_In_System (High, System); - 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); - if Is_Invalid (Low_Pos) then - Error_Msg_N ("dimension name not part of system", Low); - return; + elsif Is_Invalid (High_Pos) then + Error_Msg_N ("dimension name& not part of system", + High); - elsif Is_Invalid (High_Pos) then - Error_Msg_N ("dimension name not part of system", High); - return; + elsif Low_Pos > High_Pos then + Error_Msg_N ("expected low to high range", Choice); - elsif Low_Pos > High_Pos then - Error_Msg_N ("expected low to high range", Choice); - return; + else + for Position in Low_Pos .. High_Pos loop + Extract_Power (Expr, Position); + end loop; + end if; end if; - - for Position in Low_Pos .. High_Pos loop - Extract_Power (Expr, Position); - end loop; end; -- Others case: OTHERS => EXPRESSION elsif Nkind (Choice) = N_Others_Choice then - if Present (Next (Choice)) then + if Present (Next (Choice)) + or else Present (Prev (Choice)) + then Error_Msg_N ("OTHERS must appear alone in a choice list", Choice); - return; elsif Present (Next (Assoc)) then Error_Msg_N ("OTHERS must appear last in an aggregate", Choice); - return; elsif Others_Seen then Error_Msg_N ("multiple OTHERS not allowed", Choice); - return; - end if; - Others_Seen := True; + else + -- Fill the non-processed dimensions with the default value + -- supplied by others. - -- 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; - for Position in Processed'Range loop - if not Processed (Position) then - Extract_Power (Expr, Position); - end if; - end loop; + Others_Seen := True; -- All other cases are erroneous declarations of dimension names else - Error_Msg_N ("wrong syntax for aspect%", Choice); - return; + Error_Msg_NE ("wrong syntax for aspect&", Choice, Id); end if; Num_Choices := Num_Choices + 1; @@ -718,10 +762,10 @@ package body Sem_Dim is ("named associations cannot follow positional associations", Aggr); elsif Num_Dimensions > System.Count then - Error_Msg_N ("type has more dimensions than system allows", Def_Id); + 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); + Error_Msg_N ("type& has less dimensions than system allows", Def_Id); end if; -- STEP 5: Dimension symbol extraction @@ -740,12 +784,16 @@ package body Sem_Dim is -- STEP 6: Storage of extracted values - if String_Length (Symbol) /= 0 then - Set_Symbol (Def_Id, Symbol); - end if; + -- Check that no errors have been detected during the analysis - if Exists (Dimensions) then - Set_Dimensions (Def_Id, Dimensions); + if Errors_Count = Serious_Errors_Detected then + if String_Length (Symbol) /= 0 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; @@ -769,214 +817,156 @@ package body Sem_Dim is procedure Analyze_Aspect_Dimension_System (N : Node_Id; - Id : Node_Id; - Expr : Node_Id) + Id : Entity_Id; + Aggr : Node_Id) is - Dim_Name : Node_Id; - Dim_Node : Node_Id; - Dim_Symbol : Node_Id; - D_Sys : System_Type := Null_System; - Names : Name_Array := No_Names; - N_Of_Dims : Dimension_Position; - Symbols : Symbol_Array := No_Symbols; - - function Derived_From_Numeric_Type (N : Node_Id) return Boolean; - -- Return True if the node is a derived type declaration from any - -- numeric type. - - function Check_Dimension_System_Syntax (N : Node_Id) return Boolean; - -- Return True if the expression is an aggregate of names - - function Check_Number_Of_Dimensions (Expr : Node_Id) return Boolean; - -- Return True if the number of dimensions in the corresponding - -- dimension is positive and lower than Max_Number_Of_Dimensions. + function Is_Derived_Numeric_Type (N : Node_Id) return Boolean; + -- Determine whether type declaration N denotes a numeric derived type ------------------------------- - -- Derived_From_Numeric_Type -- + -- Is_Derived_Numeric_Type -- ------------------------------- - function Derived_From_Numeric_Type (N : Node_Id) return Boolean is + function Is_Derived_Numeric_Type (N : Node_Id) return Boolean is begin - case (Nkind (N)) is - when N_Full_Type_Declaration => - declare - T_Def : constant Node_Id := Type_Definition (N); - Ent : Entity_Id; + 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 + + Dim_Name : Node_Id; + Dim_Pair : Node_Id; + Dim_Symbol : Node_Id; + Dim_System : System_Type := Null_System; + Names : Name_Array := No_Names; + Position : Nat := 0; + 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 to Serious_Errors_Detected i.e. no erros have been + -- encountered during the process. Otherwise the System_Table is not + -- filled. - begin - -- Check that the node is a derived type declaration from - -- a numeric type. - - if Nkind (T_Def) /= N_Derived_Type_Definition then - return False; - else - Ent := Entity (Subtype_Indication (T_Def)); - - if Is_Numeric_Type (Ent) then - return True; - else - return False; - end if; - end if; - end; - - when others => return False; - end case; - end Derived_From_Numeric_Type; - - ----------------------------------- - -- Check_Dimension_System_Syntax -- - ----------------------------------- - - -- Check that the expression of aspect Dimension_System is an aggregate - -- which contains pairs of identifier and string or character literal. - - function Check_Dimension_System_Syntax (N : Node_Id) return Boolean is - Dim_Node : Node_Id; - Expr_Dim : Node_Id; - - begin - -- Chek that the aggregate is a positional array - - if Present (Component_Associations (N)) then - return False; - - else - -- Check that each component of the aggregate is an aggregate - - Dim_Node := First (Expressions (N)); - while Present (Dim_Node) loop - - -- Verify that the aggregate is a pair of identifier and string - -- or character literal. - - if Nkind (Dim_Node) = N_Aggregate then - if not Present (Expressions (Dim_Node)) then - return False; - end if; - - if Present (Component_Associations (Dim_Node)) then - return False; - end if; - - -- First expression in the aggregate - - Expr_Dim := First (Expressions (Dim_Node)); + -- Start of processing for Analyze_Aspect_Dimension_System - if Nkind (Expr_Dim) /= N_Identifier then - return False; - end if; + begin + -- STEP 1: Legality of aspect - -- Second expression in the aggregate + if not Is_Derived_Numeric_Type (N) then + Error_Msg_NE + ("aspect& must apply to numeric derived type declaration", N, Id); + return; + end if; - Next (Expr_Dim); + if Nkind (Aggr) /= N_Aggregate then + Error_Msg_N ("aggregate expected", Aggr); + return; + end if; - if not Nkind_In (Expr_Dim, - N_String_Literal, - N_Character_Literal) - then - return False; - end if; + -- STEP 2: Structural verification of the dimension aggregate - -- If the aggregate has a third expression, return False + if Present (Component_Associations (Aggr)) then + Error_Msg_N ("expected positional aggregate", Aggr); + return; + end if; - Next (Expr_Dim); + -- STEP 3: Name and Symbol extraction - if Present (Expr_Dim) then - return False; - end if; - else - return False; - end if; + Dim_Pair := First (Expressions (Aggr)); + Errors_Count := Serious_Errors_Detected; - Next (Dim_Node); - end loop; + while Present (Dim_Pair) loop + Position := Position + 1; - return True; + if Position > High_Position_Bound then + Error_Msg_N + ("too many dimensions in system", Aggr); + exit; end if; - end Check_Dimension_System_Syntax; - -------------------------------- - -- Check_Number_Of_Dimensions -- - -------------------------------- + if Nkind (Dim_Pair) /= N_Aggregate then + Error_Msg_N ("aggregate expected", Dim_Pair); - function Check_Number_Of_Dimensions (Expr : Node_Id) return Boolean is - List_Expr : constant List_Id := Expressions (Expr); - begin - if List_Length (List_Expr) < Dimension_Position'First - or else List_Length (List_Expr) > Max_Number_Of_Dimensions - then - return False; else - return True; - end if; - end Check_Number_Of_Dimensions; - - -- Start of processing for Analyze_Aspect_Dimension_System - - begin - -- Error_Msg_Name_1 := Chars (Id); - - -- Syntax checking - - if Nkind (Expr) /= N_Aggregate then - Error_Msg_N ("wrong syntax for aspect%", Expr); - return; - end if; + if Present (Component_Associations (Dim_Pair)) then + Error_Msg_N ("expected positional aggregate", Dim_Pair); - if not Derived_From_Numeric_Type (N) then - Error_Msg_N - ("aspect% only apply for type derived from numeric type", Id); - return; - end if; + else + if List_Length (Expressions (Dim_Pair)) = 2 then + Dim_Name := First (Expressions (Dim_Pair)); + Dim_Symbol := Next (Dim_Name); - if not Check_Dimension_System_Syntax (Expr) then - Error_Msg_N ("wrong syntax for aspect%", Expr); - return; - end if; + -- Check the first argument for each pair is a name - if not Check_Number_Of_Dimensions (Expr) then - Error_Msg_N ("wrong number of dimensions for aspect%", Expr); - return; - end if; + if Nkind (Dim_Name) = N_Identifier then + Names (Position) := Chars (Dim_Name); + else + Error_Msg_N ("expected dimension name", Dim_Name); + end if; - -- Number of dimensions in the system + -- Check the second argument for each pair is a string or a + -- character. - N_Of_Dims := List_Length (Expressions (Expr)); + if not Nkind_In + (Dim_Symbol, + N_String_Literal, + N_Character_Literal) + then + Error_Msg_N ("expected dimension string or character", + Dim_Symbol); - -- Create the new dimension system + else + -- String case - D_Sys.Type_Decl := N; - Dim_Node := First (Expressions (Expr)); + if Nkind (Dim_Symbol) = N_String_Literal then + Symbols (Position) := Strval (Dim_Symbol); - for Dim in Names'First .. N_Of_Dims loop - Dim_Name := First (Expressions (Dim_Node)); - Names (Dim) := Chars (Dim_Name); - Dim_Symbol := Next (Dim_Name); + -- Character case - -- N_Character_Literal case + else + Start_String; + Store_String_Char + (UI_To_CC (Char_Literal_Value (Dim_Symbol))); + Symbols (Position) := End_String; + end if; - if Nkind (Dim_Symbol) = N_Character_Literal then - Start_String; - Store_String_Char (UI_To_CC (Char_Literal_Value (Dim_Symbol))); - Symbols (Dim) := End_String; + -- Verify that the string is not empty - -- N_String_Literal case + if String_Length (Symbols (Position)) = 0 then + Error_Msg_N ("empty string not allowed here", + Dim_Symbol); + end if; + end if; - else - Symbols (Dim) := Strval (Dim_Symbol); + else + Error_Msg_N ("two expressions expected in aggregate", + Dim_Pair); + end if; + end if; end if; - Next (Dim_Node); + Next (Dim_Pair); end loop; - D_Sys.Names := Names; - D_Sys.Count := N_Of_Dims; - D_Sys.Symbols := Symbols; + -- STEP 4: Storage of extracted values - -- Store the dimension system in the Table + -- Check that no errors have been detected during the analysis - System_Table.Append (D_Sys); + if Errors_Count = Serious_Errors_Detected then + Dim_System.Type_Decl := N; + Dim_System.Names := Names; + Dim_System.Count := Position; + Dim_System.Symbols := Symbols; + System_Table.Append (Dim_System); + end if; end Analyze_Aspect_Dimension_System; ----------------------- @@ -998,28 +988,20 @@ package body Sem_Dim is when N_Assignment_Statement => Analyze_Dimension_Assignment_Statement (N); - when N_Subtype_Declaration => - Analyze_Dimension_Subtype_Declaration (N); - - when N_Object_Declaration => - Analyze_Dimension_Object_Declaration (N); - - when N_Object_Renaming_Declaration => - Analyze_Dimension_Object_Renaming_Declaration (N); + when N_Binary_Op => + Analyze_Dimension_Binary_Op (N); when N_Component_Declaration => Analyze_Dimension_Component_Declaration (N); - when N_Binary_Op => - Analyze_Dimension_Binary_Op (N); - - when N_Unary_Op => - Analyze_Dimension_Unary_Op (N); + when N_Extended_Return_Statement => + Analyze_Dimension_Extended_Return_Statement (N); - when N_Identifier => - Analyze_Dimension_Identifier (N); + when N_Function_Call => + Analyze_Dimension_Function_Call (N); when N_Attribute_Reference | + N_Identifier | N_Indexed_Component | N_Qualified_Expression | N_Selected_Component | @@ -1028,14 +1010,22 @@ package body Sem_Dim is N_Unchecked_Type_Conversion => Analyze_Dimension_Has_Etype (N); - when N_Function_Call => - Analyze_Dimension_Function_Call (N); + when N_Object_Declaration => + Analyze_Dimension_Object_Declaration (N); - when N_Extended_Return_Statement => - Analyze_Dimension_Extended_Return_Statement (N); + when N_Object_Renaming_Declaration => + Analyze_Dimension_Object_Renaming_Declaration (N); when N_Simple_Return_Statement => - Analyze_Dimension_Simple_Return_Statement (N); + 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_Unary_Op => + Analyze_Dimension_Unary_Op (N); when others => null; @@ -1047,52 +1037,65 @@ package body Sem_Dim is -------------------------------------------- procedure Analyze_Dimension_Assignment_Statement (N : Node_Id) is - Lhs : constant Node_Id := Name (N); - Dim_Lhs : constant Dimension_Type := Dimensions_Of (Lhs); - Rhs : constant Node_Id := Expression (N); - Dim_Rhs : constant Dimension_Type := Dimensions_Of (Rhs); + 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 Analyze_Dimensions_In_Assignment - (Dim_Lhs : Dimension_Type; - Dim_Rhs : Dimension_Type); - -- Perform the dimensionality checking for assignment + procedure Error_Dim_For_Assignment_Statement (N, Lhs, Rhs : Node_Id); + -- Error using Error_Msg_N at node N + -- Output in the error message the dimensions of left and right hand + -- sides. - -------------------------------------- - -- Analyze_Dimensions_In_Assignment -- - -------------------------------------- + ---------------------------------------- + -- Error_Dim_For_Assignment_Statement -- + ---------------------------------------- - procedure Analyze_Dimensions_In_Assignment - (Dim_Lhs : Dimension_Type; - Dim_Rhs : Dimension_Type) - is + procedure Error_Dim_For_Assignment_Statement (N, Lhs, Rhs : Node_Id) is begin - -- Check the lhs and the rhs have the same dimension - - if not Exists (Dim_Lhs) then - if Exists (Dim_Rhs) then - Error_Msg_N ("?dimensions missmatch in assignment", N); - end if; - - else - if Dim_Lhs /= Dim_Rhs then - Error_Msg_N ("?dimensions missmatch in assignment", N); - end if; - end if; - end Analyze_Dimensions_In_Assignment; + Error_Msg_N ("?dimensions mismatch in assignment", N); + Error_Msg_N ("?left-hand side " & Dimensions_Msg_Of (Lhs), N); + Error_Msg_N ("?right-hand side " & Dimensions_Msg_Of (Rhs), N); + end Error_Dim_For_Assignment_Statement; -- Start of processing for Analyze_Dimension_Assignment begin - Analyze_Dimensions_In_Assignment (Dim_Lhs, Dim_Rhs); + if Dims_Of_Lhs /= Dims_Of_Rhs then + Error_Dim_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); + procedure Error_Dim_For_Binary_Op (N, L, R : Node_Id); + -- Error using Error_Msg_N at node N + -- Output in the error message the dimensions of both operands. + + ----------------------------- + -- Error_Dim_For_Binary_Op -- + ----------------------------- + + procedure Error_Dim_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), N); + Error_Msg_N ("?right operand " & Dimensions_Msg_Of (R), N); + end Error_Dim_For_Binary_Op; + + -- Start of processing for Analyze_Dimension_Binary_Op + begin if Nkind_In (N_Kind, N_Op_Add, N_Op_Expon, N_Op_Subtract) or else N_Kind in N_Multiplying_Operator @@ -1100,163 +1103,125 @@ package body Sem_Dim is then declare L : constant Node_Id := Left_Opnd (N); - L_Dims : constant Dimension_Type := Dimensions_Of (L); - L_Has_Dimensions : constant Boolean := Exists (L_Dims); + Dims_Of_L : constant Dimension_Type := Dimensions_Of (L); + L_Has_Dimensions : constant Boolean := Exists (Dims_Of_L); R : constant Node_Id := Right_Opnd (N); - R_Dims : constant Dimension_Type := Dimensions_Of (R); - R_Has_Dimensions : constant Boolean := Exists (R_Dims); - Dims : Dimension_Type := Null_Dimension; + Dims_Of_R : constant Dimension_Type := Dimensions_Of (R); + R_Has_Dimensions : constant Boolean := Exists (Dims_Of_R); + Dims_Of_N : Dimension_Type := Null_Dimension; begin - if Nkind_In (N, N_Op_Add, N_Op_Mod, N_Op_Rem, N_Op_Subtract) then - - -- What is the following deleted code about - -- Error_Msg_Name_1 := Chars (N); - - -- Check both operands dimension + -- N_Op_Add, N_Op_Mod, N_Op_Rem or N_Op_Subtract case - if L_Has_Dimensions and R_Has_Dimensions then - - -- If dimensions missmatch + if Nkind_In (N, N_Op_Add, N_Op_Mod, N_Op_Rem, N_Op_Subtract) then + -- Check both operands have same dimension - if L_Dims /= R_Dims then - Error_Msg_N - ("?both operands for operation% must have same " & - "dimension", N); - else - Set_Dimensions (N, L_Dims); + if Dims_Of_L /= Dims_Of_R then + Error_Dim_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; - - elsif not L_Has_Dimensions and R_Has_Dimensions then - Error_Msg_N - ("?both operands for operation% must have same dimension", - N); - - elsif L_Has_Dimensions and not R_Has_Dimensions then - Error_Msg_N - ("?both operands for operation% must have same dimension", - N); - end if; + -- N_Op_Multiply or N_Op_Divide case + elsif Nkind_In (N_Kind, N_Op_Multiply, N_Op_Divide) then - if L_Has_Dimensions and R_Has_Dimensions then + -- Check at least one operand is not dimensionless + + if L_Has_Dimensions or R_Has_Dimensions then - -- Get both operands dimension and add them + -- Multiplication case + -- Get both operands dimensions and add them if N_Kind = N_Op_Multiply then - for Dim in Dimension_Type'Range loop - Dims (Dim) := L_Dims (Dim) + R_Dims (Dim); + for Position in Dimension_Type'Range loop + Dims_Of_N (Position) := + Dims_Of_L (Position) + Dims_Of_R (Position); end loop; - -- Get both operands dimension and subtract them + -- Division case + -- Get both operands dimensions and subtract them else - for Dim in Dimension_Type'Range loop - Dims (Dim) := L_Dims (Dim) - R_Dims (Dim); + for Position in Dimension_Type'Range loop + Dims_Of_N (Position) := + Dims_Of_L (Position) - Dims_Of_R (Position); end loop; end if; - elsif L_Has_Dimensions and not R_Has_Dimensions then - Dims := L_Dims; - - elsif not L_Has_Dimensions and R_Has_Dimensions then - if N_Kind = N_Op_Multiply then - Dims := R_Dims; - else - for Dim in R_Dims'Range loop - Dims (Dim) := -R_Dims (Dim); - end loop; + if Exists (Dims_Of_N) then + Set_Dimensions (N, Dims_Of_N); end if; end if; - if Exists (Dims) then - Set_Dimensions (N, Dims); - end if; - - -- N_Op_Expon - - -- Propagation of the dimension and evaluation of the result if - -- the exponent is a rational and if the operand has a dimension. + -- N_Op_Expon case + -- Note that rational exponent are allowed for dimensioned operand elsif N_Kind = N_Op_Expon then - declare - Rat : Rational := Zero; - - begin - -- Check exponent is dimensionless + -- 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 R_Has_Dimensions then - Error_Msg_N - ("?right operand cannot have a dimension for&", - Identifier (N)); - - else - -- Check the left operand is not dimensionless - - -- Note that the value of the exponent must be know at - -- compile time. Otherwise, the exponentiation evaluation - -- will return an error message. - - if Exists (System_Of (Base_Type (Etype (L)))) - and then Compile_Time_Known_Value (R) - then - -- Real exponent case + if L_Has_Dimensions + and then Compile_Time_Known_Value (R) + then + declare + Exponent_Value : Rational := Zero; - if Is_Real_Type (Etype (L)) then + begin + -- Real operand case - -- Define the exponent as a Rational number + if Is_Real_Type (Etype (L)) then - Rat := Create_Rational_From_Expr (R); + -- Define the exponent as a Rational number - if L_Has_Dimensions then - for Dim in Dimension_Type'Range loop - Dims (Dim) := L_Dims (Dim) * Rat; - end loop; + Exponent_Value := Create_Rational_From (R, False); - if Exists (Dims) then - Set_Dimensions (N, Dims); - end if; - end if; + -- Verify that the exponent cannot be interpreted + -- as a rational, otherwise interpret the exponent + -- as an integer. - -- Evaluate the operator with rational exponent + if Exponent_Value = No_Rational then + Exponent_Value := + +Whole (UI_To_Int (Expr_Value (R))); + end if; - -- Eval_Op_Expon_With_Rational_Exponent (N, Rat); + -- Integer operand case + -- For integer operand, the exponent cannot be + -- interpreted as a rational. - -- Integer exponent case + else + Exponent_Value := +Whole (UI_To_Int (Expr_Value (R))); + end if; - else - for Dim in Dimension_Type'Range loop - Dims (Dim) := - L_Dims (Dim) * - Whole (UI_To_Int (Expr_Value (R))); - end loop; + for Position in Dimension_Type'Range loop + Dims_Of_N (Position) := + Dims_Of_L (Position) * Exponent_Value; + end loop; - if Exists (Dims) then - Set_Dimensions (N, Dims); - end if; - end if; + if Exists (Dims_Of_N) then + Set_Dimensions (N, Dims_Of_N); end if; - end if; - end; + end; + end if; + -- N_Op_Compare case -- For relational operations, only a dimension checking is -- performed (no propagation). elsif N_Kind in N_Op_Compare then - - -- What is this deleted code about ??? - -- Error_Msg_Name_1 := Chars (N); - if (L_Has_Dimensions or R_Has_Dimensions) - and then L_Dims /= R_Dims + and then Dims_Of_L /= Dims_Of_R then - Error_Msg_N - ("?both operands for operation% must have same dimension", - N); + Error_Dim_For_Binary_Op (N, L, R); end if; end if; + -- Removal of dimensions for each operands + Remove_Dimensions (L); Remove_Dimensions (R); end; @@ -1268,43 +1233,50 @@ package body Sem_Dim is --------------------------------------------- procedure Analyze_Dimension_Component_Declaration (N : Node_Id) is - Expr : constant Node_Id := Expression (N); - Id : constant Entity_Id := Defining_Identifier (N); - E_Typ : constant Entity_Id := Etype (Id); - Dim_T : constant Dimension_Type := Dimensions_Of (E_Typ); - Dim_E : Dimension_Type; - - begin - if Exists (Dim_T) then - - -- If the component type has a dimension and there is no expression, - -- propagates the dimension. - - if Present (Expr) then - Dim_E := Dimensions_Of (Expr); - - if Exists (Dim_E) then + 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_For_Component_Declaration + (N : Node_Id; + Etyp : Entity_Id; + Expr : Node_Id); + -- Error using Error_Msg_N at node N + -- Output in the error message the dimensions of the type Etyp and the + -- expression Expr of N. + + ----------------------------------------- + -- Error_Dim_For_Component_Declaration -- + ----------------------------------------- + + procedure Error_Dim_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 ("?component type " & Dimensions_Msg_Of (Etyp), N); + Error_Msg_N ("?component expression " & Dimensions_Msg_Of (Expr), N); + end Error_Dim_For_Component_Declaration; - -- Return an error if the dimension of the expression and the - -- dimension of the type missmatch. + -- Start of processing for Analyze_Dimension_Component_Declaration - if Dim_E /= Dim_T then - Error_Msg_N ("?dimensions missmatch in object " & - "declaration", N); - end if; + begin + if Present (Expr) then + Dims_Of_Expr := Dimensions_Of (Expr); - -- Case of dimensionless expression + -- Return an error if the dimension of the expression and the + -- dimension of the type mismatch. - else - Error_Msg_N - ("?dimensions missmatch in component declaration", N); - end if; + if Dims_Of_Etyp /= Dims_Of_Expr then + Error_Dim_For_Component_Declaration (N, Etyp, Expr); + end if; - -- For every other cases, propagate the dimensions + -- Removal of dimensions in expression - else - Copy_Dimensions (E_Typ, Id); - end if; + Remove_Dimensions (Expr); end if; end Analyze_Dimension_Component_Declaration; @@ -1313,33 +1285,63 @@ package body Sem_Dim is ------------------------------------------------- procedure Analyze_Dimension_Extended_Return_Statement (N : Node_Id) is - Obj_Decls : constant List_Id := Return_Object_Declarations (N); - R_Ent : constant Entity_Id := Return_Statement_Entity (N); - R_Etyp : constant Entity_Id := Etype (Return_Applies_To (R_Ent)); - Dims_R : constant Dimension_Type := Dimensions_Of (R_Etyp); - Dims_Obj : Dimension_Type; - Obj_Decl : Node_Id; - Obj_Id : Entity_Id; + 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); + Return_Obj_Decls : constant List_Id := + Return_Object_Declarations (N); + Dims_Of_Return_Obj_Id : Dimension_Type; + Return_Obj_Decl : Node_Id; + Return_Obj_Id : Entity_Id; + + procedure Error_Dim_For_Extended_Return_Statement + (N : Node_Id; + Return_Etyp : Entity_Id; + Return_Obj_Id : Entity_Id); + -- Error using Error_Msg_N at node N + -- Output in the error message the dimensions of the returned type + -- Return_Etyp and the returned object Return_Obj_Id of N. + + --------------------------------------------- + -- Error_Dim_For_Extended_Return_Statement -- + --------------------------------------------- + + procedure Error_Dim_For_Extended_Return_Statement + (N : Node_Id; + Return_Etyp : Entity_Id; + Return_Obj_Id : Entity_Id) + is + begin + Error_Msg_N ("?dimensions mismatch in extended return statement", N); + Error_Msg_N ("?returned type " & Dimensions_Msg_Of (Return_Etyp), N); + Error_Msg_N ("?returned object " & Dimensions_Msg_Of (Return_Obj_Id), + N); + end Error_Dim_For_Extended_Return_Statement; + -- Start of processing for Analyze_Dimension_Extended_Return_Statement begin - if Present (Obj_Decls) then - Obj_Decl := First (Obj_Decls); - while Present (Obj_Decl) loop - if Nkind (Obj_Decl) = N_Object_Declaration then - Obj_Id := Defining_Identifier (Obj_Decl); - - if Is_Return_Object (Obj_Id) then - Dims_Obj := Dimensions_Of (Obj_Id); - - if Dims_R /= Dims_Obj then - Error_Msg_N - ("?dimensions missmatch in return statement", N); + 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 + Dims_Of_Return_Obj_Id := Dimensions_Of (Return_Obj_Id); + + if Dims_Of_Return_Etyp /= Dims_Of_Return_Obj_Id then + Error_Dim_For_Extended_Return_Statement + (N, Return_Etyp, Return_Obj_Id); return; end if; end if; end if; - Next (Obj_Decl); + Next (Return_Obj_Decl); end loop; end if; end Analyze_Dimension_Extended_Return_Statement; @@ -1349,11 +1351,11 @@ package body Sem_Dim is ------------------------------------- procedure Analyze_Dimension_Function_Call (N : Node_Id) is - Name_Call : constant Node_Id := Name (N); - Par_Ass : constant List_Id := Parameter_Associations (N); - Dims : Dimension_Type; - Dims_Param : Dimension_Type; - Param : Node_Id; + Name_Call : constant Node_Id := Name (N); + Actuals : constant List_Id := Parameter_Associations (N); + Actual : Node_Id; + Dims_Of_Actual : Dimension_Type; + Dims_Of_Call : Dimension_Type; function Is_Elementary_Function_Call (N : Node_Id) return Boolean; -- Return True if the call is a call of an elementary function (see @@ -1381,11 +1383,9 @@ package body Sem_Dim is -- Check the name of the generic package is -- Generic_Elementary_Functions - if Is_Library_Level_Entity (Ent) - and then Chars (Ent) = Name_Generic_Elementary_Functions - then - return True; - end if; + return + Is_Library_Level_Entity (Ent) + and then Chars (Ent) = Name_Generic_Elementary_Functions; end if; end if; @@ -1402,40 +1402,40 @@ package body Sem_Dim is -- Sqrt function call case if Chars (Name_Call) = Name_Sqrt then - Dims := Dimensions_Of (First (Par_Ass)); + Dims_Of_Call := Dimensions_Of (First (Actuals)); - if Exists (Dims) then - for Dim in Dims'Range loop - Dims (Dim) := Dims (Dim) * (1, 2); + 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); + Set_Dimensions (N, Dims_Of_Call); end if; -- All other functions in Ada.Numerics.Generic_Elementary_Functions + -- case. -- Note that all parameters here should be dimensionless else - Param := First (Par_Ass); - while Present (Param) loop - Dims_Param := Dimensions_Of (Param); - - if Exists (Dims_Param) then + Actual := First (Actuals); + while Present (Actual) loop + Dims_Of_Actual := Dimensions_Of (Actual); - -- What is this deleted code about ??? - -- Error_Msg_Name_1 := Chars (Name_Call); - - Error_Msg_N + if Exists (Dims_Of_Actual) then + Error_Msg_NE ("?parameter should be dimensionless for elementary " - & "function%", Param); - return; + & "function&", Actual, Name_Call); + Error_Msg_N ("?parameter " & Dimensions_Msg_Of (Actual), + Actual); end if; - Next (Param); + Next (Actual); end loop; end if; - -- General case + -- Other case else Analyze_Dimension_Has_Etype (N); @@ -1447,15 +1447,15 @@ package body Sem_Dim is --------------------------------- procedure Analyze_Dimension_Has_Etype (N : Node_Id) is - E_Typ : constant Entity_Id := Etype (N); - Dims : constant Dimension_Type := Dimensions_Of (E_Typ); - N_Kind : constant Node_Kind := Nkind (N); + Etyp : constant Entity_Id := Etype (N); + Dims_Of_Etyp : constant Dimension_Type := Dimensions_Of (Etyp); + N_Kind : constant Node_Kind := Nkind (N); begin -- Propagation of the dimensions from the type - if Exists (Dims) then - Set_Dimensions (N, Dims); + if Exists (Dims_Of_Etyp) then + Set_Dimensions (N, Dims_Of_Etyp); end if; -- Removal of dimensions in expression @@ -1488,70 +1488,61 @@ package body Sem_Dim is end if; end Analyze_Dimension_Has_Etype; - ---------------------------------- - -- Analyze_Dimension_Identifier -- - ---------------------------------- - - procedure Analyze_Dimension_Identifier (N : Node_Id) is - Ent : constant Entity_Id := Entity (N); - Dims : constant Dimension_Type := Dimensions_Of (Ent); - begin - if Exists (Dims) then - Set_Dimensions (N, Dims); - else - Analyze_Dimension_Has_Etype (N); - end if; - end Analyze_Dimension_Identifier; - ------------------------------------------ -- Analyze_Dimension_Object_Declaration -- ------------------------------------------ procedure Analyze_Dimension_Object_Declaration (N : Node_Id) is - Expr : constant Node_Id := Expression (N); - Id : constant Entity_Id := Defining_Identifier (N); - E_Typ : constant Entity_Id := Etype (Id); - Dim_T : constant Dimension_Type := Dimensions_Of (E_Typ); - Dim_E : Dimension_Type; - - begin - if Exists (Dim_T) then - - -- Expression is present + 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_For_Object_Declaration + (N : Node_Id; + Etyp : Entity_Id; + Expr : Node_Id); + -- Error using Error_Msg_N at node N + -- Output in the error message the dimensions of the type Etyp and the + -- expression Expr of N. - if Present (Expr) then - Dim_E := Dimensions_Of (Expr); + -------------------------------------- + -- Error_Dim_For_Object_Declaration -- + -------------------------------------- - if Exists (Dim_E) then + procedure Error_Dim_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 ("?object type " & Dimensions_Msg_Of (Etyp), N); + Error_Msg_N ("?object expression " & Dimensions_Msg_Of (Expr), N); + end Error_Dim_For_Object_Declaration; - -- Return an error if the dimension of the expression and the - -- dimension of the type missmatch. + -- Start of processing for Analyze_Dimension_Object_Declaration - if Dim_E /= Dim_T then - Error_Msg_N ("?dimensions missmatch in object " & - "declaration", N); - end if; + begin + -- Expression is present - -- If the expression is dimensionless + if Present (Expr) then + Dim_Of_Expr := Dimensions_Of (Expr); - else - -- If node is not a real or integer constant (depending on the - -- dimensioned numeric type), generate an error message. + -- case when expression is not a literal and when dimensions of the + -- expression and of the type mismatch - if not Nkind_In (Original_Node (Expr), - N_Real_Literal, - N_Integer_Literal) - then - Error_Msg_N - ("?dimensions missmatch in object declaration", N); - end if; - end if; + if not Nkind_In (Original_Node (Expr), + N_Real_Literal, + N_Integer_Literal) + and then Dim_Of_Expr /= Dim_Of_Etyp + then + Error_Dim_For_Object_Declaration (N, Etyp, Expr); + end if; - -- For every other cases, propagate the dimensions + -- Removal of dimensions in expression - else - Copy_Dimensions (E_Typ, Id); - end if; + Remove_Dimensions (Expr); end if; end Analyze_Dimension_Object_Declaration; @@ -1560,13 +1551,39 @@ package body Sem_Dim is --------------------------------------------------- procedure Analyze_Dimension_Object_Renaming_Declaration (N : Node_Id) is - Id : constant Entity_Id := Defining_Identifier (N); - Ren_Id : constant Node_Id := Name (N); - E_Typ : constant Entity_Id := Etype (Ren_Id); - Dims_Typ : constant Dimension_Type := Dimensions_Of (E_Typ); + Renamed_Name : constant Node_Id := Name (N); + Sub_Mark : constant Node_Id := Subtype_Mark (N); + + procedure Error_Dim_For_Object_Renaming_Declaration + (N : Node_Id; + Sub_Mark : Node_Id; + Renamed_Name : Node_Id); + -- Error using Error_Msg_N at node N + -- Output in the error message the dimensions of Sub_Mark and of + -- Renamed_Name. + + ----------------------------------------------- + -- Error_Dim_For_Object_Renaming_Declaration -- + ----------------------------------------------- + + procedure Error_Dim_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 ("?type " & Dimensions_Msg_Of (Sub_Mark), N); + Error_Msg_N ("?renamed object " & Dimensions_Msg_Of (Renamed_Name), + N); + end Error_Dim_For_Object_Renaming_Declaration; + + -- Start of processing for Analyze_Dimension_Object_Renaming_Declaration + begin - if Exists (Dims_Typ) then - Copy_Dimensions (E_Typ, Id); + if Dimensions_Of (Renamed_Name) /= Dimensions_Of (Sub_Mark) then + Error_Dim_For_Object_Renaming_Declaration + (N, Sub_Mark, Renamed_Name); end if; end Analyze_Dimension_Object_Renaming_Declaration; @@ -1575,14 +1592,42 @@ package body Sem_Dim is ----------------------------------------------- procedure Analyze_Dimension_Simple_Return_Statement (N : Node_Id) is - Expr : constant Node_Id := Expression (N); - Dims_Expr : constant Dimension_Type := Dimensions_Of (Expr); - R_Ent : constant Entity_Id := Return_Statement_Entity (N); - R_Etyp : constant Entity_Id := Etype (Return_Applies_To (R_Ent)); - Dims_R : constant Dimension_Type := Dimensions_Of (R_Etyp); + Expr : constant Node_Id := Expression (N); + Dims_Of_Expr : constant Dimension_Type := Dimensions_Of (Expr); + 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_For_Simple_Return_Statement + (N : Node_Id; + Return_Etyp : Entity_Id; + Expr : Node_Id); + -- Error using Error_Msg_N at node N + -- Output in the error message the dimensions of the returned type + -- Return_Etyp and the returned expression Expr of N. + + ------------------------------------------- + -- Error_Dim_For_Simple_Return_Statement -- + ------------------------------------------- + + procedure Error_Dim_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 ("?returned type " & Dimensions_Msg_Of (Return_Etyp), N); + Error_Msg_N ("?returned expression " & Dimensions_Msg_Of (Expr), N); + end Error_Dim_For_Simple_Return_Statement; + + -- Start of processing for Analyze_Dimension_Simple_Return_Statement + begin - if Dims_R /= Dims_Expr then - Error_Msg_N ("?dimensions missmatch in return statement", N); + if Dims_Of_Return_Etyp /= Dims_Of_Expr then + Error_Dim_For_Simple_Return_Statement (N, Return_Etyp, Expr); Remove_Dimensions (Expr); end if; end Analyze_Dimension_Simple_Return_Statement; @@ -1592,52 +1637,40 @@ package body Sem_Dim is ------------------------------------------- procedure Analyze_Dimension_Subtype_Declaration (N : Node_Id) is - Ent : constant Entity_Id := Defining_Identifier (N); - Dims_Ent : constant Dimension_Type := Dimensions_Of (Ent); - E_Typ : Node_Id; + 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 - if Nkind (Subtype_Indication (N)) /= N_Subtype_Indication then - E_Typ := Etype (Subtype_Indication (N)); - declare - Dims_Typ : constant Dimension_Type := Dimensions_Of (E_Typ); + -- No constraint case in subtype declaration - begin - if Exists (Dims_Typ) then - - -- If subtype already has a dimension (from Aspect_Dimension), - -- it cannot inherit a dimension from its subtype. + if Nkind (Subtype_Indication (N)) /= N_Subtype_Indication then + Etyp := Etype (Subtype_Indication (N)); + Dims_Of_Etyp := Dimensions_Of (Etyp); - if Exists (Dims_Ent) then - Error_Msg_N ("?subtype& already has a dimension", N); + if Exists (Dims_Of_Etyp) then + -- If subtype already has a dimension (from Aspect_Dimension), + -- it cannot inherit a dimension from its subtype. - else - Set_Dimensions (Ent, Dims_Typ); - Set_Symbol (Ent, Symbol_Of (E_Typ)); - end if; + if Exists (Dims_Of_Id) then + Error_Msg_N ("?subtype& already" & Dimensions_Msg_Of (Id), N); + else + Set_Dimensions (Id, Dims_Of_Etyp); + Set_Symbol (Id, Symbol_Of (Etyp)); end if; - end; - - else - E_Typ := Etype (Subtype_Mark (Subtype_Indication (N))); - declare - Dims_Typ : constant Dimension_Type := Dimensions_Of (E_Typ); - - begin - if Exists (Dims_Typ) then + end if; - -- If subtype already has a dimension (from Aspect_Dimension), - -- it cannot inherit a dimension from its subtype. + -- Constraint present in subtype declaration - if Exists (Dims_Ent) then - Error_Msg_N ("?subtype& already has a dimension", N); + else + Etyp := Etype (Subtype_Mark (Subtype_Indication (N))); + Dims_Of_Etyp := Dimensions_Of (Etyp); - else - Set_Dimensions (Ent, Dims_Typ); - Set_Symbol (Ent, Symbol_Of (E_Typ)); - end if; - end if; - end; + 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; @@ -1663,123 +1696,119 @@ package body Sem_Dim is end case; end Analyze_Dimension_Unary_Op; - --------------------- - -- Copy_Dimensions -- - --------------------- + -------------------------- + -- Create_Rational_From -- + -------------------------- - procedure Copy_Dimensions (From : Node_Id; To : Node_Id) is - Dims : constant Dimension_Type := Dimensions_Of (From); + -- RATIONAL ::= [-] NUMERAL [/ NUMERAL] - begin - -- Propagate the dimension from one node to another - - pragma Assert (OK_For_Dimension (Nkind (To))); - pragma Assert (Exists (Dims)); - Set_Dimensions (To, Dims); - end Copy_Dimensions; - - ------------------------------- - -- Create_Rational_From_Expr -- - ------------------------------- - - function Create_Rational_From_Expr (Expr : Node_Id) return Rational is - Or_N : constant Node_Id := Original_Node (Expr); - Left : Node_Id; - Left_Int : Int; - Ltype : Entity_Id; - Right : Node_Id; - Right_Int : Int; - R_Opnd_Minus : Node_Id; - Rtype : Entity_Id; - Result : Rational; + -- 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. - begin - -- 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. + 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; - -- Check the expression is either a division of two integers or an - -- integer itself. The check applies to the original node since the - -- node could have already been rewritten. + function Process_Minus (N : Node_Id) return Rational; + -- Create a rational from a N_Op_Minus - -- Numerator is positive + function Process_Divide (N : Node_Id) return Rational; + -- Create a rational from a N_Op_Divide - if Nkind (Or_N) = N_Op_Divide then - Left := Left_Opnd (Or_N); - Ltype := Etype (Left); - Right := Right_Opnd (Or_N); - Rtype := Etype (Right); + function Process_Literal (N : Node_Id) return Rational; + -- Create a rational from a N_Integer_Literal - if Is_Integer_Type (Ltype) and then Is_Integer_Type (Rtype) then - Left_Int := UI_To_Int (Expr_Value (Left)); - Right_Int := UI_To_Int (Expr_Value (Right)); + ------------------- + -- Process_Minus -- + ------------------- - -- Verify that the denominator of the rational is positive + function Process_Minus (N : Node_Id) return Rational is + Right : constant Node_Id := Original_Node (Right_Opnd (N)); + Result : Rational := No_Rational; - if Right_Int > 0 then - if Left_Int mod Right_Int = 0 then - Result := +Whole (UI_To_Int (Expr_Value (Expr))); - else - Result := Whole (Left_Int) / Whole (Right_Int); - end if; + begin + -- Operand is an integer literal - else - Error_Msg_N - ("denominator in a rational number must be positive", Right); - end if; + if Nkind (Right) = N_Integer_Literal then + Result := -Process_Literal (Right); - else - Error_Msg_N ("must be a rational", Expr); + -- Operand is a divide operator + + elsif Nkind (Right) = N_Op_Divide then + Result := -Process_Divide (Right); end if; - -- Numerator is negative + return Result; + end Process_Minus; - elsif Nkind (Or_N) = N_Op_Minus - and then Nkind (Original_Node (Right_Opnd (Or_N))) = N_Op_Divide - then - R_Opnd_Minus := Original_Node (Right_Opnd (Or_N)); - Left := Left_Opnd (R_Opnd_Minus); - Ltype := Etype (Left); - Right := Right_Opnd (R_Opnd_Minus); - Rtype := Etype (Right); - - if Is_Integer_Type (Ltype) - and then Is_Integer_Type (Rtype) + -------------------- + -- 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 an integer literal + + if Nkind (Left) = N_Integer_Literal + and then Nkind (Right) = N_Integer_Literal then - Left_Int := UI_To_Int (Expr_Value (Left)); - Right_Int := UI_To_Int (Expr_Value (Right)); + Left_Rat := Process_Literal (Left); + Right_Rat := Process_Literal (Right); + Result := Left_Rat / Right_Rat; + end if; - -- Verify that the denominator of the rational is positive + return Result; + end Process_Divide; - if Right_Int > 0 then - if Left_Int mod Right_Int = 0 then - Result := +Whole (-UI_To_Int (Expr_Value (Expr))); - else - Result := Whole (-Left_Int) / Whole (Right_Int); - end if; + --------------------- + -- Process_Literal -- + --------------------- - else - Error_Msg_N - ("denominator in a rational number must be positive", Right); - end if; + function Process_Literal (N : Node_Id) return Rational is + begin + return +Whole (UI_To_Int (Intval (N))); + end Process_Literal; - else - Error_Msg_N ("must be a rational", Expr); - end if; + -- Start of processing for Create_Rational_From - -- Integer case + 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. - else - if Is_Integer_Type (Etype (Expr)) then - Right_Int := UI_To_Int (Expr_Value (Expr)); - Result := +Whole (Right_Int); + -- Integer literal case - else - Error_Msg_N ("must be a rational", Expr); - end if; + 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, + -- return an error message. + + if Complain and then Result = No_Rational then + Error_Msg_N ("must be a rational", Expr); end if; return Result; - end Create_Rational_From_Expr; + end Create_Rational_From; ------------------- -- Dimensions_Of -- @@ -1790,6 +1819,87 @@ package body Sem_Dim is return Dimension_Table.Get (N); end Dimensions_Of; + ----------------------- + -- Dimensions_Msg_Of -- + ----------------------- + + function Dimensions_Msg_Of (N : Node_Id) return String is + Dims_Of_N : constant Dimension_Type := Dimensions_Of (N); + Dimensions_Msg : Name_Id; + System : System_Type; + + procedure Add_Dimension_Vector_To_Buffer + (Dims : Dimension_Type; + System : System_Type); + -- Given a Dims and System, add to Name_Buffer the string representation + -- of a dimension vector. + + procedure Add_Whole_To_Buffer (W : Whole); + -- Add image of Whole to Name_Buffer + + ------------------------------------ + -- Add_Dimension_Vector_To_Buffer -- + ------------------------------------ + + procedure Add_Dimension_Vector_To_Buffer + (Dims : Dimension_Type; + System : System_Type) + is + Dim_Power : Rational; + First_Dim : Boolean := True; + + begin + Add_Char_To_Name_Buffer ('('); + + for Position in Dims_Of_N'First .. System.Count loop + Dim_Power := Dims (Position); + + if First_Dim then + First_Dim := False; + else + Add_Str_To_Name_Buffer (", "); + end if; + + Add_Whole_To_Buffer (Dim_Power.Numerator); + + if Dim_Power.Denominator /= 1 then + Add_Char_To_Name_Buffer ('/'); + Add_Whole_To_Buffer (Dim_Power.Denominator); + end if; + end loop; + + Add_Char_To_Name_Buffer (')'); + end Add_Dimension_Vector_To_Buffer; + + ------------------------- + -- Add_Whole_To_Buffer -- + ------------------------- + + procedure Add_Whole_To_Buffer (W : Whole) is + begin + UI_Image (UI_From_Int (Int (W))); + Add_Str_To_Name_Buffer (UI_Image_Buffer (1 .. UI_Image_Length)); + end Add_Whole_To_Buffer; + + -- Start of processing for Dimensions_Msg_Of + + begin + -- Initialization of Name_Buffer + + Name_Len := 0; + + if Exists (Dims_Of_N) then + System := System_Of (Base_Type (Etype (N))); + Add_Str_To_Name_Buffer ("has dimensions: "); + Add_Dimension_Vector_To_Buffer (Dims_Of_N, System); + else + Add_Str_To_Name_Buffer ("is dimensionless"); + end if; + + Dimensions_Msg := Name_Find; + return Get_Name_String (Dimensions_Msg); + end Dimensions_Msg_Of; + -------------------------- -- Dimension_Table_Hash -- -------------------------- @@ -1805,21 +1915,34 @@ package body Sem_Dim is -- Eval_Op_Expon_For_Dimensioned_Type -- ---------------------------------------- - -- Evaluate the expon operator for dimensioned type + -- Evaluate the expon operator for real dimensioned type + -- Note that the node must come from source -- Note that if the exponent is an integer (denominator = 1) the node is - -- not evaluated here and must be evaluated by the Eval_Op_Expon routine. + -- evaluated by the regular Eval_Op_Expon routine (see Sem_Eval). procedure Eval_Op_Expon_For_Dimensioned_Type - (N : Node_Id; - B_Typ : Entity_Id) + (N : Node_Id; + Btyp : Entity_Id) is - R : constant Node_Id := Right_Opnd (N); - Rat : Rational := Zero; + R : constant Node_Id := Right_Opnd (N); + R_Value : Rational := No_Rational; + begin - if Compile_Time_Known_Value (R) and then Is_Real_Type (B_Typ) then - Rat := Create_Rational_From_Expr (R); - Eval_Op_Expon_With_Rational_Exponent (N, Rat); + if Comes_From_Source (N) + and then 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; @@ -1833,179 +1956,153 @@ package body Sem_Dim is -- using the function Expon_LLF from s-llflex.ads. procedure Eval_Op_Expon_With_Rational_Exponent - (N : Node_Id; - Rat : Rational) + (N : Node_Id; + Exponent_Value : Rational) is - Dims : constant Dimension_Type := Dimensions_Of (N); - L : constant Node_Id := Left_Opnd (N); - Etyp : constant Entity_Id := Etype (L); - Loc : constant Source_Ptr := Sloc (N); - Actual_1 : Node_Id; - Actual_2 : Node_Id; - Base_Typ : Entity_Id; - Dim_Value : Rational; - List_Of_Dims : List_Id; - New_Aspect : Node_Id; - New_Aspects : List_Id; - New_E : Entity_Id; - New_N : Node_Id; - New_Typ_L : Node_Id; - System : System_Type; + 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); + Loc : constant Source_Ptr := Sloc (N); + 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 - -- If Rat.Denominator = 1 that means the exponent is an Integer so - -- nothing has to be changed. Note that the node must come from source. - - if Comes_From_Source (N) and then Rat.Denominator /= 1 then - Base_Typ := Base_Type (Etyp); + -- Case when the operand is not dimensionless - -- Case when the operand is not dimensionless + if Exists (Dims_Of_N) then - if Exists (Dims) then + -- Get the corresponding System_Type to know the exact number of + -- dimensions in the system. - -- Get the corresponding Dim_Sys_Id to know the exact number of - -- dimensions in the system. + System := System_Of (Btyp_Of_L); - System := System_Of (Base_Typ); + -- Generation of a new subtype with the proper dimensions - -- Step 1: 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. - -- In order to rewrite the operator as a function call, a new - -- subtype with an aspect dimension using the dimensions of the - -- node has to be created. - - -- Generate: - - -- Base_Typ : constant Entity_Id := Base_Type (Etyp); - -- Sys : constant System_Id := - -- Get_Dimension_System_Id (Base_Typ); - -- N_Dims : constant Number_Of_Dimensions := - -- Dimension_Systems.Table (Sys).Dimension_Count; - -- Dim_Value : Rational; - - -- Aspect_Dim_Expr : List; - - -- Append ("", Aspect_Dim_Expr); - - -- for Dim in Dims'First .. N_Dims loop - -- Dim_Value := Dims (Dim); - - -- if Dim_Value.Denominator /= 1 then - -- Append (Dim_Value.Numerator / Dim_Value.Denominator, - -- Aspect_Dim_Expr); - -- else - -- Append (Dim_Value.Numerator, Aspect_Dim_Expr); - -- end if; - -- end loop; - - -- subtype T is Base_Typ with Dimension => Aspect_Dim_Expr; - - -- Step 1a: Generate the aggregate for the new Aspect_dimension - - New_Aspects := Empty_List; - List_Of_Dims := New_List; - - Append (Make_String_Literal (Loc, No_String), List_Of_Dims); - - for Dim in Dims'First .. System.Count loop - Dim_Value := Dims (Dim); - - if Dim_Value.Denominator /= 1 then - Append_To (List_Of_Dims, - Make_Op_Divide (Loc, - Left_Opnd => - Make_Integer_Literal (Loc, - Int (Dim_Value.Numerator)), - Right_Opnd => - Make_Integer_Literal (Loc, - Int (Dim_Value.Denominator)))); + -- Generate: - else - Append_To (List_Of_Dims, - Make_Integer_Literal (Loc, Int (Dim_Value.Numerator))); - end if; - end loop; + -- 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; + Append (Make_String_Literal (Loc, ""), List_Of_Dims); + + 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 1b: Create the new Aspect_Dimension + -- 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)); + New_Aspect := + Make_Aspect_Specification (Loc, + Identifier => Make_Identifier (Loc, Name_Dimension), + Expression => Make_Aggregate (Loc, Expressions => List_Of_Dims)); - -- Step 1c: New identifier for the subtype + -- Step 3: Make a temporary identifier for the new subtype - New_E := Make_Temporary (Loc, 'T'); - Set_Is_Internal (New_E); + New_Id := Make_Temporary (Loc, 'T'); + Set_Is_Internal (New_Id); - -- Step 1d: Declaration of the new subtype + -- Step 4: Declaration of the new subtype - New_Typ_L := - Make_Subtype_Declaration (Loc, - Defining_Identifier => New_E, - Subtype_Indication => New_Occurrence_Of (Base_Typ, Loc)); + 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_Typ_L); - Set_Aspect_Specifications (New_Typ_L, New_Aspects); + 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_Typ_L); + Analyze (New_Subtyp_Decl_For_L); -- Case where the operand is dimensionless - else - New_E := Base_Typ; - end if; - - -- Step 2: Generation of the function call + else + New_Id := Btyp_Of_L; + end if; - -- Generate: + -- Replacement of N by New_N - -- Actual_1 := Long_Long_Float (L), + -- Generate: - -- Actual_2 := Long_Long_Float (Rat.Numerator) / - -- Long_Long_Float (Rat.Denominator); + -- Actual_1 := Long_Long_Float (L), - -- (T (Expon_LLF (Actual_1, Actual_2))); + -- Actual_2 := Long_Long_Float (Exponent_Value.Numerator) / + -- Long_Long_Float (Exponent_Value.Denominator); - -- -- where T is the subtype declared in step 1 + -- (T (Expon_LLF (Actual_1, Actual_2))); - -- -- The node is rewritten as a type conversion + -- -- where T is the subtype declared in step 1 + -- -- The node is rewritten as a type conversion - -- Step 2a: Creation of the two parameters for function Expon_LLF + -- Step 1: Creation of the two parameters of Expon_LLF function call - Actual_1 := - Make_Type_Conversion (Loc, - Subtype_Mark => New_Reference_To (Standard_Long_Long_Float, Loc), - Expression => Relocate_Node (L)); + Actual_1 := + Make_Type_Conversion (Loc, + Subtype_Mark => New_Reference_To (Standard_Long_Long_Float, Loc), + Expression => Relocate_Node (L)); - Actual_2 := - Make_Op_Divide (Loc, - Left_Opnd => - Make_Real_Literal (Loc, - UR_From_Uint (UI_From_Int (Int (Rat.Numerator)))), - Right_Opnd => - Make_Real_Literal (Loc, - UR_From_Uint (UI_From_Int (Int (Rat.Denominator))))); + 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 2b: New Node N + -- Step 2: Creation of New_N - New_N := - Make_Type_Conversion (Loc, - Subtype_Mark => New_Reference_To (New_E, Loc), - Expression => - Make_Function_Call (Loc, - Name => New_Reference_To (RTE (RE_Expon_LLF), Loc), - Parameter_Associations => New_List ( - Actual_1, Actual_2))); + New_N := + Make_Type_Conversion (Loc, + Subtype_Mark => New_Reference_To (New_Id, Loc), + Expression => + Make_Function_Call (Loc, + Name => New_Reference_To (RTE (RE_Expon_LLF), Loc), + Parameter_Associations => New_List ( + Actual_1, Actual_2))); - -- Step 3: Rewitten of N + -- Step 3: Rewitten of N - Rewrite (N, New_N); - Set_Etype (N, New_E); - Analyze_And_Resolve (N, New_E); - end if; + Rewrite (N, New_N); + Set_Etype (N, New_Id); + Analyze_And_Resolve (N, New_Id); end Eval_Op_Expon_With_Rational_Exponent; ------------ @@ -2023,53 +2120,58 @@ package body Sem_Dim is end Exists; ------------------------------------------- - -- Expand_Put_Call_With_Dimension_String -- + -- Expand_Put_Call_With_Dimension_Symbol -- ------------------------------------------- -- For procedure Put defined in System.Dim_Float_IO/System.Dim_Integer_IO, -- the default string parameter must be rewritten to include the dimension -- symbols in the output of a dimensioned object. - -- There are two different cases: - - -- 1) If the parameter is a variable, the default string parameter is - -- replaced by the string defined in the aspect Dimension of the subtype. + -- Case 1: the parameter is a variable + -- The default string parameter is replaced by the symbol defined in the + -- aspect Dimension of the subtype. -- For instance if the user wants to output a speed: - - -- subtype Speed is Mks_Type with Dimension => - -- ("speed", Meter => 1, Second => -1, others => 0); - -- v : Speed := 2.1 * m * s**(-1); - - -- Put (v) returns: - -- > 2.1 speed - - -- 2) If the parameter is an expression, then we call the procedure - -- Expand_Put_Call_With_Dimension_String creates the string (for instance - -- "m.s**(-1)") and rewrite the default string parameter of Put with the - -- corresponding the String_Id. - - procedure Expand_Put_Call_With_Dimension_String (N : Node_Id) is - Actuals : constant List_Id := Parameter_Associations (N); - Loc : constant Source_Ptr := Sloc (N); - Name_Call : constant Node_Id := Name (N); - Actual : Node_Id; - Base_Typ : Node_Id; - Char_Pack : Name_Id; - Dims : Dimension_Type; - Etyp : Entity_Id; - First_Actual : Node_Id; - New_Par_Ass : List_Id; - New_Str_Lit : Node_Id; - System : System_Type; - - function Is_Procedure_Put_Call (N : Node_Id) return Boolean; + -- subtype Force is Mks_Type + -- with + -- Dimension => ("N", + -- Meter => 1, + -- Kilogram => 1, + -- Second => -2, + -- others => 0); + -- F : Force := 2.1 * m * kg * s**(-2); + -- Put (F); + -- > 2.1 N + + -- Case 2: the parameter is an expression + -- then we call the procedure Expand_Put_Call_With_Dimension_Symbol that + -- creates the string of symbols (for instance "m.s**(-1)") and rewrites + -- the default string parameter of Put with the corresponding the + -- String_Id. + -- For instance: + -- Put (2.1 * m * kg * s**(-2)); + -- > 2.1 m.kg.s**(-2) + + procedure Expand_Put_Call_With_Dimension_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); + Actual : Node_Id; + Base_Typ : Node_Id; + Dims_Of_Actual : Dimension_Type; + Etyp : Entity_Id; + First_Actual : Node_Id; + New_Actuals : List_Id; + New_Str_Lit : Node_Id; + Package_Name : Name_Id; + System : System_Type; + + 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 Is_Procedure_Put_Call (N : Node_Id) return Boolean is - Name_Call : constant Node_Id := Name (N); - Ent : Entity_Id; + function Is_Procedure_Put_Call return Boolean is + Ent : Entity_Id; begin -- There are three different Put routine in each generic package @@ -2079,28 +2181,23 @@ package body Sem_Dim is Ent := Entity (Name_Call); -- Check that the name of the procedure is Put - - if Chars (Name_Call) /= Name_Put then - return False; - end if; - -- Check the procedure is defined in an instantiation of a -- generic package. - if Is_Generic_Instance (Scope (Ent)) then + if Chars (Name_Call) = Name_Put + and then Is_Generic_Instance (Scope (Ent)) + then Ent := Cunit_Entity (Get_Source_Unit (Ent)); -- Verify that the generic package is System.Dim_Float_IO or -- System.Dim_Integer_IO. if Is_Library_Level_Entity (Ent) then - Char_Pack := Chars (Ent); + Package_Name := Chars (Ent); - if Char_Pack = Name_Dim_Float_IO - or else Char_Pack = Name_Dim_Integer_IO - then - return True; - end if; + return + Package_Name = Name_Dim_Float_IO + or else Package_Name = Name_Dim_Integer_IO; end if; end if; end if; @@ -2108,17 +2205,17 @@ package body Sem_Dim is return False; end Is_Procedure_Put_Call; - -- Start of processing for Expand_Put_Call_With_Dimension_String + -- Start of processing for Expand_Put_Call_With_Dimension_Symbol begin - if Is_Procedure_Put_Call (N) then + if Is_Procedure_Put_Call then -- Get the first parameter First_Actual := First (Actuals); - -- Case when the Put routine has four (integer case) or five (float - -- case) parameters. + -- Case when the Put routine has four (System.Dim_Integer_IO) or five + -- (System.Dim_Float_IO) parameters. if List_Length (Actuals) = 5 or else List_Length (Actuals) = 4 @@ -2142,31 +2239,33 @@ package body Sem_Dim is Base_Typ := Base_Type (Etype (Actual)); System := System_Of (Base_Typ); + -- Check the base type of Actual is a dimensioned type + if Exists (System) then - Dims := Dimensions_Of (Actual); + Dims_Of_Actual := Dimensions_Of (Actual); Etyp := Etype (Actual); - -- Add the string as a suffix of the value if the subtype has a - -- string of dimensions or if the parameter is not dimensionless. + -- Add the symbol as a suffix of the value if the subtype has a + -- dimension symbol or if the parameter is not dimensionless. - if Exists (Dims) + if Exists (Dims_Of_Actual) or else Symbol_Of (Etyp) /= No_String then - New_Par_Ass := New_List; + New_Actuals := New_List; -- Add to the list First_Actual and Actual if they differ if Actual /= First_Actual then - Append (New_Copy (First_Actual), New_Par_Ass); + Append (New_Copy (First_Actual), New_Actuals); end if; - Append (New_Copy (Actual), New_Par_Ass); + Append (New_Copy (Actual), New_Actuals); -- Look to the next parameter Next (Actual); - -- Check if the type of N is a subtype that has a string of + -- Check if the type of N is a subtype that has a symbol of -- dimensions in Aspect_Dimension_String_Id_Hash_Table. if Symbol_Of (Etyp) /= No_String then @@ -2185,73 +2284,75 @@ package body Sem_Dim is else New_Str_Lit := Make_String_Literal (Loc, - From_Dimension_To_String_Id (Dims, System)); + From_Dimension_To_String_Of_Symbols (Dims_Of_Actual, + System)); end if; - Append (New_Str_Lit, New_Par_Ass); + Append (New_Str_Lit, New_Actuals); -- Rewrite the procedure call with the new list of parameters Rewrite (N, Make_Procedure_Call_Statement (Loc, - Name => New_Copy (Name_Call), - Parameter_Associations => New_Par_Ass)); + Name => New_Copy (Name_Call), + Parameter_Associations => New_Actuals)); Analyze (N); end if; end if; end if; - end Expand_Put_Call_With_Dimension_String; + end Expand_Put_Call_With_Dimension_Symbol; - --------------------------------- - -- From_Dimension_To_String_Id -- - --------------------------------- + ----------------------------------------- + -- From_Dimension_To_String_Of_Symbols -- + ----------------------------------------- -- Given a dimension vector and the corresponding dimension system, create -- a String_Id to output the dimension symbols corresponding to the -- dimensions Dims. - function From_Dimension_To_String_Id + function From_Dimension_To_String_Of_Symbols (Dims : Dimension_Type; System : System_Type) return String_Id is - Dim_Rat : Rational; - First_Dim_In_Str : Boolean := True; + Dimension_Power : Rational; + First_Symbol_In_Str : Boolean := True; begin -- Initialization of the new String_Id Start_String; - -- Put a space between the value and the dimensions + -- Put a space between the value and the symbols Store_String_Char (' '); - for Dim in Dimension_Type'Range loop - Dim_Rat := Dims (Dim); - if Dim_Rat /= Zero then + for Position in Dimension_Type'Range loop + Dimension_Power := Dims (Position); + if Dimension_Power /= Zero then - if First_Dim_In_Str then - First_Dim_In_Str := False; + if First_Symbol_In_Str then + First_Symbol_In_Str := False; else Store_String_Char ('.'); end if; -- Positive dimension case - if Dim_Rat.Numerator > 0 then - if System.Symbols (Dim) = No_String then - Store_String_Chars (Get_Name_String (System.Names (Dim))); + if Dimension_Power.Numerator > 0 then + if System.Symbols (Position) = No_String then + Store_String_Chars + (Get_Name_String (System.Names (Position))); else - Store_String_Chars (System.Symbols (Dim)); + Store_String_Chars (System.Symbols (Position)); end if; -- Integer case - if Dim_Rat.Denominator = 1 then - if Dim_Rat.Numerator /= 1 then + if Dimension_Power.Denominator = 1 then + if Dimension_Power.Numerator /= 1 then Store_String_Chars ("**"); - Store_String_Int (Int (Dim_Rat.Numerator)); + Store_String_Int (Int (Dimension_Power.Numerator)); end if; -- Rational case when denominator /= 1 @@ -2259,36 +2360,37 @@ package body Sem_Dim is else Store_String_Chars ("**"); Store_String_Char ('('); - Store_String_Int (Int (Dim_Rat.Numerator)); + Store_String_Int (Int (Dimension_Power.Numerator)); Store_String_Char ('/'); - Store_String_Int (Int (Dim_Rat.Denominator)); + Store_String_Int (Int (Dimension_Power.Denominator)); Store_String_Char (')'); end if; -- Negative dimension case else - if System.Symbols (Dim) = No_String then - Store_String_Chars (Get_Name_String (System.Names (Dim))); + if System.Symbols (Position) = No_String then + Store_String_Chars + (Get_Name_String (System.Names (Position))); else - Store_String_Chars (System.Symbols (Dim)); + Store_String_Chars (System.Symbols (Position)); end if; Store_String_Chars ("**"); Store_String_Char ('('); Store_String_Char ('-'); - Store_String_Int (Int (-Dim_Rat.Numerator)); + Store_String_Int (Int (-Dimension_Power.Numerator)); -- Integer case - if Dim_Rat.Denominator = 1 then + if Dimension_Power.Denominator = 1 then Store_String_Char (')'); -- Rational case when denominator /= 1 else Store_String_Char ('/'); - Store_String_Int (Int (Dim_Rat.Denominator)); + Store_String_Int (Int (Dimension_Power.Denominator)); Store_String_Char (')'); end if; end if; @@ -2296,7 +2398,7 @@ package body Sem_Dim is end loop; return End_String; - end From_Dimension_To_String_Id; + end From_Dimension_To_String_Of_Symbols; --------- -- GCD -- @@ -2331,6 +2433,28 @@ package body Sem_Dim is return Exists (System_Of (Typ)); end Has_Dimension_System; + ------------------------------------- + -- Is_Dim_IO_Package_Instantiation -- + ------------------------------------- + + function Is_Dim_IO_Package_Instantiation (N : Node_Id) return Boolean is + Gen_Id : constant Node_Id := Name (N); + Ent : Entity_Id; + + begin + if Is_Entity_Name (Gen_Id) then + Ent := Entity (Gen_Id); + + return + Is_Library_Level_Entity (Ent) + and then + (Chars (Ent) = Name_Dim_Float_IO + or else Chars (Ent) = Name_Dim_Integer_IO); + end if; + + return False; + end Is_Dim_IO_Package_Instantiation; + ---------------- -- Is_Invalid -- ---------------- @@ -2345,13 +2469,13 @@ package body Sem_Dim is --------------------- procedure Move_Dimensions (From, To : Node_Id) is - Dims : constant Dimension_Type := Dimensions_Of (From); + Dims_Of_From : constant Dimension_Type := Dimensions_Of (From); begin -- Copy the dimension of 'From to 'To' and remove dimension of 'From' - if Exists (Dims) then - Set_Dimensions (To, Dims); + if Exists (Dims_Of_From) then + Set_Dimensions (To, Dims_Of_From); Remove_Dimensions (From); end if; end Move_Dimensions; @@ -2370,7 +2494,7 @@ package body Sem_Dim is G : constant Int := GCD (X.Numerator, X.Denominator); begin - return Rational'(Numerator => Whole (Int (X.Numerator) / G), + return Rational'(Numerator => Whole (Int (X.Numerator) / G), Denominator => Whole (Int (X.Denominator) / G)); end; end Reduce; @@ -2380,9 +2504,9 @@ package body Sem_Dim is ----------------------- procedure Remove_Dimensions (N : Node_Id) is - Dims : constant Dimension_Type := Dimensions_Of (N); + Dims_Of_N : constant Dimension_Type := Dimensions_Of (N); begin - if Exists (Dims) then + if Exists (Dims_Of_N) then Dimension_Table.Remove (N); end if; end Remove_Dimensions; @@ -2400,30 +2524,13 @@ package body Sem_Dim is end if; Actual := First (Parameter_Associations (Call)); + while Present (Actual) loop Remove_Dimensions (Actual); Next (Actual); end loop; end Remove_Dimension_In_Call; - ------------------------------------- - -- Remove_Dimension_In_Declaration -- - ------------------------------------- - - -- Removal of dimension in expressions of N_Object_Declaration and - -- N_Component_Declaration as part of the Analyze_Declarations routine - -- (see package Sem_Ch3). - - procedure Remove_Dimension_In_Declaration (Decl : Node_Id) is - begin - if Ada_Version >= Ada_2012 - and then Nkind_In (Decl, N_Object_Declaration, N_Component_Declaration) - and then Present (Expression (Decl)) - then - Remove_Dimensions (Expression (Decl)); - end if; - end Remove_Dimension_In_Declaration; - ----------------------------------- -- Remove_Dimension_In_Statement -- ----------------------------------- @@ -2504,8 +2611,7 @@ package body Sem_Dim is Type_Decl : constant Node_Id := Parent (E); begin - -- Scan the Table in order to find N - -- What is N??? no sign of anything called N here ??? + -- 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 diff --git a/gcc/ada/sem_dim.ads b/gcc/ada/sem_dim.ads index be6a8da..ddee3da 100644 --- a/gcc/ada/sem_dim.ads +++ b/gcc/ada/sem_dim.ads @@ -95,19 +95,23 @@ package Sem_Dim is procedure Analyze_Aspect_Dimension (N : Node_Id; - Id : Node_Id; + Id : Entity_Id; Aggr : Node_Id); -- Analyze the contents of aspect Dimension. Associate the provided values -- and quantifiers with the related context N. - -- ??? comment on usage of formals needed + -- Id is the corresponding Aspect_Id (Aspect_Dimension) + -- Aggr is the corresponding expression for the aspect Dimension declared + -- by the declaration of N. procedure Analyze_Aspect_Dimension_System (N : Node_Id; - Id : Node_Id; - Expr : Node_Id); + Id : Entity_Id; + Aggr : Node_Id); -- Analyze the contents of aspect Dimension_System. Extract the numerical -- type, unit name and corresponding symbol from each indivitual dimension. - -- ??? comment on usage of formals needed + -- Id is the corresponding Aspect_Id (Aspect_Dimension_System) + -- Aggr is the corresponding expression for the aspect Dimension_System + -- declared by the declaration of N. procedure Analyze_Dimension (N : Node_Id); -- N may denote any of the following contexts: @@ -133,13 +137,15 @@ package Sem_Dim is -- involved do not violate the rules of a system. procedure Eval_Op_Expon_For_Dimensioned_Type - (N : Node_Id; - B_Typ : Entity_Id); - -- Evaluate the Expon operator for dimensioned type with rational exponent - -- ??? the above doesn't explain the purpose of this routine. why is this - -- procedure needed? - - procedure Expand_Put_Call_With_Dimension_String (N : Node_Id); + (N : Node_Id; + Btyp : Entity_Id); + -- Evaluate the Expon operator for dimensioned type with rational exponent. + -- Indeed the regular Eval_Op_Expon routine (see package Sem_Eval) is + -- restricted to Integer exponent. + -- This routine deals only with rational exponent which is not an integer + -- if Btyp is a dimensioned type. + + procedure Expand_Put_Call_With_Dimension_Symbol (N : Node_Id); -- Determine whether N denotes a subprogram call to one of the routines -- defined in System.Dim_Float_IO or System.Dim_Integer_IO and add an -- extra actual to the call to represent the symbolic representation of @@ -148,12 +154,13 @@ package Sem_Dim is function Has_Dimension_System (Typ : Entity_Id) return Boolean; -- Return True if type Typ has aspect Dimension_System applied to it + function Is_Dim_IO_Package_Instantiation (N : Node_Id) return Boolean; + -- Return True if N is a package instantiation of System.Dim_Integer_IO or + -- of System.Dim_Float_IO. + procedure Remove_Dimension_In_Call (Call : Node_Id); -- Remove the dimensions from all formal parameters of Call - procedure Remove_Dimension_In_Declaration (Decl : Node_Id); - -- Remove the dimensions from the expression of Decl - procedure Remove_Dimension_In_Statement (Stmt : Node_Id); -- Remove the dimensions associated with Stmt diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 5a5ebfa..f172485 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -8013,21 +8013,14 @@ package body Sem_Res is Analyze_Dimension (N); - -- Evaluate the exponentiation operator for dimensioned type with - -- rational exponent. - if Ada_Version >= Ada_2012 and then Has_Dimension_System (B_Typ) then - Eval_Op_Expon_For_Dimensioned_Type (N, B_Typ); + -- Evaluate the exponentiation operator for dimensioned type - -- Skip the Eval_Op_Expon if the node has already been evaluated - - if Nkind (N) = N_Type_Conversion then - return; - end if; + Eval_Op_Expon_For_Dimensioned_Type (N, B_Typ); + else + Eval_Op_Expon (N); end if; - Eval_Op_Expon (N); - -- Set overflow checking bit. Much cleverer code needed here eventually -- and perhaps the Resolve routines should be separated for the various -- arithmetic operations, since they will need different processing. ??? |