+2011-12-20 Robert Dewar <dewar@adacore.com>
+
+ * sem_ch3.adb, sem_ch5.adb, s-diinio.adb, s-diinio.ads, sem_dim.adb,
+ sem_dim.ads, sem_res.adb, s-stposu.adb, s-stposu.ads, sem_ch4.adb,
+ s-diflio.adb, s-diflio.ads, exp_disp.adb, s-llflex.ads: Minor
+ reformatting.
+ * aspects.ads: Dimension[_Aspects] are GNAT defined.
+
+2011-12-20 Robert Dewar <dewar@adacore.com>
+
+ * sem_ch13.adb (Analyze_Attribute_Definition_Clause): Check
+ renaming case.
+
+2011-12-20 Thomas Quinot <quinot@adacore.com>
+
+ * sem_cat.adb, sem_ch10.adb (Analyze_With_Clause): For a WITH clause on
+ a child unit that is an illegal instantiation, mark the WITH clause in
+ error.
+ (Install_Siblings, Validate_Categorization_Dependency): Guard
+ against WITH clause marked as in error.
+
2011-12-20 Hristian Kirtchev <kirtchev@adacore.com>
* sem_res.adb (Resolve_Allocator): Warning on allocation
Aspect_Default_Component_Value,
Aspect_Default_Iterator,
Aspect_Default_Value,
- Aspect_Dimension,
- Aspect_Dimension_System,
+ Aspect_Dimension, -- GNAT
+ Aspect_Dimension_System, -- GNAT
Aspect_Dispatching_Domain,
Aspect_Dynamic_Predicate,
Aspect_External_Tag,
-- The following array identifies all implementation defined aspects
Impl_Defined_Aspects : constant array (Aspect_Id) of Boolean :=
- (Aspect_Object_Size => True,
- Aspect_Predicate => True,
- Aspect_Test_Case => True,
- Aspect_Value_Size => True,
- Aspect_Compiler_Unit => True,
- Aspect_Preelaborate_05 => True,
- Aspect_Pure_05 => True,
- Aspect_Pure_12 => True,
- Aspect_Universal_Data => True,
- Aspect_Ada_2005 => True,
+ (Aspect_Ada_2005 => True,
Aspect_Ada_2012 => True,
+ Aspect_Compiler_Unit => True,
+ Aspect_Dimension => True,
+ Aspect_Dimension_System => True,
Aspect_Favor_Top_Level => True,
Aspect_Inline_Always => True,
+ Aspect_Object_Size => True,
Aspect_Persistent_BSS => True,
+ Aspect_Predicate => True,
+ Aspect_Preelaborate_05 => True,
+ Aspect_Pure_05 => True,
+ Aspect_Pure_12 => True,
Aspect_Pure_Function => True,
Aspect_Shared => True,
Aspect_Suppress_Debug_Info => True,
+ Aspect_Test_Case => True,
+ Aspect_Universal_Data => True,
Aspect_Universal_Aliasing => True,
Aspect_Unmodified => True,
Aspect_Unreferenced => True,
Aspect_Unreferenced_Objects => True,
+ Aspect_Value_Size => True,
others => False);
-- The following array indicates aspects for which multiple occurrences of
-- Alignment
-- For CPP types we cannot rely on the value of 'Alignment provided
- -- by the backend to initialize this TSD field.
+ -- by the backend to initialize this TSD field. Why not???
if Convention (Typ) = Convention_CPP
or else Is_CPP_Class (Root_Type (Typ))
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
+-- Copyright (C) 2011, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
(File : File_Type;
Item : Num_Dim_Float;
Unit : String := "";
- Fore : Field := Default_Fore;
- Aft : Field := Default_Aft;
- Exp : Field := Default_Exp)
+ Fore : Field := Default_Fore;
+ Aft : Field := Default_Aft;
+ Exp : Field := Default_Exp)
is
begin
Num_Dim_Float_IO.Put (File, Item, Fore, Aft, Exp);
procedure Put
(Item : Num_Dim_Float;
Unit : String := "";
- Fore : Field := Default_Fore;
- Aft : Field := Default_Aft;
- Exp : Field := Default_Exp)
+ Fore : Field := Default_Fore;
+ Aft : Field := Default_Aft;
+ Exp : Field := Default_Exp)
is
begin
Num_Dim_Float_IO.Put (Item, Fore, Aft, Exp);
(To : out String;
Item : Num_Dim_Float;
Unit : String := "";
- Aft : Field := Default_Aft;
- Exp : Field := Default_Exp)
+ Aft : Field := Default_Aft;
+ Exp : Field := Default_Exp)
is
begin
Num_Dim_Float_IO.Put (To, Item, Aft, Exp);
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
+-- Copyright (C) 2011, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
------------------------------------------------------------------------------
-- Note that this package should only be instantiated with a float dimensioned
--- type.
+-- type. Shouldn't this be checked???
-- This package is a generic package that provides IO facilities for float
-- dimensioned types.
(File : File_Type;
Item : Num_Dim_Float;
Unit : String := "";
- Fore : Field := Default_Fore;
- Aft : Field := Default_Aft;
- Exp : Field := Default_Exp);
+ 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);
+ 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);
+ Aft : Field := Default_Aft;
+ Exp : Field := Default_Exp);
pragma Inline (Put);
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
+-- Copyright (C) 2011, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
---------
procedure Put
- (File : File_Type;
- Item : Num_Dim_Integer;
- Unit : String := "";
- Width : Field := Default_Width;
+ (File : File_Type;
+ Item : Num_Dim_Integer;
+ Unit : String := "";
+ Width : Field := Default_Width;
Base : Number_Base := Default_Base)
is
end Put;
procedure Put
- (Item : Num_Dim_Integer;
- Unit : String := "";
- Width : Field := Default_Width;
+ (Item : Num_Dim_Integer;
+ Unit : String := "";
+ Width : Field := Default_Width;
Base : Number_Base := Default_Base)
is
end Put;
procedure Put
- (To : out String;
- Item : Num_Dim_Integer;
- Unit : String := "";
+ (To : out String;
+ Item : Num_Dim_Integer;
+ Unit : String := "";
Base : Number_Base := Default_Base)
is
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
+-- Copyright (C) 2011, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
------------------------------------------------------------------------------
-- Note that this package should only be instantiated with an integer
--- dimensioned type
+-- dimensioned type. Shouldn't this be checked ???
-- This package is a generic package that provides IO facilities for integer
-- dimensioned types.
package System.Dim_Integer_IO is
- Default_Width : Field := Num_Dim_Integer'Width;
+ 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;
+ (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;
+ (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 := "";
+ (To : out String;
+ Item : Num_Dim_Integer;
+ Unit : String := "";
Base : Number_Base := Default_Base);
pragma Inline (Put);
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
+-- Copyright (C) 2011, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
is
begin
raise Program_Error;
-
return Pool.Subpools.Subpool;
end Default_Subpool_For_Pool;
begin
-- Do nothing if the subpool was never used
- if Subpool.Owner = null
- or else Subpool.Node = null
- then
+ if Subpool.Owner = null or else Subpool.Node = null then
return;
end if;
-- Pool_Of_Subpool --
---------------------
- function Pool_Of_Subpool (Subpool : not null Subpool_Handle)
- return access Root_Storage_Pool_With_Subpools'Class
+ function Pool_Of_Subpool
+ (Subpool : not null Subpool_Handle)
+ return access Root_Storage_Pool_With_Subpools'Class
is
begin
return Subpool.Owner;
with System.Storage_Elements;
package System.Storage_Pools.Subpools is
- pragma Preelaborate (Subpools);
+ pragma Preelaborate;
type Root_Storage_Pool_With_Subpools is abstract
new Root_Storage_Pool with private;
-- ??? This precondition causes errors in simple tests, disabled for now
--- with Pre'Class => Pool_Of_Subpool (Subpool) = Pool'Access;
+ -- with Pre'Class => Pool_Of_Subpool (Subpool) = Pool'Access;
-- This routine requires implementation. Allocate an object described by
-- Size_In_Storage_Elements and Alignment on a subpool.
- function Create_Subpool (Pool : in out Root_Storage_Pool_With_Subpools)
- return not null Subpool_Handle is abstract;
+ function Create_Subpool
+ (Pool : in out Root_Storage_Pool_With_Subpools)
+ return not null Subpool_Handle is abstract;
-- This routine requires implementation. Create a subpool within the given
-- pool_with_subpools.
Storage_Address : System.Address;
Size_In_Storage_Elements : System.Storage_Elements.Storage_Count;
Alignment : System.Storage_Elements.Storage_Count)
- is null;
+ is null;
procedure Deallocate_Subpool
(Pool : in out Root_Storage_Pool_With_Subpools;
- Subpool : in out Subpool_Handle) is abstract;
+ Subpool : in out Subpool_Handle)
+ is abstract;
-- ??? This precondition causes errors in simple tests, disabled for now
--- with Pre'Class => Pool_Of_Subpool (Subpool) = Pool'Access;
+ -- with Pre'Class => Pool_Of_Subpool (Subpool) = Pool'Access;
-- This routine requires implementation. Reclaim the storage a particular
-- subpool occupies in a pool_with_subpools. This routine is called by
-- Ada.Unchecked_Deallocate_Subpool.
-- Subpool_Handle_name in the allocator. The default implementation of this
-- routine raises Program_Error.
- function Pool_Of_Subpool (Subpool : not null Subpool_Handle)
- return access Root_Storage_Pool_With_Subpools'Class;
+ function Pool_Of_Subpool
+ (Subpool : not null Subpool_Handle)
+ return access Root_Storage_Pool_With_Subpools'Class;
-- Return the owner of the subpool
procedure Set_Pool_Of_Subpool
-- Create_Subpool or similar subpool constructors. Raises Program_Error
-- if the subpool already belongs to a pool.
- overriding function Storage_Size (Pool : Root_Storage_Pool_With_Subpools)
- return System.Storage_Elements.Storage_Count is
- (System.Storage_Elements.Storage_Count'Last);
+ overriding function Storage_Size
+ (Pool : Root_Storage_Pool_With_Subpools)
+ return System.Storage_Elements.Storage_Count
+ is
+ (System.Storage_Elements.Storage_Count'Last);
private
-- Model
while Present (Item) loop
if Nkind (Item) = N_With_Clause
and then not (Implicit_With (Item)
- or else Limited_Present (Item))
+ or else Limited_Present (Item)
+
+ -- Skip if error already posted on the WITH
+ -- clause (in which case the Name attribute
+ -- may be invalid).
+
+ or else Error_Posted (Item))
then
Entity_Of_Withed := Entity (Name (Item));
Check_Categorization_Dependencies
Generate_Reference (Par_Name, Pref);
else
- Set_Name (N, Make_Null (Sloc (N)));
+ pragma Assert (Serious_Errors_Detected /= 0);
+
+ -- Mark the node to indicate that a related error has been posted.
+ -- This defends further compilation passes against cascaded errors
+ -- caused by the invalid WITH clause node.
+
+ Set_Error_Posted (N);
+ Set_Name (N, Error);
return;
end if;
end if;
if Nkind (Item) /= N_With_Clause
or else Implicit_With (Item)
or else Limited_Present (Item)
+ or else Error_Posted (Item)
then
null;
U_Ent := Underlying_Type (Ent);
end if;
- -- Complete other routine error checks
+ -- Avoid cascaded error
if Etype (Nam) = Any_Type then
return;
+ -- Must be declared in current scope
+
elsif Scope (Ent) /= Current_Scope then
Error_Msg_N ("entity must be declared in this scope", Nam);
return;
+ -- Must not be a source renaming (we do have some cases where the
+ -- expander generates a renaming, and those cases are OK, in such
+ -- cases any attribute applies to the renamed object as well.
+
+ elsif Is_Object (Ent)
+ and then Present (Renamed_Object (Ent))
+ and then Comes_From_Source (Renamed_Object (Ent))
+ then
+ Get_Name_String (Chars (N));
+ Error_Msg_Strlen := Name_Len;
+ Error_Msg_String (1 .. Name_Len) := Name_Buffer (1 .. Name_Len);
+ Error_Msg_N
+ ("~ clause not allowed for a renaming declaration (RM 13.1(6))",
+ Nam);
+ return;
+
+ -- If no underlying entity, use entity itself, applies to some
+ -- previously detected error cases ???
+
elsif No (U_Ent) then
U_Ent := Ent;
+ -- Cannot specify for a subtype (exception Object/Value_Size)
+
elsif Is_Type (U_Ent)
and then not Is_First_Subtype (U_Ent)
and then Id /= Attribute_Object_Size
then
Error_Msg_N ("constant overlays a variable?", Expr);
- elsif Present (Renamed_Object (U_Ent)) then
- Error_Msg_N
- ("address clause not allowed"
- & " for a renaming declaration (RM 13.1(6))", Nam);
- return;
-
-- Imported variables can have an address clause, but then
-- the import is pretty meaningless except to suppress
-- initializations, so we do not need such variables to
elsif Align /= No_Uint then
Set_Has_Alignment_Clause (U_Ent);
+ -- Tagged type case, check for attempt to set alignment to a
+ -- value greater than Max_Align, and reset if so.
+
if Is_Tagged_Type (U_Ent) and then Align > Max_Align then
Error_Msg_N
("?alignment for & set to Maximum_Aligment", Nam);
- Set_Alignment (U_Ent, Max_Align);
+ Set_Alignment (U_Ent, Max_Align);
+
+ -- All other cases
+
else
Set_Alignment (U_Ent, Align);
end if;
Aspect_Type_Invariant =>
T := Standard_Boolean;
- when Aspect_Dimension |
+ when Aspect_Dimension |
Aspect_Dimension_System =>
raise Program_Error;
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
if Has_Aspects (N) then
Analyze_Aspect_Specifications (N, Id);
end if;
+
Analyze_Dimension (N);
end Analyze_Component_Declaration;
if Has_Aspects (N) then
Analyze_Aspect_Specifications (N, Id);
end if;
+
Analyze_Dimension (N);
end Analyze_Object_Declaration;
if Has_Aspects (N) then
Analyze_Aspect_Specifications (N, Id);
end if;
+
Analyze_Dimension (N);
end Analyze_Subtype_Declaration;
and then Is_Dimensioned_Type (Etype (L))
then
Error_Msg_NE
- ("exponent for dimensioned type must be a Rational" &
+ ("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;
declare
Ent : constant Entity_Id := Get_Enclosing_Object (Lhs);
-
begin
if Present (Ent)
and then Safe_To_Capture_Value (N, Ent)
Set_Last_Assignment (Ent, Lhs);
end if;
end;
+
Analyze_Dimension (N);
end Analyze_Assignment;
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
+-- Copyright (C) 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- --
package body Sem_Dim is
- -- Maximum number of dimensions in a dimension system
-
Max_Dimensions : constant Int := 7;
+ -- Maximum number of dimensions in a dimension system
+ subtype Dim_Id is Pos range 1 .. Max_Dimensions;
-- Dim_Id values are used to identify dimensions in a dimension system
-- Note that the highest value of Dim_Id is Max_Dimensions
- 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.
---------
function GCD (Left, Right : Whole) return Int is
- L : Whole := Left;
- R : Whole := Right;
+ L : Whole;
+ R : Whole;
begin
+ L := Left;
+ R := Right;
while R /= 0 loop
L := L mod R;
Rational'(Numerator => Left.Numerator * Right.Denominator +
Left.Denominator * Right.Numerator,
Denominator => Left.Denominator * Right.Denominator);
-
begin
return Reduce (R);
end "+";
-- 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
function AD_Hash (F : Node_Id) return AD_Hash_Range;
+ -------------
+ -- AD_Hash --
+ -------------
+
function AD_Hash (F : Node_Id) return AD_Hash_Range is
begin
return AD_Hash_Range (F mod 512);
Id : Node_Id;
Expr : Node_Id)
is
- Def_Id : constant Entity_Id := Defining_Identifier (N);
- N_Kind : constant Node_Kind := Nkind (N);
+ 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
is
B_Typ : Node_Id;
Sub_Ind : Node_Id;
+
begin
-- Aspect_Dimension can only apply for subtypes
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;
Typ : Entity_Id;
begin
-
-- Check the type is dimensionless before assigning a dimension
if Nkind (N) = N_Subtype_Declaration then
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.
+ -- For a positional aggregate with an Others_Choice, the number
+ -- of expressions must be less than or equal to N_Of_Dims - 1.
if Present (Comp_Expr) then
N_Dims_Aggr := List_Length (Expressions (Expr)) - 1;
if Dim_Name = Na_Id then
Dim := D;
end if;
-
end loop;
return Dim;
Comp_Expr : Node_Id;
begin
- Comp_Expr := First (Expressions (Expr));
- Next (Comp_Expr);
+ Comp_Expr := Next (First (Expressions (Expr)));
while Present (Comp_Expr) loop
-- First, analyze the expression
Analyze_And_Resolve (Comp_Expr);
+
if not Compile_Time_Known_Value (Comp_Expr) then
return False;
end if;
end loop;
Comp_Assn := First (Component_Associations (Expr));
-
while Present (Comp_Assn) loop
Comp_Expr := Expression (Comp_Assn);
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;
- -- 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.
+ -- 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
-- Analyze_Aspect_Dimension_System --
-------------------------------------
- -- with Dimension_System => DIMENSION_PAIRS
+ -- with Dimension_System => DIMENSION_PAIRS
+
-- DIMENSION_PAIRS ::=
-- (DIMENSION_PAIR
-- [, DIMENSION_PAIR]
Dim_Node : Node_Id;
Dim_Symbol : Node_Id;
D_Sys : Dimension_System := No_Dimension_System;
- Names : Name_Array := No_Names;
+ Names : Name_Array := No_Names;
N_Of_Dims : N_Of_Dimensions;
- Symbols : Symbol_Array := No_Symbols;
+ 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
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));
+ else
-- Check that each component of the aggregate is an aggregate
+ Dim_Node := First (Expressions (N));
while Present (Dim_Node) loop
-- Verify that the aggregate is a pair of identifier and string
begin
if List_Length (List_Expr) < Dim_Id'First
- or else List_Length (List_Expr) > Max_Dimensions then
+ or else List_Length (List_Expr) > Max_Dimensions
+ then
return False;
else
return True;
end if;
if not Derived_From_Numeric_Type (N) then
- Error_Msg_N ("aspect% only apply for type derived from numeric type",
- Id);
+ Error_Msg_N
+ ("aspect% only apply for type derived from numeric type", Id);
return;
end if;
-- 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
+ else
if Dim_Lhs /= Dim_Rhs then
Error_Msg_N ("?dimensions missmatch in assignment", N);
end if;
-
end if;
end Analyze_Dimensions_In_Assignment;
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);
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
Dims := L_Dims;
elsif not L_Has_Dimensions and R_Has_Dimensions then
-
if N_Kind = N_Op_Multiply then
Dims := R_Dims;
else
end;
-- For relational operations, only a dimension checking is
- -- performed.
- -- No propagation
+ -- performed (no propagation).
elsif N_Kind in N_Op_Compare then
Error_Msg_Name_1 := Chars (N);
---------------------------------------------
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);
+ Expr : constant Node_Id := Expression (N);
+ Id : constant Entity_Id := Defining_Identifier (N);
+ E_Typ : constant Entity_Id := Etype (Id);
Dim_T : constant Dimensions := Get_Dimensions (E_Typ);
Dim_E : Dimensions;
Dim_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.
"declaration", N);
end if;
- -- If the expression is dimensionless
+ -- Case of dimensionless expression
else
Error_Msg_N
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);
else
Param := First (Par_Ass);
-
while Present (Param) loop
Dims_Param := Get_Dimensions (Param);
begin
if Present (Exprs) then
Expr := First (Exprs);
-
while Present (Expr) loop
Remove_Dimensions (Expr);
Next (Expr);
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);
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.
-- (depending on the dimensioned numeric type), return an error
-- message.
- if not Nkind_In
- (Original_Node (Expr),
- N_Real_Literal,
- N_Integer_Literal)
+ if not Nkind_In (Original_Node (Expr),
+ N_Real_Literal,
+ N_Integer_Literal)
then
- Error_Msg_N ("?dimensions missmatch in object " &
- "declaration", N);
+ Error_Msg_N
+ ("?dimensions missmatch in object declaration", N);
end if;
end if;
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);
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);
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 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);
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 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);
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.
+ -- A rational number is a number that can be expressed as the quotient
+ -- or fraction a/b of two integers, where b is non-zero.
-- Check the expression is either a division of two integers or an
-- integer itself. The check applies to the original node since the
Right := Right_Opnd (Or_N);
Rtype := Etype (Right);
- if Is_Integer_Type (Ltype)
- and then Is_Integer_Type (Rtype)
- then
+ 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
-- 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
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;
-- 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.
+ -- Note that if the exponent is an integer (denominator = 1) the node is
+ -- not evaluated here and must be evaluated by the Eval_Op_Expon routine.
procedure Eval_Op_Expon_For_Dimensioned_Type
(N : Node_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
+ 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;
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
+ -- nothing has to be changed. Note that the node must come from source.
if Comes_From_Source (N)
and then Rat.Denominator /= 1
-- 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);
for Dim in Dims'First .. Dim_Systems.Table (Sys).N_Of_Dims loop
Dim_Value := Dims (Dim);
+
if Dim_Value.Denominator /= 1 then
- Append (
+ Append_To (List_Of_Dims,
Make_Op_Divide (Loc,
Left_Opnd =>
Make_Integer_Literal (Loc,
Int (Dim_Value.Numerator)),
Right_Opnd =>
Make_Integer_Literal (Loc,
- Int (Dim_Value.Denominator))),
- List_Of_Dims);
+ Int (Dim_Value.Denominator))));
+
else
- Append (
- Make_Integer_Literal (Loc,
- Int (Dim_Value.Numerator)),
- List_Of_Dims);
+ Append_To (List_Of_Dims,
+ Make_Integer_Literal (Loc, Int (Dim_Value.Numerator)));
end if;
end loop;
New_Aspect :=
Make_Aspect_Specification (Loc,
- Identifier =>
- Make_Identifier (Loc, Name_Dimension),
+ Identifier => Make_Identifier (Loc, Name_Dimension),
Expression =>
- Make_Aggregate (Loc,
- Expressions => List_Of_Dims));
+ Make_Aggregate (Loc, Expressions => List_Of_Dims));
-- Step 1c: New identifier for the subtype
New_Typ_L :=
Make_Subtype_Declaration (Loc,
Defining_Identifier => New_E,
- Subtype_Indication =>
- New_Occurrence_Of (Base_Typ, Loc));
+ Subtype_Indication => New_Occurrence_Of (Base_Typ, Loc));
Append (New_Aspect, New_Aspects);
Set_Parent (New_Aspects, New_Typ_L);
-- 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.
+ -- For procedure Put defined in System.Dim_Float_IO/System.Dim_Integer_IO,
+ -- the default string parameter must be rewritten to include the dimension
+ -- symbols in the output of a dimensioned object.
-- There are two different cases:
-- Put (v) returns:
-- > 2.1 speed
- -- 2) If the parameter is an expression, the procedure
+ -- 2) If the parameter is an expression, then we call the procedure
-- Expand_Put_Call_With_Dimension_String creates the string (for instance
- -- "m.s**(-1)") and rewrites the default string parameter of Put with the
+ -- "m.s**(-1)") and rewrite the default string parameter of Put with the
-- corresponding the String_Id.
procedure Expand_Put_Call_With_Dimension_String (N : Node_Id) is
Store_String_Char (' ');
for Dim in Dimensions'Range loop
-
Dim_Rat := Dims (Dim);
if Dim_Rat /= Zero_Rational then
-- 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)));
-- Integer case
if Dim_Rat.Denominator = 1 then
-
if Dim_Rat.Numerator /= 1 then
Store_String_Chars ("**");
Store_String_Int (Int (Dim_Rat.Numerator));
begin
-- Scan the Table in order to find N
+ -- What is N??? no sign of anything called N here ???
for Dim_Sys in 1 .. Dim_Systems.Last loop
if Parent (E) = Dim_Systems.Table (Dim_Sys).Base_Type then
-- Is_Dimensioned_Type --
--------------------------
- function Is_Dimensioned_Type (E : Entity_Id) return Boolean
- is
+ function Is_Dimensioned_Type (E : Entity_Id) return Boolean is
begin
if Get_Dimension_System_Id (E) /= No_Dim_Sys then
return True;
+ else
+ return False;
end if;
-
- return False;
end Is_Dimensioned_Type;
---------------------
Dims : constant Dimensions := Get_Dimensions (From);
begin
- -- Copy the dimension of 'From to 'To' and remove the dimension of
- -- 'From'.
+ -- Copy the dimension of 'From to 'To' and remove dimension of 'From'
if Present (Dims) then
Set_Dimensions (To, Dims);
procedure Remove_Dimensions (N : Node_Id) is
Dims : constant Dimensions := Get_Dimensions (N);
-
begin
if Present (Dims) then
Aspect_Dimension_Hash_Table.Remove (N);
if Present (Par_Ass) then
Actual := First (Par_Ass);
-
while Present (Actual) loop
Remove_Dimensions (Actual);
Next (Actual);
if S_Kind = N_Accept_Statement then
declare
Param : Node_Id := First (Parameter_Specifications (S));
-
begin
while Present (Param) loop
Remove_Dimensions (Param);
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
+-- Copyright (C) 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- --
-- 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
+-- Indeed, the user is now able to create their own dimension system and to
-- assign a dimension, defined from the MKS system (package System.Dim_Mks)
--- or his own dimension systems, with any item and to run operations with
+-- or their 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.
+
+-- In that case, a dimensionality checking will be performed at compile time.
-- If no dimension has been assigned, the compiler assumes that the item is
-- dimensionless.
-- Aspect_Dimension_System --
-----------------------------
--- In order to enable the user to create his own dimension system, a new
+-- In order to enable the user to create their 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.
+-- 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.
-- 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.
+-- This section contains the routine used for IO purposes
with Types; use Types;
----------------------
procedure Analyze_Aspect_Dimension
- (N : Node_Id;
- Id : Node_Id;
+ (N : Node_Id;
+ Id : Node_Id;
Expr : Node_Id);
-- Analyzes the aggregate of Aspect_Dimension and attaches the
-- corresponding dimension to N.
-- when needed.
procedure Eval_Op_Expon_For_Dimensioned_Type
- (N : Node_Id;
+ (N : Node_Id;
B_Typ : Entity_Id);
- -- Eval the Expon operator for dimensioned type with rational exponent
+ -- Evaluate 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
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.
+ -- parameter in the call N.
procedure Remove_Dimension_In_Declaration (D : Node_Id);
-- At the end of Analyze_Declarations routine (see Sem_Ch3), removes the
end;
end if;
- -- dimension analysis
-
Analyze_Dimension (N);
-- All done, evaluate call and deal with elaboration issues
Analyze_Dimension (N);
- -- Evaluate the Expon operator for dimensioned type with rational
- -- exponent.
+ -- Evaluate the exponentiation operator for dimensioned type with
+ -- rational exponent.
- if Ada_Version >= Ada_2012
- and then Is_Dimensioned_Type (B_Typ)
- then
+ if Ada_Version >= Ada_2012 and then 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
and then Is_Packed (T)
and then Is_LHS (N)
then
- Error_Msg_N ("?assignment to component of packed atomic record",
- Prefix (N));
- Error_Msg_N ("?\may cause unexpected accesses to atomic object",
- Prefix (N));
+ Error_Msg_N
+ ("?assignment to component of packed atomic record", Prefix (N));
+ Error_Msg_N
+ ("?\may cause unexpected accesses to atomic object", Prefix (N));
end if;
+
Analyze_Dimension (N);
end Resolve_Selected_Component;
OSDN Git Service
