diff options
Diffstat (limited to 'gcc')
| -rw-r--r-- | gcc/ada/ChangeLog | 29 | ||||
| -rw-r--r-- | gcc/ada/s-dimkio.ads | 10 | ||||
| -rw-r--r-- | gcc/ada/s-dimmks.ads | 16 | ||||
| -rw-r--r-- | gcc/ada/s-dmotpr.ads | 10 | ||||
| -rw-r--r-- | gcc/ada/sem_ch4.adb | 2 | ||||
| -rw-r--r-- | gcc/ada/sem_dim.adb | 1685 | ||||
| -rw-r--r-- | gcc/ada/sem_dim.ads | 103 | ||||
| -rw-r--r-- | gcc/ada/sem_res.adb | 2 |
8 files changed, 829 insertions, 1028 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 26d8fcb..1728be4 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,32 @@ +2011-12-20 Hristian Kirtchev <kirtchev@adacore.com> + + * sem_ch4.adb (Operator_Check): Update the call to + Is_Dimensioned_Type. + * sem_dim.adb: Remove with and use clause for Namet.Sp. Reorganize + all type declarations and datastructures involved. Propagate + all changes involving data structures and types throughout + the pakage. Alphabetize all subprograms. Add ??? comments. + (AD_Hash): Removed. + (Analyze_Aspect_Dimension): Rewritten. This + routine now does all its checks in one pass rather than + two. Refactor code. The error message are now in a more GNAT-ish style. + (Create_Rational_From_Expr): This is now a function. + (Get_Dimensions): Removed. + (Get_Dimensions_String_Id): Removed. + (Dimensions_Of): New rouitne. + (Exists): New routines. + (Is_Invalid): New routine. + (Permits_Dimensions): Removed. + (Present): Removed. + (Set_Symbol): New routine. + (System_Of): New routine. + * sem_dim.ads: Rewrite the top level description of the + package. Alphabetize subprograms. Add various comments on + subprogram usage. Add ??? comments. + (Is_Dimensioned_Type): + Renamed to Has_Dimension_System. + * sem_res.adb (Resolve_Op_Expon): Update the call to Is_Dimensioned_Type + 2011-12-20 Ed Schonberg <schonberg@adacore.com> * sem_ch13.adb (Check_Indexing_Functions): The return type of an diff --git a/gcc/ada/s-dimkio.ads b/gcc/ada/s-dimkio.ads index 27ac0ca..eb8d8e6 100644 --- a/gcc/ada/s-dimkio.ads +++ b/gcc/ada/s-dimkio.ads @@ -1,14 +1,14 @@ ------------------------------------------------------------------------------ -- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- GNAT RUN-TIME COMPONENTS -- -- -- -- S Y S T E M . D I M _ M K S _ I O -- -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 2011, Free Software Foundation, Inc. -- -- -- --- GNARL is free software; you can redistribute it and/or modify it under -- +-- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- @@ -24,8 +24,8 @@ -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- -- <http://www.gnu.org/licenses/>. -- -- -- --- GNARL was developed by the GNARL team at Florida State University. -- --- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ diff --git a/gcc/ada/s-dimmks.ads b/gcc/ada/s-dimmks.ads index 1026992..88a29dd 100644 --- a/gcc/ada/s-dimmks.ads +++ b/gcc/ada/s-dimmks.ads @@ -1,14 +1,14 @@ ------------------------------------------------------------------------------ -- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- GNAT RUN-TIME COMPONENTS -- -- -- -- S Y S T E M . D I M _ M K S -- -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 2011, Free Software Foundation, Inc. -- -- -- --- GNARL is free software; you can redistribute it and/or modify it under -- +-- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- @@ -24,14 +24,14 @@ -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- -- <http://www.gnu.org/licenses/>. -- -- -- --- GNARL was developed by the GNARL team at Florida State University. -- --- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ --- This package defines the MKS dimension system which is the SI system of --- units. --- Some other prefixes of this sytem are defined in a child package (see +-- Defines the MKS dimension system which is the SI system of units + +-- Some other prefixes of this system are defined in a child package (see -- System.Dim_Mks.Other_Prefixes) in order to avoid too many constant -- declarations in this package. diff --git a/gcc/ada/s-dmotpr.ads b/gcc/ada/s-dmotpr.ads index b91afb8..57fa139 100644 --- a/gcc/ada/s-dmotpr.ads +++ b/gcc/ada/s-dmotpr.ads @@ -1,14 +1,14 @@ ------------------------------------------------------------------------------ -- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- GNAT RUN-TIME COMPONENTS -- -- -- -- S Y S T E M . D I M _ M K S . O T H E R _ P R E F I X E S -- -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 2011, Free Software Foundation, Inc. -- -- -- --- GNARL is free software; you can redistribute it and/or modify it under -- +-- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- @@ -24,8 +24,8 @@ -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- -- <http://www.gnu.org/licenses/>. -- -- -- --- GNARL was developed by the GNARL team at Florida State University. -- --- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index 4163231..99f2966 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -6042,7 +6042,7 @@ package body Sem_Ch4 is and then Base_Type (Etype (R)) /= Universal_Integer then if Ada_Version >= Ada_2012 - and then Is_Dimensioned_Type (Etype (L)) + and then Has_Dimension_System (Etype (L)) then Error_Msg_NE ("exponent for dimensioned type must be a rational" & diff --git a/gcc/ada/sem_dim.adb b/gcc/ada/sem_dim.adb index 4f20e45..341ceda 100644 --- a/gcc/ada/sem_dim.adb +++ b/gcc/ada/sem_dim.adb @@ -29,7 +29,6 @@ with Einfo; use Einfo; with Errout; use Errout; with Lib; use Lib; with Namet; use Namet; -with Namet.Sp; use Namet.Sp; with Nlists; use Nlists; with Nmake; use Nmake; with Opt; use Opt; @@ -51,61 +50,9 @@ with GNAT.HTable; package body Sem_Dim is - Max_Dimensions : constant Int := 7; - -- Maximum number of dimensions in a dimension system - - subtype Dim_Id is Pos range 1 .. Max_Dimensions; - -- Dim_Id values are used to identify dimensions in a dimension system - -- Note that the highest value of Dim_Id is Max_Dimensions - - -- Record type for dimension system - - -- A dimension system is defined by the number and the names of its - -- dimensions and its base type. - - subtype N_Of_Dimensions is Int range 0 .. Max_Dimensions; - - No_Dimensions : constant N_Of_Dimensions := N_Of_Dimensions'First; - - type Name_Array is array (Dim_Id) of Name_Id; - - No_Names : constant Name_Array := (others => No_Name); - - -- The symbols are used for IO purposes - - type Symbol_Array is array (Dim_Id) of String_Id; - - No_Symbols : constant Symbol_Array := (others => No_String); - - type Dimension_System is record - Base_Type : Node_Id; - Names : Name_Array; - N_Of_Dims : N_Of_Dimensions; - Symbols : Symbol_Array; - end record; - - No_Dimension_System : constant Dimension_System := - (Empty, No_Names, No_Dimensions, No_Symbols); - - -- Dim_Sys_Id values are used to identify dimension system in the Table - -- Note that the special value No_Dim_Sys has no corresponding component in - -- the Table since it represents no dimension system. - - subtype Dim_Sys_Id is Nat; - - No_Dim_Sys : constant Dim_Sys_Id := Dim_Sys_Id'First; - - -- The following table records every dimension system - - package Dim_Systems is new Table.Table ( - Table_Component_Type => Dimension_System, - Table_Index_Type => Dim_Sys_Id, - Table_Low_Bound => 1, - Table_Initial => 5, - Table_Increment => 5, - Table_Name => "Dim_Systems"); - - -- Rational (definitions & operations) + ------------------------- + -- Rational arithmetic -- + ------------------------- type Whole is new Int; subtype Positive_Whole is Whole range 1 .. Whole'Last; @@ -115,7 +62,7 @@ package body Sem_Dim is Denominator : Positive_Whole; end record; - Zero_Rational : constant Rational := (0, 1); + Zero : constant Rational := (0, 1); -- Rational constructors @@ -138,222 +85,152 @@ package body Sem_Dim is function "*" (Left : Rational; Right : Whole) return Rational; - --------- - -- GCD -- - --------- - - function GCD (Left, Right : Whole) return Int is - L : Whole; - R : Whole; - - begin - L := Left; - R := Right; - while R /= 0 loop - L := L mod R; - - if L = 0 then - return Int (R); - end if; - - R := R mod L; - end loop; - - return Int (L); - end GCD; - - ------------ - -- Reduce -- - ------------ - - function Reduce (X : Rational) return Rational is - begin - if X.Numerator = 0 then - return Zero_Rational; - end if; - - declare - G : constant Int := GCD (X.Numerator, X.Denominator); - - begin - return Rational'(Numerator => Whole (Int (X.Numerator) / G), - Denominator => Whole (Int (X.Denominator) / G)); - end; - end Reduce; - - --------- - -- "+" -- - --------- - - function "+" (Right : Whole) return Rational is - begin - return (Right, 1); - end "+"; - - function "+" (Left, Right : Rational) return Rational is - R : constant Rational := - Rational'(Numerator => Left.Numerator * Right.Denominator + - Left.Denominator * Right.Numerator, - Denominator => Left.Denominator * Right.Denominator); - begin - return Reduce (R); - end "+"; - - --------- - -- "-" -- - --------- - - function "-" (Right : Rational) return Rational is - begin - return Rational'(Numerator => -Right.Numerator, - Denominator => Right.Denominator); - end "-"; - - function "-" (Left, Right : Rational) return Rational is - R : constant Rational := - Rational'(Numerator => Left.Numerator * Right.Denominator - - Left.Denominator * Right.Numerator, - Denominator => Left.Denominator * Right.Denominator); - - begin - return Reduce (R); - end "-"; - - --------- - -- "*" -- - --------- - - function "*" (Left, Right : Rational) return Rational is - R : constant Rational := - Rational'(Numerator => Left.Numerator * Right.Numerator, - Denominator => Left.Denominator * Right.Denominator); - - begin - return Reduce (R); - end "*"; - - function "*" (Left : Rational; Right : Whole) return Rational is - R : constant Rational := - Rational'(Numerator => Left.Numerator * Right, - Denominator => Left.Denominator); + ------------------ + -- System types -- + ------------------ - begin - return Reduce (R); - end "*"; + Max_Number_Of_Dimensions : constant := 7; + -- Maximum number of dimensions in a dimension system - --------- - -- "/" -- - --------- + High_Position_Bound : constant := Max_Number_Of_Dimensions; + Invalid_Position : constant := 0; + Low_Position_Bound : constant := 1; - function "/" (Left, Right : Whole) return Rational is - R : constant Int := abs Int (Right); - L : Int := Int (Left); + subtype Dimension_Position is + Nat range Invalid_Position .. High_Position_Bound; - begin - if Right < 0 then - L := -L; - end if; + type Name_Array is + array (Dimension_Position range + Low_Position_Bound .. High_Position_Bound) of Name_Id; + -- A data structure used to store the names of all units within a system - return Reduce (Rational'(Numerator => Whole (L), - Denominator => Whole (R))); - end "/"; + No_Names : constant Name_Array := (others => No_Name); - -- Hash Table for aspect dimension. + type Symbol_Array is + array (Dimension_Position range + Low_Position_Bound .. High_Position_Bound) of String_Id; + -- A data structure used to store the symbols of all units within a system - -- The following table provides a relation between nodes and its dimension - -- (if not dimensionless). If a node is not stored in the Hash Table, the - -- node is considered to be dimensionless. + No_Symbols : constant Symbol_Array := (others => No_String); - -- A dimension is represented by an array of Max_Dimensions Rationals. - -- If the corresponding dimension system has less than Max_Dimensions - -- dimensions, the array is filled by as many as Zero_Rationals needed to - -- complete the array. + type System_Type is record + Type_Decl : Node_Id; + Names : Name_Array; + Symbols : Symbol_Array; + Count : Dimension_Position; + end record; - -- Here is a list of nodes that can have entries in this Htable: + Null_System : constant System_Type := + (Empty, No_Names, No_Symbols, Invalid_Position); - -- N_Attribute_Reference - -- N_Defining_Identifier - -- N_Function_Call - -- N_Identifier - -- N_Indexed_Component - -- N_Integer_Literal - -- N_Op_Abs - -- N_Op_Add - -- N_Op_Divide - -- N_Op_Expon - -- N_Op_Minus - -- N_Op_Mod - -- N_Op_Multiply - -- N_Op_Plus - -- N_Op_Rem - -- N_Op_Subtract - -- N_Qualified_Expression - -- N_Real_Literal - -- N_Selected_Component - -- N_Slice - -- N_Type_Conversion - -- N_Unchecked_Type_Conversion + subtype System_Id is Nat; - type Dimensions is array (Dim_Id) of Rational; + -- The following table maps types to systems - Zero_Dimensions : constant Dimensions := (others => Zero_Rational); + package System_Table is new Table.Table ( + Table_Component_Type => System_Type, + Table_Index_Type => System_Id, + Table_Low_Bound => 1, + Table_Initial => 5, + Table_Increment => 5, + Table_Name => "System_Table"); - type AD_Hash_Range is range 0 .. 511; + -------------------- + -- Dimension type -- + -------------------- - function AD_Hash (F : Node_Id) return AD_Hash_Range; + type Dimension_Type is + array (Dimension_Position range + Low_Position_Bound .. High_Position_Bound) of Rational; - ------------- - -- AD_Hash -- - ------------- + Null_Dimension : constant Dimension_Type := (others => Zero); - function AD_Hash (F : Node_Id) return AD_Hash_Range is - begin - return AD_Hash_Range (F mod 512); - end AD_Hash; + type Dimension_Table_Range is range 0 .. 510; + function Dimension_Table_Hash (Key : Node_Id) return Dimension_Table_Range; - -- Node_Id --> Dimensions + -- The following table associates nodes with dimensions - package Aspect_Dimension_Hash_Table is new + package Dimension_Table is new GNAT.HTable.Simple_HTable - (Header_Num => AD_Hash_Range, - Element => Dimensions, - No_Element => Zero_Dimensions, + (Header_Num => Dimension_Table_Range, + Element => Dimension_Type, + No_Element => Null_Dimension, Key => Node_Id, - Hash => AD_Hash, + Hash => Dimension_Table_Hash, Equal => "="); - -- Table to record the string of each subtype declaration - -- Note that this table is only used for IO purposes + ------------------ + -- Symbol types -- + ------------------ + + type Symbol_Table_Range is range 0 .. 510; + function Symbol_Table_Hash (Key : Entity_Id) return Symbol_Table_Range; - -- Entity_Id --> String_Id + -- Each subtype with a dimension has a symbolic representation of the + -- related unit. This table establishes a relation between the subtype + -- and the symbol. - package Aspect_Dimension_String_Id_Hash_Table is new + package Symbol_Table is new GNAT.HTable.Simple_HTable - (Header_Num => AD_Hash_Range, + (Header_Num => Symbol_Table_Range, Element => String_Id, No_Element => No_String, Key => Entity_Id, - Hash => AD_Hash, + Hash => Symbol_Table_Hash, Equal => "="); + -- The following array enumerates all contexts which may contain or + -- produce a dimension. + + OK_For_Dimension : constant array (Node_Kind) of Boolean := + (N_Attribute_Reference => True, + N_Defining_Identifier => True, + N_Function_Call => True, + N_Identifier => True, + N_Indexed_Component => True, + N_Integer_Literal => True, + N_Op_Abs => True, + N_Op_Add => True, + N_Op_Divide => True, + N_Op_Expon => True, + N_Op_Minus => True, + N_Op_Mod => True, + N_Op_Multiply => True, + N_Op_Plus => True, + N_Op_Rem => True, + N_Op_Subtract => True, + N_Qualified_Expression => True, + N_Real_Literal => True, + N_Selected_Component => True, + N_Slice => True, + N_Type_Conversion => True, + N_Unchecked_Type_Conversion => True, + + others => False); + ----------------------- -- Local Subprograms -- ----------------------- procedure Analyze_Dimension_Assignment_Statement (N : Node_Id); -- Subroutine of Analyze_Dimension for assignment statement + -- ??? what does this routine do? procedure Analyze_Dimension_Binary_Op (N : Node_Id); -- Subroutine of Analyze_Dimension for binary operators + -- ??? same here procedure Analyze_Dimension_Component_Declaration (N : Node_Id); -- Subroutine of Analyze_Dimension for component declaration + -- ??? same here procedure Analyze_Dimension_Extended_Return_Statement (N : Node_Id); -- Subroutine of Analyze_Dimension for extended return statement + -- ??? same here procedure Analyze_Dimension_Function_Call (N : Node_Id); -- Subroutine of Analyze_Dimension for function call + -- ??? same here procedure Analyze_Dimension_Has_Etype (N : Node_Id); -- Subroutine of Analyze_Dimension for N_Has_Etype nodes: @@ -364,30 +241,42 @@ package body Sem_Dim is -- 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 procedure Analyze_Dimension_Object_Renaming_Declaration (N : Node_Id); -- Subroutine of Analyze_Dimension for object renaming declaration + -- ??? same here procedure Analyze_Dimension_Simple_Return_Statement (N : Node_Id); -- Subroutine of Analyze_Dimension for simple return statement + -- ??? same here procedure Analyze_Dimension_Subtype_Declaration (N : Node_Id); -- Subroutine of Analyze_Dimension for subtype declaration + -- ??? same here procedure Analyze_Dimension_Unary_Op (N : Node_Id); -- Subroutine of Analyze_Dimension for unary operators + -- ??? same here - procedure Copy_Dimensions (From, To : Node_Id); - -- Propagate dimensions between two nodes + procedure Copy_Dimensions (From : Node_Id; To : Node_Id); + -- Copy the dimension vector from one node to another - procedure Create_Rational_From_Expr (Expr : Node_Id; R : in out Rational); + function Create_Rational_From_Expr (Expr : Node_Id) return Rational; -- Given an expression, creates a rational number + -- ??? what does this expression represent? + + function Dimensions_Of (N : Node_Id) return Dimension_Type; + -- Return the dimension vector of node N procedure Eval_Op_Expon_With_Rational_Exponent (N : Node_Id; @@ -395,39 +284,116 @@ package body Sem_Dim is -- Evaluate the Expon if the exponent is a rational and the operand has a -- dimension. + function Exists (Dim : Dimension_Type) return Boolean; + -- Determine whether Dim does not denote the null dimension + + function Exists (Sys : System_Type) return Boolean; + -- Determine whether Sys does not denote the null system + function From_Dimension_To_String_Id - (Dims : Dimensions; - Sys : Dim_Sys_Id) return String_Id; + (Dims : Dimension_Type; + System : System_Type) return String_Id; -- Given a dimension vector and a dimension system, return the proper -- string of symbols. - function Get_Dimensions (N : Node_Id) return Dimensions; - -- Return the dimensions for the corresponding node + function Is_Invalid (Position : Dimension_Position) return Boolean; + -- Determine whether Pos denotes the invalid position - function Get_Dimensions_String_Id (E : Entity_Id) return String_Id; - -- Return the String_Id of dimensions for the corresponding entity + procedure Move_Dimensions (From : Node_Id; To : Node_Id); + -- Copy dimension vector of From to To, delete dimension vector of From - function Get_Dimension_System_Id (E : Entity_Id) return Dim_Sys_Id; - -- Return the Dim_Id of the corresponding dimension system + procedure Remove_Dimensions (N : Node_Id); + -- Remove the dimension vector of node N - procedure Move_Dimensions (From, To : Node_Id); - -- Move Dimensions from 'From' to 'To'. Only called when 'From' has a - -- dimension. + procedure Set_Dimensions (N : Node_Id; Val : Dimension_Type); + -- Associate a dimension vector with a node - function Permits_Dimensions (N : Node_Id) return Boolean; - -- Return True if a node can have a dimension + procedure Set_Symbol (E : Entity_Id; Val : String_Id); + -- Associate a symbol representation of a dimension vector with a subtype - function Present (Dim : Dimensions) return Boolean; - -- Return True if Dim is not equal to Zero_Dimensions. + function Symbol_Of (E : Entity_Id) return String_Id; + -- E denotes a subtype with a dimension. Return the symbol representation + -- of the dimension vector. - procedure Remove_Dimensions (N : Node_Id); - -- Remove the node from the HTable + function System_Of (E : Entity_Id) return System_Type; + -- E denotes a type, return associated system of the type if it has one + + --------- + -- "+" -- + --------- + + function "+" (Right : Whole) return Rational is + begin + return (Right, 1); + end "+"; - procedure Set_Dimensions (N : Node_Id; Dims : Dimensions); - -- Store the dimensions of N in the Hash_Table for Dimensions + function "+" (Left, Right : Rational) return Rational is + R : constant Rational := + Rational'(Numerator => Left.Numerator * Right.Denominator + + Left.Denominator * Right.Numerator, + Denominator => Left.Denominator * Right.Denominator); + begin + return Reduce (R); + end "+"; - procedure Set_Dimensions_String_Id (E : Entity_Id; Str : String_Id); - -- Store the string of dimensions of E in the Hash_Table for String_Id + --------- + -- "-" -- + --------- + + function "-" (Right : Rational) return Rational is + begin + return Rational'(Numerator => -Right.Numerator, + Denominator => Right.Denominator); + end "-"; + + function "-" (Left, Right : Rational) return Rational is + R : constant Rational := + Rational'(Numerator => Left.Numerator * Right.Denominator - + Left.Denominator * Right.Numerator, + Denominator => Left.Denominator * Right.Denominator); + + begin + return Reduce (R); + end "-"; + + --------- + -- "*" -- + --------- + + function "*" (Left, Right : Rational) return Rational is + R : constant Rational := + Rational'(Numerator => Left.Numerator * Right.Numerator, + Denominator => Left.Denominator * Right.Denominator); + + begin + return Reduce (R); + end "*"; + + function "*" (Left : Rational; Right : Whole) return Rational is + R : constant Rational := + Rational'(Numerator => Left.Numerator * Right, + Denominator => Left.Denominator); + + begin + return Reduce (R); + end "*"; + + --------- + -- "/" -- + --------- + + function "/" (Left, Right : Whole) return Rational is + R : constant Int := abs Int (Right); + L : Int := Int (Left); + + begin + if Right < 0 then + L := -L; + end if; + + return Reduce (Rational'(Numerator => Whole (L), + Denominator => Whole (R))); + end "/"; ------------------------------ -- Analyze_Aspect_Dimension -- @@ -445,566 +411,341 @@ package body Sem_Dim is procedure Analyze_Aspect_Dimension (N : Node_Id; Id : Node_Id; - Expr : Node_Id) + Aggr : Node_Id) is - Def_Id : constant Entity_Id := Defining_Identifier (N); - N_Kind : constant Node_Kind := Nkind (N); - - Analyzed : array (Dimensions'Range) of Boolean := (others => False); - -- This array has been defined in order to deals with Others_Choice - -- It is a reminder of the dimensions in the aggregate that have already - -- been analyzed. - - Choice : Node_Id; - Comp_Expr : Node_Id; - Comp_Assn : Node_Id; - Dim : Dim_Id; - Dims : Dimensions := Zero_Dimensions; - Dim_Str_Lit : Node_Id; - D_Sys : Dim_Sys_Id := No_Dim_Sys; - N_Of_Dims : N_Of_Dimensions; - Str : String_Id := No_String; - - function Check_Identifier_Is_Dimension - (Id : Node_Id; - D_Sys : Dim_Sys_Id) return Boolean; - -- Return True if the identifier name is the name of a dimension in the - -- dimension system D_Sys. - - function Check_Compile_Time_Known_Expressions_In_Aggregate - (Expr : Node_Id) return Boolean; - -- Check that each expression in the aggregate is known at compile time - - function Check_Number_Dimensions_Aggregate - (Expr : Node_Id; - D_Sys : Dim_Sys_Id; - N_Of_Dims : N_Of_Dimensions) return Boolean; - -- This routine checks the number of dimensions in the aggregate. - - function Corresponding_Dimension_System (N : Node_Id) return Dim_Sys_Id; - -- Return the Dim_Sys_Id of the corresponding dimension system - - function Corresponding_Etype_Has_Dimensions (N : Node_Id) return Boolean; - -- Return True if the Etype of N has a dimension - - function Get_Dimension_Id - (Id : Node_Id; - D_Sys : Dim_Sys_Id) return Dim_Id; - -- Given an identifier and the Dim_Sys_Id of the dimension system in the - -- Table, returns the Dim_Id that has the same name as the identifier. - - ------------------------------------ - -- Corresponding_Dimension_System -- - ------------------------------------ - - function Corresponding_Dimension_System - (N : Node_Id) return Dim_Sys_Id + 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); + + Processed : array (Dimension_Type'Range) of Boolean := (others => False); + -- This array is used when processing ranges or Others_Choice as part of + -- the dimension aggregate. + + Dimensions : Dimension_Type := Null_Dimension; + + procedure Extract_Power + (Expr : Node_Id; + Position : Dimension_Position); + -- Given an expression with denotes a rational number, read the number + -- and associate it with Position in Dimensions. + + function Has_Compile_Time_Known_Expressions + (Aggr : Node_Id) return Boolean; + -- Determine whether aggregate Aggr contains only expressions that are + -- known at compile time. + + function Position_In_System + (Id : Node_Id; + System : System_Type) return Dimension_Position; + -- Given an identifier which denotes a dimension, return the position of + -- that dimension within System. + + ------------------- + -- Extract_Power -- + ------------------- + + procedure Extract_Power + (Expr : Node_Id; + Position : Dimension_Position) is - B_Typ : Node_Id; - Sub_Ind : Node_Id; - begin - -- Aspect_Dimension can only apply for subtypes - - -- Look for the dimension system corresponding to this - -- Aspect_Dimension. - - if Nkind (N) = N_Subtype_Declaration then - Sub_Ind := Subtype_Indication (N); - - if Nkind (Sub_Ind) /= N_Subtype_Indication then - B_Typ := Etype (Sub_Ind); - return Get_Dimension_System_Id (B_Typ); - else - return No_Dim_Sys; - end if; - + if Is_Integer_Type (Def_Id) then + Dimensions (Position) := +Whole (UI_To_Int (Expr_Value (Expr))); else - return No_Dim_Sys; + Dimensions (Position) := Create_Rational_From_Expr (Expr); end if; - end Corresponding_Dimension_System; + + Processed (Position) := True; + end Extract_Power; ---------------------------------------- - -- Corresponding_Etype_Has_Dimensions -- + -- Has_Compile_Time_Known_Expressions -- ---------------------------------------- - function Corresponding_Etype_Has_Dimensions - (N : Node_Id) return Boolean - is - Dims_Typ : Dimensions; - Typ : Entity_Id; - - begin - -- Check the type is dimensionless before assigning a dimension - - if Nkind (N) = N_Subtype_Declaration then - declare - Sub : constant Node_Id := Subtype_Indication (N); - - begin - if Nkind (Sub) /= N_Subtype_Indication then - Typ := Etype (Sub); - else - Typ := Etype (Subtype_Mark (Sub)); - end if; - - Dims_Typ := Get_Dimensions (Typ); - return Present (Dims_Typ); - end; - - else - return False; - end if; - end Corresponding_Etype_Has_Dimensions; - - --------------------------------------- - -- Check_Number_Dimensions_Aggregate -- - --------------------------------------- - - function Check_Number_Dimensions_Aggregate - (Expr : Node_Id; - D_Sys : Dim_Sys_Id; - N_Of_Dims : N_Of_Dimensions) return Boolean + function Has_Compile_Time_Known_Expressions + (Aggr : Node_Id) return Boolean is - Assoc : Node_Id; - Choice : Node_Id; - Comp_Expr : Node_Id; - N_Dims_Aggr : Int := No_Dimensions; - -- The number of dimensions in this aggregate + Comp : Node_Id; + Expr : Node_Id; begin - -- Check the size of the aggregate match with the size of the - -- corresponding dimension system. - - Comp_Expr := First (Expressions (Expr)); - - -- Skip the first argument in the aggregate since it's a character or - -- a string and not a dimension value. - - Next (Comp_Expr); - - if Present (Component_Associations (Expr)) then - - -- For a positional aggregate with an Others_Choice, the number - -- of expressions must be less than or equal to N_Of_Dims - 1. - - if Present (Comp_Expr) then - N_Dims_Aggr := List_Length (Expressions (Expr)) - 1; - return N_Dims_Aggr <= N_Of_Dims - 1; - - -- If the aggregate is a named aggregate, N_Dims_Aggr is used to - -- count all the dimensions referenced by the aggregate. - - else - Assoc := First (Component_Associations (Expr)); - - while Present (Assoc) loop - if Nkind (Assoc) = N_Range then - Choice := First (Choices (Assoc)); - - declare - HB : constant Node_Id := High_Bound (Choice); - LB : constant Node_Id := Low_Bound (Choice); - LB_Dim : Dim_Id; - HB_Dim : Dim_Id; - - begin - if not Check_Identifier_Is_Dimension (HB, D_Sys) - or else not Check_Identifier_Is_Dimension (LB, D_Sys) - then - return False; - end if; - - HB_Dim := Get_Dimension_Id (HB, D_Sys); - LB_Dim := Get_Dimension_Id (LB, D_Sys); - - N_Dims_Aggr := N_Dims_Aggr + HB_Dim - LB_Dim + 1; - end; - - else - N_Dims_Aggr := - N_Dims_Aggr + List_Length (Choices (Assoc)); - end if; + Expr := First (Expressions (Aggr)); + if Present (Expr) then - Next (Assoc); - end loop; + -- The first expression within the aggregate describes the + -- symbolic name of a dimension, skip it. - -- Check whether an Others_Choice is present or not + Next (Expr); + while Present (Expr) loop + Analyze_And_Resolve (Expr); - if Nkind - (First (Choices (Last (Component_Associations (Expr))))) = - N_Others_Choice - then - return N_Dims_Aggr <= N_Of_Dims; - else - return N_Dims_Aggr = N_Of_Dims; + if not Compile_Time_Known_Value (Expr) then + return False; end if; - end if; - -- If the aggregate is a positional aggregate without Others_Choice, - -- the number of expressions must match the number of dimensions in - -- the dimension system. - - else - N_Dims_Aggr := List_Length (Expressions (Expr)) - 1; - return N_Dims_Aggr = N_Of_Dims; + Next (Expr); + end loop; end if; - end Check_Number_Dimensions_Aggregate; - - ----------------------------------- - -- Check_Identifier_Is_Dimension -- - ----------------------------------- - function Check_Identifier_Is_Dimension - (Id : Node_Id; - D_Sys : Dim_Sys_Id) return Boolean - is - Na_Id : constant Name_Id := Chars (Id); - Dim_Name1 : Name_Id; - Dim_Name2 : Name_Id; - - begin - - for Dim1 in Dim_Id'Range loop - Dim_Name1 := Dim_Systems.Table (D_Sys).Names (Dim1); - - if Dim_Name1 = Na_Id then - return True; - end if; - - if Dim1 = Max_Dimensions then - - -- Check for possible misspelling - - Error_Msg_N ("& is not a dimension argument for aspect%", Id); + Comp := First (Component_Associations (Aggr)); + while Present (Comp) loop + Expr := Expression (Comp); - for Dim2 in Dim_Id'Range loop - Dim_Name2 := Dim_Systems.Table (D_Sys).Names (Dim2); + Analyze_And_Resolve (Expr); - if Is_Bad_Spelling_Of (Na_Id, Dim_Name2) then - Error_Msg_Name_1 := Dim_Name2; - Error_Msg_N ("\possible misspelling of%", Id); - exit; - end if; - end loop; + if not Compile_Time_Known_Value (Expr) then + return False; end if; - end loop; - - return False; - end Check_Identifier_Is_Dimension; - - ---------------------- - -- Get_Dimension_Id -- - ---------------------- - - -- Given an identifier, returns the correponding position of the - -- dimension in the dimension system. - - function Get_Dimension_Id - (Id : Node_Id; - D_Sys : Dim_Sys_Id) return Dim_Id - is - Na_Id : constant Name_Id := Chars (Id); - Dim : Dim_Id; - Dim_Name : Name_Id; - - begin - for D in Dim_Id'Range loop - Dim_Name := Dim_Systems.Table (D_Sys).Names (D); - if Dim_Name = Na_Id then - Dim := D; - end if; + Next (Comp); end loop; - return Dim; - end Get_Dimension_Id; + return True; + end Has_Compile_Time_Known_Expressions; - ------------------------------------------------------- - -- Check_Compile_Time_Known_Expressions_In_Aggregate -- - ------------------------------------------------------- + ------------------------ + -- Position_In_System -- + ------------------------ - function Check_Compile_Time_Known_Expressions_In_Aggregate - (Expr : Node_Id) return Boolean + function Position_In_System + (Id : Node_Id; + System : System_Type) return Dimension_Position is - Comp_Assn : Node_Id; - Comp_Expr : Node_Id; + Dimension_Name : constant Name_Id := Chars (Id); begin - - Comp_Expr := Next (First (Expressions (Expr))); - while Present (Comp_Expr) loop - - -- First, analyze the expression - - Analyze_And_Resolve (Comp_Expr); - - if not Compile_Time_Known_Value (Comp_Expr) then - return False; + for Position in System.Names'Range loop + if Dimension_Name = System.Names (Position) then + return Position; end if; - - Next (Comp_Expr); end loop; - Comp_Assn := First (Component_Associations (Expr)); - while Present (Comp_Assn) loop - Comp_Expr := Expression (Comp_Assn); - - -- First, analyze the expression + return Invalid_Position; + end Position_In_System; - Analyze_And_Resolve (Comp_Expr); + -- Local variables - if not Compile_Time_Known_Value (Comp_Expr) then - return False; - end if; - - Next (Comp_Assn); - end loop; - - return True; - end Check_Compile_Time_Known_Expressions_In_Aggregate; + Assoc : Node_Id; + Choice : Node_Id; + Expr : Node_Id; + Num_Choices : Nat := 0; + Num_Dimensions : Nat := 0; + Others_Seen : Boolean := False; + Position : Nat := 0; + Symbol : String_Id; + Symbol_Decl : Node_Id; -- Start of processing for Analyze_Aspect_Dimension begin - -- Syntax checking - - Error_Msg_Name_1 := Chars (Id); + -- STEP 1: Legality of aspect - if N_Kind /= N_Subtype_Declaration then - Error_Msg_N ("aspect% doesn't apply here", N); + if Nkind (N) /= N_Subtype_Declaration then + Error_Msg_NE ("aspect % must apply to subtype declaration", N, Id); return; end if; - if Nkind (Expr) /= N_Aggregate then - Error_Msg_N ("wrong syntax for aspect%", Expr); + if Nkind (Aggr) /= N_Aggregate then + Error_Msg_N ("aggregate expected", Aggr); return; end if; - D_Sys := Corresponding_Dimension_System (N); + -- Each expression in dimension aggregate must be known at compile time - if D_Sys = No_Dim_Sys then - Error_Msg_N ("dimension system not found for aspect%", N); + if not Has_Compile_Time_Known_Expressions (Aggr) then + Error_Msg_N ("values of aggregate must be static", Aggr); return; end if; - if Corresponding_Etype_Has_Dimensions (N) then - Error_Msg_N ("corresponding type already has a dimension", N); - return; - end if; - - -- Check the first expression is a string or a character literal and - -- skip it. + -- The dimension declarations are useless if the parent type does not + -- declare a valid system. - Dim_Str_Lit := First (Expressions (Expr)); - - if not Present (Dim_Str_Lit) - or else not Nkind_In (Dim_Str_Lit, - N_String_Literal, - N_Character_Literal) - then - Error_Msg_N - ("wrong syntax for aspect%: first argument in the aggregate must " & - "be a character or a string", - Expr); + if not Exists (System) then + Error_Msg_NE ("parent type of % lacks dimension system", N, Def_Id); return; end if; - Comp_Expr := Next (Dim_Str_Lit); + -- STEP 2: Structural verification of the dimension aggregate - -- Check the number of dimensions match with the dimension system + -- The first entry in the aggregate is the symbolic representation of + -- the dimension. - N_Of_Dims := Dim_Systems.Table (D_Sys).N_Of_Dims; + Symbol_Decl := First (Expressions (Aggr)); - if not Check_Number_Dimensions_Aggregate (Expr, D_Sys, N_Of_Dims) then - Error_Msg_N ("wrong number of dimensions for aspect%", Expr); + if No (Symbol_Decl) + or else not Nkind_In (Symbol_Decl, N_Character_Literal, + N_String_Literal) + then + Error_Msg_N ("first argument must be character or string", Aggr); return; end if; - Dim := Dim_Id'First; - Comp_Assn := First (Component_Associations (Expr)); + -- STEP 3: Name and value extraction - if Present (Comp_Expr) then - if List_Length (Component_Associations (Expr)) > 1 then - Error_Msg_N ("named association cannot follow " & - "positional association for aspect%", Expr); - return; - end if; + -- Positional elements - if Present (Comp_Assn) - and then Nkind (First (Choices (Comp_Assn))) /= N_Others_Choice - then - Error_Msg_N ("named association cannot follow " & - "positional association for aspect%", Expr); + Expr := Next (Symbol_Decl); + Position := Low_Position_Bound; + while Present (Expr) loop + if Position > High_Position_Bound then + Error_Msg_N + ("type has more dimensions than system allows", Def_Id); return; end if; - end if; - - -- Check each expression in the aspect Dimension aggregate is known at - -- compile time. - - if not Check_Compile_Time_Known_Expressions_In_Aggregate (Expr) then - Error_Msg_N ("wrong syntax for aspect%", Expr); - return; - end if; - - -- Get the dimension values and store them in the Hash_Table - - -- Positional aggregate case - - while Present (Comp_Expr) loop - if Is_Integer_Type (Def_Id) then - Dims (Dim) := +Whole (UI_To_Int (Expr_Value (Comp_Expr))); - else - Create_Rational_From_Expr (Comp_Expr, Dims (Dim)); - end if; - Analyzed (Dim) := True; + Extract_Power (Expr, Position); - exit when Dim = Max_Dimensions; + Position := Position + 1; + Num_Dimensions := Num_Dimensions + 1; - Dim := Dim + 1; - Next (Comp_Expr); + Next (Expr); end loop; - -- Named aggregate case + -- Named elements - while Present (Comp_Assn) loop - Comp_Expr := Expression (Comp_Assn); - Choice := First (Choices (Comp_Assn)); + Assoc := First (Component_Associations (Aggr)); + while Present (Assoc) loop + Expr := Expression (Assoc); + Choice := First (Choices (Assoc)); - if List_Length (Choices (Comp_Assn)) = 1 then + while Present (Choice) loop - -- N_Identifier case + -- Identifier case: NAME => EXPRESSION if Nkind (Choice) = N_Identifier then + Position := Position_In_System (Choice, System); - if not Check_Identifier_Is_Dimension (Choice, D_Sys) then + if Is_Invalid (Position) then + Error_Msg_N ("dimension name not part of system", Choice); return; end if; - Dim := Get_Dimension_Id (Choice, D_Sys); - - if Is_Integer_Type (Def_Id) then - Dims (Dim) := +Whole (UI_To_Int (Expr_Value (Comp_Expr))); - else - Create_Rational_From_Expr (Comp_Expr, Dims (Dim)); - end if; - - Analyzed (Dim) := True; + Extract_Power (Expr, Position); - -- N_Range case + -- Range case: NAME .. NAME => EXPRESSION elsif Nkind (Choice) = N_Range then declare - HB : constant Node_Id := High_Bound (Choice); - LB : constant Node_Id := Low_Bound (Choice); - LB_Dim : constant Dim_Id := Get_Dimension_Id (LB, D_Sys); - HB_Dim : constant Dim_Id := Get_Dimension_Id (HB, D_Sys); + Low : constant Node_Id := Low_Bound (Choice); + High : constant Node_Id := High_Bound (Choice); + Low_Pos : Dimension_Position; + High_Pos : Dimension_Position; begin - for Dim in LB_Dim .. HB_Dim loop - if Is_Integer_Type (Def_Id) then - Dims (Dim) := - +Whole (UI_To_Int (Expr_Value (Comp_Expr))); - else - Create_Rational_From_Expr (Comp_Expr, Dims (Dim)); - end if; + 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; + + 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); + return; + + 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); + return; + end if; - Analyzed (Dim) := True; + for Position in Low_Pos .. High_Pos loop + Extract_Power (Expr, Position); end loop; end; - -- N_Others_Choice case + -- Others case: OTHERS => EXPRESSION elsif Nkind (Choice) = N_Others_Choice then + if Present (Next (Choice)) then + Error_Msg_N + ("OTHERS must appear alone in a choice list", Choice); + return; - -- Check the Others_Choice is alone and last in the aggregate - - if Present (Next (Comp_Assn)) then + elsif Present (Next (Assoc)) then Error_Msg_N - ("OTHERS must appear alone and last in expression " & - "for aspect%", Choice); + ("OTHERS must appear last in an aggregate", Choice); + return; + + elsif Others_Seen then + Error_Msg_N ("multiple OTHERS not allowed", Choice); return; end if; - -- End the filling of Dims by the Others_Choice value. If - -- N_Of_Dims < Max_Dimensions then only the positions that - -- haven't been already analyzed from Dim_Id'First to N_Of_Dims - -- are filled. + Others_Seen := True; - for Dim in Dim_Id'First .. N_Of_Dims loop - if not Analyzed (Dim) then - if Is_Integer_Type (Def_Id) then - Dims (Dim) := - +Whole (UI_To_Int (Expr_Value (Comp_Expr))); - else - Create_Rational_From_Expr (Comp_Expr, Dims (Dim)); - end if; + -- 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; + -- All other cases are erroneous declarations of dimension names + else - Error_Msg_N ("wrong syntax for aspect%", Id); + Error_Msg_N ("wrong syntax for aspect%", Choice); + return; end if; - else - while Present (Choice) loop - if Nkind (Choice) = N_Identifier then + Num_Choices := Num_Choices + 1; - if not Check_Identifier_Is_Dimension (Choice, D_Sys) then - return; - end if; + Next (Choice); + end loop; - Dim := Get_Dimension_Id (Choice, D_Sys); + Num_Dimensions := Num_Dimensions + 1; - if Is_Integer_Type (Def_Id) then - Dims (Dim) := +Whole (UI_To_Int (Expr_Value (Comp_Expr))); - else - Create_Rational_From_Expr (Comp_Expr, Dims (Dim)); - end if; + Next (Assoc); + end loop; - Analyzed (Dim) := True; - Next (Choice); - else - Error_Msg_N ("wrong syntax for aspect%", Id); - end if; - end loop; - end if; + -- STEP 4: Consistency of system and dimensions - Next (Comp_Assn); - end loop; + if Present (Next (Symbol_Decl)) + and then (Num_Choices > 1 + or else (Num_Choices = 1 and then not Others_Seen)) + then + Error_Msg_N + ("named associations cannot follow positional associations", Aggr); - -- Create the string of dimensions + elsif Num_Dimensions > System.Count then + Error_Msg_N ("type has more dimensions than system allows", Def_Id); - if Nkind (Dim_Str_Lit) = N_Character_Literal then - Start_String; - Store_String_Char (UI_To_CC (Char_Literal_Value (Dim_Str_Lit))); - Str := End_String; - else - Str := Strval (Dim_Str_Lit); + elsif Num_Dimensions < System.Count and then not Others_Seen then + Error_Msg_N ("type has less dimensions than system allows", Def_Id); end if; - -- Store the dimensions in the Hash Table if not all equal to zero and - -- string is empty. + -- STEP 5: Dimension symbol extraction - if not Present (Dims) then - if String_Length (Str) = 0 then - Error_Msg_N - ("?dimension values all equal to zero for aspect%", Expr); - return; - end if; + if Nkind (Symbol_Decl) = N_Character_Literal then + Start_String; + Store_String_Char (UI_To_CC (Char_Literal_Value (Symbol_Decl))); + Symbol := End_String; else - Set_Dimensions (Def_Id, Dims); + Symbol := Strval (Symbol_Decl); end if; - -- Store the string in the Hash Table - -- When the string is empty, don't store the string in the Hash Table + if String_Length (Symbol) = 0 and then not Exists (Dimensions) then + Error_Msg_N ("useless dimension declaration", Aggr); + end if; - if Str /= No_String - and then String_Length (Str) /= 0 - then - Set_Dimensions_String_Id (Def_Id, Str); + -- STEP 6: Storage of extracted values + + 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 Analyze_Aspect_Dimension; @@ -1034,10 +775,10 @@ package body Sem_Dim is Dim_Name : Node_Id; Dim_Node : Node_Id; Dim_Symbol : Node_Id; - D_Sys : Dimension_System := No_Dimension_System; - Names : Name_Array := No_Names; - N_Of_Dims : N_Of_Dimensions; - Symbols : Symbol_Array := No_Symbols; + 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 @@ -1048,7 +789,7 @@ package body Sem_Dim is function Check_Number_Of_Dimensions (Expr : Node_Id) return Boolean; -- Return True if the number of dimensions in the corresponding - -- dimension is positive and lower than Max_Dimensions. + -- dimension is positive and lower than Max_Number_Of_Dimensions. ------------------------------- -- Derived_From_Numeric_Type -- @@ -1161,10 +902,9 @@ package body Sem_Dim is function Check_Number_Of_Dimensions (Expr : Node_Id) return Boolean is List_Expr : constant List_Id := Expressions (Expr); - begin - if List_Length (List_Expr) < Dim_Id'First - or else List_Length (List_Expr) > Max_Dimensions + if List_Length (List_Expr) < Dimension_Position'First + or else List_Length (List_Expr) > Max_Number_Of_Dimensions then return False; else @@ -1175,7 +915,7 @@ package body Sem_Dim is -- Start of processing for Analyze_Aspect_Dimension_System begin - Error_Msg_Name_1 := Chars (Id); + -- Error_Msg_Name_1 := Chars (Id); -- Syntax checking @@ -1206,10 +946,10 @@ package body Sem_Dim is -- Create the new dimension system - D_Sys.Base_Type := N; + D_Sys.Type_Decl := N; Dim_Node := First (Expressions (Expr)); - for Dim in Dim_Id'First .. N_Of_Dims loop + 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); @@ -1230,13 +970,13 @@ package body Sem_Dim is Next (Dim_Node); end loop; - D_Sys.Names := Names; - D_Sys.N_Of_Dims := N_Of_Dims; - D_Sys.Symbols := Symbols; + D_Sys.Names := Names; + D_Sys.Count := N_Of_Dims; + D_Sys.Symbols := Symbols; -- Store the dimension system in the Table - Dim_Systems.Append (D_Sys); + System_Table.Append (D_Sys); end Analyze_Aspect_Dimension_System; ----------------------- @@ -1308,28 +1048,28 @@ package body Sem_Dim is procedure Analyze_Dimension_Assignment_Statement (N : Node_Id) is Lhs : constant Node_Id := Name (N); - Dim_Lhs : constant Dimensions := Get_Dimensions (Lhs); + Dim_Lhs : constant Dimension_Type := Dimensions_Of (Lhs); Rhs : constant Node_Id := Expression (N); - Dim_Rhs : constant Dimensions := Get_Dimensions (Rhs); + Dim_Rhs : constant Dimension_Type := Dimensions_Of (Rhs); procedure Analyze_Dimensions_In_Assignment - (Dim_Lhs : Dimensions; - Dim_Rhs : Dimensions); - -- Subroutine to perform the dimensionnality checking for assignment + (Dim_Lhs : Dimension_Type; + Dim_Rhs : Dimension_Type); + -- Perform the dimensionality checking for assignment -------------------------------------- -- Analyze_Dimensions_In_Assignment -- -------------------------------------- procedure Analyze_Dimensions_In_Assignment - (Dim_Lhs : Dimensions; - Dim_Rhs : Dimensions) + (Dim_Lhs : Dimension_Type; + Dim_Rhs : Dimension_Type) is begin -- Check the lhs and the rhs have the same dimension - if not Present (Dim_Lhs) then - if Present (Dim_Rhs) then + if not Exists (Dim_Lhs) then + if Exists (Dim_Rhs) then Error_Msg_N ("?dimensions missmatch in assignment", N); end if; @@ -1360,16 +1100,18 @@ package body Sem_Dim is then declare L : constant Node_Id := Left_Opnd (N); - L_Dims : constant Dimensions := Get_Dimensions (L); - L_Has_Dimensions : constant Boolean := Present (L_Dims); + L_Dims : constant Dimension_Type := Dimensions_Of (L); + L_Has_Dimensions : constant Boolean := Exists (L_Dims); R : constant Node_Id := Right_Opnd (N); - R_Dims : constant Dimensions := Get_Dimensions (R); - R_Has_Dimensions : constant Boolean := Present (R_Dims); - Dims : Dimensions := Zero_Dimensions; + R_Dims : constant Dimension_Type := Dimensions_Of (R); + R_Has_Dimensions : constant Boolean := Exists (R_Dims); + Dims : Dimension_Type := Null_Dimension; begin if Nkind_In (N, N_Op_Add, N_Op_Mod, N_Op_Rem, N_Op_Subtract) then - Error_Msg_Name_1 := Chars (N); + + -- What is the following deleted code about + -- Error_Msg_Name_1 := Chars (N); -- Check both operands dimension @@ -1403,14 +1145,14 @@ package body Sem_Dim is -- Get both operands dimension and add them if N_Kind = N_Op_Multiply then - for Dim in Dimensions'Range loop + for Dim in Dimension_Type'Range loop Dims (Dim) := L_Dims (Dim) + R_Dims (Dim); end loop; -- Get both operands dimension and subtract them else - for Dim in Dimensions'Range loop + for Dim in Dimension_Type'Range loop Dims (Dim) := L_Dims (Dim) - R_Dims (Dim); end loop; end if; @@ -1428,17 +1170,18 @@ package body Sem_Dim is end if; end if; - if Present (Dims) then + if Exists (Dims) then Set_Dimensions (N, Dims); end if; - -- N_Op_Expon + -- N_Op_Expon + -- Propagation of the dimension and evaluation of the result if -- the exponent is a rational and if the operand has a dimension. elsif N_Kind = N_Op_Expon then declare - Rat : Rational := Zero_Rational; + Rat : Rational := Zero; begin -- Check exponent is dimensionless @@ -1455,23 +1198,23 @@ package body Sem_Dim is -- compile time. Otherwise, the exponentiation evaluation -- will return an error message. - if Get_Dimension_System_Id - (Base_Type (Etype (L))) /= No_Dim_Sys + if Exists (System_Of (Base_Type (Etype (L)))) and then Compile_Time_Known_Value (R) then -- Real exponent case if Is_Real_Type (Etype (L)) then + -- Define the exponent as a Rational number - Create_Rational_From_Expr (R, Rat); + Rat := Create_Rational_From_Expr (R); if L_Has_Dimensions then - for Dim in Dimensions'Range loop + for Dim in Dimension_Type'Range loop Dims (Dim) := L_Dims (Dim) * Rat; end loop; - if Present (Dims) then + if Exists (Dims) then Set_Dimensions (N, Dims); end if; end if; @@ -1483,13 +1226,13 @@ package body Sem_Dim is -- Integer exponent case else - for Dim in Dimensions'Range loop + for Dim in Dimension_Type'Range loop Dims (Dim) := L_Dims (Dim) * Whole (UI_To_Int (Expr_Value (R))); end loop; - if Present (Dims) then + if Exists (Dims) then Set_Dimensions (N, Dims); end if; end if; @@ -1501,7 +1244,9 @@ package body Sem_Dim is -- performed (no propagation). elsif N_Kind in N_Op_Compare then - Error_Msg_Name_1 := Chars (N); + + -- 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 @@ -1526,19 +1271,19 @@ package body Sem_Dim is Expr : constant Node_Id := Expression (N); Id : constant Entity_Id := Defining_Identifier (N); E_Typ : constant Entity_Id := Etype (Id); - Dim_T : constant Dimensions := Get_Dimensions (E_Typ); - Dim_E : Dimensions; + Dim_T : constant Dimension_Type := Dimensions_Of (E_Typ); + Dim_E : Dimension_Type; begin - if Present (Dim_T) then + 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 := Get_Dimensions (Expr); + Dim_E := Dimensions_Of (Expr); - if Present (Dim_E) then + if Exists (Dim_E) then -- Return an error if the dimension of the expression and the -- dimension of the type missmatch. @@ -1571,8 +1316,8 @@ package body Sem_Dim is Obj_Decls : constant List_Id := Return_Object_Declarations (N); R_Ent : constant Entity_Id := Return_Statement_Entity (N); R_Etyp : constant Entity_Id := Etype (Return_Applies_To (R_Ent)); - Dims_R : constant Dimensions := Get_Dimensions (R_Etyp); - Dims_Obj : Dimensions; + Dims_R : constant Dimension_Type := Dimensions_Of (R_Etyp); + Dims_Obj : Dimension_Type; Obj_Decl : Node_Id; Obj_Id : Entity_Id; @@ -1584,11 +1329,11 @@ package body Sem_Dim is Obj_Id := Defining_Identifier (Obj_Decl); if Is_Return_Object (Obj_Id) then - Dims_Obj := Get_Dimensions (Obj_Id); + Dims_Obj := Dimensions_Of (Obj_Id); if Dims_R /= Dims_Obj then - Error_Msg_N ("?dimensions missmatch in return statement", - N); + Error_Msg_N + ("?dimensions missmatch in return statement", N); return; end if; end if; @@ -1606,8 +1351,8 @@ 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 : Dimensions; - Dims_Param : Dimensions; + Dims : Dimension_Type; + Dims_Param : Dimension_Type; Param : Node_Id; function Is_Elementary_Function_Call (N : Node_Id) return Boolean; @@ -1624,9 +1369,7 @@ package body Sem_Dim is begin -- Note that the node must come from source - if Comes_From_Source (N) - and then Is_Entity_Name (Name_Call) - then + if Comes_From_Source (N) and then Is_Entity_Name (Name_Call) then Ent := Entity (Name_Call); -- Check the procedure is defined in an instantiation of a generic @@ -1659,9 +1402,9 @@ package body Sem_Dim is -- Sqrt function call case if Chars (Name_Call) = Name_Sqrt then - Dims := Get_Dimensions (First (Par_Ass)); + Dims := Dimensions_Of (First (Par_Ass)); - if Present (Dims) then + if Exists (Dims) then for Dim in Dims'Range loop Dims (Dim) := Dims (Dim) * (1, 2); end loop; @@ -1675,14 +1418,16 @@ package body Sem_Dim is else Param := First (Par_Ass); while Present (Param) loop - Dims_Param := Get_Dimensions (Param); + Dims_Param := Dimensions_Of (Param); + + if Exists (Dims_Param) then + + -- What is this deleted code about ??? + -- Error_Msg_Name_1 := Chars (Name_Call); - if Present (Dims_Param) then - Error_Msg_Name_1 := Chars (Name_Call); Error_Msg_N - ("?parameter should be dimensionless for elementary " & - "function%", - Param); + ("?parameter should be dimensionless for elementary " + & "function%", Param); return; end if; @@ -1703,13 +1448,13 @@ package body Sem_Dim is procedure Analyze_Dimension_Has_Etype (N : Node_Id) is E_Typ : constant Entity_Id := Etype (N); - Dims : constant Dimensions := Get_Dimensions (E_Typ); + Dims : constant Dimension_Type := Dimensions_Of (E_Typ); N_Kind : constant Node_Kind := Nkind (N); begin -- Propagation of the dimensions from the type - if Present (Dims) then + if Exists (Dims) then Set_Dimensions (N, Dims); end if; @@ -1749,9 +1494,9 @@ package body Sem_Dim is procedure Analyze_Dimension_Identifier (N : Node_Id) is Ent : constant Entity_Id := Entity (N); - Dims : constant Dimensions := Get_Dimensions (Ent); + Dims : constant Dimension_Type := Dimensions_Of (Ent); begin - if Present (Dims) then + if Exists (Dims) then Set_Dimensions (N, Dims); else Analyze_Dimension_Has_Etype (N); @@ -1766,18 +1511,18 @@ package body Sem_Dim is Expr : constant Node_Id := Expression (N); Id : constant Entity_Id := Defining_Identifier (N); E_Typ : constant Entity_Id := Etype (Id); - Dim_T : constant Dimensions := Get_Dimensions (E_Typ); - Dim_E : Dimensions; + Dim_T : constant Dimension_Type := Dimensions_Of (E_Typ); + Dim_E : Dimension_Type; begin - if Present (Dim_T) then + if Exists (Dim_T) then -- Expression is present if Present (Expr) then - Dim_E := Get_Dimensions (Expr); + Dim_E := Dimensions_Of (Expr); - if Present (Dim_E) then + if Exists (Dim_E) then -- Return an error if the dimension of the expression and the -- dimension of the type missmatch. @@ -1790,9 +1535,8 @@ package body Sem_Dim is -- If the expression is dimensionless else - -- If the node is not a real constant or an integer constant - -- (depending on the dimensioned numeric type), return an error - -- message. + -- If node is not a real or integer constant (depending on the + -- dimensioned numeric type), generate an error message. if not Nkind_In (Original_Node (Expr), N_Real_Literal, @@ -1819,9 +1563,9 @@ package body Sem_Dim is Id : constant Entity_Id := Defining_Identifier (N); Ren_Id : constant Node_Id := Name (N); E_Typ : constant Entity_Id := Etype (Ren_Id); - Dims_Typ : constant Dimensions := Get_Dimensions (E_Typ); + Dims_Typ : constant Dimension_Type := Dimensions_Of (E_Typ); begin - if Present (Dims_Typ) then + if Exists (Dims_Typ) then Copy_Dimensions (E_Typ, Id); end if; end Analyze_Dimension_Object_Renaming_Declaration; @@ -1832,10 +1576,10 @@ package body Sem_Dim is procedure Analyze_Dimension_Simple_Return_Statement (N : Node_Id) is Expr : constant Node_Id := Expression (N); - Dims_Expr : constant Dimensions := Get_Dimensions (Expr); + 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 Dimensions := Get_Dimensions (R_Etyp); + Dims_R : constant Dimension_Type := Dimensions_Of (R_Etyp); begin if Dims_R /= Dims_Expr then Error_Msg_N ("?dimensions missmatch in return statement", N); @@ -1849,28 +1593,27 @@ package body Sem_Dim is procedure Analyze_Dimension_Subtype_Declaration (N : Node_Id) is Ent : constant Entity_Id := Defining_Identifier (N); - Dims_Ent : constant Dimensions := Get_Dimensions (Ent); + Dims_Ent : constant Dimension_Type := Dimensions_Of (Ent); E_Typ : Node_Id; begin if Nkind (Subtype_Indication (N)) /= N_Subtype_Indication then E_Typ := Etype (Subtype_Indication (N)); declare - Dims_Typ : constant Dimensions := Get_Dimensions (E_Typ); + Dims_Typ : constant Dimension_Type := Dimensions_Of (E_Typ); begin - if Present (Dims_Typ) then + if Exists (Dims_Typ) then -- If subtype already has a dimension (from Aspect_Dimension), -- it cannot inherit a dimension from its subtype. - if Present (Dims_Ent) then + if Exists (Dims_Ent) then Error_Msg_N ("?subtype& already has a dimension", N); else Set_Dimensions (Ent, Dims_Typ); - Set_Dimensions_String_Id - (Ent, Get_Dimensions_String_Id (E_Typ)); + Set_Symbol (Ent, Symbol_Of (E_Typ)); end if; end if; end; @@ -1878,21 +1621,20 @@ package body Sem_Dim is else E_Typ := Etype (Subtype_Mark (Subtype_Indication (N))); declare - Dims_Typ : constant Dimensions := Get_Dimensions (E_Typ); + Dims_Typ : constant Dimension_Type := Dimensions_Of (E_Typ); begin - if Present (Dims_Typ) then + if Exists (Dims_Typ) then -- If subtype already has a dimension (from Aspect_Dimension), -- it cannot inherit a dimension from its subtype. - if Present (Dims_Ent) then + if Exists (Dims_Ent) then Error_Msg_N ("?subtype& already has a dimension", N); else Set_Dimensions (Ent, Dims_Typ); - Set_Dimensions_String_Id - (Ent, Get_Dimensions_String_Id (E_Typ)); + Set_Symbol (Ent, Symbol_Of (E_Typ)); end if; end if; end; @@ -1925,22 +1667,22 @@ package body Sem_Dim is -- Copy_Dimensions -- --------------------- - procedure Copy_Dimensions (From, To : Node_Id) is - Dims : constant Dimensions := Aspect_Dimension_Hash_Table.Get (From); + procedure Copy_Dimensions (From : Node_Id; To : Node_Id) is + Dims : constant Dimension_Type := Dimensions_Of (From); begin -- Propagate the dimension from one node to another - pragma Assert (Permits_Dimensions (To)); - pragma Assert (Present (Dims)); - Aspect_Dimension_Hash_Table.Set (To, Dims); + pragma Assert (OK_For_Dimension (Nkind (To))); + pragma Assert (Exists (Dims)); + Set_Dimensions (To, Dims); end Copy_Dimensions; ------------------------------- -- Create_Rational_From_Expr -- ------------------------------- - procedure Create_Rational_From_Expr (Expr : Node_Id; R : in out Rational) is + 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; @@ -1949,6 +1691,7 @@ package body Sem_Dim is Right_Int : Int; R_Opnd_Minus : Node_Id; Rtype : Entity_Id; + Result : Rational; begin -- A rational number is a number that can be expressed as the quotient @@ -1974,9 +1717,9 @@ package body Sem_Dim is if Right_Int > 0 then if Left_Int mod Right_Int = 0 then - R := +Whole (UI_To_Int (Expr_Value (Expr))); + Result := +Whole (UI_To_Int (Expr_Value (Expr))); else - R := Whole (Left_Int) / Whole (Right_Int); + Result := Whole (Left_Int) / Whole (Right_Int); end if; else @@ -2009,9 +1752,9 @@ package body Sem_Dim is if Right_Int > 0 then if Left_Int mod Right_Int = 0 then - R := +Whole (-UI_To_Int (Expr_Value (Expr))); + Result := +Whole (-UI_To_Int (Expr_Value (Expr))); else - R := Whole (-Left_Int) / Whole (Right_Int); + Result := Whole (-Left_Int) / Whole (Right_Int); end if; else @@ -2028,19 +1771,41 @@ package body Sem_Dim is else if Is_Integer_Type (Etype (Expr)) then Right_Int := UI_To_Int (Expr_Value (Expr)); - R := +Whole (Right_Int); + Result := +Whole (Right_Int); else Error_Msg_N ("must be a rational", Expr); end if; end if; + + return Result; end Create_Rational_From_Expr; + ------------------- + -- Dimensions_Of -- + ------------------- + + function Dimensions_Of (N : Node_Id) return Dimension_Type is + begin + return Dimension_Table.Get (N); + end Dimensions_Of; + + -------------------------- + -- Dimension_Table_Hash -- + -------------------------- + + function Dimension_Table_Hash + (Key : Node_Id) return Dimension_Table_Range + is + begin + return Dimension_Table_Range (Key mod 511); + end Dimension_Table_Hash; + ---------------------------------------- -- Eval_Op_Expon_For_Dimensioned_Type -- ---------------------------------------- - -- Eval the expon operator for dimensioned type + -- Evaluate the expon operator for dimensioned type -- 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. @@ -2050,10 +1815,10 @@ package body Sem_Dim is B_Typ : Entity_Id) is R : constant Node_Id := Right_Opnd (N); - Rat : Rational := Zero_Rational; + Rat : Rational := Zero; begin if Compile_Time_Known_Value (R) and then Is_Real_Type (B_Typ) then - Create_Rational_From_Expr (R, Rat); + Rat := Create_Rational_From_Expr (R); Eval_Op_Expon_With_Rational_Exponent (N, Rat); end if; end Eval_Op_Expon_For_Dimensioned_Type; @@ -2071,7 +1836,7 @@ package body Sem_Dim is (N : Node_Id; Rat : Rational) is - Dims : constant Dimensions := Get_Dimensions (N); + 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); @@ -2085,25 +1850,23 @@ package body Sem_Dim is New_E : Entity_Id; New_N : Node_Id; New_Typ_L : Node_Id; - Sys : Dim_Sys_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 + if Comes_From_Source (N) and then Rat.Denominator /= 1 then Base_Typ := Base_Type (Etyp); -- Case when the operand is not dimensionless - if Present (Dims) then + if Exists (Dims) then -- Get the corresponding Dim_Sys_Id to know the exact number of -- dimensions in the system. - Sys := Get_Dimension_System_Id (Base_Typ); + System := System_Of (Base_Typ); -- Step 1: Generation of a new subtype with the proper dimensions @@ -2114,10 +1877,10 @@ package body Sem_Dim is -- Generate: -- Base_Typ : constant Entity_Id := Base_Type (Etyp); - -- Sys : constant Dim_Sys_Id := + -- Sys : constant System_Id := -- Get_Dimension_System_Id (Base_Typ); - -- N_Dims : constant N_Of_Dimensions := - -- Dim_Systems.Table (Sys).N_Of_Dims; + -- N_Dims : constant Number_Of_Dimensions := + -- Dimension_Systems.Table (Sys).Dimension_Count; -- Dim_Value : Rational; -- Aspect_Dim_Expr : List; @@ -2144,7 +1907,7 @@ package body Sem_Dim is Append (Make_String_Literal (Loc, No_String), List_Of_Dims); - for Dim in Dims'First .. Dim_Systems.Table (Sys).N_Of_Dims loop + for Dim in Dims'First .. System.Count loop Dim_Value := Dims (Dim); if Dim_Value.Denominator /= 1 then @@ -2245,6 +2008,20 @@ package body Sem_Dim is end if; end Eval_Op_Expon_With_Rational_Exponent; + ------------ + -- Exists -- + ------------ + + function Exists (Dim : Dimension_Type) return Boolean is + begin + return Dim /= Null_Dimension; + end Exists; + + function Exists (Sys : System_Type) return Boolean is + begin + return Sys /= Null_System; + end Exists; + ------------------------------------------- -- Expand_Put_Call_With_Dimension_String -- ------------------------------------------- @@ -2278,12 +2055,12 @@ package body Sem_Dim is Actual : Node_Id; Base_Typ : Node_Id; Char_Pack : Name_Id; - Dims : Dimensions; + Dims : Dimension_Type; Etyp : Entity_Id; First_Actual : Node_Id; New_Par_Ass : List_Id; New_Str_Lit : Node_Id; - Sys : Dim_Sys_Id; + System : System_Type; function Is_Procedure_Put_Call (N : Node_Id) return Boolean; -- Return True if the current call is a call of an instantiation of a @@ -2363,17 +2140,17 @@ package body Sem_Dim is end if; Base_Typ := Base_Type (Etype (Actual)); - Sys := Get_Dimension_System_Id (Base_Typ); + System := System_Of (Base_Typ); - if Sys /= No_Dim_Sys then - Dims := Get_Dimensions (Actual); + if Exists (System) then + Dims := 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. - if Present (Dims) - or else Get_Dimensions_String_Id (Etyp) /= No_String + if Exists (Dims) + or else Symbol_Of (Etyp) /= No_String then New_Par_Ass := New_List; @@ -2392,15 +2169,14 @@ package body Sem_Dim is -- Check if the type of N is a subtype that has a string of -- dimensions in Aspect_Dimension_String_Id_Hash_Table. - if Get_Dimensions_String_Id (Etyp) /= No_String then + if Symbol_Of (Etyp) /= No_String then Start_String; -- Put a space between the value and the dimension Store_String_Char (' '); - Store_String_Chars (Get_Dimensions_String_Id (Etyp)); - New_Str_Lit := - Make_String_Literal (Loc, End_String); + Store_String_Chars (Symbol_Of (Etyp)); + New_Str_Lit := Make_String_Literal (Loc, End_String); -- Rewrite the String_Literal of the second actual with the -- new String_Id created by the routine @@ -2409,7 +2185,7 @@ package body Sem_Dim is else New_Str_Lit := Make_String_Literal (Loc, - From_Dimension_To_String_Id (Dims, Sys)); + From_Dimension_To_String_Id (Dims, System)); end if; Append (New_Str_Lit, New_Par_Ass); @@ -2418,7 +2194,7 @@ package body Sem_Dim is Rewrite (N, Make_Procedure_Call_Statement (Loc, - Name => New_Copy (Name_Call), + Name => New_Copy (Name_Call), Parameter_Associations => New_Par_Ass)); Analyze (N); @@ -2436,8 +2212,8 @@ package body Sem_Dim is -- dimensions Dims. function From_Dimension_To_String_Id - (Dims : Dimensions; - Sys : Dim_Sys_Id) return String_Id + (Dims : Dimension_Type; + System : System_Type) return String_Id is Dim_Rat : Rational; First_Dim_In_Str : Boolean := True; @@ -2451,9 +2227,9 @@ package body Sem_Dim is Store_String_Char (' '); - for Dim in Dimensions'Range loop + for Dim in Dimension_Type'Range loop Dim_Rat := Dims (Dim); - if Dim_Rat /= Zero_Rational then + if Dim_Rat /= Zero then if First_Dim_In_Str then First_Dim_In_Str := False; @@ -2464,11 +2240,10 @@ package body Sem_Dim is -- Positive dimension case if Dim_Rat.Numerator > 0 then - if Dim_Systems.Table (Sys).Symbols (Dim) = No_String then - Store_String_Chars - (Get_Name_String (Dim_Systems.Table (Sys).Names (Dim))); + if System.Symbols (Dim) = No_String then + Store_String_Chars (Get_Name_String (System.Names (Dim))); else - Store_String_Chars (Dim_Systems.Table (Sys).Symbols (Dim)); + Store_String_Chars (System.Symbols (Dim)); end if; -- Integer case @@ -2493,11 +2268,10 @@ package body Sem_Dim is -- Negative dimension case else - if Dim_Systems.Table (Sys).Symbols (Dim) = No_String then - Store_String_Chars - (Get_Name_String (Dim_Systems.Table (Sys).Names (Dim))); + if System.Symbols (Dim) = No_String then + Store_String_Chars (Get_Name_String (System.Names (Dim))); else - Store_String_Chars (Dim_Systems.Table (Sys).Symbols (Dim)); + Store_String_Chars (System.Symbols (Dim)); end if; Store_String_Chars ("**"); @@ -2524,130 +2298,92 @@ package body Sem_Dim is return End_String; end From_Dimension_To_String_Id; - -------------------- - -- Get_Dimensions -- - -------------------- - - function Get_Dimensions (N : Node_Id) return Dimensions is - begin - return Aspect_Dimension_Hash_Table.Get (N); - end Get_Dimensions; - - ------------------------------ - -- Get_Dimensions_String_Id -- - ------------------------------ - - function Get_Dimensions_String_Id (E : Entity_Id) return String_Id is - begin - return Aspect_Dimension_String_Id_Hash_Table.Get (E); - end Get_Dimensions_String_Id; - - ----------------------------- - -- Get_Dimension_System_Id -- - ----------------------------- + --------- + -- GCD -- + --------- - function Get_Dimension_System_Id (E : Entity_Id) return Dim_Sys_Id is - D_Sys : Dim_Sys_Id := No_Dim_Sys; + function GCD (Left, Right : Whole) return Int is + L : Whole; + R : Whole; begin - -- Scan the Table in order to find N - -- What is N??? no sign of anything called N here ??? + L := Left; + R := Right; + while R /= 0 loop + L := L mod R; - for Dim_Sys in 1 .. Dim_Systems.Last loop - if Parent (E) = Dim_Systems.Table (Dim_Sys).Base_Type then - D_Sys := Dim_Sys; + if L = 0 then + return Int (R); end if; + + R := R mod L; end loop; - return D_Sys; - end Get_Dimension_System_Id; + return Int (L); + end GCD; -------------------------- - -- Is_Dimensioned_Type -- + -- Has_Dimension_System -- -------------------------- - function Is_Dimensioned_Type (E : Entity_Id) return Boolean is + function Has_Dimension_System (Typ : Entity_Id) return Boolean is begin - if Get_Dimension_System_Id (E) /= No_Dim_Sys then - return True; - else - return False; - end if; - end Is_Dimensioned_Type; + return Exists (System_Of (Typ)); + end Has_Dimension_System; + + ---------------- + -- Is_Invalid -- + ---------------- + + function Is_Invalid (Position : Dimension_Position) return Boolean is + begin + return Position = Invalid_Position; + end Is_Invalid; --------------------- -- Move_Dimensions -- --------------------- procedure Move_Dimensions (From, To : Node_Id) is - Dims : constant Dimensions := Get_Dimensions (From); + Dims : constant Dimension_Type := Dimensions_Of (From); begin -- Copy the dimension of 'From to 'To' and remove dimension of 'From' - if Present (Dims) then + if Exists (Dims) then Set_Dimensions (To, Dims); Remove_Dimensions (From); end if; end Move_Dimensions; - ------------------------ - -- Permits_Dimensions -- - ------------------------ - - -- Here is the list of node that permits a dimension - - Dimensions_Permission : constant array (Node_Kind) of Boolean := - (N_Attribute_Reference => True, - N_Defining_Identifier => True, - N_Function_Call => True, - N_Identifier => True, - N_Indexed_Component => True, - N_Integer_Literal => True, - - N_Op_Abs => True, - N_Op_Add => True, - N_Op_Divide => True, - N_Op_Expon => True, - N_Op_Minus => True, - N_Op_Mod => True, - N_Op_Multiply => True, - N_Op_Plus => True, - N_Op_Rem => True, - N_Op_Subtract => True, - - N_Qualified_Expression => True, - N_Real_Literal => True, - N_Selected_Component => True, - N_Slice => True, - N_Type_Conversion => True, - N_Unchecked_Type_Conversion => True, - - others => False); + ------------ + -- Reduce -- + ------------ - function Permits_Dimensions (N : Node_Id) return Boolean is + function Reduce (X : Rational) return Rational is begin - return Dimensions_Permission (Nkind (N)); - end Permits_Dimensions; + if X.Numerator = 0 then + return Zero; + end if; - ------------- - -- Present -- - ------------- + declare + G : constant Int := GCD (X.Numerator, X.Denominator); - function Present (Dim : Dimensions) return Boolean is - begin - return Dim /= Zero_Dimensions; - end Present; + begin + return Rational'(Numerator => Whole (Int (X.Numerator) / G), + Denominator => Whole (Int (X.Denominator) / G)); + end; + end Reduce; ----------------------- -- Remove_Dimensions -- ----------------------- procedure Remove_Dimensions (N : Node_Id) is - Dims : constant Dimensions := Get_Dimensions (N); + Dims : constant Dimension_Type := Dimensions_Of (N); begin - if Present (Dims) then - Aspect_Dimension_Hash_Table.Remove (N); + if Exists (Dims) then + Dimension_Table.Remove (N); end if; end Remove_Dimensions; @@ -2655,22 +2391,19 @@ package body Sem_Dim is -- Remove_Dimension_In_Call -- ------------------------------ - procedure Remove_Dimension_In_Call (N : Node_Id) is - Actual : Node_Id; - Par_Ass : constant List_Id := Parameter_Associations (N); + procedure Remove_Dimension_In_Call (Call : Node_Id) is + Actual : Node_Id; begin if Ada_Version < Ada_2012 then return; end if; - if Present (Par_Ass) then - Actual := First (Par_Ass); - while Present (Actual) loop - Remove_Dimensions (Actual); - Next (Actual); - end loop; - end if; + Actual := First (Parameter_Associations (Call)); + while Present (Actual) loop + Remove_Dimensions (Actual); + Next (Actual); + end loop; end Remove_Dimension_In_Call; ------------------------------------- @@ -2681,16 +2414,13 @@ package body Sem_Dim is -- N_Component_Declaration as part of the Analyze_Declarations routine -- (see package Sem_Ch3). - procedure Remove_Dimension_In_Declaration (D : Node_Id) is + procedure Remove_Dimension_In_Declaration (Decl : Node_Id) is begin - if Ada_Version < Ada_2012 then - return; - end if; - - if Nkind_In (D, N_Object_Declaration, N_Component_Declaration) then - if Present (Expression (D)) then - Remove_Dimensions (Expression (D)); - end if; + 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; @@ -2701,9 +2431,7 @@ package body Sem_Dim is -- Removal of dimension in statement as part of the Analyze_Statements -- routine (see package Sem_Ch5). - procedure Remove_Dimension_In_Statement (S : Node_Id) is - S_Kind : constant Node_Kind := Nkind (S); - + procedure Remove_Dimension_In_Statement (Stmt : Node_Id) is begin if Ada_Version < Ada_2012 then return; @@ -2711,9 +2439,9 @@ package body Sem_Dim is -- Remove dimension in parameter specifications for accept statement - if S_Kind = N_Accept_Statement then + if Nkind (Stmt) = N_Accept_Statement then declare - Param : Node_Id := First (Parameter_Specifications (S)); + Param : Node_Id := First (Parameter_Specifications (Stmt)); begin while Present (Param) loop Remove_Dimensions (Param); @@ -2723,9 +2451,9 @@ package body Sem_Dim is -- Remove dimension of name and expression in assignments - elsif S_Kind = N_Assignment_Statement then - Remove_Dimensions (Expression (S)); - Remove_Dimensions (Name (S)); + elsif Nkind (Stmt) = N_Assignment_Statement then + Remove_Dimensions (Expression (Stmt)); + Remove_Dimensions (Name (Stmt)); end if; end Remove_Dimension_In_Statement; @@ -2733,20 +2461,59 @@ package body Sem_Dim is -- Set_Dimensions -- -------------------- - procedure Set_Dimensions (N : Node_Id; Dims : Dimensions) is + procedure Set_Dimensions (N : Node_Id; Val : Dimension_Type) is begin - pragma Assert (Permits_Dimensions (N)); - pragma Assert (Present (Dims)); - Aspect_Dimension_Hash_Table.Set (N, Dims); + pragma Assert (OK_For_Dimension (Nkind (N))); + pragma Assert (Exists (Val)); + + Dimension_Table.Set (N, Val); end Set_Dimensions; - ------------------------------ - -- Set_Dimensions_String_Id -- - ------------------------------ + ---------------- + -- Set_Symbol -- + ---------------- - procedure Set_Dimensions_String_Id (E : Entity_Id; Str : String_Id) is + procedure Set_Symbol (E : Entity_Id; Val : String_Id) is begin - Aspect_Dimension_String_Id_Hash_Table.Set (E, Str); - end Set_Dimensions_String_Id; + Symbol_Table.Set (E, Val); + end Set_Symbol; + + --------------- + -- Symbol_Of -- + --------------- + + function Symbol_Of (E : Entity_Id) return String_Id is + begin + return Symbol_Table.Get (E); + end Symbol_Of; + + ----------------------- + -- Symbol_Table_Hash -- + ----------------------- + + function Symbol_Table_Hash (Key : Entity_Id) return Symbol_Table_Range is + begin + return Symbol_Table_Range (Key mod 511); + end Symbol_Table_Hash; + + --------------- + -- System_Of -- + --------------- + + function System_Of (E : Entity_Id) return System_Type is + 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 ??? + + for Dim_Sys in 1 .. System_Table.Last loop + if Type_Decl = System_Table.Table (Dim_Sys).Type_Decl then + return System_Table.Table (Dim_Sys); + end if; + end loop; + + return Null_System; + end System_Of; end Sem_Dim; diff --git a/gcc/ada/sem_dim.ads b/gcc/ada/sem_dim.ads index cda1135..be6a8da 100644 --- a/gcc/ada/sem_dim.ads +++ b/gcc/ada/sem_dim.ads @@ -23,17 +23,17 @@ -- -- ------------------------------------------------------------------------------ --- This new package of the GNAT compiler has been created in order to enable --- any user of the GNAT compiler to deal with physical issues. +-- This package provides support for numerical systems with dimensions. A +-- "dimension" is a compile-time property of a numerical type which represents +-- a relation between various quantifiers such as length, velocity, etc. --- Indeed, the user is now able to create their own dimension system and to --- assign a dimension, defined from the MKS system (package System.Dim_Mks) --- or their own dimension systems, with any item and to run operations with --- dimensionned entities. +-- Package System.Dim_Mks offers a ready-to-use system of SI base units. In +-- addition, the implementation of this feature offers the ability to define +-- an arbitrary system of units through the use of Ada 2012 aspects. --- In that case, a dimensionality checking will be performed at compile time. --- If no dimension has been assigned, the compiler assumes that the item is --- dimensionless. +-- Dimensionality checking is part of type analysis performed by the compiler. +-- It ensures that manipulation of quantified numeric values is sensible with +-- respect to the system of units. ----------------------------- -- Aspect_Dimension_System -- @@ -93,63 +93,68 @@ with Types; use Types; package Sem_Dim is - ----------------------------- - -- Aspect_Dimension_System -- - ----------------------------- - - procedure Analyze_Aspect_Dimension_System + procedure Analyze_Aspect_Dimension (N : Node_Id; Id : Node_Id; - Expr : Node_Id); - -- Analyzes the aggregate of Aspect_Dimension_System - - ---------------------- - -- Aspect_Dimension -- - ---------------------- + 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 - procedure Analyze_Aspect_Dimension + procedure Analyze_Aspect_Dimension_System (N : Node_Id; Id : Node_Id; Expr : Node_Id); - -- Analyzes the aggregate of Aspect_Dimension and attaches the - -- corresponding dimension to N. - - ------------------------------------------- - -- Dimensionality checking & propagation -- - ------------------------------------------- + -- 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 procedure Analyze_Dimension (N : Node_Id); - -- Performs a dimension analysis and propagates dimension between nodes - -- when needed. + -- N may denote any of the following contexts: + -- * assignment statement + -- * attribute reference + -- * binary operator + -- * compontent declaration + -- * extended return statement + -- * function call + -- * identifier + -- * indexed component + -- * object declaration + -- * object renaming declaration + -- * qualified expression + -- * selected component + -- * simple return statement + -- * slice + -- * subtype declaration + -- * type conversion + -- * unary operator + -- * unchecked type conversion + -- Depending on the context, ensure that all expressions and entities + -- 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? - function Is_Dimensioned_Type (E : Entity_Id) return Boolean; - -- Return True if the type is a dimensioned type (i.e: a type which has an - -- aspect Dimension_System) - - procedure Remove_Dimension_In_Call (N : Node_Id); - -- At the end of the Expand_Call routine, remove the dimensions of every - -- parameter in the call N. + procedure Expand_Put_Call_With_Dimension_String (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 + -- a dimension. - procedure Remove_Dimension_In_Declaration (D : Node_Id); - -- At the end of Analyze_Declarations routine (see Sem_Ch3), removes the - -- dimension of the expression for each declaration. + function Has_Dimension_System (Typ : Entity_Id) return Boolean; + -- Return True if type Typ has aspect Dimension_System applied to it - procedure Remove_Dimension_In_Statement (S : Node_Id); - -- At the end of the Analyze_Statements routine (see Sem_Ch5), removes the - -- dimension for every statements. + procedure Remove_Dimension_In_Call (Call : Node_Id); + -- Remove the dimensions from all formal parameters of Call - ------------------ - -- Dimension_IO -- - ------------------ + procedure Remove_Dimension_In_Declaration (Decl : Node_Id); + -- Remove the dimensions from the expression of Decl - procedure Expand_Put_Call_With_Dimension_String (N : Node_Id); - -- Expansion of Put call (from package System.Dim_Float_IO and - -- System.Dim_Integer_IO) for a dimensioned object in order to add the - -- dimension symbols as a suffix of the numeric value. + procedure Remove_Dimension_In_Statement (Stmt : Node_Id); + -- Remove the dimensions associated with Stmt end Sem_Dim; diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 3ebd88f..5a5ebfa 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -8016,7 +8016,7 @@ package body Sem_Res is -- Evaluate the exponentiation operator for dimensioned type with -- rational exponent. - if Ada_Version >= Ada_2012 and then Is_Dimensioned_Type (B_Typ) then + if Ada_Version >= Ada_2012 and then Has_Dimension_System (B_Typ) then Eval_Op_Expon_For_Dimensioned_Type (N, B_Typ); -- Skip the Eval_Op_Expon if the node has already been evaluated |