===================================================================
@@ -56,6 +56,7 @@
with Sem_Ch7; use Sem_Ch7;
with Sem_Ch8; use Sem_Ch8;
with Sem_Ch13; use Sem_Ch13;
+with Sem_Dim; use Sem_Dim;
with Sem_Disp; use Sem_Disp;
with Sem_Dist; use Sem_Dist;
with Sem_Elim; use Sem_Elim;
@@ -2036,6 +2037,7 @@
if Has_Aspects (N) then
Analyze_Aspect_Specifications (N, Id);
end if;
+ Analyze_Dimension (N);
end Analyze_Component_Declaration;
--------------------------
@@ -2089,6 +2091,11 @@
-- 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
@@ -3773,6 +3780,7 @@
if Has_Aspects (N) then
Analyze_Aspect_Specifications (N, Id);
end if;
+ Analyze_Dimension (N);
end Analyze_Object_Declaration;
---------------------------
@@ -4571,6 +4579,7 @@
if Has_Aspects (N) then
Analyze_Aspect_Specifications (N, Id);
end if;
+ Analyze_Dimension (N);
end Analyze_Subtype_Declaration;
--------------------------------
===================================================================
@@ -366,6 +366,8 @@
("s-addima", F), -- System.Address_Image
("s-assert", F), -- System.Assertions
+ ("s-diflio", F), -- System.Dim_Float_IO
+ ("s-diinio", F), -- System.Dim_Integer_IO
("s-memory", F), -- System.Memory
("s-parint", F), -- System.Partition_Interface
("s-pooglo", F), -- System.Pool_Global
===================================================================
@@ -47,6 +47,7 @@
with Sem_Ch3; use Sem_Ch3;
with Sem_Ch6; use Sem_Ch6;
with Sem_Ch8; use Sem_Ch8;
+with Sem_Dim; use Sem_Dim;
with Sem_Disp; use Sem_Disp;
with Sem_Elab; use Sem_Elab;
with Sem_Eval; use Sem_Eval;
@@ -839,6 +840,7 @@
Set_Last_Assignment (Ent, Lhs);
end if;
end;
+ Analyze_Dimension (N);
end Analyze_Assignment;
-----------------------------
@@ -2731,6 +2733,10 @@
S := First (L);
while Present (S) loop
Analyze (S);
+
+ -- Remove dimension in all statements
+
+ Remove_Dimension_In_Statement (S);
Next (S);
end loop;
===================================================================
@@ -0,0 +1,77 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . D I M _ I N T E G E R _ I O --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
+-- --
+-- GNARL is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- 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. --
+-- --
+------------------------------------------------------------------------------
+
+package body System.Dim_Integer_IO is
+
+ package Num_Dim_Integer_IO is new Ada.Text_IO.Integer_IO (Num_Dim_Integer);
+
+ ---------
+ -- Put --
+ ---------
+
+ procedure Put
+ (File : File_Type;
+ Item : Num_Dim_Integer;
+ Unit : String := "";
+ Width : Field := Default_Width;
+ Base : Number_Base := Default_Base)
+
+ is
+ begin
+ Num_Dim_Integer_IO.Put (File, Item, Width, Base);
+ Ada.Text_IO.Put (File, Unit);
+ end Put;
+
+ procedure Put
+ (Item : Num_Dim_Integer;
+ Unit : String := "";
+ Width : Field := Default_Width;
+ Base : Number_Base := Default_Base)
+
+ is
+ begin
+ Num_Dim_Integer_IO.Put (Item, Width, Base);
+ Ada.Text_IO.Put (Unit);
+ end Put;
+
+ procedure Put
+ (To : out String;
+ Item : Num_Dim_Integer;
+ Unit : String := "";
+ Base : Number_Base := Default_Base)
+
+ is
+ begin
+ Num_Dim_Integer_IO.Put (To, Item, Base);
+ To := To & Unit;
+ end Put;
+
+end System.Dim_Integer_IO;
===================================================================
@@ -0,0 +1,73 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . D I M _ I N T E G E R _ I O --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
+-- --
+-- GNARL is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- 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. --
+-- --
+------------------------------------------------------------------------------
+
+-- Note that this package should only be instantiated with an integer
+-- dimensioned type
+
+-- This package is a generic package that provides IO facilities for integer
+-- dimensioned types.
+
+-- Note that there is a default string parameter in every Put routine
+-- rewritten at compile time to output the corresponding dimensions as a
+-- suffix of the numeric value.
+
+with Ada.Text_IO; use Ada.Text_IO;
+
+generic
+ type Num_Dim_Integer is range <>;
+
+package System.Dim_Integer_IO is
+
+ Default_Width : Field := Num_Dim_Integer'Width;
+ Default_Base : Number_Base := 10;
+
+ procedure Put
+ (File : File_Type;
+ Item : Num_Dim_Integer;
+ Unit : String := "";
+ Width : Field := Default_Width;
+ Base : Number_Base := Default_Base);
+
+ procedure Put
+ (Item : Num_Dim_Integer;
+ Unit : String := "";
+ Width : Field := Default_Width;
+ Base : Number_Base := Default_Base);
+
+ procedure Put
+ (To : out String;
+ Item : Num_Dim_Integer;
+ Unit : String := "";
+ Base : Number_Base := Default_Base);
+
+ pragma Inline (Put);
+
+end System.Dim_Integer_IO;
===================================================================
@@ -0,0 +1,2779 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S E M _ D I M --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING3. If not, go to --
+-- http://www.gnu.org/licenses for a complete copy of the license. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+with Aspects; use Aspects;
+with Atree; use Atree;
+with Einfo; use Einfo;
+with Errout; use Errout;
+with Lib; use Lib;
+with Namet; use Namet;
+with Namet.Sp; use Namet.Sp;
+with Nlists; use Nlists;
+with Nmake; use Nmake;
+with Opt; use Opt;
+with Rtsfind; use Rtsfind;
+with Sem; use Sem;
+with Sem_Eval; use Sem_Eval;
+with Sem_Res; use Sem_Res;
+with Sem_Util; use Sem_Util;
+with Sinfo; use Sinfo;
+with Snames; use Snames;
+with Stand; use Stand;
+with Stringt; use Stringt;
+with Table;
+with Tbuild; use Tbuild;
+with Uintp; use Uintp;
+with Urealp; use Urealp;
+
+with GNAT.HTable;
+
+package body Sem_Dim is
+
+ -- Maximum number of dimensions in a dimension system
+
+ Max_Dimensions : constant Int := 7;
+
+ -- Dim_Id values are used to identify dimensions in a dimension system
+ -- Note that the highest value of Dim_Id is Max_Dimensions
+
+ subtype Dim_Id is Pos range 1 .. Max_Dimensions;
+
+ -- Record type for dimension system
+ -- A dimension system is defined by the number and the names of its
+ -- dimensions and its base type.
+
+ subtype N_Of_Dimensions is Int range 0 .. Max_Dimensions;
+
+ No_Dimensions : constant N_Of_Dimensions := N_Of_Dimensions'First;
+
+ type Name_Array is array (Dim_Id) of Name_Id;
+
+ No_Names : constant Name_Array := (others => No_Name);
+
+ -- The symbols are used for IO purposes
+
+ type Symbol_Array is array (Dim_Id) of String_Id;
+
+ No_Symbols : constant Symbol_Array := (others => No_String);
+
+ type Dimension_System is record
+ Base_Type : Node_Id;
+ Names : Name_Array;
+ N_Of_Dims : N_Of_Dimensions;
+ Symbols : Symbol_Array;
+ end record;
+
+ No_Dimension_System : constant Dimension_System :=
+ (Empty, No_Names, No_Dimensions, No_Symbols);
+
+ -- Dim_Sys_Id values are used to identify dimension system in the Table
+ -- Note that the special value No_Dim_Sys has no corresponding component in
+ -- the Table since it represents no dimension system.
+
+ subtype Dim_Sys_Id is Nat;
+
+ No_Dim_Sys : constant Dim_Sys_Id := Dim_Sys_Id'First;
+
+ -- The following table records every dimension system
+
+ package Dim_Systems is new Table.Table (
+ Table_Component_Type => Dimension_System,
+ Table_Index_Type => Dim_Sys_Id,
+ Table_Low_Bound => 1,
+ Table_Initial => 5,
+ Table_Increment => 5,
+ Table_Name => "Dim_Systems");
+
+ -- Rational (definitions & operations)
+
+ type Whole is new Int;
+ subtype Positive_Whole is Whole range 1 .. Whole'Last;
+
+ type Rational is record
+ Numerator : Whole;
+ Denominator : Positive_Whole;
+ end record;
+
+ Zero_Rational : constant Rational := (0, 1);
+
+ -- Rational constructors
+
+ function "+" (Right : Whole) return Rational;
+ function "/" (Left, Right : Whole) return Rational;
+ function GCD (Left, Right : Whole) return Int;
+ function Reduce (X : Rational) return Rational;
+
+ -- Unary operator for Rational
+
+ function "-" (Right : Rational) return Rational;
+
+ -- Rational operations for Rationals
+
+ function "+" (Left, Right : Rational) return Rational;
+ function "-" (Left, Right : Rational) return Rational;
+ function "*" (Left, Right : Rational) return Rational;
+
+ -- Operation between Rational and Int
+
+ function "*" (Left : Rational; Right : Whole) return Rational;
+
+ ---------
+ -- GCD --
+ ---------
+
+ function GCD (Left, Right : Whole) return Int is
+ L : Whole := Left;
+ R : Whole := Right;
+
+ begin
+ while R /= 0 loop
+ L := L mod R;
+
+ if L = 0 then
+ return Int (R);
+ end if;
+
+ R := R mod L;
+ end loop;
+
+ return Int (L);
+ end GCD;
+
+ ------------
+ -- Reduce --
+ ------------
+
+ function Reduce (X : Rational) return Rational is
+ begin
+ if X.Numerator = 0 then
+ return Zero_Rational;
+ end if;
+
+ declare
+ G : constant Int := GCD (X.Numerator, X.Denominator);
+
+ begin
+ return Rational'(Numerator => Whole (Int (X.Numerator) / G),
+ Denominator => Whole (Int (X.Denominator) / G));
+ end;
+ end Reduce;
+
+ ---------
+ -- "+" --
+ ---------
+
+ function "+" (Right : Whole) return Rational is
+ begin
+ return (Right, 1);
+ end "+";
+
+ function "+" (Left, Right : Rational) return Rational is
+ R : constant Rational :=
+ Rational'(Numerator => Left.Numerator * Right.Denominator +
+ Left.Denominator * Right.Numerator,
+ Denominator => Left.Denominator * Right.Denominator);
+
+ begin
+ return Reduce (R);
+ end "+";
+
+ ---------
+ -- "-" --
+ ---------
+
+ function "-" (Right : Rational) return Rational is
+ begin
+ return Rational'(Numerator => -Right.Numerator,
+ Denominator => Right.Denominator);
+ end "-";
+
+ function "-" (Left, Right : Rational) return Rational is
+ R : constant Rational :=
+ Rational'(Numerator => Left.Numerator * Right.Denominator -
+ Left.Denominator * Right.Numerator,
+ Denominator => Left.Denominator * Right.Denominator);
+
+ begin
+ return Reduce (R);
+ end "-";
+
+ ---------
+ -- "*" --
+ ---------
+
+ function "*" (Left, Right : Rational) return Rational is
+ R : constant Rational :=
+ Rational'(Numerator => Left.Numerator * Right.Numerator,
+ Denominator => Left.Denominator * Right.Denominator);
+
+ begin
+ return Reduce (R);
+ end "*";
+
+ function "*" (Left : Rational; Right : Whole) return Rational is
+ R : constant Rational :=
+ Rational'(Numerator => Left.Numerator * Right,
+ Denominator => Left.Denominator);
+
+ begin
+ return Reduce (R);
+ end "*";
+
+ ---------
+ -- "/" --
+ ---------
+
+ function "/" (Left, Right : Whole) return Rational is
+ R : constant Int := abs Int (Right);
+ L : Int := Int (Left);
+
+ begin
+ if Right < 0 then
+ L := -L;
+ end if;
+
+ return Reduce (Rational'(Numerator => Whole (L),
+ Denominator => Whole (R)));
+ end "/";
+
+ -- Hash Table for aspect dimension.
+
+ -- The following table provides a relation between nodes and its dimension
+ -- (if not dimensionless). If a node is not stored in the Hash Table, the
+ -- node is considered to be dimensionless.
+ -- A dimension is represented by an array of Max_Dimensions Rationals.
+ -- If the corresponding dimension system has less than Max_Dimensions
+ -- dimensions, the array is filled by as many as Zero_Rationals needed to
+ -- complete the array.
+
+ -- Here is a list of nodes that can have entries in this Htable:
+
+ -- N_Attribute_Reference
+ -- N_Defining_Identifier
+ -- N_Function_Call
+ -- N_Identifier
+ -- N_Indexed_Component
+ -- N_Integer_Literal
+ -- N_Op_Abs
+ -- N_Op_Add
+ -- N_Op_Divide
+ -- N_Op_Expon
+ -- N_Op_Minus
+ -- N_Op_Mod
+ -- N_Op_Multiply
+ -- N_Op_Plus
+ -- N_Op_Rem
+ -- N_Op_Subtract
+ -- N_Qualified_Expression
+ -- N_Real_Literal
+ -- N_Selected_Component
+ -- N_Slice
+ -- N_Type_Conversion
+ -- N_Unchecked_Type_Conversion
+
+ type Dimensions is array (Dim_Id) of Rational;
+
+ Zero_Dimensions : constant Dimensions := (others => Zero_Rational);
+
+ type AD_Hash_Range is range 0 .. 511;
+
+ function AD_Hash (F : Node_Id) return AD_Hash_Range;
+
+ function AD_Hash (F : Node_Id) return AD_Hash_Range is
+ begin
+ return AD_Hash_Range (F mod 512);
+ end AD_Hash;
+
+ -- Node_Id --> Dimensions
+
+ package Aspect_Dimension_Hash_Table is new
+ GNAT.HTable.Simple_HTable
+ (Header_Num => AD_Hash_Range,
+ Element => Dimensions,
+ No_Element => Zero_Dimensions,
+ Key => Node_Id,
+ Hash => AD_Hash,
+ Equal => "=");
+
+ -- Table to record the string of each subtype declaration
+ -- Note that this table is only used for IO purposes
+
+ -- Entity_Id --> String_Id
+
+ package Aspect_Dimension_String_Id_Hash_Table is new
+ GNAT.HTable.Simple_HTable
+ (Header_Num => AD_Hash_Range,
+ Element => String_Id,
+ No_Element => No_String,
+ Key => Entity_Id,
+ Hash => AD_Hash,
+ Equal => "=");
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ procedure Analyze_Dimension_Assignment_Statement (N : Node_Id);
+ -- Subroutine of Analyze_Dimension for assignment statement
+
+ procedure Analyze_Dimension_Binary_Op (N : Node_Id);
+ -- Subroutine of Analyze_Dimension for binary operators
+
+ procedure Analyze_Dimension_Component_Declaration (N : Node_Id);
+ -- Subroutine of Analyze_Dimension for component declaration
+
+ procedure Analyze_Dimension_Extended_Return_Statement (N : Node_Id);
+ -- Subroutine of Analyze_Dimension for extended return statement
+
+ procedure Analyze_Dimension_Function_Call (N : Node_Id);
+ -- Subroutine of Analyze_Dimension for function call
+
+ procedure Analyze_Dimension_Has_Etype (N : Node_Id);
+ -- Subroutine of Analyze_Dimension for N_Has_Etype nodes:
+ -- N_Attribute_Reference
+ -- N_Indexed_Component
+ -- N_Qualified_Expression
+ -- N_Selected_Component
+ -- N_Slice
+ -- N_Type_Conversion
+ -- N_Unchecked_Type_Conversion
+
+ procedure Analyze_Dimension_Identifier (N : Node_Id);
+ -- Subroutine of Analyze_Dimension for identifier
+
+ procedure Analyze_Dimension_Object_Declaration (N : Node_Id);
+ -- Subroutine of Analyze_Dimension for object declaration
+
+ procedure Analyze_Dimension_Object_Renaming_Declaration (N : Node_Id);
+ -- Subroutine of Analyze_Dimension for object renaming declaration
+
+ procedure Analyze_Dimension_Simple_Return_Statement (N : Node_Id);
+ -- Subroutine of Analyze_Dimension for simple return statement
+
+ procedure Analyze_Dimension_Subtype_Declaration (N : Node_Id);
+ -- Subroutine of Analyze_Dimension for subtype declaration
+
+ procedure Analyze_Dimension_Unary_Op (N : Node_Id);
+ -- Subroutine of Analyze_Dimension for unary operators
+
+ procedure Copy_Dimensions (From, To : Node_Id);
+ -- Propagate dimensions between two nodes
+
+ procedure Create_Rational_From_Expr (Expr : Node_Id; R : in out Rational);
+ -- Given an expression, creates a rational number
+
+ procedure Eval_Op_Expon_With_Rational_Exponent
+ (N : Node_Id;
+ Rat : Rational);
+ -- Evaluate the Expon if the exponent is a rational and the operand has a
+ -- dimension.
+
+ function From_Dimension_To_String_Id
+ (Dims : Dimensions;
+ Sys : Dim_Sys_Id) return String_Id;
+ -- Given a dimension vector and a dimension system, return the proper
+ -- string of symbols.
+
+ function Get_Dimensions (N : Node_Id) return Dimensions;
+ -- Return the dimensions for the corresponding node
+
+ function Get_Dimensions_String_Id (E : Entity_Id) return String_Id;
+ -- Return the String_Id of dimensions for the corresponding entity
+
+ function Get_Dimension_System_Id (E : Entity_Id) return Dim_Sys_Id;
+ -- Return the Dim_Id of the corresponding dimension system
+
+ procedure Move_Dimensions (From, To : Node_Id);
+ -- Move Dimensions from 'From' to 'To'. Only called when 'From' has a
+ -- dimension.
+
+ function Permits_Dimensions (N : Node_Id) return Boolean;
+ -- Return True if a node can have a dimension
+
+ function Present (Dim : Dimensions) return Boolean;
+ -- Return True if Dim is not equal to Zero_Dimensions.
+
+ procedure Remove_Dimensions (N : Node_Id);
+ -- Remove the node from the HTable
+
+ procedure Set_Dimensions (N : Node_Id; Dims : Dimensions);
+ -- Store the dimensions of N in the Hash_Table for Dimensions
+
+ procedure Set_Dimensions_String_Id (E : Entity_Id; Str : String_Id);
+ -- Store the string of dimensions of E in the Hash_Table for String_Id
+
+ ------------------------------
+ -- Analyze_Aspect_Dimension --
+ ------------------------------
+
+ -- with Dimension => DIMENSION_FOR_SUBTYPE
+ -- DIMENSION_FOR_SUBTYPE ::= (DIMENSION_STRING, DIMENSION_RATIONALS)
+ -- DIMENSION_RATIONALS ::=
+ -- RATIONAL, {, RATIONAL}
+ -- | RATIONAL {, RATIONAL}, others => RATIONAL
+ -- | DISCRETE_CHOICE_LIST => RATIONAL
+
+ -- (see Analyze_Aspect_Dimension_System for DIMENSION_STRING grammar)
+
+ procedure Analyze_Aspect_Dimension
+ (N : Node_Id;
+ Id : Node_Id;
+ Expr : Node_Id)
+ is
+ Def_Id : constant Entity_Id := Defining_Identifier (N);
+ N_Kind : constant Node_Kind := Nkind (N);
+ Analyzed : array (Dimensions'Range) of Boolean := (others => False);
+ -- This array has been defined in order to deals with Others_Choice
+ -- It is a reminder of the dimensions in the aggregate that have already
+ -- been analyzed.
+
+ Choice : Node_Id;
+ Comp_Expr : Node_Id;
+ Comp_Assn : Node_Id;
+ Dim : Dim_Id;
+ Dims : Dimensions := Zero_Dimensions;
+ Dim_Str_Lit : Node_Id;
+ D_Sys : Dim_Sys_Id := No_Dim_Sys;
+ N_Of_Dims : N_Of_Dimensions;
+ Str : String_Id := No_String;
+
+ function Check_Identifier_Is_Dimension
+ (Id : Node_Id;
+ D_Sys : Dim_Sys_Id) return Boolean;
+ -- Return True if the identifier name is the name of a dimension in the
+ -- dimension system D_Sys.
+
+ function Check_Compile_Time_Known_Expressions_In_Aggregate
+ (Expr : Node_Id) return Boolean;
+ -- Check that each expression in the aggregate is known at compile time
+
+ function Check_Number_Dimensions_Aggregate
+ (Expr : Node_Id;
+ D_Sys : Dim_Sys_Id;
+ N_Of_Dims : N_Of_Dimensions) return Boolean;
+ -- This routine checks the number of dimensions in the aggregate.
+
+ function Corresponding_Dimension_System (N : Node_Id) return Dim_Sys_Id;
+ -- Return the Dim_Sys_Id of the corresponding dimension system
+
+ function Corresponding_Etype_Has_Dimensions (N : Node_Id) return Boolean;
+ -- Return True if the Etype of N has a dimension
+
+ function Get_Dimension_Id
+ (Id : Node_Id;
+ D_Sys : Dim_Sys_Id) return Dim_Id;
+ -- Given an identifier and the Dim_Sys_Id of the dimension system in the
+ -- Table, returns the Dim_Id that has the same name as the identifier.
+
+ ------------------------------------
+ -- Corresponding_Dimension_System --
+ ------------------------------------
+
+ function Corresponding_Dimension_System
+ (N : Node_Id) return Dim_Sys_Id
+ is
+ B_Typ : Node_Id;
+ Sub_Ind : Node_Id;
+ begin
+ -- Aspect_Dimension can only apply for subtypes
+
+ -- Look for the dimension system corresponding to this
+ -- Aspect_Dimension.
+
+ if Nkind (N) = N_Subtype_Declaration then
+ Sub_Ind := Subtype_Indication (N);
+
+ if Nkind (Sub_Ind) /= N_Subtype_Indication then
+ B_Typ := Etype (Sub_Ind);
+ return Get_Dimension_System_Id (B_Typ);
+
+ else
+ return No_Dim_Sys;
+ end if;
+
+ else
+ return No_Dim_Sys;
+ end if;
+ end Corresponding_Dimension_System;
+
+ ----------------------------------------
+ -- Corresponding_Etype_Has_Dimensions --
+ ----------------------------------------
+
+ function Corresponding_Etype_Has_Dimensions
+ (N : Node_Id) return Boolean
+ is
+ Dims_Typ : Dimensions;
+ Typ : Entity_Id;
+
+ begin
+
+ -- Check the type is dimensionless before assigning a dimension
+
+ if Nkind (N) = N_Subtype_Declaration then
+ declare
+ Sub : constant Node_Id := Subtype_Indication (N);
+
+ begin
+ if Nkind (Sub) /= N_Subtype_Indication then
+ Typ := Etype (Sub);
+ else
+ Typ := Etype (Subtype_Mark (Sub));
+ end if;
+
+ Dims_Typ := Get_Dimensions (Typ);
+ return Present (Dims_Typ);
+ end;
+
+ else
+ return False;
+ end if;
+ end Corresponding_Etype_Has_Dimensions;
+
+ ---------------------------------------
+ -- Check_Number_Dimensions_Aggregate --
+ ---------------------------------------
+
+ function Check_Number_Dimensions_Aggregate
+ (Expr : Node_Id;
+ D_Sys : Dim_Sys_Id;
+ N_Of_Dims : N_Of_Dimensions) return Boolean
+ is
+ Assoc : Node_Id;
+ Choice : Node_Id;
+ Comp_Expr : Node_Id;
+ N_Dims_Aggr : Int := No_Dimensions;
+ -- The number of dimensions in this aggregate
+
+ begin
+ -- Check the size of the aggregate match with the size of the
+ -- corresponding dimension system.
+
+ Comp_Expr := First (Expressions (Expr));
+
+ -- Skip the first argument in the aggregate since it's a character or
+ -- a string and not a dimension value.
+
+ Next (Comp_Expr);
+
+ if Present (Component_Associations (Expr)) then
+
+ -- If the aggregate is a positional aggregate with an
+ -- Others_Choice, the number of expressions must be less than or
+ -- equal to N_Of_Dims - 1.
+
+ if Present (Comp_Expr) then
+ N_Dims_Aggr := List_Length (Expressions (Expr)) - 1;
+ return N_Dims_Aggr <= N_Of_Dims - 1;
+
+ -- If the aggregate is a named aggregate, N_Dims_Aggr is used to
+ -- count all the dimensions referenced by the aggregate.
+
+ else
+ Assoc := First (Component_Associations (Expr));
+
+ while Present (Assoc) loop
+ if Nkind (Assoc) = N_Range then
+ Choice := First (Choices (Assoc));
+
+ declare
+ HB : constant Node_Id := High_Bound (Choice);
+ LB : constant Node_Id := Low_Bound (Choice);
+ LB_Dim : Dim_Id;
+ HB_Dim : Dim_Id;
+
+ begin
+ if not Check_Identifier_Is_Dimension (HB, D_Sys)
+ or else not Check_Identifier_Is_Dimension (LB, D_Sys)
+ then
+ return False;
+ end if;
+
+ HB_Dim := Get_Dimension_Id (HB, D_Sys);
+ LB_Dim := Get_Dimension_Id (LB, D_Sys);
+
+ N_Dims_Aggr := N_Dims_Aggr + HB_Dim - LB_Dim + 1;
+ end;
+
+ else
+ N_Dims_Aggr :=
+ N_Dims_Aggr + List_Length (Choices (Assoc));
+ end if;
+
+ Next (Assoc);
+ end loop;
+
+ -- Check whether an Others_Choice is present or not
+
+ if Nkind
+ (First (Choices (Last (Component_Associations (Expr))))) =
+ N_Others_Choice
+ then
+ return N_Dims_Aggr <= N_Of_Dims;
+ else
+ return N_Dims_Aggr = N_Of_Dims;
+ end if;
+ end if;
+
+ -- If the aggregate is a positional aggregate without Others_Choice,
+ -- the number of expressions must match the number of dimensions in
+ -- the dimension system.
+
+ else
+ N_Dims_Aggr := List_Length (Expressions (Expr)) - 1;
+ return N_Dims_Aggr = N_Of_Dims;
+ end if;
+ end Check_Number_Dimensions_Aggregate;
+
+ -----------------------------------
+ -- Check_Identifier_Is_Dimension --
+ -----------------------------------
+
+ function Check_Identifier_Is_Dimension
+ (Id : Node_Id;
+ D_Sys : Dim_Sys_Id) return Boolean
+ is
+ Na_Id : constant Name_Id := Chars (Id);
+ Dim_Name1 : Name_Id;
+ Dim_Name2 : Name_Id;
+
+ begin
+
+ for Dim1 in Dim_Id'Range loop
+ Dim_Name1 := Dim_Systems.Table (D_Sys).Names (Dim1);
+
+ if Dim_Name1 = Na_Id then
+ return True;
+ end if;
+
+ if Dim1 = Max_Dimensions then
+
+ -- Check for possible misspelling
+
+ Error_Msg_N ("& is not a dimension argument for aspect%", Id);
+
+ for Dim2 in Dim_Id'Range loop
+ Dim_Name2 := Dim_Systems.Table (D_Sys).Names (Dim2);
+
+ if Is_Bad_Spelling_Of (Na_Id, Dim_Name2) then
+ Error_Msg_Name_1 := Dim_Name2;
+ Error_Msg_N ("\possible misspelling of%", Id);
+ exit;
+ end if;
+ end loop;
+ end if;
+ end loop;
+
+ return False;
+ end Check_Identifier_Is_Dimension;
+
+ ----------------------
+ -- Get_Dimension_Id --
+ ----------------------
+
+ -- Given an identifier, returns the correponding position of the
+ -- dimension in the dimension system.
+
+ function Get_Dimension_Id
+ (Id : Node_Id;
+ D_Sys : Dim_Sys_Id) return Dim_Id
+ is
+ Na_Id : constant Name_Id := Chars (Id);
+ Dim : Dim_Id;
+ Dim_Name : Name_Id;
+
+ begin
+ for D in Dim_Id'Range loop
+ Dim_Name := Dim_Systems.Table (D_Sys).Names (D);
+
+ if Dim_Name = Na_Id then
+ Dim := D;
+ end if;
+
+ end loop;
+
+ return Dim;
+ end Get_Dimension_Id;
+
+ -------------------------------------------------------
+ -- Check_Compile_Time_Known_Expressions_In_Aggregate --
+ -------------------------------------------------------
+
+ function Check_Compile_Time_Known_Expressions_In_Aggregate
+ (Expr : Node_Id) return Boolean
+ is
+ Comp_Assn : Node_Id;
+ Comp_Expr : Node_Id;
+
+ begin
+ Comp_Expr := First (Expressions (Expr));
+ Next (Comp_Expr);
+
+ while Present (Comp_Expr) loop
+
+ -- First, analyze the expression
+
+ Analyze_And_Resolve (Comp_Expr);
+ if not Compile_Time_Known_Value (Comp_Expr) then
+ return False;
+ end if;
+
+ Next (Comp_Expr);
+ end loop;
+
+ Comp_Assn := First (Component_Associations (Expr));
+
+ while Present (Comp_Assn) loop
+ Comp_Expr := Expression (Comp_Assn);
+
+ -- First, analyze the expression
+
+ Analyze_And_Resolve (Comp_Expr);
+
+ if not Compile_Time_Known_Value (Comp_Expr) then
+ return False;
+ end if;
+
+ Next (Comp_Assn);
+ end loop;
+
+ return True;
+ end Check_Compile_Time_Known_Expressions_In_Aggregate;
+
+ -- Start of processing for Analyze_Aspect_Dimension
+
+ begin
+ -- Syntax checking
+
+ Error_Msg_Name_1 := Chars (Id);
+
+ if N_Kind /= N_Subtype_Declaration then
+ Error_Msg_N ("aspect% doesn't apply here", N);
+ return;
+ end if;
+
+ if Nkind (Expr) /= N_Aggregate then
+ Error_Msg_N ("wrong syntax for aspect%", Expr);
+ return;
+ end if;
+
+ D_Sys := Corresponding_Dimension_System (N);
+
+ if D_Sys = No_Dim_Sys then
+ Error_Msg_N ("dimension system not found for aspect%", N);
+ return;
+ end if;
+
+ if Corresponding_Etype_Has_Dimensions (N) then
+ Error_Msg_N ("corresponding type already has a dimension", N);
+ return;
+ end if;
+
+ -- Check the first expression is a string or a character literal and
+ -- skip it.
+
+ Dim_Str_Lit := First (Expressions (Expr));
+
+ if not Present (Dim_Str_Lit)
+ or else not Nkind_In (Dim_Str_Lit,
+ N_String_Literal,
+ N_Character_Literal)
+ then
+ Error_Msg_N
+ ("wrong syntax for aspect%: first argument in the aggregate must " &
+ "be a character or a string",
+ Expr);
+ return;
+ end if;
+
+ Comp_Expr := Next (Dim_Str_Lit);
+
+ -- Check the number of dimensions match with the dimension system
+
+ N_Of_Dims := Dim_Systems.Table (D_Sys).N_Of_Dims;
+
+ if not Check_Number_Dimensions_Aggregate (Expr, D_Sys, N_Of_Dims) then
+ Error_Msg_N ("wrong number of dimensions for aspect%", Expr);
+ return;
+ end if;
+
+ Dim := Dim_Id'First;
+ Comp_Assn := First (Component_Associations (Expr));
+
+ if Present (Comp_Expr) then
+
+ if List_Length (Component_Associations (Expr)) > 1 then
+ Error_Msg_N ("named association cannot follow " &
+ "positional association for aspect%", Expr);
+ return;
+ end if;
+
+ if Present (Comp_Assn)
+ and then Nkind (First (Choices (Comp_Assn))) /= N_Others_Choice
+ then
+ Error_Msg_N ("named association cannot follow " &
+ "positional association for aspect%", Expr);
+ return;
+ end if;
+ end if;
+
+ -- Check each expression in the aspect Dimension aggregate is known at
+ -- compile time.
+
+ if not Check_Compile_Time_Known_Expressions_In_Aggregate (Expr) then
+ Error_Msg_N ("wrong syntax for aspect%", Expr);
+ return;
+ end if;
+
+ -- Get the dimension values and store them in the Hash_Table
+
+ -- Positional aggregate case
+
+ while Present (Comp_Expr) loop
+ if Is_Integer_Type (Def_Id) then
+ Dims (Dim) := +Whole (UI_To_Int (Expr_Value (Comp_Expr)));
+ else
+ Create_Rational_From_Expr (Comp_Expr, Dims (Dim));
+ end if;
+
+ Analyzed (Dim) := True;
+
+ exit when Dim = Max_Dimensions;
+
+ Dim := Dim + 1;
+ Next (Comp_Expr);
+ end loop;
+
+ -- Named aggregate case
+
+ while Present (Comp_Assn) loop
+ Comp_Expr := Expression (Comp_Assn);
+ Choice := First (Choices (Comp_Assn));
+
+ if List_Length (Choices (Comp_Assn)) = 1 then
+
+ -- N_Identifier case
+
+ if Nkind (Choice) = N_Identifier then
+
+ if not Check_Identifier_Is_Dimension (Choice, D_Sys) then
+ return;
+ end if;
+
+ Dim := Get_Dimension_Id (Choice, D_Sys);
+
+ if Is_Integer_Type (Def_Id) then
+ Dims (Dim) := +Whole (UI_To_Int (Expr_Value (Comp_Expr)));
+ else
+ Create_Rational_From_Expr (Comp_Expr, Dims (Dim));
+ end if;
+
+ Analyzed (Dim) := True;
+
+ -- N_Range case
+
+ elsif Nkind (Choice) = N_Range then
+ declare
+ HB : constant Node_Id := High_Bound (Choice);
+ LB : constant Node_Id := Low_Bound (Choice);
+ LB_Dim : constant Dim_Id := Get_Dimension_Id (LB, D_Sys);
+ HB_Dim : constant Dim_Id := Get_Dimension_Id (HB, D_Sys);
+
+ begin
+ for Dim in LB_Dim .. HB_Dim loop
+ if Is_Integer_Type (Def_Id) then
+ Dims (Dim) :=
+ +Whole (UI_To_Int (Expr_Value (Comp_Expr)));
+ else
+ Create_Rational_From_Expr (Comp_Expr, Dims (Dim));
+ end if;
+
+ Analyzed (Dim) := True;
+ end loop;
+ end;
+
+ -- N_Others_Choice case
+
+ elsif Nkind (Choice) = N_Others_Choice then
+
+ -- Check the Others_Choice is alone and last in the aggregate
+
+ if Present (Next (Comp_Assn)) then
+ Error_Msg_N
+ ("OTHERS must appear alone and last in expression " &
+ "for aspect%", Choice);
+ return;
+ end if;
+
+ -- End the filling of Dims by the Others_Choice value
+ -- If N_Of_Dims < Max_Dimensions then only the
+ -- positions that haven't been already analyzed from
+ -- Dim_Id'First to N_Of_Dims are filled.
+
+ for Dim in Dim_Id'First .. N_Of_Dims loop
+ if not Analyzed (Dim) then
+ if Is_Integer_Type (Def_Id) then
+ Dims (Dim) :=
+ +Whole (UI_To_Int (Expr_Value (Comp_Expr)));
+ else
+ Create_Rational_From_Expr (Comp_Expr, Dims (Dim));
+ end if;
+ end if;
+ end loop;
+
+ else
+ Error_Msg_N ("wrong syntax for aspect%", Id);
+ end if;
+
+ else
+ while Present (Choice) loop
+ if Nkind (Choice) = N_Identifier then
+
+ if not Check_Identifier_Is_Dimension (Choice, D_Sys) then
+ return;
+ end if;
+
+ Dim := Get_Dimension_Id (Choice, D_Sys);
+
+ if Is_Integer_Type (Def_Id) then
+ Dims (Dim) := +Whole (UI_To_Int (Expr_Value (Comp_Expr)));
+ else
+ Create_Rational_From_Expr (Comp_Expr, Dims (Dim));
+ end if;
+
+ Analyzed (Dim) := True;
+ Next (Choice);
+ else
+ Error_Msg_N ("wrong syntax for aspect%", Id);
+ end if;
+ end loop;
+ end if;
+
+ Next (Comp_Assn);
+ end loop;
+
+ -- Create the string of dimensions
+
+ if Nkind (Dim_Str_Lit) = N_Character_Literal then
+ Start_String;
+ Store_String_Char (UI_To_CC (Char_Literal_Value (Dim_Str_Lit)));
+ Str := End_String;
+ else
+ Str := Strval (Dim_Str_Lit);
+ end if;
+
+ -- Store the dimensions in the Hash Table if not all equal to zero and
+ -- string is empty.
+
+ if not Present (Dims) then
+ if String_Length (Str) = 0 then
+ Error_Msg_N
+ ("?dimension values all equal to zero for aspect%", Expr);
+ return;
+ end if;
+ else
+ Set_Dimensions (Def_Id, Dims);
+ end if;
+
+ -- Store the string in the Hash Table
+ -- When the string is empty, don't store the string in the Hash Table
+
+ if Str /= No_String
+ and then String_Length (Str) /= 0
+ then
+ Set_Dimensions_String_Id (Def_Id, Str);
+ end if;
+ end Analyze_Aspect_Dimension;
+
+ -------------------------------------
+ -- Analyze_Aspect_Dimension_System --
+ -------------------------------------
+
+ -- with Dimension_System => DIMENSION_PAIRS
+ -- DIMENSION_PAIRS ::=
+ -- (DIMENSION_PAIR
+ -- [, DIMENSION_PAIR]
+ -- [, DIMENSION_PAIR]
+ -- [, DIMENSION_PAIR]
+ -- [, DIMENSION_PAIR]
+ -- [, DIMENSION_PAIR]
+ -- [, DIMENSION_PAIR])
+ -- DIMENSION_PAIR ::= (DIMENSION_IDENTIFIER, DIMENSION_STRING)
+ -- DIMENSION_IDENTIFIER ::= IDENTIFIER
+ -- DIMENSION_STRING ::= STRING_LITERAL | CHARACTER_LITERAL
+
+ procedure Analyze_Aspect_Dimension_System
+ (N : Node_Id;
+ Id : Node_Id;
+ Expr : Node_Id)
+ is
+ Dim_Name : Node_Id;
+ Dim_Node : Node_Id;
+ Dim_Symbol : Node_Id;
+ D_Sys : Dimension_System := No_Dimension_System;
+ Names : Name_Array := No_Names;
+ N_Of_Dims : N_Of_Dimensions;
+ Symbols : Symbol_Array := No_Symbols;
+
+ function Derived_From_Numeric_Type (N : Node_Id) return Boolean;
+ -- Return True if the node is a derived type declaration from any
+ -- numeric type.
+
+ function Check_Dimension_System_Syntax (N : Node_Id) return Boolean;
+ -- Return True if the expression is an aggregate of names
+
+ function Check_Number_Of_Dimensions (Expr : Node_Id) return Boolean;
+ -- Return True if the number of dimensions in the corresponding
+ -- dimension is positive and lower than Max_Dimensions.
+
+ -------------------------------
+ -- Derived_From_Numeric_Type --
+ -------------------------------
+
+ function Derived_From_Numeric_Type (N : Node_Id) return Boolean is
+ begin
+ case (Nkind (N)) is
+ when N_Full_Type_Declaration =>
+ declare
+ T_Def : constant Node_Id := Type_Definition (N);
+ Ent : Entity_Id;
+
+ begin
+ -- Check that the node is a derived type declaration from
+ -- a numeric type.
+
+ if Nkind (T_Def) /= N_Derived_Type_Definition then
+ return False;
+ else
+ Ent := Entity (Subtype_Indication (T_Def));
+
+ if Is_Numeric_Type (Ent) then
+ return True;
+ else
+ return False;
+ end if;
+ end if;
+ end;
+
+ when others => return False;
+ end case;
+ end Derived_From_Numeric_Type;
+
+ -----------------------------------
+ -- Check_Dimension_System_Syntax --
+ -----------------------------------
+
+ -- Check that the expression of aspect Dimension_System is an aggregate
+ -- which contains pairs of identifier and string or character literal.
+
+ function Check_Dimension_System_Syntax (N : Node_Id) return Boolean is
+ Dim_Node : Node_Id;
+ Expr_Dim : Node_Id;
+ begin
+ -- Chek that the aggregate is a positional array
+
+ if Present (Component_Associations (N)) then
+ return False;
+ else
+ Dim_Node := First (Expressions (N));
+
+ -- Check that each component of the aggregate is an aggregate
+
+ while Present (Dim_Node) loop
+
+ -- Verify that the aggregate is a pair of identifier and string
+ -- or character literal.
+
+ if Nkind (Dim_Node) = N_Aggregate then
+ if not Present (Expressions (Dim_Node)) then
+ return False;
+ end if;
+
+ if Present (Component_Associations (Dim_Node)) then
+ return False;
+ end if;
+
+ -- First expression in the aggregate
+
+ Expr_Dim := First (Expressions (Dim_Node));
+
+ if Nkind (Expr_Dim) /= N_Identifier then
+ return False;
+ end if;
+
+ -- Second expression in the aggregate
+
+ Next (Expr_Dim);
+
+ if not Nkind_In (Expr_Dim,
+ N_String_Literal,
+ N_Character_Literal)
+ then
+ return False;
+ end if;
+
+ -- If the aggregate has a third expression, return False
+
+ Next (Expr_Dim);
+
+ if Present (Expr_Dim) then
+ return False;
+ end if;
+ else
+ return False;
+ end if;
+
+ Next (Dim_Node);
+ end loop;
+
+ return True;
+ end if;
+ end Check_Dimension_System_Syntax;
+
+ --------------------------------
+ -- Check_Number_Of_Dimensions --
+ --------------------------------
+
+ function Check_Number_Of_Dimensions (Expr : Node_Id) return Boolean is
+ List_Expr : constant List_Id := Expressions (Expr);
+
+ begin
+ if List_Length (List_Expr) < Dim_Id'First
+ or else List_Length (List_Expr) > Max_Dimensions then
+ return False;
+ else
+ return True;
+ end if;
+ end Check_Number_Of_Dimensions;
+
+ -- Start of processing for Analyze_Aspect_Dimension_System
+
+ begin
+ Error_Msg_Name_1 := Chars (Id);
+
+ -- Syntax checking
+
+ if Nkind (Expr) /= N_Aggregate then
+ Error_Msg_N ("wrong syntax for aspect%", Expr);
+ return;
+ end if;
+
+ if not Derived_From_Numeric_Type (N) then
+ Error_Msg_N ("aspect% only apply for type derived from numeric type",
+ Id);
+ return;
+ end if;
+
+ if not Check_Dimension_System_Syntax (Expr) then
+ Error_Msg_N ("wrong syntax for aspect%", Expr);
+ return;
+ end if;
+
+ if not Check_Number_Of_Dimensions (Expr) then
+ Error_Msg_N ("wrong number of dimensions for aspect%", Expr);
+ return;
+ end if;
+
+ -- Number of dimensions in the system
+
+ N_Of_Dims := List_Length (Expressions (Expr));
+
+ -- Create the new dimension system
+
+ D_Sys.Base_Type := N;
+ Dim_Node := First (Expressions (Expr));
+
+ for Dim in Dim_Id'First .. N_Of_Dims loop
+ Dim_Name := First (Expressions (Dim_Node));
+ Names (Dim) := Chars (Dim_Name);
+ Dim_Symbol := Next (Dim_Name);
+
+ -- N_Character_Literal case
+
+ if Nkind (Dim_Symbol) = N_Character_Literal then
+ Start_String;
+ Store_String_Char (UI_To_CC (Char_Literal_Value (Dim_Symbol)));
+ Symbols (Dim) := End_String;
+
+ -- N_String_Literal case
+
+ else
+ Symbols (Dim) := Strval (Dim_Symbol);
+ end if;
+
+ Next (Dim_Node);
+ end loop;
+
+ D_Sys.Names := Names;
+ D_Sys.N_Of_Dims := N_Of_Dims;
+ D_Sys.Symbols := Symbols;
+
+ -- Store the dimension system in the Table
+
+ Dim_Systems.Append (D_Sys);
+ end Analyze_Aspect_Dimension_System;
+
+ -----------------------
+ -- Analyze_Dimension --
+ -----------------------
+
+ -- This dispatch routine propagates dimensions for each node
+
+ procedure Analyze_Dimension (N : Node_Id) is
+ begin
+ -- Aspect is an Ada 2012 feature
+
+ if Ada_Version < Ada_2012 then
+ return;
+ end if;
+
+ case Nkind (N) is
+
+ when N_Assignment_Statement =>
+ Analyze_Dimension_Assignment_Statement (N);
+
+ when N_Subtype_Declaration =>
+ Analyze_Dimension_Subtype_Declaration (N);
+
+ when N_Object_Declaration =>
+ Analyze_Dimension_Object_Declaration (N);
+
+ when N_Object_Renaming_Declaration =>
+ Analyze_Dimension_Object_Renaming_Declaration (N);
+
+ when N_Component_Declaration =>
+ Analyze_Dimension_Component_Declaration (N);
+
+ when N_Binary_Op =>
+ Analyze_Dimension_Binary_Op (N);
+
+ when N_Unary_Op =>
+ Analyze_Dimension_Unary_Op (N);
+
+ when N_Identifier =>
+ Analyze_Dimension_Identifier (N);
+
+ when N_Attribute_Reference |
+ N_Indexed_Component |
+ N_Qualified_Expression |
+ N_Selected_Component |
+ N_Slice |
+ N_Type_Conversion |
+ N_Unchecked_Type_Conversion =>
+ Analyze_Dimension_Has_Etype (N);
+
+ when N_Function_Call =>
+ Analyze_Dimension_Function_Call (N);
+
+ when N_Extended_Return_Statement =>
+ Analyze_Dimension_Extended_Return_Statement (N);
+
+ when N_Simple_Return_Statement =>
+ Analyze_Dimension_Simple_Return_Statement (N);
+
+ when others => null;
+
+ end case;
+ end Analyze_Dimension;
+
+ --------------------------------------------
+ -- Analyze_Dimension_Assignment_Statement --
+ --------------------------------------------
+
+ procedure Analyze_Dimension_Assignment_Statement (N : Node_Id) is
+ Lhs : constant Node_Id := Name (N);
+ Dim_Lhs : constant Dimensions := Get_Dimensions (Lhs);
+ Rhs : constant Node_Id := Expression (N);
+ Dim_Rhs : constant Dimensions := Get_Dimensions (Rhs);
+
+ procedure Analyze_Dimensions_In_Assignment
+ (Dim_Lhs : Dimensions;
+ Dim_Rhs : Dimensions);
+ -- Subroutine to perform the dimensionnality checking for assignment
+
+ --------------------------------------
+ -- Analyze_Dimensions_In_Assignment --
+ --------------------------------------
+
+ procedure Analyze_Dimensions_In_Assignment
+ (Dim_Lhs : Dimensions;
+ Dim_Rhs : Dimensions)
+ is
+ begin
+ -- Check the lhs and the rhs have the same dimension
+
+ if not Present (Dim_Lhs) then
+
+ if Present (Dim_Rhs) then
+ Error_Msg_N ("?dimensions missmatch in assignment", N);
+ end if;
+ else
+
+ if Dim_Lhs /= Dim_Rhs then
+ Error_Msg_N ("?dimensions missmatch in assignment", N);
+ end if;
+
+ end if;
+ end Analyze_Dimensions_In_Assignment;
+
+ -- Start of processing for Analyze_Dimension_Assignment
+
+ begin
+ Analyze_Dimensions_In_Assignment (Dim_Lhs, Dim_Rhs);
+ end Analyze_Dimension_Assignment_Statement;
+
+ ---------------------------------
+ -- Analyze_Dimension_Binary_Op --
+ ---------------------------------
+
+ procedure Analyze_Dimension_Binary_Op (N : Node_Id) is
+ N_Kind : constant Node_Kind := Nkind (N);
+
+ begin
+ if Nkind_In (N_Kind, N_Op_Add, N_Op_Expon, N_Op_Subtract)
+ or else N_Kind in N_Multiplying_Operator
+ or else N_Kind in N_Op_Compare
+ then
+ declare
+ L : constant Node_Id := Left_Opnd (N);
+ L_Dims : constant Dimensions := Get_Dimensions (L);
+ L_Has_Dimensions : constant Boolean := Present (L_Dims);
+ R : constant Node_Id := Right_Opnd (N);
+ R_Dims : constant Dimensions := Get_Dimensions (R);
+ R_Has_Dimensions : constant Boolean := Present (R_Dims);
+ Dims : Dimensions := Zero_Dimensions;
+
+ begin
+
+ if Nkind_In (N, N_Op_Add, N_Op_Mod, N_Op_Rem, N_Op_Subtract) then
+ Error_Msg_Name_1 := Chars (N);
+
+ -- Check both operands dimension
+
+ if L_Has_Dimensions and R_Has_Dimensions then
+
+ -- If dimensions missmatch
+
+ if L_Dims /= R_Dims then
+ Error_Msg_N
+ ("?both operands for operation% must have same " &
+ "dimension", N);
+ else
+ Set_Dimensions (N, L_Dims);
+ end if;
+
+ elsif not L_Has_Dimensions and R_Has_Dimensions then
+ Error_Msg_N
+ ("?both operands for operation% must have same dimension",
+ N);
+
+ elsif L_Has_Dimensions and not R_Has_Dimensions then
+ Error_Msg_N
+ ("?both operands for operation% must have same dimension",
+ N);
+
+ end if;
+
+ elsif Nkind_In (N_Kind, N_Op_Multiply, N_Op_Divide) then
+
+ if L_Has_Dimensions and R_Has_Dimensions then
+
+ -- Get both operands dimension and add them
+
+ if N_Kind = N_Op_Multiply then
+ for Dim in Dimensions'Range loop
+ Dims (Dim) := L_Dims (Dim) + R_Dims (Dim);
+ end loop;
+
+ -- Get both operands dimension and subtract them
+
+ else
+ for Dim in Dimensions'Range loop
+ Dims (Dim) := L_Dims (Dim) - R_Dims (Dim);
+ end loop;
+ end if;
+
+ elsif L_Has_Dimensions and not R_Has_Dimensions then
+ Dims := L_Dims;
+
+ elsif not L_Has_Dimensions and R_Has_Dimensions then
+
+ if N_Kind = N_Op_Multiply then
+ Dims := R_Dims;
+ else
+ for Dim in R_Dims'Range loop
+ Dims (Dim) := -R_Dims (Dim);
+ end loop;
+ end if;
+ end if;
+
+ if Present (Dims) then
+ Set_Dimensions (N, Dims);
+ end if;
+
+ -- N_Op_Expon
+ -- Propagation of the dimension and evaluation of the result if
+ -- the exponent is a rational and if the operand has a dimension.
+
+ elsif N_Kind = N_Op_Expon then
+ declare
+ Rat : Rational := Zero_Rational;
+
+ begin
+ -- Check exponent is dimensionless
+
+ if R_Has_Dimensions then
+ Error_Msg_N
+ ("?right operand cannot have a dimension for&",
+ Identifier (N));
+
+ else
+ -- Check the left operand is not dimensionless
+
+ -- Note that the value of the exponent must be know at
+ -- compile time. Otherwise, the exponentiation evaluation
+ -- will return an error message.
+
+ if Get_Dimension_System_Id
+ (Base_Type (Etype (L))) /= No_Dim_Sys
+ and then Compile_Time_Known_Value (R)
+ then
+ -- Real exponent case
+
+ if Is_Real_Type (Etype (L)) then
+ -- Define the exponent as a Rational number
+
+ Create_Rational_From_Expr (R, Rat);
+
+ if L_Has_Dimensions then
+ for Dim in Dimensions'Range loop
+ Dims (Dim) := L_Dims (Dim) * Rat;
+ end loop;
+
+ if Present (Dims) then
+ Set_Dimensions (N, Dims);
+ end if;
+ end if;
+
+ -- Evaluate the operator with rational exponent
+
+ -- Eval_Op_Expon_With_Rational_Exponent (N, Rat);
+
+ -- Integer exponent case
+
+ else
+ for Dim in Dimensions'Range loop
+ Dims (Dim) :=
+ L_Dims (Dim) *
+ Whole (UI_To_Int (Expr_Value (R)));
+ end loop;
+
+ if Present (Dims) then
+ Set_Dimensions (N, Dims);
+ end if;
+ end if;
+ end if;
+ end if;
+ end;
+
+ -- For relational operations, only a dimension checking is
+ -- performed.
+ -- No propagation
+
+ elsif N_Kind in N_Op_Compare then
+ Error_Msg_Name_1 := Chars (N);
+
+ if (L_Has_Dimensions or R_Has_Dimensions)
+ and then L_Dims /= R_Dims
+ then
+ Error_Msg_N
+ ("?both operands for operation% must have same dimension",
+ N);
+ end if;
+ end if;
+
+ Remove_Dimensions (L);
+ Remove_Dimensions (R);
+ end;
+ end if;
+ end Analyze_Dimension_Binary_Op;
+
+ ---------------------------------------------
+ -- Analyze_Dimension_Component_Declaration --
+ ---------------------------------------------
+
+ procedure Analyze_Dimension_Component_Declaration (N : Node_Id) is
+ Expr : constant Node_Id := Expression (N);
+ Id : constant Entity_Id := Defining_Identifier (N);
+ E_Typ : constant Entity_Id := Etype (Id);
+ Dim_T : constant Dimensions := Get_Dimensions (E_Typ);
+ Dim_E : Dimensions;
+
+ begin
+ if Present (Dim_T) then
+
+ -- If the component type has a dimension and there is no expression,
+ -- propagates the dimension.
+
+ if Present (Expr) then
+ Dim_E := Get_Dimensions (Expr);
+
+ if Present (Dim_E) then
+ -- Return an error if the dimension of the expression and the
+ -- dimension of the type missmatch.
+
+ if Dim_E /= Dim_T then
+ Error_Msg_N ("?dimensions missmatch in object " &
+ "declaration", N);
+ end if;
+
+ -- If the expression is dimensionless
+
+ else
+ Error_Msg_N
+ ("?dimensions missmatch in component declaration", N);
+ end if;
+
+ -- For every other cases, propagate the dimensions
+
+ else
+ Copy_Dimensions (E_Typ, Id);
+ end if;
+ end if;
+ end Analyze_Dimension_Component_Declaration;
+
+ -------------------------------------------------
+ -- Analyze_Dimension_Extended_Return_Statement --
+ -------------------------------------------------
+
+ procedure Analyze_Dimension_Extended_Return_Statement (N : Node_Id) is
+ Obj_Decls : constant List_Id := Return_Object_Declarations (N);
+ R_Ent : constant Entity_Id := Return_Statement_Entity (N);
+ R_Etyp : constant Entity_Id := Etype (Return_Applies_To (R_Ent));
+ Dims_R : constant Dimensions := Get_Dimensions (R_Etyp);
+ Dims_Obj : Dimensions;
+ Obj_Decl : Node_Id;
+ Obj_Id : Entity_Id;
+
+ begin
+ if Present (Obj_Decls) then
+ Obj_Decl := First (Obj_Decls);
+
+ while Present (Obj_Decl) loop
+ if Nkind (Obj_Decl) = N_Object_Declaration then
+ Obj_Id := Defining_Identifier (Obj_Decl);
+
+ if Is_Return_Object (Obj_Id) then
+ Dims_Obj := Get_Dimensions (Obj_Id);
+
+ if Dims_R /= Dims_Obj then
+ Error_Msg_N ("?dimensions missmatch in return statement",
+ N);
+ return;
+ end if;
+ end if;
+ end if;
+
+ Next (Obj_Decl);
+ end loop;
+ end if;
+ end Analyze_Dimension_Extended_Return_Statement;
+
+ -------------------------------------
+ -- Analyze_Dimension_Function_Call --
+ -------------------------------------
+
+ procedure Analyze_Dimension_Function_Call (N : Node_Id) is
+ Name_Call : constant Node_Id := Name (N);
+ Par_Ass : constant List_Id := Parameter_Associations (N);
+ Dims : Dimensions;
+ Dims_Param : Dimensions;
+ Param : Node_Id;
+
+ function Is_Elementary_Function_Call (N : Node_Id) return Boolean;
+ -- Return True if the call is a call of an elementary function (see
+ -- Ada.Numerics.Generic_Elementary_Functions).
+
+ ---------------------------------
+ -- Is_Elementary_Function_Call --
+ ---------------------------------
+
+ function Is_Elementary_Function_Call (N : Node_Id) return Boolean is
+ Ent : Entity_Id;
+
+ begin
+ -- Note that the node must come from source
+
+ if Comes_From_Source (N)
+ and then Is_Entity_Name (Name_Call)
+ then
+ Ent := Entity (Name_Call);
+
+ -- Check the procedure is defined in an instantiation of a generic
+ -- package.
+
+ if Is_Generic_Instance (Scope (Ent)) then
+ Ent := Cunit_Entity (Get_Source_Unit (Ent));
+
+ -- Check the name of the generic package is
+ -- Generic_Elementary_Functions
+
+ if Is_Library_Level_Entity (Ent)
+ and then Chars (Ent) = Name_Generic_Elementary_Functions
+ then
+ return True;
+ end if;
+ end if;
+ end if;
+
+ return False;
+ end Is_Elementary_Function_Call;
+
+ -- Start of processing for Analyze_Dimension_Function_Call
+
+ begin
+ -- Elementary function case
+
+ if Is_Elementary_Function_Call (N) then
+
+ -- Sqrt function call case
+
+ if Chars (Name_Call) = Name_Sqrt then
+ Dims := Get_Dimensions (First (Par_Ass));
+
+ if Present (Dims) then
+ for Dim in Dims'Range loop
+ Dims (Dim) := Dims (Dim) * (1, 2);
+ end loop;
+
+ Set_Dimensions (N, Dims);
+ end if;
+
+ -- All other functions in Ada.Numerics.Generic_Elementary_Functions
+ -- Note that all parameters here should be dimensionless
+
+ else
+ Param := First (Par_Ass);
+
+ while Present (Param) loop
+ Dims_Param := Get_Dimensions (Param);
+
+ if Present (Dims_Param) then
+ Error_Msg_Name_1 := Chars (Name_Call);
+ Error_Msg_N
+ ("?parameter should be dimensionless for elementary " &
+ "function%",
+ Param);
+ return;
+ end if;
+
+ Next (Param);
+ end loop;
+ end if;
+
+ -- General case
+
+ else
+ Analyze_Dimension_Has_Etype (N);
+ end if;
+ end Analyze_Dimension_Function_Call;
+
+ ---------------------------------
+ -- Analyze_Dimension_Has_Etype --
+ ---------------------------------
+
+ procedure Analyze_Dimension_Has_Etype (N : Node_Id) is
+ E_Typ : constant Entity_Id := Etype (N);
+ Dims : constant Dimensions := Get_Dimensions (E_Typ);
+ N_Kind : constant Node_Kind := Nkind (N);
+
+ begin
+ -- Propagation of the dimensions from the type
+
+ if Present (Dims) then
+ Set_Dimensions (N, Dims);
+ end if;
+
+ -- Removal of dimensions in expression
+
+ if Nkind_In (N_Kind, N_Attribute_Reference, N_Indexed_Component) then
+ declare
+ Expr : Node_Id;
+ Exprs : constant List_Id := Expressions (N);
+
+ begin
+ if Present (Exprs) then
+ Expr := First (Exprs);
+
+ while Present (Expr) loop
+ Remove_Dimensions (Expr);
+ Next (Expr);
+ end loop;
+ end if;
+ end;
+
+ elsif Nkind_In
+ (N_Kind,
+ N_Qualified_Expression,
+ N_Type_Conversion,
+ N_Unchecked_Type_Conversion)
+ then
+ Remove_Dimensions (Expression (N));
+
+ elsif N_Kind = N_Selected_Component then
+ Remove_Dimensions (Selector_Name (N));
+ end if;
+ end Analyze_Dimension_Has_Etype;
+
+ ----------------------------------
+ -- Analyze_Dimension_Identifier --
+ ----------------------------------
+
+ procedure Analyze_Dimension_Identifier (N : Node_Id) is
+ Ent : constant Entity_Id := Entity (N);
+ Dims : constant Dimensions := Get_Dimensions (Ent);
+
+ begin
+ if Present (Dims) then
+ Set_Dimensions (N, Dims);
+ else
+ Analyze_Dimension_Has_Etype (N);
+ end if;
+ end Analyze_Dimension_Identifier;
+
+ ------------------------------------------
+ -- Analyze_Dimension_Object_Declaration --
+ ------------------------------------------
+
+ procedure Analyze_Dimension_Object_Declaration (N : Node_Id) is
+ Expr : constant Node_Id := Expression (N);
+ Id : constant Entity_Id := Defining_Identifier (N);
+ E_Typ : constant Entity_Id := Etype (Id);
+ Dim_T : constant Dimensions := Get_Dimensions (E_Typ);
+ Dim_E : Dimensions;
+
+ begin
+ if Present (Dim_T) then
+ -- Expression is present
+
+ if Present (Expr) then
+ Dim_E := Get_Dimensions (Expr);
+
+ if Present (Dim_E) then
+ -- Return an error if the dimension of the expression and the
+ -- dimension of the type missmatch.
+
+ if Dim_E /= Dim_T then
+ Error_Msg_N ("?dimensions missmatch in object " &
+ "declaration", N);
+ end if;
+
+ -- If the expression is dimensionless
+
+ else
+ -- If the node is not a real constant or an integer constant
+ -- (depending on the dimensioned numeric type), return an error
+ -- message.
+
+ if not Nkind_In
+ (Original_Node (Expr),
+ N_Real_Literal,
+ N_Integer_Literal)
+ then
+ Error_Msg_N ("?dimensions missmatch in object " &
+ "declaration", N);
+ end if;
+ end if;
+
+ -- For every other cases, propagate the dimensions
+
+ else
+ Copy_Dimensions (E_Typ, Id);
+ end if;
+ end if;
+ end Analyze_Dimension_Object_Declaration;
+
+ ---------------------------------------------------
+ -- Analyze_Dimension_Object_Renaming_Declaration --
+ ---------------------------------------------------
+
+ procedure Analyze_Dimension_Object_Renaming_Declaration (N : Node_Id) is
+ Id : constant Entity_Id := Defining_Identifier (N);
+ Ren_Id : constant Node_Id := Name (N);
+ E_Typ : constant Entity_Id := Etype (Ren_Id);
+ Dims_Typ : constant Dimensions := Get_Dimensions (E_Typ);
+
+ begin
+ if Present (Dims_Typ) then
+ Copy_Dimensions (E_Typ, Id);
+ end if;
+ end Analyze_Dimension_Object_Renaming_Declaration;
+
+ -----------------------------------------------
+ -- Analyze_Dimension_Simple_Return_Statement --
+ -----------------------------------------------
+
+ procedure Analyze_Dimension_Simple_Return_Statement (N : Node_Id) is
+ Expr : constant Node_Id := Expression (N);
+ Dims_Expr : constant Dimensions := Get_Dimensions (Expr);
+ R_Ent : constant Entity_Id := Return_Statement_Entity (N);
+ R_Etyp : constant Entity_Id := Etype (Return_Applies_To (R_Ent));
+ Dims_R : constant Dimensions := Get_Dimensions (R_Etyp);
+
+ begin
+ if Dims_R /= Dims_Expr then
+ Error_Msg_N ("?dimensions missmatch in return statement", N);
+ Remove_Dimensions (Expr);
+ end if;
+ end Analyze_Dimension_Simple_Return_Statement;
+
+ -------------------------------------------
+ -- Analyze_Dimension_Subtype_Declaration --
+ -------------------------------------------
+
+ procedure Analyze_Dimension_Subtype_Declaration (N : Node_Id) is
+ Ent : constant Entity_Id := Defining_Identifier (N);
+ Dims_Ent : constant Dimensions := Get_Dimensions (Ent);
+ E_Typ : Node_Id;
+
+ begin
+ if Nkind (Subtype_Indication (N)) /= N_Subtype_Indication then
+ E_Typ := Etype (Subtype_Indication (N));
+ declare
+ Dims_Typ : constant Dimensions := Get_Dimensions (E_Typ);
+
+ begin
+ if Present (Dims_Typ) then
+
+ -- If the subtype already has a dimension (from
+ -- Aspect_Dimension), it cannot inherit a dimension from its
+ -- subtype.
+
+ if Present (Dims_Ent) then
+ Error_Msg_N ("?subtype& already has a dimension", N);
+
+ else
+ Set_Dimensions (Ent, Dims_Typ);
+ Set_Dimensions_String_Id
+ (Ent, Get_Dimensions_String_Id (E_Typ));
+ end if;
+ end if;
+ end;
+
+ else
+ E_Typ := Etype (Subtype_Mark (Subtype_Indication (N)));
+ declare
+ Dims_Typ : constant Dimensions := Get_Dimensions (E_Typ);
+
+ begin
+ if Present (Dims_Typ) then
+
+ -- If the subtype already has a dimension (from
+ -- Aspect_Dimension), it cannot inherit a dimension from its
+ -- subtype.
+
+ if Present (Dims_Ent) then
+ Error_Msg_N ("?subtype& already has a dimension", N);
+
+ else
+ Set_Dimensions (Ent, Dims_Typ);
+ Set_Dimensions_String_Id
+ (Ent, Get_Dimensions_String_Id (E_Typ));
+ end if;
+ end if;
+ end;
+ end if;
+ end Analyze_Dimension_Subtype_Declaration;
+
+ --------------------------------
+ -- Analyze_Dimension_Unary_Op --
+ --------------------------------
+
+ procedure Analyze_Dimension_Unary_Op (N : Node_Id) is
+ begin
+ case Nkind (N) is
+ when N_Op_Plus | N_Op_Minus | N_Op_Abs =>
+ declare
+ R : constant Node_Id := Right_Opnd (N);
+
+ begin
+ -- Propagate the dimension if the operand is not dimensionless
+
+ Move_Dimensions (R, N);
+ end;
+
+ when others => null;
+
+ end case;
+ end Analyze_Dimension_Unary_Op;
+
+ ---------------------
+ -- Copy_Dimensions --
+ ---------------------
+
+ procedure Copy_Dimensions (From, To : Node_Id) is
+ Dims : constant Dimensions := Aspect_Dimension_Hash_Table.Get (From);
+
+ begin
+ -- Propagate the dimension from one node to another
+
+ pragma Assert (Permits_Dimensions (To));
+ pragma Assert (Present (Dims));
+ Aspect_Dimension_Hash_Table.Set (To, Dims);
+ end Copy_Dimensions;
+
+ -------------------------------
+ -- Create_Rational_From_Expr --
+ -------------------------------
+
+ procedure Create_Rational_From_Expr (Expr : Node_Id; R : in out Rational) is
+ Or_N : constant Node_Id := Original_Node (Expr);
+ Left : Node_Id;
+ Left_Int : Int;
+ Ltype : Entity_Id;
+ Right : Node_Id;
+ Right_Int : Int;
+ R_Opnd_Minus : Node_Id;
+ Rtype : Entity_Id;
+
+ begin
+ -- A rational number is any number that can be expressed as the quotient
+ -- or fraction a/b of two integers, with the denominator b not equal to
+ -- zero.
+
+ -- Check the expression is either a division of two integers or an
+ -- integer itself. The check applies to the original node since the
+ -- node could have already been rewritten.
+
+ -- Numerator is positive
+
+ if Nkind (Or_N) = N_Op_Divide then
+ Left := Left_Opnd (Or_N);
+ Ltype := Etype (Left);
+ Right := Right_Opnd (Or_N);
+ Rtype := Etype (Right);
+
+ if Is_Integer_Type (Ltype)
+ and then Is_Integer_Type (Rtype)
+ then
+ Left_Int := UI_To_Int (Expr_Value (Left));
+ Right_Int := UI_To_Int (Expr_Value (Right));
+
+ -- Verify that the denominator of the rational is positive
+
+ if Right_Int > 0 then
+
+ if Left_Int mod Right_Int = 0 then
+ R := +Whole (UI_To_Int (Expr_Value (Expr)));
+ else
+ R := Whole (Left_Int) / Whole (Right_Int);
+ end if;
+
+ else
+ Error_Msg_N
+ ("denominator in a rational number must be positive", Right);
+ end if;
+
+ else
+ Error_Msg_N ("must be a rational", Expr);
+ end if;
+
+ -- Numerator is negative
+
+ elsif Nkind (Or_N) = N_Op_Minus
+ and then Nkind (Original_Node (Right_Opnd (Or_N))) = N_Op_Divide
+ then
+ R_Opnd_Minus := Original_Node (Right_Opnd (Or_N));
+ Left := Left_Opnd (R_Opnd_Minus);
+ Ltype := Etype (Left);
+ Right := Right_Opnd (R_Opnd_Minus);
+ Rtype := Etype (Right);
+
+ if Is_Integer_Type (Ltype)
+ and then Is_Integer_Type (Rtype)
+ then
+ Left_Int := UI_To_Int (Expr_Value (Left));
+ Right_Int := UI_To_Int (Expr_Value (Right));
+
+ -- Verify that the denominator of the rational is positive
+
+ if Right_Int > 0 then
+
+ if Left_Int mod Right_Int = 0 then
+ R := +Whole (-UI_To_Int (Expr_Value (Expr)));
+ else
+ R := Whole (-Left_Int) / Whole (Right_Int);
+ end if;
+
+ else
+ Error_Msg_N
+ ("denominator in a rational number must be positive", Right);
+ end if;
+
+ else
+ Error_Msg_N ("must be a rational", Expr);
+ end if;
+
+ -- Integer case
+
+ else
+ if Is_Integer_Type (Etype (Expr)) then
+ Right_Int := UI_To_Int (Expr_Value (Expr));
+ R := +Whole (Right_Int);
+ else
+ Error_Msg_N ("must be a rational", Expr);
+ end if;
+ end if;
+ end Create_Rational_From_Expr;
+
+ ----------------------------------------
+ -- Eval_Op_Expon_For_Dimensioned_Type --
+ ----------------------------------------
+
+ -- Eval the expon operator for dimensioned type
+
+ -- Note that if the exponent is an integer (denominator equals to 1) the
+ -- node is not evaluated here and must be evaluated by the Eval_Op_Expon
+ -- routine.
+
+ procedure Eval_Op_Expon_For_Dimensioned_Type
+ (N : Node_Id;
+ B_Typ : Entity_Id)
+ is
+ R : constant Node_Id := Right_Opnd (N);
+ Rat : Rational := Zero_Rational;
+
+ begin
+ if Compile_Time_Known_Value (R)
+ and then Is_Real_Type (B_Typ)
+ then
+ Create_Rational_From_Expr (R, Rat);
+ Eval_Op_Expon_With_Rational_Exponent (N, Rat);
+ end if;
+ end Eval_Op_Expon_For_Dimensioned_Type;
+
+ ------------------------------------------
+ -- Eval_Op_Expon_With_Rational_Exponent --
+ ------------------------------------------
+
+ -- For dimensioned operand in exponentiation, exponent is allowed to be a
+ -- Rational and not only an Integer like for dimensionless operands. For
+ -- that particular case, the left operand is rewritten as a function call
+ -- using the function Expon_LLF from s-llflex.ads.
+
+ procedure Eval_Op_Expon_With_Rational_Exponent
+ (N : Node_Id;
+ Rat : Rational)
+ is
+ Dims : constant Dimensions := Get_Dimensions (N);
+ L : constant Node_Id := Left_Opnd (N);
+ Etyp : constant Entity_Id := Etype (L);
+ Loc : constant Source_Ptr := Sloc (N);
+ Actual_1 : Node_Id;
+ Actual_2 : Node_Id;
+ Base_Typ : Entity_Id;
+ Dim_Value : Rational;
+ List_Of_Dims : List_Id;
+ New_Aspect : Node_Id;
+ New_Aspects : List_Id;
+ New_E : Entity_Id;
+ New_N : Node_Id;
+ New_Typ_L : Node_Id;
+ Sys : Dim_Sys_Id;
+
+ begin
+ -- If Rat.Denominator = 1 that means the exponent is an Integer so
+ -- nothing has to be changed.
+ -- Note that the node must come from source
+
+ if Comes_From_Source (N)
+ and then Rat.Denominator /= 1
+ then
+ Base_Typ := Base_Type (Etyp);
+
+ -- Case when the operand is not dimensionless
+
+ if Present (Dims) then
+
+ -- Get the corresponding Dim_Sys_Id to know the exact number of
+ -- dimensions in the system.
+
+ Sys := Get_Dimension_System_Id (Base_Typ);
+
+ -- Step 1: Generation of a new subtype with the proper dimensions
+
+ -- In order to rewrite the operator as a function call, a new
+ -- subtype with an aspect dimension using the dimensions of the
+ -- node has to be created.
+
+ -- Generate:
+
+ -- Base_Typ : constant Entity_Id := Base_Type (Etyp);
+ -- Sys : constant Dim_Sys_Id :=
+ -- Get_Dimension_System_Id (Base_Typ);
+ -- N_Dims : constant N_Of_Dimensions :=
+ -- Dim_Systems.Table (Sys).N_Of_Dims;
+ -- Dim_Value : Rational;
+
+ -- Aspect_Dim_Expr : List;
+
+ -- Append ("", Aspect_Dim_Expr);
+
+ -- for Dim in Dims'First .. N_Dims loop
+ -- Dim_Value := Dims (Dim);
+ -- if Dim_Value.Denominator /= 1 then
+ -- Append (Dim_Value.Numerator / Dim_Value.Denominator,
+ -- Aspect_Dim_Expr);
+ -- else
+ -- Append (Dim_Value.Numerator, Aspect_Dim_Expr);
+ -- end if;
+ -- end loop;
+
+ -- subtype T is Base_Typ with Dimension => Aspect_Dim_Expr;
+
+ -- Step 1a: Generate the aggregate for the new Aspect_dimension
+
+ New_Aspects := Empty_List;
+ List_Of_Dims := New_List;
+
+ Append (Make_String_Literal (Loc, No_String), List_Of_Dims);
+
+ for Dim in Dims'First .. Dim_Systems.Table (Sys).N_Of_Dims loop
+ Dim_Value := Dims (Dim);
+ if Dim_Value.Denominator /= 1 then
+ Append (
+ Make_Op_Divide (Loc,
+ Left_Opnd =>
+ Make_Integer_Literal (Loc,
+ Int (Dim_Value.Numerator)),
+ Right_Opnd =>
+ Make_Integer_Literal (Loc,
+ Int (Dim_Value.Denominator))),
+ List_Of_Dims);
+ else
+ Append (
+ Make_Integer_Literal (Loc,
+ Int (Dim_Value.Numerator)),
+ List_Of_Dims);
+ end if;
+ end loop;
+
+ -- Step 1b: Create the new Aspect_Dimension
+
+ New_Aspect :=
+ Make_Aspect_Specification (Loc,
+ Identifier =>
+ Make_Identifier (Loc, Name_Dimension),
+ Expression =>
+ Make_Aggregate (Loc,
+ Expressions => List_Of_Dims));
+
+ -- Step 1c: New identifier for the subtype
+
+ New_E := Make_Temporary (Loc, 'T');
+ Set_Is_Internal (New_E);
+
+ -- Step 1d: Declaration of the new subtype
+
+ New_Typ_L :=
+ Make_Subtype_Declaration (Loc,
+ Defining_Identifier => New_E,
+ Subtype_Indication =>
+ New_Occurrence_Of (Base_Typ, Loc));
+
+ Append (New_Aspect, New_Aspects);
+ Set_Parent (New_Aspects, New_Typ_L);
+ Set_Aspect_Specifications (New_Typ_L, New_Aspects);
+
+ Analyze (New_Typ_L);
+
+ -- Case where the operand is dimensionless
+
+ else
+ New_E := Base_Typ;
+ end if;
+
+ -- Step 2: Generation of the function call
+
+ -- Generate:
+
+ -- Actual_1 := Long_Long_Float (L),
+
+ -- Actual_2 := Long_Long_Float (Rat.Numerator) /
+ -- Long_Long_Float (Rat.Denominator);
+
+ -- (T (Expon_LLF (Actual_1, Actual_2)));
+
+ -- -- where T is the subtype declared in step 1
+
+ -- -- The node is rewritten as a type conversion
+
+ -- Step 2a: Creation of the two parameters for function Expon_LLF
+
+ Actual_1 :=
+ Make_Type_Conversion (Loc,
+ Subtype_Mark => New_Reference_To (Standard_Long_Long_Float, Loc),
+ Expression => Relocate_Node (L));
+
+ Actual_2 :=
+ Make_Op_Divide (Loc,
+ Left_Opnd =>
+ Make_Real_Literal (Loc,
+ UR_From_Uint (UI_From_Int (Int (Rat.Numerator)))),
+ Right_Opnd =>
+ Make_Real_Literal (Loc,
+ UR_From_Uint (UI_From_Int (Int (Rat.Denominator)))));
+
+ -- Step 2b: New Node N
+
+ New_N :=
+ Make_Type_Conversion (Loc,
+ Subtype_Mark => New_Reference_To (New_E, Loc),
+ Expression =>
+ Make_Function_Call (Loc,
+ Name => New_Reference_To (RTE (RE_Expon_LLF), Loc),
+ Parameter_Associations => New_List (
+ Actual_1, Actual_2)));
+
+ -- Step 3: Rewitten of N
+
+ Rewrite (N, New_N);
+ Set_Etype (N, New_E);
+ Analyze_And_Resolve (N, New_E);
+ end if;
+ end Eval_Op_Expon_With_Rational_Exponent;
+
+ -------------------------------------------
+ -- Expand_Put_Call_With_Dimension_String --
+ -------------------------------------------
+
+ -- For procedure Put defined in System.Dim_Float_IO and
+ -- System.Dim_Integer_IO, the default string parameter must be rewritten to
+ -- include the dimension symbols in the output of a dimensioned object.
+
+ -- There are two different cases:
+
+ -- 1) If the parameter is a variable, the default string parameter is
+ -- replaced by the string defined in the aspect Dimension of the subtype.
+ -- For instance if the user wants to output a speed:
+
+ -- subtype Speed is Mks_Type with Dimension =>
+ -- ("speed", Meter => 1, Second => -1, others => 0);
+ -- v : Speed := 2.1 * m * s**(-1);
+
+ -- Put (v) returns:
+ -- > 2.1 speed
+
+ -- 2) If the parameter is an expression, the procedure
+ -- Expand_Put_Call_With_Dimension_String creates the string (for instance
+ -- "m.s**(-1)") and rewrites the default string parameter of Put with the
+ -- corresponding the String_Id.
+
+ procedure Expand_Put_Call_With_Dimension_String (N : Node_Id) is
+ Actuals : constant List_Id := Parameter_Associations (N);
+ Loc : constant Source_Ptr := Sloc (N);
+ Name_Call : constant Node_Id := Name (N);
+ Actual : Node_Id;
+ Base_Typ : Node_Id;
+ Char_Pack : Name_Id;
+ Dims : Dimensions;
+ Etyp : Entity_Id;
+ First_Actual : Node_Id;
+ New_Par_Ass : List_Id;
+ New_Str_Lit : Node_Id;
+ Sys : Dim_Sys_Id;
+
+ function Is_Procedure_Put_Call (N : Node_Id) return Boolean;
+ -- Return True if the current call is a call of an instantiation of a
+ -- procedure Put defined in the package System.Dim_Float_IO and
+ -- System.Dim_Integer_IO.
+
+ function Is_Procedure_Put_Call (N : Node_Id) return Boolean is
+ Name_Call : constant Node_Id := Name (N);
+ Ent : Entity_Id;
+
+ begin
+ -- There are three different Put routine in each generic package
+ -- Check that the current procedure call is one of them
+
+ if Is_Entity_Name (Name_Call) then
+ Ent := Entity (Name_Call);
+
+ -- Check that the name of the procedure is Put
+
+ if Chars (Name_Call) /= Name_Put then
+ return False;
+ end if;
+
+ -- Check the procedure is defined in an instantiation of a
+ -- generic package.
+
+ if Is_Generic_Instance (Scope (Ent)) then
+ Ent := Cunit_Entity (Get_Source_Unit (Ent));
+
+ -- Verify that the generic package is System.Dim_Float_IO or
+ -- System.Dim_Integer_IO.
+
+ if Is_Library_Level_Entity (Ent) then
+ Char_Pack := Chars (Ent);
+
+ if Char_Pack = Name_Dim_Float_IO
+ or else Char_Pack = Name_Dim_Integer_IO
+ then
+ return True;
+ end if;
+ end if;
+ end if;
+ end if;
+
+ return False;
+ end Is_Procedure_Put_Call;
+
+ -- Start of processing for Expand_Put_Call_With_Dimension_String
+
+ begin
+ if Is_Procedure_Put_Call (N) then
+
+ -- Get the first parameter
+
+ First_Actual := First (Actuals);
+
+ -- Case when the Put routine has four (integer case) or five (float
+ -- case) parameters.
+
+ if List_Length (Actuals) = 5
+ or else List_Length (Actuals) = 4
+ then
+ Actual := Next (First_Actual);
+
+ if Nkind (Actual) = N_Parameter_Association then
+
+ -- Get the dimensions and the corresponding dimension system
+ -- from the first actual.
+
+ Actual := First_Actual;
+ end if;
+
+ -- Case when the Put routine has six parameters
+
+ else
+ Actual := Next (First_Actual);
+ end if;
+
+ Base_Typ := Base_Type (Etype (Actual));
+ Sys := Get_Dimension_System_Id (Base_Typ);
+
+ if Sys /= No_Dim_Sys then
+ Dims := Get_Dimensions (Actual);
+ Etyp := Etype (Actual);
+
+ -- Add the string as a suffix of the value if the subtype has a
+ -- string of dimensions or if the parameter is not dimensionless.
+
+ if Present (Dims)
+ or else Get_Dimensions_String_Id (Etyp) /= No_String
+ then
+ New_Par_Ass := New_List;
+
+ -- Add to the list First_Actual and Actual if they differ
+
+ if Actual /= First_Actual then
+ Append (New_Copy (First_Actual), New_Par_Ass);
+ end if;
+
+ Append (New_Copy (Actual), New_Par_Ass);
+
+ -- Look to the next parameter
+
+ Next (Actual);
+
+ -- Check if the type of N is a subtype that has a string of
+ -- dimensions in Aspect_Dimension_String_Id_Hash_Table.
+
+ if Get_Dimensions_String_Id (Etyp) /= No_String then
+ Start_String;
+
+ -- Put a space between the value and the dimension
+
+ Store_String_Char (' ');
+ Store_String_Chars (Get_Dimensions_String_Id (Etyp));
+ New_Str_Lit :=
+ Make_String_Literal (Loc, End_String);
+
+ -- Rewrite the String_Literal of the second actual with the
+ -- new String_Id created by the routine
+ -- From_Dimension_To_String.
+
+ else
+ New_Str_Lit :=
+ Make_String_Literal (Loc,
+ From_Dimension_To_String_Id (Dims, Sys));
+ end if;
+
+ Append (New_Str_Lit, New_Par_Ass);
+
+ -- Rewrite the procedure call with the new list of parameters
+
+ Rewrite (N,
+ Make_Procedure_Call_Statement (Loc,
+ Name => New_Copy (Name_Call),
+ Parameter_Associations => New_Par_Ass));
+
+ Analyze (N);
+ end if;
+ end if;
+ end if;
+ end Expand_Put_Call_With_Dimension_String;
+
+ ---------------------------------
+ -- From_Dimension_To_String_Id --
+ ---------------------------------
+
+ -- Given a dimension vector and the corresponding dimension system, create
+ -- a String_Id to output the dimension symbols corresponding to the
+ -- dimensions Dims.
+
+ function From_Dimension_To_String_Id
+ (Dims : Dimensions;
+ Sys : Dim_Sys_Id) return String_Id
+ is
+ Dim_Rat : Rational;
+ First_Dim_In_Str : Boolean := True;
+
+ begin
+ -- Initialization of the new String_Id
+
+ Start_String;
+
+ -- Put a space between the value and the dimensions
+
+ Store_String_Char (' ');
+
+ for Dim in Dimensions'Range loop
+
+ Dim_Rat := Dims (Dim);
+ if Dim_Rat /= Zero_Rational then
+
+ if First_Dim_In_Str then
+ First_Dim_In_Str := False;
+ else
+ Store_String_Char ('.');
+ end if;
+
+ -- Positive dimension case
+
+ if Dim_Rat.Numerator > 0 then
+
+ if Dim_Systems.Table (Sys).Symbols (Dim) = No_String then
+ Store_String_Chars
+ (Get_Name_String (Dim_Systems.Table (Sys).Names (Dim)));
+ else
+ Store_String_Chars (Dim_Systems.Table (Sys).Symbols (Dim));
+ end if;
+
+ -- Integer case
+
+ if Dim_Rat.Denominator = 1 then
+
+ if Dim_Rat.Numerator /= 1 then
+ Store_String_Chars ("**");
+ Store_String_Int (Int (Dim_Rat.Numerator));
+ end if;
+
+ -- Rational case when denominator /= 1
+
+ else
+ Store_String_Chars ("**");
+ Store_String_Char ('(');
+ Store_String_Int (Int (Dim_Rat.Numerator));
+ Store_String_Char ('/');
+ Store_String_Int (Int (Dim_Rat.Denominator));
+ Store_String_Char (')');
+ end if;
+
+ -- Negative dimension case
+
+ else
+ if Dim_Systems.Table (Sys).Symbols (Dim) = No_String then
+ Store_String_Chars
+ (Get_Name_String (Dim_Systems.Table (Sys).Names (Dim)));
+ else
+ Store_String_Chars (Dim_Systems.Table (Sys).Symbols (Dim));
+ end if;
+
+ Store_String_Chars ("**");
+ Store_String_Char ('(');
+ Store_String_Char ('-');
+ Store_String_Int (Int (-Dim_Rat.Numerator));
+
+ -- Integer case
+
+ if Dim_Rat.Denominator = 1 then
+ Store_String_Char (')');
+
+ -- Rational case when denominator /= 1
+
+ else
+ Store_String_Char ('/');
+ Store_String_Int (Int (Dim_Rat.Denominator));
+ Store_String_Char (')');
+ end if;
+ end if;
+ end if;
+ end loop;
+
+ return End_String;
+ end From_Dimension_To_String_Id;
+
+ --------------------
+ -- Get_Dimensions --
+ --------------------
+
+ function Get_Dimensions (N : Node_Id) return Dimensions is
+ begin
+ return Aspect_Dimension_Hash_Table.Get (N);
+ end Get_Dimensions;
+
+ ------------------------------
+ -- Get_Dimensions_String_Id --
+ ------------------------------
+
+ function Get_Dimensions_String_Id (E : Entity_Id) return String_Id is
+ begin
+ return Aspect_Dimension_String_Id_Hash_Table.Get (E);
+ end Get_Dimensions_String_Id;
+
+ -----------------------------
+ -- Get_Dimension_System_Id --
+ -----------------------------
+
+ function Get_Dimension_System_Id (E : Entity_Id) return Dim_Sys_Id is
+ D_Sys : Dim_Sys_Id := No_Dim_Sys;
+
+ begin
+ -- Scan the Table in order to find N
+
+ for Dim_Sys in 1 .. Dim_Systems.Last loop
+ if Parent (E) = Dim_Systems.Table (Dim_Sys).Base_Type then
+ D_Sys := Dim_Sys;
+ end if;
+ end loop;
+
+ return D_Sys;
+ end Get_Dimension_System_Id;
+
+ --------------------------
+ -- Is_Dimensioned_Type --
+ --------------------------
+
+ function Is_Dimensioned_Type (E : Entity_Id) return Boolean
+ is
+ begin
+ if Get_Dimension_System_Id (E) /= No_Dim_Sys then
+ return True;
+ end if;
+
+ return False;
+ end Is_Dimensioned_Type;
+
+ ---------------------
+ -- Move_Dimensions --
+ ---------------------
+
+ procedure Move_Dimensions (From, To : Node_Id) is
+ Dims : constant Dimensions := Get_Dimensions (From);
+
+ begin
+ -- Copy the dimension of 'From to 'To' and remove the dimension of
+ -- 'From'.
+
+ if Present (Dims) then
+ Set_Dimensions (To, Dims);
+ Remove_Dimensions (From);
+ end if;
+ end Move_Dimensions;
+
+ ------------------------
+ -- Permits_Dimensions --
+ ------------------------
+
+ -- Here is the list of node that permits a dimension
+
+ Dimensions_Permission : constant array (Node_Kind) of Boolean :=
+ (N_Attribute_Reference => True,
+ N_Defining_Identifier => True,
+ N_Function_Call => True,
+ N_Identifier => True,
+ N_Indexed_Component => True,
+ N_Integer_Literal => True,
+
+ N_Op_Abs => True,
+ N_Op_Add => True,
+ N_Op_Divide => True,
+ N_Op_Expon => True,
+ N_Op_Minus => True,
+ N_Op_Mod => True,
+ N_Op_Multiply => True,
+ N_Op_Plus => True,
+ N_Op_Rem => True,
+ N_Op_Subtract => True,
+
+ N_Qualified_Expression => True,
+ N_Real_Literal => True,
+ N_Selected_Component => True,
+ N_Slice => True,
+ N_Type_Conversion => True,
+ N_Unchecked_Type_Conversion => True,
+
+ others => False);
+
+ function Permits_Dimensions (N : Node_Id) return Boolean is
+ begin
+ return Dimensions_Permission (Nkind (N));
+ end Permits_Dimensions;
+
+ -------------
+ -- Present --
+ -------------
+
+ function Present (Dim : Dimensions) return Boolean is
+ begin
+ return Dim /= Zero_Dimensions;
+ end Present;
+
+ -----------------------
+ -- Remove_Dimensions --
+ -----------------------
+
+ procedure Remove_Dimensions (N : Node_Id) is
+ Dims : constant Dimensions := Get_Dimensions (N);
+
+ begin
+ if Present (Dims) then
+ Aspect_Dimension_Hash_Table.Remove (N);
+ end if;
+ end Remove_Dimensions;
+
+ ------------------------------
+ -- Remove_Dimension_In_Call --
+ ------------------------------
+
+ procedure Remove_Dimension_In_Call (N : Node_Id) is
+ Actual : Node_Id;
+ Par_Ass : constant List_Id := Parameter_Associations (N);
+
+ begin
+ if Ada_Version < Ada_2012 then
+ return;
+ end if;
+
+ if Present (Par_Ass) then
+ Actual := First (Par_Ass);
+
+ while Present (Actual) loop
+ Remove_Dimensions (Actual);
+ Next (Actual);
+ end loop;
+ end if;
+ end Remove_Dimension_In_Call;
+
+ -------------------------------------
+ -- Remove_Dimension_In_Declaration --
+ -------------------------------------
+
+ -- Removal of dimension in expressions of N_Object_Declaration and
+ -- N_Component_Declaration as part of the Analyze_Declarations routine
+ -- (see package Sem_Ch3).
+
+ procedure Remove_Dimension_In_Declaration (D : Node_Id) is
+ begin
+ if Ada_Version < Ada_2012 then
+ return;
+ end if;
+
+ if Nkind_In (D, N_Object_Declaration, N_Component_Declaration) then
+ if Present (Expression (D)) then
+ Remove_Dimensions (Expression (D));
+ end if;
+ end if;
+ end Remove_Dimension_In_Declaration;
+
+ -----------------------------------
+ -- Remove_Dimension_In_Statement --
+ -----------------------------------
+
+ -- Removal of dimension in statement as part of the Analyze_Statements
+ -- routine (see package Sem_Ch5).
+
+ procedure Remove_Dimension_In_Statement (S : Node_Id) is
+ S_Kind : constant Node_Kind := Nkind (S);
+
+ begin
+ if Ada_Version < Ada_2012 then
+ return;
+ end if;
+
+ -- Remove dimension in parameter specifications for accept statement
+
+ if S_Kind = N_Accept_Statement then
+ declare
+ Param : Node_Id := First (Parameter_Specifications (S));
+
+ begin
+ while Present (Param) loop
+ Remove_Dimensions (Param);
+ Next (Param);
+ end loop;
+ end;
+
+ -- Remove dimension of name and expression in assignments
+
+ elsif S_Kind = N_Assignment_Statement then
+ Remove_Dimensions (Expression (S));
+ Remove_Dimensions (Name (S));
+ end if;
+ end Remove_Dimension_In_Statement;
+
+ --------------------
+ -- Set_Dimensions --
+ --------------------
+
+ procedure Set_Dimensions (N : Node_Id; Dims : Dimensions) is
+ begin
+ pragma Assert (Permits_Dimensions (N));
+ pragma Assert (Present (Dims));
+ Aspect_Dimension_Hash_Table.Set (N, Dims);
+ end Set_Dimensions;
+
+ ------------------------------
+ -- Set_Dimensions_String_Id --
+ ------------------------------
+
+ procedure Set_Dimensions_String_Id (E : Entity_Id; Str : String_Id) is
+ begin
+ Aspect_Dimension_String_Id_Hash_Table.Set (E, Str);
+ end Set_Dimensions_String_Id;
+
+end Sem_Dim;
===================================================================
@@ -0,0 +1,150 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S E M _ D I M --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING3. If not, go to --
+-- http://www.gnu.org/licenses for a complete copy of the license. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- 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.
+
+-- Indeed, the user is now able to create his own dimension system and to
+-- assign a dimension, defined from the MKS system (package System.Dim_Mks)
+-- or his own dimension systems, with any item and to run operations with
+-- dimensionned entities.
+-- In that case, a dimensionnality checking will be performed at compile time.
+-- If no dimension has been assigned, the compiler assumes that the item is
+-- dimensionless.
+
+-----------------------------
+-- Aspect_Dimension_System --
+-----------------------------
+
+-- In order to enable the user to create his own dimension system, a new
+-- aspect: Aspect_Dimension_System has been created.
+-- Note that this aspect applies for type declaration of type derived from any
+-- numeric type.
+
+-- It defines the names of each dimension.
+
+----------------------
+-- Aspect_Dimension --
+----------------------
+
+-- This new aspect applies for subtype and object declarations in order to
+-- define new dimensions.
+-- Using this aspect, the user is able to create new subtype/object with any
+-- dimension needed.
+-- Note that the base type of the subtype/object must be the type that defines
+-- the corresponding dimension system.
+
+-- The expression of this aspect is an aggregate of rational values for each
+-- dimension in the corresponding dimension system.
+
+-------------------------------------------
+-- Dimensionality checking & propagation --
+-------------------------------------------
+
+-- For each node (when needed), a dimension analysis (Analyze_Dimension) is
+-- performed as part of the Resolution routine or the Analysis routine if no
+-- Resolution.
+
+-- The dimension analysis is divided into two phases:
+
+-- Phase 1: dimension checking
+
+-- Phase 2: propagation of dimensions
+
+-- Depending on the node kind, either none, one phase or two phases are
+-- executed.
+-- Phase 2 is called only when the node allows a dimension (see body of
+-- Sem_Dim to get the list of nodes that permit dimensions).
+
+------------------
+-- Dimension_IO --
+------------------
+
+-- This section contains the routine used for IO purposes.
+
+with Types; use Types;
+
+package Sem_Dim is
+
+ -----------------------------
+ -- Aspect_Dimension_System --
+ -----------------------------
+
+ procedure Analyze_Aspect_Dimension_System
+ (N : Node_Id;
+ Id : Node_Id;
+ Expr : Node_Id);
+ -- Analyzes the aggregate of Aspect_Dimension_System
+
+ ----------------------
+ -- Aspect_Dimension --
+ ----------------------
+
+ procedure Analyze_Aspect_Dimension
+ (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 --
+ -------------------------------------------
+
+ procedure Analyze_Dimension (N : Node_Id);
+ -- Performs a dimension analysis and propagates dimension between nodes
+ -- when needed.
+
+ procedure Eval_Op_Expon_For_Dimensioned_Type
+ (N : Node_Id;
+ B_Typ : Entity_Id);
+ -- Eval the Expon operator for dimensioned type with rational exponent
+
+ 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
+ -- parameters in the call N.
+
+ 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.
+
+ 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.
+
+ ------------------
+ -- Dimension_IO --
+ ------------------
+
+ 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.
+
+end Sem_Dim;
===================================================================
@@ -8062,24 +8062,6 @@
Default_Pool := Expression (Arg1);
- ---------------
- -- Dimension --
- ---------------
-
- when Pragma_Dimension =>
- GNAT_Pragma;
- Check_Arg_Count (4);
- Check_No_Identifiers;
- Check_Arg_Is_Local_Name (Arg1);
-
- if not Is_Type (Arg1) then
- Error_Pragma ("first argument for pragma% must be subtype");
- end if;
-
- Check_Arg_Is_Static_Expression (Arg2, Standard_Integer);
- Check_Arg_Is_Static_Expression (Arg3, Standard_Integer);
- Check_Arg_Is_Static_Expression (Arg4, Standard_Integer);
-
------------------------------------
-- Disable_Atomic_Synchronization --
------------------------------------
@@ -14956,7 +14938,6 @@
Pragma_Debug_Policy => 0,
Pragma_Detect_Blocking => -1,
Pragma_Default_Storage_Pool => -1,
- Pragma_Dimension => -1,
Pragma_Disable_Atomic_Synchronization => -1,
Pragma_Discard_Names => 0,
Pragma_Dispatching_Domain => -1,
===================================================================
@@ -262,6 +262,7 @@
System_Img_Uns,
System_Img_WChar,
System_Interrupts,
+ System_Long_Long_Float_Expon,
System_Machine_Code,
System_Mantissa,
System_Memcop,
@@ -866,6 +867,8 @@
RE_Static_Interrupt_Protection, -- System.Interrupts
RE_System_Interrupt_Id, -- System.Interrupts
+ RE_Expon_LLF, -- System.Long_Long_Float_Expon
+
RE_Asm_Insn, -- System.Machine_Code
RE_Asm_Input_Operand, -- System.Machine_Code
RE_Asm_Output_Operand, -- System.Machine_Code
@@ -2066,6 +2069,8 @@
RE_Static_Interrupt_Protection => System_Interrupts,
RE_System_Interrupt_Id => System_Interrupts,
+ RE_Expon_LLF => System_Long_Long_Float_Expon,
+
RE_Asm_Insn => System_Machine_Code,
RE_Asm_Input_Operand => System_Machine_Code,
RE_Asm_Output_Operand => System_Machine_Code,
===================================================================
@@ -57,6 +57,7 @@
with Sem_Ch6; use Sem_Ch6;
with Sem_Ch8; use Sem_Ch8;
with Sem_Ch13; use Sem_Ch13;
+with Sem_Dim; use Sem_Dim;
with Sem_Disp; use Sem_Disp;
with Sem_Dist; use Sem_Dist;
with Sem_Elim; use Sem_Elim;
@@ -2010,6 +2011,7 @@
if Analyzed (N) then
Debug_A_Exit ("resolving ", N, " (done, already analyzed)");
+ Analyze_Dimension (N);
return;
-- Return if type = Any_Type (previous error encountered)
@@ -4878,6 +4880,7 @@
end if;
Generate_Operator_Reference (N, Typ);
+ Analyze_Dimension (N);
Eval_Arithmetic_Op (N);
-- In SPARK, a multiplication or division with operands of fixed point
@@ -5808,6 +5811,10 @@
end;
end if;
+ -- dimension analysis
+
+ Analyze_Dimension (N);
+
-- All done, evaluate call and deal with elaboration issues
Eval_Call (N);
@@ -6004,6 +6011,7 @@
-- Evaluate the relation (note we do this after the above check since
-- this Eval call may change N to True/False.
+ Analyze_Dimension (N);
Eval_Relational_Op (N);
end Resolve_Comparison_Op;
@@ -6889,6 +6897,7 @@
or else Is_Intrinsic_Subprogram
(Corresponding_Equality (Entity (N)))
then
+ Analyze_Dimension (N);
Eval_Relational_Op (N);
elsif Nkind (N) = N_Op_Ne
@@ -7143,6 +7152,8 @@
end loop;
end if;
+ Analyze_Dimension (N);
+
-- Do not generate the warning on suspicious index if we are analyzing
-- package Ada.Tags; otherwise we will report the warning with the
-- Prims_Ptr field of the dispatch table.
@@ -7998,6 +8009,24 @@
Set_Etype (N, B_Typ);
Generate_Operator_Reference (N, B_Typ);
+
+ Analyze_Dimension (N);
+
+ -- Evaluate the Expon operator for dimensioned type with rational
+ -- exponent.
+
+ if Ada_Version >= Ada_2012
+ and then Is_Dimensioned_Type (B_Typ)
+ then
+ Eval_Op_Expon_For_Dimensioned_Type (N, B_Typ);
+
+ -- Skip the Eval_Op_Expon if the node has already been evaluated
+
+ if Nkind (N) = N_Type_Conversion then
+ return;
+ end if;
+ end if;
+
Eval_Op_Expon (N);
-- Set overflow checking bit. Much cleverer code needed here eventually
@@ -8196,6 +8225,7 @@
Set_Etype (N, Etype (Expr));
end if;
+ Analyze_Dimension (N);
Eval_Qualified_Expression (N);
end Resolve_Qualified_Expression;
@@ -8629,6 +8659,7 @@
Error_Msg_N ("?\may cause unexpected accesses to atomic object",
Prefix (N));
end if;
+ Analyze_Dimension (N);
end Resolve_Selected_Component;
-------------------
@@ -8940,6 +8971,7 @@
Warn_On_Suspicious_Index (Name, High_Bound (Drange));
end if;
+ Analyze_Dimension (N);
Eval_Slice (N);
end Resolve_Slice;
@@ -9346,6 +9378,8 @@
Check_SPARK_Restriction ("object required", Operand);
end if;
+ Analyze_Dimension (N);
+
-- Note: we do the Eval_Type_Conversion call before applying the
-- required checks for a subtype conversion. This is important, since
-- both are prepared under certain circumstances to change the type
@@ -9629,6 +9663,7 @@
Check_Unset_Reference (R);
Generate_Operator_Reference (N, B_Typ);
+ Analyze_Dimension (N);
Eval_Unary_Op (N);
-- Set overflow checking bit. Much cleverer code needed here eventually
@@ -9795,6 +9830,7 @@
-- Resolve operand using its own type
Resolve (Operand, Opnd_Type);
+ Analyze_Dimension (N);
Eval_Unchecked_Conversion (N);
end Resolve_Unchecked_Type_Conversion;
===================================================================
@@ -52,6 +52,7 @@
with Sem_Ch6; use Sem_Ch6;
with Sem_Ch8; use Sem_Ch8;
with Sem_Ch10; use Sem_Ch10;
+with Sem_Dim; use Sem_Dim;
with Sem_Dist; use Sem_Dist;
with Sem_Elim; use Sem_Elim;
with Sem_Eval; use Sem_Eval;
@@ -9165,6 +9166,7 @@
-- Finally perform static evaluation on the attribute reference
+ Analyze_Dimension (N);
Eval_Attribute (N);
end Resolve_Attribute;
===================================================================
@@ -30,6 +30,7 @@
with Restrict; use Restrict;
with Rident; use Rident;
with Sem_Ch8; use Sem_Ch8;
+with Sem_Dim; use Sem_Dim;
with Sinfo; use Sinfo;
with Stand; use Stand;
with Uintp; use Uintp;
@@ -75,6 +76,8 @@
else
Find_Direct_Name (N);
end if;
+
+ Analyze_Dimension (N);
end Analyze_Identifier;
-----------------------------
===================================================================
@@ -60,9 +60,10 @@
with Sem_Ch8; use Sem_Ch8;
with Sem_Ch12; use Sem_Ch12;
with Sem_Ch13; use Sem_Ch13;
-with Sem_Eval; use Sem_Eval;
+with Sem_Dim; use Sem_Dim;
with Sem_Disp; use Sem_Disp;
with Sem_Dist; use Sem_Dist;
+with Sem_Eval; use Sem_Eval;
with Sem_Mech; use Sem_Mech;
with Sem_Res; use Sem_Res;
with Sem_SCIL; use Sem_SCIL;
@@ -2103,6 +2104,20 @@
-- Start of processing for Expand_Call
begin
+ -- Expand the procedure call if the first actual has a dimension and if
+ -- the procedure is Put (Ada 2012).
+
+ if Ada_Version >= Ada_2012
+ 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);
+ end if;
+
+ -- Remove the dimensions of every parameters in call
+
+ Remove_Dimension_In_Call (N);
+
-- Ignore if previous error
if Nkind (Call_Node) in N_Has_Etype
===================================================================
@@ -50,6 +50,7 @@
with Sem_Ch5; use Sem_Ch5;
with Sem_Ch6; use Sem_Ch6;
with Sem_Ch8; use Sem_Ch8;
+with Sem_Dim; use Sem_Dim;
with Sem_Disp; use Sem_Disp;
with Sem_Dist; use Sem_Dist;
with Sem_Eval; use Sem_Eval;
@@ -6040,8 +6041,16 @@
First_Subtype (Base_Type (Etype (R))) /= Standard_Integer
and then Base_Type (Etype (R)) /= Universal_Integer
then
- Error_Msg_NE
- ("exponent must be of type Natural, found}", R, Etype (R));
+ if Ada_Version >= Ada_2012
+ and then Is_Dimensioned_Type (Etype (L))
+ then
+ Error_Msg_NE
+ ("exponent for dimensioned type must be a Rational" &
+ ", found}", R, Etype (R));
+ else
+ Error_Msg_NE
+ ("exponent must be of type Natural, found}", R, Etype (R));
+ end if;
return;
end if;
===================================================================
@@ -240,6 +240,8 @@
Aspect_Default_Component_Value => Aspect_Default_Component_Value,
Aspect_Default_Iterator => Aspect_Default_Iterator,
Aspect_Default_Value => Aspect_Default_Value,
+ Aspect_Dimension => Aspect_Dimension,
+ Aspect_Dimension_System => Aspect_Dimension_System,
Aspect_Discard_Names => Aspect_Discard_Names,
Aspect_Dispatching_Domain => Aspect_Dispatching_Domain,
Aspect_Dynamic_Predicate => Aspect_Predicate,
===================================================================
@@ -54,6 +54,8 @@
Aspect_Default_Component_Value,
Aspect_Default_Iterator,
Aspect_Default_Value,
+ Aspect_Dimension,
+ Aspect_Dimension_System,
Aspect_Dispatching_Domain,
Aspect_Dynamic_Predicate,
Aspect_External_Tag,
@@ -232,6 +234,8 @@
Aspect_Default_Component_Value => Expression,
Aspect_Default_Iterator => Name,
Aspect_Default_Value => Expression,
+ Aspect_Dimension => Expression,
+ Aspect_Dimension_System => Expression,
Aspect_Dispatching_Domain => Expression,
Aspect_Dynamic_Predicate => Expression,
Aspect_External_Tag => Expression,
@@ -293,6 +297,8 @@
Aspect_Default_Iterator => Name_Default_Iterator,
Aspect_Default_Value => Name_Default_Value,
Aspect_Default_Component_Value => Name_Default_Component_Value,
+ Aspect_Dimension => Name_Dimension,
+ Aspect_Dimension_System => Name_Dimension_System,
Aspect_Discard_Names => Name_Discard_Names,
Aspect_Dispatching_Domain => Name_Dispatching_Domain,
Aspect_Dynamic_Predicate => Name_Dynamic_Predicate,
===================================================================
@@ -0,0 +1,77 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . D I M _ F L O A T _ I O --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
+-- --
+-- GNARL is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- 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. --
+-- --
+------------------------------------------------------------------------------
+
+package body System.Dim_Float_IO is
+
+ package Num_Dim_Float_IO is new Ada.Text_IO.Float_IO (Num_Dim_Float);
+
+ ---------
+ -- Put --
+ ---------
+
+ procedure Put
+ (File : File_Type;
+ Item : Num_Dim_Float;
+ Unit : String := "";
+ Fore : Field := Default_Fore;
+ Aft : Field := Default_Aft;
+ Exp : Field := Default_Exp)
+ is
+ begin
+ Num_Dim_Float_IO.Put (File, Item, Fore, Aft, Exp);
+ Ada.Text_IO.Put (File, Unit);
+ end Put;
+
+ procedure Put
+ (Item : Num_Dim_Float;
+ Unit : String := "";
+ Fore : Field := Default_Fore;
+ Aft : Field := Default_Aft;
+ Exp : Field := Default_Exp)
+ is
+ begin
+ Num_Dim_Float_IO.Put (Item, Fore, Aft, Exp);
+ Ada.Text_IO.Put (Unit);
+ end Put;
+
+ procedure Put
+ (To : out String;
+ Item : Num_Dim_Float;
+ Unit : String := "";
+ Aft : Field := Default_Aft;
+ Exp : Field := Default_Exp)
+ is
+ begin
+ Num_Dim_Float_IO.Put (To, Item, Aft, Exp);
+ To := To & Unit;
+ end Put;
+
+end System.Dim_Float_IO;
===================================================================
@@ -60,6 +60,7 @@
with Sem_Ch10; use Sem_Ch10;
with Sem_Ch12; use Sem_Ch12;
with Sem_Ch13; use Sem_Ch13;
+with Sem_Dim; use Sem_Dim;
with Sem_Disp; use Sem_Disp;
with Sem_Dist; use Sem_Dist;
with Sem_Elim; use Sem_Elim;
@@ -1529,6 +1530,8 @@
Kill_Current_Values (Last_Assignment_Only => True);
Check_Unreachable_Code (N);
+
+ Analyze_Dimension (N);
end Analyze_Return_Statement;
-------------------------------------
===================================================================
@@ -0,0 +1,77 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . D I M _ F L O A T _ I O --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
+-- --
+-- GNARL is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- 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. --
+-- --
+------------------------------------------------------------------------------
+
+-- Note that this package should only be instantiated with a float dimensioned
+-- type.
+
+-- This package is a generic package that provides IO facilities for float
+-- dimensioned types.
+
+-- Note that there is a default string parameter in every Put routine
+-- rewritten at compile time to output the corresponding dimensions as a
+-- suffix of the numeric value.
+
+with Ada.Text_IO; use Ada.Text_IO;
+
+generic
+ type Num_Dim_Float is digits <>;
+
+package System.Dim_Float_IO is
+
+ Default_Fore : Field := 2;
+ Default_Aft : Field := Num_Dim_Float'Digits - 1;
+ Default_Exp : Field := 3;
+
+ procedure Put
+ (File : File_Type;
+ Item : Num_Dim_Float;
+ Unit : String := "";
+ Fore : Field := Default_Fore;
+ Aft : Field := Default_Aft;
+ Exp : Field := Default_Exp);
+
+ procedure Put
+ (Item : Num_Dim_Float;
+ Unit : String := "";
+ Fore : Field := Default_Fore;
+ Aft : Field := Default_Aft;
+ Exp : Field := Default_Exp);
+
+ procedure Put
+ (To : out String;
+ Item : Num_Dim_Float;
+ Unit : String := "";
+ Aft : Field := Default_Aft;
+ Exp : Field := Default_Exp);
+
+ pragma Inline (Put);
+
+end System.Dim_Float_IO;
===================================================================
@@ -1126,7 +1126,6 @@
Pragma_Debug_Policy |
Pragma_Detect_Blocking |
Pragma_Default_Storage_Pool |
- Pragma_Dimension |
Pragma_Disable_Atomic_Synchronization |
Pragma_Discard_Names |
Pragma_Dispatching_Domain |
===================================================================
@@ -53,6 +53,7 @@
with Sem_Ch6; use Sem_Ch6;
with Sem_Ch12; use Sem_Ch12;
with Sem_Ch13; use Sem_Ch13;
+with Sem_Dim; use Sem_Dim;
with Sem_Disp; use Sem_Disp;
with Sem_Dist; use Sem_Dist;
with Sem_Eval; use Sem_Eval;
@@ -1215,6 +1216,7 @@
end if;
Set_Renamed_Object (Id, Nam);
+ Analyze_Dimension (N);
end Analyze_Object_Renaming;
------------------------------
===================================================================
@@ -504,6 +504,8 @@
s-crc32$(objext) \
s-crtl$(objext) \
s-crtrun$(objext) \
+ s-diflio$(objext) \
+ s-diinio$(objext) \
s-direio$(objext) \
s-dsaser$(objext) \
s-excdeb$(objext) \
@@ -554,6 +556,7 @@
s-imgwch$(objext) \
s-imgwiu$(objext) \
s-io$(objext) \
+ s-llflex$(objext) \
s-maccod$(objext) \
s-mantis$(objext) \
s-mastop$(objext) \
===================================================================
@@ -46,6 +46,7 @@
with Sem_Ch3; use Sem_Ch3;
with Sem_Ch6; use Sem_Ch6;
with Sem_Ch8; use Sem_Ch8;
+with Sem_Dim; use Sem_Dim;
with Sem_Eval; use Sem_Eval;
with Sem_Res; use Sem_Res;
with Sem_Type; use Sem_Type;
@@ -1476,6 +1477,15 @@
goto Continue;
end;
+
+ when Aspect_Dimension =>
+ Analyze_Aspect_Dimension (N, Id, Expr);
+ goto Continue;
+
+ when Aspect_Dimension_System =>
+ Analyze_Aspect_Dimension_System (N, Id, Expr);
+ goto Continue;
+
end case;
-- If a delay is required, we delay the freeze (not much point in
@@ -6046,6 +6056,11 @@
Aspect_Static_Predicate |
Aspect_Type_Invariant =>
T := Standard_Boolean;
+
+ when Aspect_Dimension |
+ Aspect_Dimension_System =>
+ raise Program_Error;
+
end case;
-- Do the preanalyze call
@@ -8777,8 +8792,8 @@
Source : constant Entity_Id := T.Source;
Target : constant Entity_Id := T.Target;
- Source_Siz : Uint;
- Target_Siz : Uint;
+ Source_Siz : Uint;
+ Target_Siz : Uint;
begin
-- This validation check, which warns if we have unequal sizes for
===================================================================
@@ -139,6 +139,8 @@
Name_Default_Value : constant Name_Id := N + $;
Name_Default_Component_Value : constant Name_Id := N + $;
+ Name_Dimension : constant Name_Id := N + $;
+ Name_Dimension_System : constant Name_Id := N + $;
Name_Dynamic_Predicate : constant Name_Id := N + $;
Name_Post : constant Name_Id := N + $;
Name_Pre : constant Name_Id := N + $;
@@ -219,6 +221,14 @@
subtype Text_IO_Package_Name is Name_Id
range First_Text_IO_Package .. Last_Text_IO_Package;
+ -- Names used by the analyzer and expander for aspect Dimension and
+ -- Dimension_System to deal with Sqrt and IO routines.
+
+ Name_Dim_Float_IO : constant Name_Id := N + $; -- Ada 12
+ Name_Dim_Integer_IO : constant Name_Id := N + $; -- Ada 12
+ Name_Generic_Elementary_Functions : constant Name_Id := N + $; -- Ada 12
+ Name_Sqrt : constant Name_Id := N + $; -- Ada 12
+
-- Some miscellaneous names used for error detection/recovery
Name_Const : constant Name_Id := N + $;
@@ -447,7 +457,6 @@
Name_CPP_Vtable : constant Name_Id := N + $; -- GNAT
Name_CPU : constant Name_Id := N + $; -- Ada 12
Name_Debug : constant Name_Id := N + $; -- GNAT
- Name_Dimension : constant Name_Id := N + $; -- GNAT
Name_Elaborate : constant Name_Id := N + $; -- Ada 83
Name_Elaborate_All : constant Name_Id := N + $;
Name_Elaborate_Body : constant Name_Id := N + $;
@@ -1610,7 +1619,6 @@
Pragma_CPP_Vtable,
Pragma_CPU,
Pragma_Debug,
- Pragma_Dimension,
Pragma_Elaborate,
Pragma_Elaborate_All,
Pragma_Elaborate_Body,
===================================================================
@@ -0,0 +1,42 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . L O N G _ L O N G _ F L O A T _ E X P O N --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
+-- --
+-- GNARL is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- 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. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package contains an instantiation of the functions "**" and Sqrt
+-- between two long long floats.
+
+with Ada.Numerics.Long_Long_Elementary_Functions;
+
+package System.Long_Long_Float_Expon is
+
+ function Expon_LLF (Left, Right : Long_Long_Float) return Long_Long_Float
+ renames Ada.Numerics.Long_Long_Elementary_Functions."**";
+
+end System.Long_Long_Float_Expon;
===================================================================
@@ -304,6 +304,7 @@
ada/s-htable.o \
ada/s-imenne.o \
ada/s-imgenu.o \
+ ada/s-llflex.o \
ada/s-mastop.o \
ada/s-memory.o \
ada/s-os_lib.o \
@@ -353,6 +354,7 @@
ada/sem_ch7.o \
ada/sem_ch8.o \
ada/sem_ch9.o \
+ ada/sem_dim.o \
ada/sem_disp.o \
ada/sem_dist.o \
ada/sem_elab.o \
@@ -4307,6 +4309,9 @@
ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/validsw.ads \
ada/warnsw.ads ada/widechar.ads
+ada/sem_dim.o : ada/sem_util.ads ada/sem_util.adb ada/nmake.ads \
+ ada/nmake.adb
+
ada/sem_disp.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \
ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \
ada/atree.adb ada/casing.ads ada/checks.ads ada/csets.ads ada/debug.ads \
The system is implemented in the GNAT compiler, and performs compile-time checks to verify the dimensional consistency of physical computations. The system allows the user to define his own system of units, and imposes no run-time changes nor multiple compilation passes on the user. Indeed, the user is now able to create his own dimension system, to assign a dimension with any subtypes and to run operations with dimensionned objects. In that case, a dimensionnality checking will be performed. If no dimension has been assigned, the compiler assumes that the item is dimensionless. The following gives an overall example of the dimensionality checking system: -- with System.Dim_Float_IO; procedure Dimension_Test is -- CGS dimensioned type type CGS_Type is new Long_Float with Dimension_System => ((Centimeter, "cm"), (Gram, 'g'), (Second, 's')); -- IO package for CGS_Type package CGS_IO is new System.Dim_Float_IO (CGS_Type); use CGS_IO; -- CGS dimensioned subtypes subtype Length is CGS_Type with Dimension => ("cm", Centimeter => 1, others => 0); subtype Mass is CGS_Type with Dimension => ("g", Gram => 1, others => 0); subtype Time is CGS_Type with Dimension => ('s', Second => 1, others => 0); -- CGS units cm : constant Length := 1.0; g : constant Mass := 1.0; s : constant Time := 1.0; -- Force dimensioned subtype subtype Force is CGS_Type with Dimension => ("dyn", 1, 1, -2); Random_Force : Force; begin Random_Force := 2.1E+02 * cm * g * s**(-2); Put (Random_Force); end Dimension_Test; Tested on x86_64-pc-linux-gnu, committed on trunk 2011-12-15 Vincent Pucci <pucci@adacore.com> * aspects.adb, aspects.ads Aspect_Dimension and Aspect_Dimension_System added * exp_ch6.adb (Expand_Call): Expand_Put_Call_With_Dimension_String case added * gcc-interface/Make-lang.in: s-llflex, sem_dim added. * impunit.adb :s-diflio and s-diinio defined as GNAT Defined Additions to System. * Makefile.rtl: s-diflio, s-diinio and s-llflex added * par-prag.adb, sem_prag.adb: Pragma_Dimension removed * rtsfind.ads: Expon_LLF added * sem_aggr.adb (Resolve_Aggregate): handles aggregate for Aspect_Dimension case * sem_attr.adb (Resolve_Attribute): analyze dimension for attribute * sem_ch10.adb (Analyze_With_Clause): Avoid the warning messages due to the use of a GNAT library for Dimension packages * sem_ch13.adb (Analyze_Aspect_Specifications): Aspect_Dimension and Aspect_Dimension_System cases added (Check_Aspect_At_Freeze_Point): Aspect_Dimension and Aspect_Dimension_System cases added * sem_ch2.adb (Analyze_Identifier): analyze dimension for identifier * sem_ch3.adb (Analyze_Component_Declaration): analyze dimension for component declaration (Analyze_Object_Declaration): analyze dimension for object declaration (Analyze_Subtype_Declaration): analyze dimension for subtype declaration * sem_ch4.adb (Operator_Check): checks exponent is a rational for dimensioned operand for a N_Op_Expon * sem_ch5.adb (Analyze_Assignment): analyze dimension for assignment (Analyze_Statements): removal of dimensions in all statements * sem_ch6.adb (Analyze_Return_Statement): analyze dimension for return statement * sem_ch8.adb (Analyze_Object_Renaming): analyze dimension for object renaming * sem_dim.adb, sem_dim.ads (Analyze_Aspect_Dimension): analyze the expression for aspect dimension and store the values in a Htable. (Analyze_Aspect_Dimension_System): analyze the expression for aspect dimension system and store the new system in a Table. (Analyze_Dimension): propagates dimension (Expand_Put_Call_With_Dimension_String): add the dimension string as a suffix of the numeric value in the output (Has_Dimension): return True if the node has a dimension (Remove_Dimension_In_Declaration): removal of dimension in the expression of the declaration. (Remove_Dimension_In_Statement): removal of dimension in statement * sem_res.adb (Resolve): analyze dimension if the node has already been analyzed. (Resolve_Arithmetic_Op): analyze dimension for arithmetic op. (Resolve_Call): analyze dimension for function call. (Resolve_Comparison_Op): analyze dimension for comparison op. (Resolve_Equality_Op): analyze dimension for equality op. (Resolve_Indexed_Component): analyze dimension for indexed component. (Resolve_Op_Expon): analyze dimension for op expon. (Resolve_Selected_Component): analyze dimension for selected component. (Resolve_Slice): analyze dimension for slice. (Resolve_Unary_Op): analyze dimension for unary op (Resolve_Type_Conversion): analyze dimension for type conversion (Resolve_Unchecked_Type_Conversion): analyze dimension for unchecked type conversion * snames.ads-tmpl Name_Dimension, Name_Dimension_System, Name_Dim_Float_IO, Name_Dim_Integer_IO, Name_Generic_Elementary_Functions, Name_Sqrt added. Pragma_Dimension removed * s-diflio.adb, s-diflio.ads New GNAT library generic package for dimensioned float type IO * s-diinio.adb, s-diinio.ads New GNAT library generic package for dimensioned integer type IO * s-llflex.ads (Expon_LLF): exponentiation routine for long long floats operand and exponent