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 Sinput; use Sinput;
with Snames; use Snames;
with Stand; use Stand;
with Stringt; use Stringt;
No_Symbols : constant Symbol_Array := (others => No_String);
+ -- The following record should be documented field by field
+
type System_Type is record
- Type_Decl : Node_Id;
- Names : Name_Array;
- Symbols : Symbol_Array;
- Count : Dimension_Position;
+ Type_Decl : Node_Id;
+ Unit_Names : Name_Array;
+ Unit_Symbols : Symbol_Array;
+ Dim_Symbols : Symbol_Array;
+ Count : Dimension_Position;
end record;
Null_System : constant System_Type :=
- (Empty, No_Names, No_Symbols, Invalid_Position);
+ (Empty, No_Names, No_Symbols, No_Symbols, Invalid_Position);
subtype System_Id is Nat;
OK_For_Dimension : constant array (Node_Kind) of Boolean :=
(N_Attribute_Reference => True,
+ N_Expanded_Name => True,
N_Defining_Identifier => True,
N_Function_Call => True,
N_Identifier => True,
-- that the dimensions of the returned type and of the returned object
-- match.
- procedure Analyze_Dimension_Function_Call (N : Node_Id);
- -- Subroutine of Analyze_Dimension for function call. General case:
- -- propagate the dimensions from the returned type to N. Elementary
- -- function case (Ada.Numerics.Generic_Elementary_Functions): If N
- -- is a Sqrt call, then evaluate the resulting dimensions as half the
- -- dimensions of the parameter. Otherwise, verify that each parameters
- -- are dimensionless.
-
procedure Analyze_Dimension_Has_Etype (N : Node_Id);
-- Subroutine of Analyze_Dimension for a subset of N_Has_Etype denoted by
-- the list below:
function Dimensions_Of (N : Node_Id) return Dimension_Type;
-- Return the dimension vector of node N
- function Dimensions_Msg_Of (N : Node_Id) return String;
- -- Given a node, return "has dimension" followed by the dimension vector of
- -- N or "is dimensionless" if N is dimensionless.
+ function Dimensions_Msg_Of
+ (N : Node_Id;
+ Description_Needed : Boolean := False) return String;
+ -- Given a node N, return the dimension symbols of N, preceded by "has
+ -- dimension" if Description_Needed. if N is dimensionless, return "[]", or
+ -- "is dimensionless" if Description_Needed.
+
+ procedure Dim_Warning_For_Numeric_Literal (N : Node_Id; Typ : Entity_Id);
+ -- Issue a warning on the given numeric literal N to indicate the
+ -- compilateur made the assumption that the literal is not dimensionless
+ -- but has the dimension of Typ.
procedure Eval_Op_Expon_With_Rational_Exponent
(N : Node_Id;
function Exists (Dim : Dimension_Type) return Boolean;
-- Returns True iff Dim does not denote the null dimension
+ function Exists (Str : String_Id) return Boolean;
+ -- Returns True iff Str does not denote No_String
+
function Exists (Sys : System_Type) return Boolean;
-- Returns True iff Sys does not denote the null system
- function From_Dimension_To_String_Of_Symbols
+ function From_Dim_To_Str_Of_Dim_Symbols
+ (Dims : Dimension_Type;
+ System : System_Type;
+ In_Error_Msg : Boolean := False) return String_Id;
+ -- Given a dimension vector and a dimension system, return the proper
+ -- string of dimension symbols. If In_Error_Msg is True (i.e. the String_Id
+ -- will be used to issue an error message) then this routine has a special
+ -- handling for the insertion character asterisk * which must be precede by
+ -- a quote ' to to be placed literally into the message.
+
+ function From_Dim_To_Str_Of_Unit_Symbols
(Dims : Dimension_Type;
System : System_Type) return String_Id;
-- Given a dimension vector and a dimension system, return the proper
- -- string of symbols.
+ -- string of unit symbols.
function Is_Dim_IO_Package_Entity (E : Entity_Id) return Boolean;
-- Return True if E is the package entity of System.Dim.Float_IO or
-- Return True if Pos denotes the invalid position
procedure Move_Dimensions (From : Node_Id; To : Node_Id);
- -- Copy dimension vector of From to To, delete dimension vector of From
+ -- Copy dimension vector of From to To and delete dimension vector of From
procedure Remove_Dimensions (N : Node_Id);
-- Remove the dimension vector of node N
procedure Set_Symbol (E : Entity_Id; Val : String_Id);
-- Associate a symbol representation of a dimension vector with a subtype
+ function String_From_Numeric_Literal (N : Node_Id) return String_Id;
+ -- Return the string that corresponds to the numeric litteral N as it
+ -- appears in the source.
+
function Symbol_Of (E : Entity_Id) return String_Id;
-- E denotes a subtype with a dimension. Return the symbol representation
-- of the dimension vector.
return Reduce (Rational'(Numerator => L.Numerator * R.Denominator,
Denominator => L.Denominator * R.Numerator));
end "/";
+
-----------
-- "abs" --
-----------
-- Analyze_Aspect_Dimension --
------------------------------
- -- with Dimension => DIMENSION_FOR_SUBTYPE
- -- DIMENSION_FOR_SUBTYPE ::= (DIMENSION_STRING, DIMENSION_RATIONALS)
- -- DIMENSION_RATIONALS ::=
- -- RATIONAL, {, RATIONAL}
- -- | RATIONAL {, RATIONAL}, others => RATIONAL
+ -- with Dimension => (
+ -- [[Symbol =>] SYMBOL,]
+ -- DIMENSION_VALUE
+ -- [, DIMENSION_VALUE]
+ -- [, DIMENSION_VALUE]
+ -- [, DIMENSION_VALUE]
+ -- [, DIMENSION_VALUE]
+ -- [, DIMENSION_VALUE]
+ -- [, DIMENSION_VALUE]);
+ --
+ -- SYMBOL ::= STRING_LITERAL | CHARACTER_LITERAL
+
+ -- DIMENSION_VALUE ::=
+ -- RATIONAL
+ -- | others => RATIONAL
-- | DISCRETE_CHOICE_LIST => RATIONAL
+
-- RATIONAL ::= [-] NUMERAL [/ NUMERAL]
- -- (see Analyze_Aspect_Dimension_System for DIMENSION_STRING grammar)
+ -- Note that when the dimensioned type is an integer type, then any
+ -- dimension value must be an integer literal.
procedure Analyze_Aspect_Dimension
(N : Node_Id;
-- Given an expression with denotes a rational number, read the number
-- and associate it with Position in Dimensions.
- function Has_Compile_Time_Known_Expressions
- (Aggr : Node_Id) return Boolean;
- -- Determine whether aggregate Aggr contains only expressions that are
- -- known at compile time.
-
function Position_In_System
(Id : Node_Id;
System : System_Type) return Dimension_Position;
Position : Dimension_Position)
is
begin
+ -- Integer case
+
if Is_Integer_Type (Def_Id) then
- Dimensions (Position) := +Whole (UI_To_Int (Expr_Value (Expr)));
+ -- Dimension value must be an integer literal
+
+ if Nkind (Expr) = N_Integer_Literal then
+ Dimensions (Position) := +Whole (UI_To_Int (Intval (Expr)));
+ else
+ Error_Msg_N ("integer literal expected", Expr);
+ end if;
+
+ -- Float case
+
else
Dimensions (Position) := Create_Rational_From (Expr, True);
end if;
Processed (Position) := True;
end Extract_Power;
- ----------------------------------------
- -- Has_Compile_Time_Known_Expressions --
- ----------------------------------------
-
- function Has_Compile_Time_Known_Expressions
- (Aggr : Node_Id) return Boolean
- is
- Comp : Node_Id;
- Expr : Node_Id;
-
- begin
- Expr := First (Expressions (Aggr));
- if Present (Expr) then
-
- -- The first expression within the aggregate describes the
- -- symbolic name of a dimension, skip it.
-
- Next (Expr);
- while Present (Expr) loop
- Analyze_And_Resolve (Expr);
-
- if not Compile_Time_Known_Value (Expr) then
- return False;
- end if;
-
- Next (Expr);
- end loop;
- end if;
-
- Comp := First (Component_Associations (Aggr));
- while Present (Comp) loop
- Expr := Expression (Comp);
-
- Analyze_And_Resolve (Expr);
-
- if not Compile_Time_Known_Value (Expr) then
- return False;
- end if;
-
- Next (Comp);
- end loop;
-
- return True;
- end Has_Compile_Time_Known_Expressions;
-
------------------------
-- Position_In_System --
------------------------
Dimension_Name : constant Name_Id := Chars (Id);
begin
- for Position in System.Names'Range loop
- if Dimension_Name = System.Names (Position) then
+ for Position in System.Unit_Names'Range loop
+ if Dimension_Name = System.Unit_Names (Position) then
return Position;
end if;
end loop;
Others_Seen : Boolean := False;
Position : Nat := 0;
Sub_Ind : Node_Id;
- Symbol : String_Id;
- Symbol_Decl : Node_Id;
+ Symbol : String_Id := No_String;
+ Symbol_Expr : Node_Id;
System : System_Type;
Typ : Entity_Id;
Errors_Count : Nat;
-- Errors_Count is a count of errors detected by the compiler so far
- -- just before the extraction of names and values in the aggregate
- -- (Step 3).
+ -- just before the extraction of symbol, names and values in the
+ -- aggregate (Step 2).
--
-- At the end of the analysis, there is a check to verify that this
-- count equals to Serious_Errors_Detected i.e. no erros have been
return;
end if;
- if Nkind (Aggr) /= N_Aggregate then
- Error_Msg_N ("aggregate expected", Aggr);
- return;
- end if;
-
- -- Each expression in dimension aggregate must be known at compile time
-
- if not Has_Compile_Time_Known_Expressions (Aggr) then
- Error_Msg_N ("values of aggregate must be static", Aggr);
- return;
- end if;
-
-- The dimension declarations are useless if the parent type does not
-- declare a valid system.
return;
end if;
- -- STEP 2: Structural verification of the dimension aggregate
+ if Nkind (Aggr) /= N_Aggregate then
+ Error_Msg_N ("aggregate expected", Aggr);
+ return;
+ end if;
+
+ -- STEP 2: Symbol, Names and values extraction
+
+ -- Get the number of errors detected by the compiler so far
+
+ Errors_Count := Serious_Errors_Detected;
+
+ -- STEP 2a: Symbol extraction
+
+ -- The first entry in the aggregate may be the symbolic representation
+ -- of the quantity.
- -- The first entry in the aggregate is the symbolic representation of
- -- the dimension.
+ -- Positional symbol argument
- Symbol_Decl := First (Expressions (Aggr));
+ Symbol_Expr := First (Expressions (Aggr));
- if No (Symbol_Decl)
- or else not Nkind_In (Symbol_Decl, N_Character_Literal,
+ -- Named symbol argument
+
+ if No (Symbol_Expr)
+ or else not Nkind_In (Symbol_Expr, N_Character_Literal,
N_String_Literal)
then
- Error_Msg_N ("first argument must be character or string", Aggr);
- return;
- end if;
+ Symbol_Expr := Empty;
- -- STEP 3: Name and value extraction
+ -- Component associations present
- -- Get the number of errors detected by the compiler so far
+ if Present (Component_Associations (Aggr)) then
+ Assoc := First (Component_Associations (Aggr));
+ Choice := First (Choices (Assoc));
- Errors_Count := Serious_Errors_Detected;
+ if No (Next (Choice)) and then Nkind (Choice) = N_Identifier then
+
+ -- Symbol component association is present
+
+ if Chars (Choice) = Name_Symbol then
+ Num_Choices := Num_Choices + 1;
+ Symbol_Expr := Expression (Assoc);
+
+ -- Verify symbol expression is a string or a character
+
+ if not Nkind_In (Symbol_Expr, N_Character_Literal,
+ N_String_Literal)
+ then
+ Symbol_Expr := Empty;
+ Error_Msg_N
+ ("symbol expression must be character or string",
+ Symbol_Expr);
+ end if;
+
+ -- Special error if no Symbol choice but expression is string
+ -- or character.
+
+ elsif Nkind_In (Expression (Assoc), N_Character_Literal,
+ N_String_Literal)
+ then
+ Num_Choices := Num_Choices + 1;
+ Error_Msg_N ("optional component Symbol expected, found&",
+ Choice);
+ end if;
+ end if;
+ end if;
+ end if;
+
+ -- STEP 2b: Names and values extraction
-- Positional elements
- Expr := Next (Symbol_Decl);
+ Expr := First (Expressions (Aggr));
+
+ -- Skip the symbol expression when present
+
+ if Present (Symbol_Expr) and then Num_Choices = 0 then
+ Expr := Next (Expr);
+ end if;
+
Position := Low_Position_Bound;
while Present (Expr) loop
if Position > High_Position_Bound then
-- Named elements
Assoc := First (Component_Associations (Aggr));
+
+ -- Skip the symbol association when present
+
+ if Num_Choices = 1 then
+ Next (Assoc);
+ end if;
+
while Present (Assoc) loop
- Expr := Expression (Assoc);
+ Expr := Expression (Assoc);
+
Choice := First (Choices (Assoc));
while Present (Choice) loop
-- Others case: OTHERS => EXPRESSION
elsif Nkind (Choice) = N_Others_Choice then
- if Present (Next (Choice))
- or else Present (Prev (Choice))
- then
+ if Present (Next (Choice)) or else Present (Prev (Choice)) then
Error_Msg_N
("OTHERS must appear alone in a choice list", Choice);
Next (Assoc);
end loop;
- -- STEP 4: Consistency of system and dimensions
+ -- STEP 3: Consistency of system and dimensions
- if Present (Next (Symbol_Decl))
+ if Present (First (Expressions (Aggr)))
+ and then (First (Expressions (Aggr)) /= Symbol_Expr
+ or else Present (Next (Symbol_Expr)))
and then (Num_Choices > 1
or else (Num_Choices = 1 and then not Others_Seen))
then
Error_Msg_N
("named associations cannot follow positional associations", Aggr);
+ end if;
- elsif Num_Dimensions > System.Count then
+ if Num_Dimensions > System.Count then
Error_Msg_N ("type& has more dimensions than system allows", Def_Id);
elsif Num_Dimensions < System.Count and then not Others_Seen then
Error_Msg_N ("type& has less dimensions than system allows", Def_Id);
end if;
- -- STEP 5: Dimension symbol extraction
+ -- STEP 4: Dimension symbol extraction
- if Nkind (Symbol_Decl) = N_Character_Literal then
- Start_String;
- Store_String_Char (UI_To_CC (Char_Literal_Value (Symbol_Decl)));
- Symbol := End_String;
+ if Present (Symbol_Expr) then
+ if Nkind (Symbol_Expr) = N_Character_Literal then
+ Start_String;
+ Store_String_Char (UI_To_CC (Char_Literal_Value (Symbol_Expr)));
+ Symbol := End_String;
- else
- Symbol := Strval (Symbol_Decl);
- end if;
+ else
+ Symbol := Strval (Symbol_Expr);
+ end if;
- if String_Length (Symbol) = 0 and then not Exists (Dimensions) then
- Error_Msg_N ("useless dimension declaration", Aggr);
+ if String_Length (Symbol) = 0 then
+ Error_Msg_N ("empty string not allowed here", Symbol_Expr);
+ end if;
end if;
- -- STEP 6: Storage of extracted values
+ -- STEP 5: Storage of extracted values
-- Check that no errors have been detected during the analysis
if Errors_Count = Serious_Errors_Detected then
- if String_Length (Symbol) /= 0 then
+
+ -- Check for useless declaration
+
+ if Symbol = No_String and then not Exists (Dimensions) then
+ Error_Msg_N ("useless dimension declaration", Aggr);
+ end if;
+
+ if Symbol /= No_String then
Set_Symbol (Def_Id, Symbol);
end if;
-- Analyze_Aspect_Dimension_System --
-------------------------------------
- -- with Dimension_System => DIMENSION_PAIRS
+ -- with Dimension_System => (
+ -- DIMENSION
+ -- [, DIMENSION]
+ -- [, DIMENSION]
+ -- [, DIMENSION]
+ -- [, DIMENSION]
+ -- [, DIMENSION]
+ -- [, DIMENSION]);
- -- 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
+ -- DIMENSION ::= (
+ -- [Unit_Name =>] IDENTIFIER,
+ -- [Unit_Symbol =>] SYMBOL,
+ -- [Dim_Symbol =>] SYMBOL)
procedure Analyze_Aspect_Dimension_System
(N : Node_Id;
-- Local variables
- Dim_Name : Node_Id;
- Dim_Pair : Node_Id;
+ Assoc : Node_Id;
+ Choice : Node_Id;
+ Dim_Aggr : Node_Id;
Dim_Symbol : Node_Id;
+ Dim_Symbols : Symbol_Array := No_Symbols;
Dim_System : System_Type := Null_System;
- Names : Name_Array := No_Names;
Position : Nat := 0;
- Symbols : Symbol_Array := No_Symbols;
+ Unit_Name : Node_Id;
+ Unit_Names : Name_Array := No_Names;
+ Unit_Symbol : Node_Id;
+ Unit_Symbols : Symbol_Array := No_Symbols;
Errors_Count : Nat;
-- Errors_Count is a count of errors detected by the compiler so far
-- STEP 3: Name and Symbol extraction
- Dim_Pair := First (Expressions (Aggr));
+ Dim_Aggr := First (Expressions (Aggr));
Errors_Count := Serious_Errors_Detected;
- while Present (Dim_Pair) loop
+ while Present (Dim_Aggr) loop
Position := Position + 1;
if Position > High_Position_Bound then
exit;
end if;
- if Nkind (Dim_Pair) /= N_Aggregate then
- Error_Msg_N ("aggregate expected", Dim_Pair);
+ if Nkind (Dim_Aggr) /= N_Aggregate then
+ Error_Msg_N ("aggregate expected", Dim_Aggr);
else
- if Present (Component_Associations (Dim_Pair)) then
- Error_Msg_N ("expected positional aggregate", Dim_Pair);
+ if Present (Component_Associations (Dim_Aggr))
+ and then Present (Expressions (Dim_Aggr))
+ then
+ Error_Msg_N ("mixed positional/named aggregate not allowed " &
+ "here",
+ Dim_Aggr);
+
+ -- Verify each dimension aggregate has three arguments
+
+ elsif List_Length (Component_Associations (Dim_Aggr)) /= 3
+ and then List_Length (Expressions (Dim_Aggr)) /= 3
+ then
+ Error_Msg_N
+ ("three components expected in aggregate", Dim_Aggr);
else
- if List_Length (Expressions (Dim_Pair)) = 2 then
- Dim_Name := First (Expressions (Dim_Pair));
- Dim_Symbol := Next (Dim_Name);
+ -- Named dimension aggregate
- -- Check the first argument for each pair is a name
+ if Present (Component_Associations (Dim_Aggr)) then
- if Nkind (Dim_Name) = N_Identifier then
- Names (Position) := Chars (Dim_Name);
- else
- Error_Msg_N ("expected dimension name", Dim_Name);
+ -- Check first argument denotes the unit name
+
+ Assoc := First (Component_Associations (Dim_Aggr));
+ Choice := First (Choices (Assoc));
+ Unit_Name := Expression (Assoc);
+
+ if Present (Next (Choice))
+ or else Nkind (Choice) /= N_Identifier
+ then
+ Error_Msg_NE ("wrong syntax for aspect&", Choice, Id);
+
+ elsif Chars (Choice) /= Name_Unit_Name then
+ Error_Msg_N ("expected Unit_Name, found&", Choice);
end if;
- -- Check the second argument for each pair is a string or a
- -- character.
+ -- Check the second argument denotes the unit symbol
+
+ Next (Assoc);
+ Choice := First (Choices (Assoc));
+ Unit_Symbol := Expression (Assoc);
- if not Nkind_In
- (Dim_Symbol,
- N_String_Literal,
- N_Character_Literal)
+ if Present (Next (Choice))
+ or else Nkind (Choice) /= N_Identifier
then
- Error_Msg_N ("expected dimension string or character",
- Dim_Symbol);
+ Error_Msg_NE ("wrong syntax for aspect&", Choice, Id);
- else
- -- String case
+ elsif Chars (Choice) /= Name_Unit_Symbol then
+ Error_Msg_N ("expected Unit_Symbol, found&", Choice);
+ end if;
- if Nkind (Dim_Symbol) = N_String_Literal then
- Symbols (Position) := Strval (Dim_Symbol);
+ -- Check the third argument denotes the dimension symbol
- -- Character case
+ Next (Assoc);
+ Choice := First (Choices (Assoc));
+ Dim_Symbol := Expression (Assoc);
- else
- Start_String;
- Store_String_Char
- (UI_To_CC (Char_Literal_Value (Dim_Symbol)));
- Symbols (Position) := End_String;
- end if;
+ if Present (Next (Choice))
+ or else Nkind (Choice) /= N_Identifier
+ then
+ Error_Msg_NE ("wrong syntax for aspect&", Choice, Id);
- -- Verify that the string is not empty
+ elsif Chars (Choice) /= Name_Dim_Symbol then
+ Error_Msg_N ("expected Dim_Symbol, found&", Choice);
+ end if;
- if String_Length (Symbols (Position)) = 0 then
- Error_Msg_N
- ("empty string not allowed here", Dim_Symbol);
- end if;
+ -- Positional dimension aggregate
+
+ else
+ Unit_Name := First (Expressions (Dim_Aggr));
+ Unit_Symbol := Next (Unit_Name);
+ Dim_Symbol := Next (Unit_Symbol);
+ end if;
+
+ -- Check the first argument for each dimension aggregate is
+ -- a name.
+
+ if Nkind (Unit_Name) = N_Identifier then
+ Unit_Names (Position) := Chars (Unit_Name);
+ else
+ Error_Msg_N ("expected unit name", Unit_Name);
+ end if;
+
+ -- Check the second argument for each dimension aggregate is
+ -- a string or a character.
+
+ if not Nkind_In
+ (Unit_Symbol,
+ N_String_Literal,
+ N_Character_Literal)
+ then
+ Error_Msg_N ("expected unit symbol (string or character)",
+ Unit_Symbol);
+
+ else
+ -- String case
+
+ if Nkind (Unit_Symbol) = N_String_Literal then
+ Unit_Symbols (Position) := Strval (Unit_Symbol);
+
+ -- Character case
+
+ else
+ Start_String;
+ Store_String_Char
+ (UI_To_CC (Char_Literal_Value (Unit_Symbol)));
+ Unit_Symbols (Position) := End_String;
end if;
+ -- Verify that the string is not empty
+
+ if String_Length (Unit_Symbols (Position)) = 0 then
+ Error_Msg_N
+ ("empty string not allowed here", Unit_Symbol);
+ end if;
+ end if;
+
+ -- Check the third argument for each dimension aggregate is
+ -- a string or a character.
+
+ if not Nkind_In
+ (Dim_Symbol,
+ N_String_Literal,
+ N_Character_Literal)
+ then
+ Error_Msg_N ("expected dimension symbol (string or " &
+ "character)",
+ Dim_Symbol);
+
else
- Error_Msg_N
- ("two expressions expected in aggregate", Dim_Pair);
+ -- String case
+
+ if Nkind (Dim_Symbol) = N_String_Literal then
+ Dim_Symbols (Position) := Strval (Dim_Symbol);
+
+ -- Character case
+
+ else
+ Start_String;
+ Store_String_Char
+ (UI_To_CC (Char_Literal_Value (Dim_Symbol)));
+ Dim_Symbols (Position) := End_String;
+ end if;
+
+ -- Verify that the string is not empty
+
+ if String_Length (Dim_Symbols (Position)) = 0 then
+ Error_Msg_N
+ ("empty string not allowed here", Dim_Symbol);
+ end if;
end if;
end if;
end if;
- Next (Dim_Pair);
+ Next (Dim_Aggr);
end loop;
-- STEP 4: Storage of extracted values
-- Check that no errors have been detected during the analysis
if Errors_Count = Serious_Errors_Detected then
- Dim_System.Type_Decl := N;
- Dim_System.Names := Names;
- Dim_System.Count := Position;
- Dim_System.Symbols := Symbols;
+ Dim_System.Type_Decl := N;
+ Dim_System.Unit_Names := Unit_Names;
+ Dim_System.Unit_Symbols := Unit_Symbols;
+ Dim_System.Dim_Symbols := Dim_Symbols;
+ Dim_System.Count := Position;
System_Table.Append (Dim_System);
end if;
end Analyze_Aspect_Dimension_System;
procedure Analyze_Dimension (N : Node_Id) is
begin
- -- Aspect is an Ada 2012 feature
+ -- Aspect is an Ada 2012 feature. Note that there is no need to check
+ -- dimensions for nodes that don't come from source.
- if Ada_Version < Ada_2012 then
+ if Ada_Version < Ada_2012 or else not Comes_From_Source (N) then
return;
end if;
case Nkind (N) is
-
when N_Assignment_Statement =>
Analyze_Dimension_Assignment_Statement (N);
when N_Extended_Return_Statement =>
Analyze_Dimension_Extended_Return_Statement (N);
- when N_Function_Call =>
- Analyze_Dimension_Function_Call (N);
-
when N_Attribute_Reference |
+ N_Expanded_Name |
+ N_Function_Call |
N_Identifier |
N_Indexed_Component |
N_Qualified_Expression |
end case;
end Analyze_Dimension;
+ ---------------------------------------
+ -- Analyze_Dimension_Array_Aggregate --
+ ---------------------------------------
+
+ procedure Analyze_Dimension_Array_Aggregate
+ (N : Node_Id;
+ Comp_Typ : Entity_Id)
+ is
+ Comp_Ass : constant List_Id := Component_Associations (N);
+ Dims_Of_Comp_Typ : constant Dimension_Type := Dimensions_Of (Comp_Typ);
+ Exps : constant List_Id := Expressions (N);
+
+ Comp : Node_Id;
+ Expr : Node_Id;
+
+ Error_Detected : Boolean := False;
+ -- This flag is used in order to indicate if an error has been detected
+ -- so far by the compiler in this routine.
+
+ begin
+ -- Aspect is an Ada 2012 feature. Nothing to do here if the component
+ -- base type is not a dimensioned type.
+
+ -- Note that here the original node must come from source since the
+ -- original array aggregate may not have been entirely decorated.
+
+ if Ada_Version < Ada_2012
+ or else not Comes_From_Source (Original_Node (N))
+ or else not Has_Dimension_System (Base_Type (Comp_Typ))
+ then
+ return;
+ end if;
+
+ -- Check whether there is any positional component association
+
+ if Is_Empty_List (Exps) then
+ Comp := First (Comp_Ass);
+ else
+ Comp := First (Exps);
+ end if;
+
+ while Present (Comp) loop
+
+ -- Get the expression from the component
+
+ if Nkind (Comp) = N_Component_Association then
+ Expr := Expression (Comp);
+ else
+ Expr := Comp;
+ end if;
+
+ -- Issue an error if the dimensions of the component type and the
+ -- dimensions of the component mismatch.
+
+ -- Note that we must ensure the expression has been fully analyzed
+ -- since it may not be decorated at this point. We also don't want to
+ -- issue the same error message multiple times on the same expression
+ -- (may happen when an aggregate is converted into a positional
+ -- aggregate).
+
+ if Comes_From_Source (Original_Node (Expr))
+ and then Present (Etype (Expr))
+ and then Dimensions_Of (Expr) /= Dims_Of_Comp_Typ
+ and then Sloc (Comp) /= Sloc (Prev (Comp))
+ then
+ -- Check if an error has already been encountered so far
+
+ if not Error_Detected then
+ Error_Msg_N ("dimensions mismatch in array aggregate", N);
+ Error_Detected := True;
+ end if;
+
+ Error_Msg_N
+ ("\expected dimension "
+ & Dimensions_Msg_Of (Comp_Typ)
+ & ", found "
+ & Dimensions_Msg_Of (Expr),
+ Expr);
+ end if;
+
+ -- Look at the named components right after the positional components
+
+ if not Present (Next (Comp))
+ and then List_Containing (Comp) = Exps
+ then
+ Comp := First (Comp_Ass);
+ else
+ Next (Comp);
+ end if;
+ end loop;
+ end Analyze_Dimension_Array_Aggregate;
+
--------------------------------------------
-- Analyze_Dimension_Assignment_Statement --
--------------------------------------------
is
begin
Error_Msg_N ("dimensions mismatch in assignment", N);
- Error_Msg_N ("\left-hand side " & Dimensions_Msg_Of (Lhs), N);
- Error_Msg_N ("\right-hand side " & Dimensions_Msg_Of (Rhs), N);
+ Error_Msg_N ("\left-hand side " & Dimensions_Msg_Of (Lhs, True), N);
+ Error_Msg_N ("\right-hand side " & Dimensions_Msg_Of (Rhs, True), N);
end Error_Dim_Msg_For_Assignment_Statement;
-- Start of processing for Analyze_Dimension_Assignment
"dimensions",
N,
Entity (N));
- Error_Msg_N ("\left operand " & Dimensions_Msg_Of (L), N);
- Error_Msg_N ("\right operand " & Dimensions_Msg_Of (R), N);
+ Error_Msg_N ("\left operand " & Dimensions_Msg_Of (L, True), N);
+ Error_Msg_N ("\right operand " & Dimensions_Msg_Of (R, True), N);
end Error_Dim_Msg_For_Binary_Op;
-- Start of processing for Analyze_Dimension_Binary_Op
-- value of the exponent must be known compile time. Otherwise,
-- the exponentiation evaluation will return an error message.
- if L_Has_Dimensions
- and then Compile_Time_Known_Value (R)
- then
+ if L_Has_Dimensions then
+ if not Compile_Time_Known_Value (R) then
+ Error_Msg_N ("exponent of dimensioned operand must be " &
+ "known at compile-time", N);
+ end if;
+
declare
Exponent_Value : Rational := Zero;
end if;
end Analyze_Dimension_Binary_Op;
+ ----------------------------
+ -- Analyze_Dimension_Call --
+ ----------------------------
+
+ procedure Analyze_Dimension_Call (N : Node_Id; Nam : Entity_Id) is
+ Actuals : constant List_Id := Parameter_Associations (N);
+ Actual : Node_Id;
+ Dims_Of_Formal : Dimension_Type;
+ Formal : Node_Id;
+ Formal_Typ : Entity_Id;
+
+ Error_Detected : Boolean := False;
+ -- This flag is used in order to indicate if an error has been detected
+ -- so far by the compiler in this routine.
+
+ begin
+ -- Aspect is an Ada 2012 feature. Note that there is no need to check
+ -- dimensions for calls that don't come from source, or those that may
+ -- have semantic errors.
+
+ if Ada_Version < Ada_2012
+ or else not Comes_From_Source (N)
+ or else Error_Posted (N)
+ then
+ return;
+ end if;
+
+ -- Check the dimensions of the actuals, if any
+
+ if not Is_Empty_List (Actuals) then
+
+ -- Special processing for elementary functions
+
+ -- For Sqrt call, the resulting dimensions equal to half the
+ -- dimensions of the actual. For all other elementary calls, this
+ -- routine check that every actual is dimensionless.
+
+ if Nkind (N) = N_Function_Call then
+ Elementary_Function_Calls : declare
+ Dims_Of_Call : Dimension_Type;
+ Ent : Entity_Id := Nam;
+
+ function Is_Elementary_Function_Entity
+ (Sub_Id : Entity_Id) return Boolean;
+ -- Given Sub_Id, the original subprogram entity, return True
+ -- if call is to an elementary function (see Ada.Numerics.
+ -- Generic_Elementary_Functions).
+
+ -----------------------------------
+ -- Is_Elementary_Function_Entity --
+ -----------------------------------
+
+ function Is_Elementary_Function_Entity
+ (Sub_Id : Entity_Id) return Boolean
+ is
+ Loc : constant Source_Ptr := Sloc (Sub_Id);
+
+ begin
+ -- Is entity in Ada.Numerics.Generic_Elementary_Functions?
+
+ return
+ Loc > No_Location
+ and then
+ Is_RTU
+ (Cunit_Entity (Get_Source_Unit (Loc)),
+ Ada_Numerics_Generic_Elementary_Functions);
+ end Is_Elementary_Function_Entity;
+
+ -- Start of processing for Elementary_Function_Calls
+
+ begin
+ -- Get original subprogram entity following the renaming chain
+
+ if Present (Alias (Ent)) then
+ Ent := Alias (Ent);
+ end if;
+
+ -- Check the call is an Elementary function call
+
+ if Is_Elementary_Function_Entity (Ent) then
+
+ -- Sqrt function call case
+
+ if Chars (Ent) = Name_Sqrt then
+ Dims_Of_Call := Dimensions_Of (First_Actual (N));
+
+ -- Evaluates the resulting dimensions (i.e. half the
+ -- dimensions of the actual).
+
+ if Exists (Dims_Of_Call) then
+ for Position in Dims_Of_Call'Range loop
+ Dims_Of_Call (Position) :=
+ Dims_Of_Call (Position) *
+ Rational'(Numerator => 1, Denominator => 2);
+ end loop;
+
+ Set_Dimensions (N, Dims_Of_Call);
+ end if;
+
+ -- All other elementary functions case. Note that every
+ -- actual here should be dimensionless.
+
+ else
+ Actual := First_Actual (N);
+ while Present (Actual) loop
+ if Exists (Dimensions_Of (Actual)) then
+
+ -- Check if error has already been encountered
+
+ if not Error_Detected then
+ Error_Msg_NE ("dimensions mismatch in call of&",
+ N, Name (N));
+ Error_Detected := True;
+ end if;
+
+ Error_Msg_N ("\expected dimension [], found " &
+ Dimensions_Msg_Of (Actual),
+ Actual);
+ end if;
+
+ Next_Actual (Actual);
+ end loop;
+ end if;
+
+ -- Nothing more to do for elementary functions
+
+ return;
+ end if;
+ end Elementary_Function_Calls;
+ end if;
+
+ -- General case. Check, for each parameter, the dimensions of the
+ -- actual and its corresponding formal match. Otherwise, complain.
+
+ Actual := First_Actual (N);
+ Formal := First_Formal (Nam);
+
+ while Present (Formal) loop
+
+ -- A missing corresponding actual indicates that the analysis of
+ -- the call was aborted due to a previous error.
+
+ if No (Actual) then
+ Check_Error_Detected;
+ return;
+ end if;
+
+ Formal_Typ := Etype (Formal);
+ Dims_Of_Formal := Dimensions_Of (Formal_Typ);
+
+ -- If the formal is not dimensionless, check dimensions of formal
+ -- and actual match. Otherwise, complain.
+
+ if Exists (Dims_Of_Formal)
+ and then Dimensions_Of (Actual) /= Dims_Of_Formal
+ then
+ -- Check if an error has already been encountered so far
+
+ if not Error_Detected then
+ Error_Msg_NE ("dimensions mismatch in& call", N, Name (N));
+ Error_Detected := True;
+ end if;
+
+ Error_Msg_N
+ ("\expected dimension " & Dimensions_Msg_Of (Formal_Typ)
+ & ", found " & Dimensions_Msg_Of (Actual), Actual);
+ end if;
+
+ Next_Actual (Actual);
+ Next_Formal (Formal);
+ end loop;
+ end if;
+
+ -- For function calls, propagate the dimensions from the returned type
+
+ if Nkind (N) = N_Function_Call then
+ Analyze_Dimension_Has_Etype (N);
+ end if;
+ end Analyze_Dimension_Call;
+
---------------------------------------------
-- Analyze_Dimension_Component_Declaration --
---------------------------------------------
Expr : Node_Id) is
begin
Error_Msg_N ("dimensions mismatch in component declaration", N);
- Error_Msg_N ("\component type " & Dimensions_Msg_Of (Etyp), N);
- Error_Msg_N ("\component expression " & Dimensions_Msg_Of (Expr), N);
+ Error_Msg_N ("\expected dimension "
+ & Dimensions_Msg_Of (Etyp)
+ & ", found "
+ & Dimensions_Msg_Of (Expr),
+ Expr);
end Error_Dim_Msg_For_Component_Declaration;
-- Start of processing for Analyze_Dimension_Component_Declaration
begin
+ -- Expression is present
+
if Present (Expr) then
Dims_Of_Expr := Dimensions_Of (Expr);
- -- Return an error if the dimension of the expression and the
- -- dimension of the type mismatch.
+ -- Check dimensions match
if Dims_Of_Etyp /= Dims_Of_Expr then
- Error_Dim_Msg_For_Component_Declaration (N, Etyp, Expr);
- end if;
+ -- Numeric literal case. Issue a warning if the object type is not
+ -- dimensionless to indicate the literal is treated as if its
+ -- dimension matches the type dimension.
- -- Removal of dimensions in expression
+ if Nkind_In (Original_Node (Expr), N_Real_Literal,
+ N_Integer_Literal)
+ then
+ Dim_Warning_For_Numeric_Literal (Expr, Etyp);
- Remove_Dimensions (Expr);
+ -- Issue a dimension mismatch error for all other cases
+
+ else
+ Error_Dim_Msg_For_Component_Declaration (N, Etyp, Expr);
+ end if;
+ end if;
end if;
end Analyze_Dimension_Component_Declaration;
-------------------------------------------------
procedure Analyze_Dimension_Extended_Return_Statement (N : Node_Id) is
- Return_Ent : constant Entity_Id :=
- Return_Statement_Entity (N);
- Return_Etyp : constant Entity_Id :=
- Etype (Return_Applies_To (Return_Ent));
- Dims_Of_Return_Etyp : constant Dimension_Type :=
- Dimensions_Of (Return_Etyp);
- Return_Obj_Decls : constant List_Id :=
- Return_Object_Declarations (N);
- Dims_Of_Return_Obj_Id : Dimension_Type;
- Return_Obj_Decl : Node_Id;
- Return_Obj_Id : Entity_Id;
+ Return_Ent : constant Entity_Id := Return_Statement_Entity (N);
+ Return_Etyp : constant Entity_Id :=
+ Etype (Return_Applies_To (Return_Ent));
+ Return_Obj_Decls : constant List_Id := Return_Object_Declarations (N);
+ Return_Obj_Decl : Node_Id;
+ Return_Obj_Id : Entity_Id;
+ Return_Obj_Typ : Entity_Id;
procedure Error_Dim_Msg_For_Extended_Return_Statement
- (N : Node_Id;
- Return_Etyp : Entity_Id;
- Return_Obj_Id : Entity_Id);
+ (N : Node_Id;
+ Return_Etyp : Entity_Id;
+ Return_Obj_Typ : Entity_Id);
-- Error using Error_Msg_N at node N. Output the dimensions of the
- -- returned type Return_Etyp and the returned object Return_Obj_Id of N.
+ -- returned type Return_Etyp and the returned object type Return_Obj_Typ
+ -- of N.
-------------------------------------------------
-- Error_Dim_Msg_For_Extended_Return_Statement --
-------------------------------------------------
procedure Error_Dim_Msg_For_Extended_Return_Statement
- (N : Node_Id;
- Return_Etyp : Entity_Id;
- Return_Obj_Id : Entity_Id)
+ (N : Node_Id;
+ Return_Etyp : Entity_Id;
+ Return_Obj_Typ : Entity_Id)
is
begin
Error_Msg_N ("dimensions mismatch in extended return statement", N);
- Error_Msg_N ("\returned type " & Dimensions_Msg_Of (Return_Etyp), N);
- Error_Msg_N ("\returned object " & Dimensions_Msg_Of (Return_Obj_Id),
+ Error_Msg_N ("\expected dimension "
+ & Dimensions_Msg_Of (Return_Etyp)
+ & ", found "
+ & Dimensions_Msg_Of (Return_Obj_Typ),
N);
end Error_Dim_Msg_For_Extended_Return_Statement;
Return_Obj_Id := Defining_Identifier (Return_Obj_Decl);
if Is_Return_Object (Return_Obj_Id) then
- Dims_Of_Return_Obj_Id := Dimensions_Of (Return_Obj_Id);
+ Return_Obj_Typ := Etype (Return_Obj_Id);
+
+ -- Issue an error message if dimensions mismatch
- if Dims_Of_Return_Etyp /= Dims_Of_Return_Obj_Id then
+ if Dimensions_Of (Return_Etyp) /=
+ Dimensions_Of (Return_Obj_Typ)
+ then
Error_Dim_Msg_For_Extended_Return_Statement
- (N, Return_Etyp, Return_Obj_Id);
+ (N, Return_Etyp, Return_Obj_Typ);
return;
end if;
end if;
end if;
end Analyze_Dimension_Extended_Return_Statement;
- -------------------------------------
- -- Analyze_Dimension_Function_Call --
- -------------------------------------
+ -----------------------------------------------------
+ -- Analyze_Dimension_Extension_Or_Record_Aggregate --
+ -----------------------------------------------------
- -- Propagate the dimensions from the returned type to the call node. Note
- -- that there is a special treatment for elementary function calls. Indeed
- -- for Sqrt call, the resulting dimensions equal to half the dimensions of
- -- the actual, and for other elementary calls, this routine check that
- -- every actuals are dimensionless.
+ procedure Analyze_Dimension_Extension_Or_Record_Aggregate (N : Node_Id) is
+ Comp : Node_Id;
+ Comp_Id : Entity_Id;
+ Comp_Typ : Entity_Id;
+ Expr : Node_Id;
- procedure Analyze_Dimension_Function_Call (N : Node_Id) is
- Actuals : constant List_Id := Parameter_Associations (N);
- Name_Call : constant Node_Id := Name (N);
- Actual : Node_Id;
- Dims_Of_Actual : Dimension_Type;
- Dims_Of_Call : Dimension_Type;
- Ent : Entity_Id;
+ Error_Detected : Boolean := False;
+ -- This flag is used in order to indicate if an error has been detected
+ -- so far by the compiler in this routine.
- function Is_Elementary_Function_Entity (E : Entity_Id) return Boolean;
- -- Given E, the original subprogram entity, return True if call is to an
- -- elementary function (see Ada.Numerics.Generic_Elementary_Functions).
+ begin
+ -- Aspect is an Ada 2012 feature. Note that there is no need to check
+ -- dimensions for aggregates that don't come from source.
- -----------------------------------
- -- Is_Elementary_Function_Entity --
- -----------------------------------
+ if Ada_Version < Ada_2012 or else not Comes_From_Source (N) then
+ return;
+ end if;
- function Is_Elementary_Function_Entity (E : Entity_Id) return Boolean is
- Loc : constant Source_Ptr := Sloc (E);
+ Comp := First (Component_Associations (N));
+ while Present (Comp) loop
+ Comp_Id := Entity (First (Choices (Comp)));
+ Comp_Typ := Etype (Comp_Id);
- begin
- -- Is function entity in Ada.Numerics.Generic_Elementary_Functions?
+ -- Check the component type is either a dimensioned type or a
+ -- dimensioned subtype.
- return
- Loc > No_Location
- and then
- Is_RTU
- (Cunit_Entity (Get_Source_Unit (Loc)),
- Ada_Numerics_Generic_Elementary_Functions);
- end Is_Elementary_Function_Entity;
+ if Has_Dimension_System (Base_Type (Comp_Typ)) then
+ Expr := Expression (Comp);
- -- Start of processing for Analyze_Dimension_Function_Call
+ -- Issue an error if the dimensions of the component type and the
+ -- dimensions of the component mismatch.
- begin
- -- Look for elementary function call
+ if Dimensions_Of (Expr) /= Dimensions_Of (Comp_Typ) then
- if Is_Entity_Name (Name_Call) then
- Ent := Entity (Name_Call);
+ -- Check if an error has already been encountered so far
- -- Get the original subprogram entity following the renaming chain
+ if not Error_Detected then
- if Present (Alias (Ent)) then
- Ent := Alias (Ent);
- end if;
+ -- Extension aggregate case
- -- Elementary function case
+ if Nkind (N) = N_Extension_Aggregate then
+ Error_Msg_N
+ ("dimensions mismatch in extension aggregate", N);
- if Is_Elementary_Function_Entity (Ent) then
+ -- Record aggregate case
- -- Sqrt function call case
+ else
+ Error_Msg_N
+ ("dimensions mismatch in record aggregate", N);
+ end if;
- if Chars (Ent) = Name_Sqrt then
- Dims_Of_Call := Dimensions_Of (First (Actuals));
+ Error_Detected := True;
+ end if;
- if Exists (Dims_Of_Call) then
- for Position in Dims_Of_Call'Range loop
- Dims_Of_Call (Position) :=
- Dims_Of_Call (Position) * Rational'(Numerator => 1,
- Denominator => 2);
- end loop;
+ Error_Msg_N
+ ("\expected dimension "
+ & Dimensions_Msg_Of (Comp_Typ)
+ & ", found "
+ & Dimensions_Msg_Of (Expr),
+ Comp);
+ end if;
+ end if;
- Set_Dimensions (N, Dims_Of_Call);
- end if;
+ Next (Comp);
+ end loop;
+ end Analyze_Dimension_Extension_Or_Record_Aggregate;
- -- All other elementary functions case. Note that every actual
- -- here should be dimensionless.
+ -------------------------------
+ -- Analyze_Dimension_Formals --
+ -------------------------------
- else
- Actual := First (Actuals);
- while Present (Actual) loop
- Dims_Of_Actual := Dimensions_Of (Actual);
-
- if Exists (Dims_Of_Actual) then
- Error_Msg_NE ("parameter should be dimensionless for " &
- "elementary function&",
- Actual, Name_Call);
- Error_Msg_N ("\parameter " & Dimensions_Msg_Of (Actual),
- Actual);
- end if;
+ procedure Analyze_Dimension_Formals (N : Node_Id; Formals : List_Id) is
+ Dims_Of_Typ : Dimension_Type;
+ Formal : Node_Id;
+ Typ : Entity_Id;
- Next (Actual);
- end loop;
- end if;
+ begin
+ -- Aspect is an Ada 2012 feature. Note that there is no need to check
+ -- dimensions for sub specs that don't come from source.
- return;
- end if;
+ if Ada_Version < Ada_2012 or else not Comes_From_Source (N) then
+ return;
end if;
- -- Other cases
+ Formal := First (Formals);
+ while Present (Formal) loop
+ Typ := Parameter_Type (Formal);
+ Dims_Of_Typ := Dimensions_Of (Typ);
- Analyze_Dimension_Has_Etype (N);
- end Analyze_Dimension_Function_Call;
+ if Exists (Dims_Of_Typ) then
+ declare
+ Expr : constant Node_Id := Expression (Formal);
+
+ begin
+ -- Issue a warning if Expr is a numeric literal and if its
+ -- dimensions differ with the dimensions of the formal type.
+
+ if Present (Expr)
+ and then Dims_Of_Typ /= Dimensions_Of (Expr)
+ and then Nkind_In (Original_Node (Expr), N_Real_Literal,
+ N_Integer_Literal)
+ then
+ Dim_Warning_For_Numeric_Literal (Expr, Etype (Typ));
+ end if;
+ end;
+ end if;
+
+ Next (Formal);
+ end loop;
+ end Analyze_Dimension_Formals;
---------------------------------
-- Analyze_Dimension_Has_Etype --
procedure Analyze_Dimension_Has_Etype (N : Node_Id) is
Etyp : constant Entity_Id := Etype (N);
- Dims_Of_Etyp : constant Dimension_Type := Dimensions_Of (Etyp);
+ Dims_Of_Etyp : Dimension_Type := Dimensions_Of (Etyp);
begin
- -- Propagation of the dimensions from the type
+ -- General case. Propagation of the dimensions from the type
if Exists (Dims_Of_Etyp) then
Set_Dimensions (N, Dims_Of_Etyp);
+
+ -- Identifier case. Propagate the dimensions from the entity for
+ -- identifier whose entity is a non-dimensionless constant.
+
+ elsif Nkind (N) = N_Identifier then
+ Analyze_Dimension_Identifier : declare
+ Id : constant Entity_Id := Entity (N);
+ begin
+ if Ekind (Id) = E_Constant
+ and then Exists (Dimensions_Of (Id))
+ then
+ Set_Dimensions (N, Dimensions_Of (Id));
+ end if;
+ end Analyze_Dimension_Identifier;
+
+ -- Attribute reference case. Propagate the dimensions from the prefix.
+
+ elsif Nkind (N) = N_Attribute_Reference
+ and then Has_Dimension_System (Base_Type (Etyp))
+ then
+ Dims_Of_Etyp := Dimensions_Of (Prefix (N));
+
+ -- Check the prefix is not dimensionless
+
+ if Exists (Dims_Of_Etyp) then
+ Set_Dimensions (N, Dims_Of_Etyp);
+ end if;
end if;
-- Removal of dimensions in expression
case Nkind (N) is
-
when N_Attribute_Reference |
N_Indexed_Component =>
declare
Remove_Dimensions (Selector_Name (N));
when others => null;
-
end case;
end Analyze_Dimension_Has_Etype;
Expr : Node_Id) is
begin
Error_Msg_N ("dimensions mismatch in object declaration", N);
- Error_Msg_N ("\object type " & Dimensions_Msg_Of (Etyp), N);
- Error_Msg_N ("\object expression " & Dimensions_Msg_Of (Expr), N);
+ Error_Msg_N
+ ("\expected dimension "
+ & Dimensions_Msg_Of (Etyp)
+ & ", found "
+ & Dimensions_Msg_Of (Expr),
+ Expr);
end Error_Dim_Msg_For_Object_Declaration;
-- Start of processing for Analyze_Dimension_Object_Declaration
if Present (Expr) then
Dim_Of_Expr := Dimensions_Of (Expr);
- -- case when expression is not a literal and when dimensions of the
- -- expression and of the type mismatch
+ -- Check dimensions match
- if not Nkind_In (Original_Node (Expr),
- N_Real_Literal,
- N_Integer_Literal)
- and then Dim_Of_Expr /= Dim_Of_Etyp
- then
- Error_Dim_Msg_For_Object_Declaration (N, Etyp, Expr);
+ if Dim_Of_Expr /= Dim_Of_Etyp then
+
+ -- Numeric literal case. Issue a warning if the object type is not
+ -- dimensionless to indicate the literal is treated as if its
+ -- dimension matches the type dimension.
+
+ if Nkind_In (Original_Node (Expr), N_Real_Literal,
+ N_Integer_Literal)
+ then
+ Dim_Warning_For_Numeric_Literal (Expr, Etyp);
+
+ -- Case of object is a constant whose type is a dimensioned type
+
+ elsif Constant_Present (N) and then not Exists (Dim_Of_Etyp) then
+
+ -- Propagate dimension from expression to object entity
+
+ Set_Dimensions (Id, Dim_Of_Expr);
+
+ -- For all other cases, issue an error message
+
+ else
+ Error_Dim_Msg_For_Object_Declaration (N, Etyp, Expr);
+ end if;
end if;
-- Removal of dimensions in expression
Sub_Mark : Node_Id;
Renamed_Name : Node_Id) is
begin
- Error_Msg_N ("dimensions mismatch in object renaming declaration",
- N);
- Error_Msg_N ("\type " & Dimensions_Msg_Of (Sub_Mark), N);
- Error_Msg_N ("\renamed object " & Dimensions_Msg_Of (Renamed_Name),
- N);
+ Error_Msg_N ("dimensions mismatch in object renaming declaration", N);
+ Error_Msg_N
+ ("\expected dimension "
+ & Dimensions_Msg_Of (Sub_Mark)
+ & ", found "
+ & Dimensions_Msg_Of (Renamed_Name),
+ Renamed_Name);
end Error_Dim_Msg_For_Object_Renaming_Declaration;
-- Start of processing for Analyze_Dimension_Object_Renaming_Declaration
is
begin
Error_Msg_N ("dimensions mismatch in return statement", N);
- Error_Msg_N ("\returned type " & Dimensions_Msg_Of (Return_Etyp), N);
- Error_Msg_N ("\returned expression " & Dimensions_Msg_Of (Expr), N);
+ Error_Msg_N
+ ("\expected dimension "
+ & Dimensions_Msg_Of (Return_Etyp)
+ & ", found "
+ & Dimensions_Msg_Of (Expr),
+ Expr);
end Error_Dim_Msg_For_Simple_Return_Statement;
-- Start of processing for Analyze_Dimension_Simple_Return_Statement
-- it cannot inherit a dimension from its subtype.
if Exists (Dims_Of_Id) then
- Error_Msg_N ("subtype& already" & Dimensions_Msg_Of (Id), N);
+ Error_Msg_N
+ ("subtype& already" & Dimensions_Msg_Of (Id, True), N);
+
else
Set_Dimensions (Id, Dims_Of_Etyp);
Set_Symbol (Id, Symbol_Of (Etyp));
end case;
end Analyze_Dimension_Unary_Op;
+ ---------------------
+ -- Copy_Dimensions --
+ ---------------------
+
+ procedure Copy_Dimensions (From, To : Node_Id) is
+ Dims_Of_From : constant Dimension_Type := Dimensions_Of (From);
+
+ begin
+ -- Ignore if not Ada 2012 or beyond
+
+ if Ada_Version < Ada_2012 then
+ return;
+
+ -- For Ada 2012, Copy the dimension of 'From to 'To'
+
+ elsif Exists (Dims_Of_From) then
+ Set_Dimensions (To, Dims_Of_From);
+ end if;
+ end Copy_Dimensions;
+
--------------------------
-- Create_Rational_From --
--------------------------
-- generate an error message.
if Complain and then Result = No_Rational then
- Error_Msg_N ("must be a rational", Expr);
+ Error_Msg_N ("rational expected", Expr);
end if;
return Result;
-- Dimensions_Msg_Of --
-----------------------
- function Dimensions_Msg_Of (N : Node_Id) return String is
+ function Dimensions_Msg_Of
+ (N : Node_Id;
+ Description_Needed : Boolean := False) return String
+ is
Dims_Of_N : constant Dimension_Type := Dimensions_Of (N);
Dimensions_Msg : Name_Id;
System : System_Type;
- procedure Add_Dimension_Vector_To_Buffer
- (Dims : Dimension_Type;
- System : System_Type);
- -- Given a Dims and System, add to Name_Buffer the string representation
- -- of a dimension vector.
-
- procedure Add_Whole_To_Buffer (W : Whole);
- -- Add image of Whole to Name_Buffer
-
- ------------------------------------
- -- Add_Dimension_Vector_To_Buffer --
- ------------------------------------
-
- procedure Add_Dimension_Vector_To_Buffer
- (Dims : Dimension_Type;
- System : System_Type)
- is
- Dim_Power : Rational;
- First_Dim : Boolean := True;
-
- begin
- Add_Char_To_Name_Buffer ('(');
+ begin
+ -- Initialization of Name_Buffer
- for Position in Dims_Of_N'First .. System.Count loop
- Dim_Power := Dims (Position);
+ Name_Len := 0;
- if First_Dim then
- First_Dim := False;
- else
- Add_Str_To_Name_Buffer (", ");
- end if;
+ -- N is not dimensionless
- Add_Whole_To_Buffer (Dim_Power.Numerator);
+ if Exists (Dims_Of_N) then
+ System := System_Of (Base_Type (Etype (N)));
- if Dim_Power.Denominator /= 1 then
- Add_Char_To_Name_Buffer ('/');
- Add_Whole_To_Buffer (Dim_Power.Denominator);
- end if;
- end loop;
+ -- When Description_Needed, add to string "has dimension " before the
+ -- actual dimension.
- Add_Char_To_Name_Buffer (')');
- end Add_Dimension_Vector_To_Buffer;
+ if Description_Needed then
+ Add_Str_To_Name_Buffer ("has dimension ");
+ end if;
- -------------------------
- -- Add_Whole_To_Buffer --
- -------------------------
+ Add_String_To_Name_Buffer
+ (From_Dim_To_Str_Of_Dim_Symbols (Dims_Of_N, System, True));
- procedure Add_Whole_To_Buffer (W : Whole) is
- begin
- UI_Image (UI_From_Int (Int (W)));
- Add_Str_To_Name_Buffer (UI_Image_Buffer (1 .. UI_Image_Length));
- end Add_Whole_To_Buffer;
+ -- N is dimensionless
- -- Start of processing for Dimensions_Msg_Of
+ -- When Description_Needed, return "is dimensionless"
- begin
- -- Initialization of Name_Buffer
+ elsif Description_Needed then
+ Add_Str_To_Name_Buffer ("is dimensionless");
- Name_Len := 0;
+ -- Otherwise, return "[]"
- if Exists (Dims_Of_N) then
- System := System_Of (Base_Type (Etype (N)));
- Add_Str_To_Name_Buffer ("has dimensions ");
- Add_Dimension_Vector_To_Buffer (Dims_Of_N, System);
else
- Add_Str_To_Name_Buffer ("is dimensionless");
+ Add_Str_To_Name_Buffer ("[]");
end if;
Dimensions_Msg := Name_Find;
return Dimension_Table_Range (Key mod 511);
end Dimension_Table_Hash;
+ -------------------------------------
+ -- Dim_Warning_For_Numeric_Literal --
+ -------------------------------------
+
+ procedure Dim_Warning_For_Numeric_Literal (N : Node_Id; Typ : Entity_Id) is
+ begin
+ -- Initialize name buffer
+
+ Name_Len := 0;
+
+ Add_String_To_Name_Buffer (String_From_Numeric_Literal (N));
+
+ -- Insert a blank between the literal and the symbol
+ Add_Str_To_Name_Buffer (" ");
+
+ Add_String_To_Name_Buffer (Symbol_Of (Typ));
+
+ Error_Msg_Name_1 := Name_Find;
+ Error_Msg_N ("??assumed to be%%", N);
+ end Dim_Warning_For_Numeric_Literal;
+
----------------------------------------
-- Eval_Op_Expon_For_Dimensioned_Type --
----------------------------------------
-- subtype T is Btyp_Of_L
-- with
- -- Dimension => ("",
+ -- Dimension => (
-- Dims_Of_N (1).Numerator / Dims_Of_N (1).Denominator,
-- Dims_Of_N (2).Numerator / Dims_Of_N (2).Denominator,
-- ...
New_Aspects := Empty_List;
List_Of_Dims := New_List;
- Append (Make_String_Literal (Loc, ""), List_Of_Dims);
for Position in Dims_Of_N'First .. System.Count loop
Dim_Power := Dims_Of_N (Position);
return Dim /= Null_Dimension;
end Exists;
+ function Exists (Str : String_Id) return Boolean is
+ begin
+ return Str /= No_String;
+ end Exists;
+
function Exists (Sys : System_Type) return Boolean is
begin
return Sys /= Null_System;
end Exists;
- -------------------------------------------
- -- Expand_Put_Call_With_Dimension_Symbol --
- -------------------------------------------
+ ---------------------------------
+ -- Expand_Put_Call_With_Symbol --
+ ---------------------------------
+
+ -- For procedure Put (resp. Put_Dim_Of) defined in System.Dim.Float_IO
+ -- (System.Dim.Integer_IO), the default string parameter must be rewritten
+ -- to include the unit symbols (resp. dimension symbols) in the output
+ -- of a dimensioned object. Note that if a value is already supplied for
+ -- parameter Symbol, this routine doesn't do anything.
+
+ -- Case 1. Item is dimensionless
- -- 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.
+ -- * Put : Item appears without a suffix
- -- Case 1: the parameter is a variable
+ -- * Put_Dim_Of : the output is []
- -- The default string parameter is replaced by the symbol defined in the
- -- aspect Dimension of the subtype. For instance to output a speed:
+ -- Obj : Mks_Type := 2.6;
+ -- Put (Obj, 1, 1, 0);
+ -- Put_Dim_Of (Obj);
- -- subtype Force is Mks_Type
- -- with
- -- Dimension => ("N",
- -- Meter => 1,
- -- Kilogram => 1,
- -- Second => -2,
- -- others => 0);
- -- F : Force := 2.1 * m * kg * s**(-2);
- -- Put (F);
- -- > 2.1 N
+ -- The corresponding outputs are:
+ -- $2.6
+ -- $[]
- -- Case 2: the parameter is an expression
+ -- Case 2. Item has a dimension
- -- In this case we call the procedure Expand_Put_Call_With_Dimension_Symbol
- -- that creates the string of symbols (for instance "m.s**(-1)") and
- -- rewrites the default string parameter of Put with the corresponding
- -- the String_Id. For instance:
+ -- * Put : If the type of Item is a dimensioned subtype whose
+ -- symbol is not empty, then the symbol appears as a
+ -- suffix. Otherwise, a new string is created and appears
+ -- as a suffix of Item. This string results in the
+ -- successive concatanations between each unit symbol
+ -- raised by its corresponding dimension power from the
+ -- dimensions of Item.
- -- Put (2.1 * m * kg * s**(-2));
- -- > 2.1 m.kg.s**(-2)
+ -- * Put_Dim_Of : The output is a new string resulting in the successive
+ -- concatanations between each dimension symbol raised by
+ -- its corresponding dimension power from the dimensions of
+ -- Item.
- procedure Expand_Put_Call_With_Dimension_Symbol (N : Node_Id) is
+ -- subtype Random is Mks_Type
+ -- with
+ -- Dimension => (
+ -- Meter => 3,
+ -- Candela => -1,
+ -- others => 0);
+
+ -- Obj : Random := 5.0;
+ -- Put (Obj);
+ -- Put_Dim_Of (Obj);
+
+ -- The corresponding outputs are:
+ -- $5.0 m**3.cd**(-1)
+ -- $[l**3.J**(-1)]
+
+ procedure Expand_Put_Call_With_Symbol (N : Node_Id) is
Actuals : constant List_Id := Parameter_Associations (N);
Loc : constant Source_Ptr := Sloc (N);
Name_Call : constant Node_Id := Name (N);
Dims_Of_Actual : Dimension_Type;
Etyp : Entity_Id;
New_Str_Lit : Node_Id := Empty;
- System : System_Type;
+ Symbols : String_Id;
- function Has_Dimension_Symbols return Boolean;
+ Is_Put_Dim_Of : Boolean := False;
+ -- This flag is used in order to differentiate routines Put and
+ -- Put_Dim_Of. Set to True if the procedure is one of the Put_Dim_Of
+ -- defined in System.Dim.Float_IO or System.Dim.Integer_IO.
+
+ function Has_Symbols return Boolean;
-- Return True if the current Put call already has a parameter
-- association for parameter "Symbols" with the correct string of
-- symbols.
-- System.Dim.Integer_IO.
function Item_Actual return Node_Id;
- -- Return the item actual parameter node in the put call
+ -- Return the item actual parameter node in the output call
- ---------------------------
- -- Has_Dimension_Symbols --
- ---------------------------
+ -----------------
+ -- Has_Symbols --
+ -----------------
- function Has_Dimension_Symbols return Boolean is
- Actual : Node_Id;
+ function Has_Symbols return Boolean is
+ Actual : Node_Id;
+ Actual_Str : Node_Id;
begin
Actual := First (Actuals);
-- Look for a symbols parameter association in the list of actuals
while Present (Actual) loop
- if Nkind (Actual) = N_Parameter_Association
- and then Chars (Selector_Name (Actual)) = Name_Symbols
+
+ -- Positional parameter association case when the actual is a
+ -- string literal.
+
+ if Nkind (Actual) = N_String_Literal then
+ Actual_Str := Actual;
+
+ -- Named parameter association case when selector name is Symbol
+
+ elsif Nkind (Actual) = N_Parameter_Association
+ and then Chars (Selector_Name (Actual)) = Name_Symbol
then
+ Actual_Str := Explicit_Actual_Parameter (Actual);
+
+ -- Ignore all other cases
+
+ else
+ Actual_Str := Empty;
+ end if;
+
+ if Present (Actual_Str) then
- -- return True if the actual comes from source or if the string
- -- of symbols doesn't have the default value (i.e "").
+ -- Return True if the actual comes from source or if the string
+ -- of symbols doesn't have the default value (i.e. it is "").
- return Comes_From_Source (Actual)
- or else String_Length
- (Strval
- (Explicit_Actual_Parameter (Actual))) /= 0;
+ if Comes_From_Source (Actual)
+ or else String_Length (Strval (Actual_Str)) /= 0
+ then
+ -- Complain only if the actual comes from source or if it
+ -- hasn't been fully analyzed yet.
+
+ if Comes_From_Source (Actual)
+ or else not Analyzed (Actual)
+ then
+ Error_Msg_N ("Symbol parameter should not be provided",
+ Actual);
+ Error_Msg_N ("\reserved for compiler use only", Actual);
+ end if;
+
+ return True;
+
+ else
+ return False;
+ end if;
end if;
Next (Actual);
end loop;
- -- At this point, the call has no parameter association
- -- Look to the last actual since the symbols parameter is the last
- -- one.
+ -- At this point, the call has no parameter association. Look to the
+ -- last actual since the symbols parameter is the last one.
return Nkind (Last (Actuals)) = N_String_Literal;
- end Has_Dimension_Symbols;
+ end Has_Symbols;
---------------------------
-- Is_Procedure_Put_Call --
Loc : Source_Ptr;
begin
- -- There are three different Put routines in each generic dim IO
- -- package. Verify the current procedure call is one of them.
+ -- There are three different Put (resp. Put_Dim_Of) routines in each
+ -- generic dim IO package. Verify the current procedure call is one
+ -- of them.
if Is_Entity_Name (Name_Call) then
Ent := Entity (Name_Call);
Loc := Sloc (Ent);
- -- Check the name of the entity subprogram is Put and verify this
- -- entity is located in either System.Dim.Float_IO or
- -- System.Dim.Integer_IO.
+ -- Check the name of the entity subprogram is Put (resp.
+ -- Put_Dim_Of) and verify this entity is located in either
+ -- System.Dim.Float_IO or System.Dim.Integer_IO.
- return Chars (Ent) = Name_Put
- and then Loc > No_Location
+ if Loc > No_Location
and then Is_Dim_IO_Package_Entity
- (Cunit_Entity (Get_Source_Unit (Loc)));
+ (Cunit_Entity (Get_Source_Unit (Loc)))
+ then
+ if Chars (Ent) = Name_Put_Dim_Of then
+ Is_Put_Dim_Of := True;
+ return True;
+
+ elsif Chars (Ent) = Name_Put then
+ return True;
+ end if;
+ end if;
end if;
return False;
end if;
end Item_Actual;
- -- Start of processing for Expand_Put_Call_With_Dimension_Symbol
+ -- Start of processing for Expand_Put_Call_With_Symbol
begin
- if Is_Procedure_Put_Call and then not Has_Dimension_Symbols then
+ if Is_Procedure_Put_Call and then not Has_Symbols then
Actual := Item_Actual;
Dims_Of_Actual := Dimensions_Of (Actual);
Etyp := Etype (Actual);
- -- Add the symbol as a suffix of the value if the subtype has a
- -- dimension symbol or if the parameter is not dimensionless.
+ -- Put_Dim_Of case
- if Symbol_Of (Etyp) /= No_String then
- Start_String;
+ if Is_Put_Dim_Of then
+
+ -- Check that the item is not dimensionless
+
+ -- Create the new String_Literal with the new String_Id generated
+ -- by the routine From_Dim_To_Str_Of_Dim_Symbols.
+
+ if Exists (Dims_Of_Actual) then
+ New_Str_Lit :=
+ Make_String_Literal (Loc,
+ From_Dim_To_Str_Of_Dim_Symbols
+ (Dims_Of_Actual, System_Of (Base_Type (Etyp))));
+
+ -- If dimensionless, the output is []
+
+ else
+ New_Str_Lit :=
+ Make_String_Literal (Loc, "[]");
+ end if;
+
+ -- Put case
+
+ else
+ -- Add the symbol as a suffix of the value if the subtype has a
+ -- unit symbol or if the parameter is not dimensionless.
- -- Put a space between the value and the dimension
+ if Exists (Symbol_Of (Etyp)) then
+ Symbols := Symbol_Of (Etyp);
+ else
+ Symbols := From_Dim_To_Str_Of_Unit_Symbols
+ (Dims_Of_Actual, System_Of (Base_Type (Etyp)));
+ end if;
- Store_String_Char (' ');
- Store_String_Chars (Symbol_Of (Etyp));
- New_Str_Lit := Make_String_Literal (Loc, End_String);
+ -- Check Symbols exists
- -- Check that the item is not dimensionless
+ if Exists (Symbols) then
+ Start_String;
- -- Create the new String_Literal with the new String_Id generated by
- -- the routine From_Dimension_To_String.
+ -- Put a space between the value and the dimension
- elsif Exists (Dims_Of_Actual) then
- System := System_Of (Base_Type (Etyp));
- New_Str_Lit :=
- Make_String_Literal (Loc,
- From_Dimension_To_String_Of_Symbols (Dims_Of_Actual, System));
+ Store_String_Char (' ');
+ Store_String_Chars (Symbols);
+ New_Str_Lit := Make_String_Literal (Loc, End_String);
+ end if;
end if;
if Present (New_Str_Lit) then
-- parameter association.
if Nkind (Actual) = N_Parameter_Association
- and then Chars (Selector_Name (Actual)) /= Name_Symbols
+ and then Chars (Selector_Name (Actual)) /= Name_Symbol
then
Append_To (New_Actuals,
Make_Parameter_Association (Loc,
Append_To (New_Actuals,
Make_Parameter_Association (Loc,
- Selector_Name => Make_Identifier (Loc, Name_Symbols),
+ Selector_Name => Make_Identifier (Loc, Name_Symbol),
Explicit_Actual_Parameter => New_Str_Lit));
-- Rewrite and analyze the procedure call
Analyze (N);
end if;
end if;
- end Expand_Put_Call_With_Dimension_Symbol;
+ end Expand_Put_Call_With_Symbol;
- -----------------------------------------
- -- From_Dimension_To_String_Of_Symbols --
- -----------------------------------------
+ ------------------------------------
+ -- From_Dim_To_Str_Of_Dim_Symbols --
+ ------------------------------------
- -- Given a dimension vector and the corresponding dimension system,
- -- create a String_Id to output the dimension symbols corresponding to
- -- the dimensions Dims.
+ -- Given a dimension vector and the corresponding dimension system, create
+ -- a String_Id to output dimension symbols corresponding to the dimensions
+ -- Dims. If In_Error_Msg is True, there is a special handling for character
+ -- asterisk * which is an insertion character in error messages.
- function From_Dimension_To_String_Of_Symbols
- (Dims : Dimension_Type;
- System : System_Type) return String_Id
+ function From_Dim_To_Str_Of_Dim_Symbols
+ (Dims : Dimension_Type;
+ System : System_Type;
+ In_Error_Msg : Boolean := False) return String_Id
is
- Dimension_Power : Rational;
- First_Symbol_In_Str : Boolean := True;
+ Dim_Power : Rational;
+ First_Dim : Boolean := True;
+
+ procedure Store_String_Oexpon;
+ -- Store the expon operator symbol "**" in the string. In error
+ -- messages, asterisk * is a special character and must be quoted
+ -- to be placed literally into the message.
+
+ -------------------------
+ -- Store_String_Oexpon --
+ -------------------------
+
+ procedure Store_String_Oexpon is
+ begin
+ if In_Error_Msg then
+ Store_String_Chars ("'*'*");
+ else
+ Store_String_Chars ("**");
+ end if;
+ end Store_String_Oexpon;
+
+ -- Start of processing for From_Dim_To_Str_Of_Dim_Symbols
begin
-- Initialization of the new String_Id
Start_String;
- -- Put a space between the value and the symbols
+ -- Store the dimension symbols inside boxes
- Store_String_Char (' ');
+ Store_String_Char ('[');
for Position in Dimension_Type'Range loop
- Dimension_Power := Dims (Position);
- if Dimension_Power /= Zero then
+ Dim_Power := Dims (Position);
+ if Dim_Power /= Zero then
- if First_Symbol_In_Str then
- First_Symbol_In_Str := False;
+ if First_Dim then
+ First_Dim := False;
else
Store_String_Char ('.');
end if;
+ Store_String_Chars (System.Dim_Symbols (Position));
+
-- Positive dimension case
- if Dimension_Power.Numerator > 0 then
- if System.Symbols (Position) = No_String then
- Store_String_Chars
- (Get_Name_String (System.Names (Position)));
+ if Dim_Power.Numerator > 0 then
+ -- Integer case
+
+ if Dim_Power.Denominator = 1 then
+ if Dim_Power.Numerator /= 1 then
+ Store_String_Oexpon;
+ Store_String_Int (Int (Dim_Power.Numerator));
+ end if;
+
+ -- Rational case when denominator /= 1
+
+ else
+ Store_String_Oexpon;
+ Store_String_Char ('(');
+ Store_String_Int (Int (Dim_Power.Numerator));
+ Store_String_Char ('/');
+ Store_String_Int (Int (Dim_Power.Denominator));
+ Store_String_Char (')');
+ end if;
+
+ -- Negative dimension case
+
+ else
+ Store_String_Oexpon;
+ Store_String_Char ('(');
+ Store_String_Char ('-');
+ Store_String_Int (Int (-Dim_Power.Numerator));
+
+ -- Integer case
+
+ if Dim_Power.Denominator = 1 then
+ Store_String_Char (')');
+
+ -- Rational case when denominator /= 1
+
else
- Store_String_Chars (System.Symbols (Position));
+ Store_String_Char ('/');
+ Store_String_Int (Int (Dim_Power.Denominator));
+ Store_String_Char (')');
end if;
+ end if;
+ end if;
+ end loop;
+
+ Store_String_Char (']');
+ return End_String;
+ end From_Dim_To_Str_Of_Dim_Symbols;
+
+ -------------------------------------
+ -- From_Dim_To_Str_Of_Unit_Symbols --
+ -------------------------------------
+
+ -- Given a dimension vector and the corresponding dimension system,
+ -- create a String_Id to output the unit symbols corresponding to the
+ -- dimensions Dims.
+
+ function From_Dim_To_Str_Of_Unit_Symbols
+ (Dims : Dimension_Type;
+ System : System_Type) return String_Id
+ is
+ Dim_Power : Rational;
+ First_Dim : Boolean := True;
+
+ begin
+ -- Return No_String if dimensionless
+
+ if not Exists (Dims) then
+ return No_String;
+ end if;
+
+ -- Initialization of the new String_Id
+
+ Start_String;
+
+ for Position in Dimension_Type'Range loop
+ Dim_Power := Dims (Position);
+
+ if Dim_Power /= Zero then
+
+ if First_Dim then
+ First_Dim := False;
+ else
+ Store_String_Char ('.');
+ end if;
+
+ Store_String_Chars (System.Unit_Symbols (Position));
+
+ -- Positive dimension case
+
+ if Dim_Power.Numerator > 0 then
-- Integer case
- if Dimension_Power.Denominator = 1 then
- if Dimension_Power.Numerator /= 1 then
+ if Dim_Power.Denominator = 1 then
+ if Dim_Power.Numerator /= 1 then
Store_String_Chars ("**");
- Store_String_Int (Int (Dimension_Power.Numerator));
+ Store_String_Int (Int (Dim_Power.Numerator));
end if;
-- Rational case when denominator /= 1
else
Store_String_Chars ("**");
Store_String_Char ('(');
- Store_String_Int (Int (Dimension_Power.Numerator));
+ Store_String_Int (Int (Dim_Power.Numerator));
Store_String_Char ('/');
- Store_String_Int (Int (Dimension_Power.Denominator));
+ Store_String_Int (Int (Dim_Power.Denominator));
Store_String_Char (')');
end if;
-- Negative dimension case
else
- if System.Symbols (Position) = No_String then
- Store_String_Chars
- (Get_Name_String (System.Names (Position)));
- else
- Store_String_Chars (System.Symbols (Position));
- end if;
-
Store_String_Chars ("**");
Store_String_Char ('(');
Store_String_Char ('-');
- Store_String_Int (Int (-Dimension_Power.Numerator));
+ Store_String_Int (Int (-Dim_Power.Numerator));
-- Integer case
- if Dimension_Power.Denominator = 1 then
+ if Dim_Power.Denominator = 1 then
Store_String_Char (')');
-- Rational case when denominator /= 1
else
Store_String_Char ('/');
- Store_String_Int (Int (Dimension_Power.Denominator));
+ Store_String_Int (Int (Dim_Power.Denominator));
Store_String_Char (')');
end if;
end if;
end loop;
return End_String;
- end From_Dimension_To_String_Of_Symbols;
+ end From_Dim_To_Str_Of_Unit_Symbols;
---------
-- GCD --
return
Is_RTU (E, System_Dim_Float_IO)
- or Is_RTU (E, System_Dim_Integer_IO);
+ or else
+ Is_RTU (E, System_Dim_Integer_IO);
end Is_Dim_IO_Package_Entity;
-------------------------------------
---------------------
procedure Move_Dimensions (From, To : Node_Id) is
- Dims_Of_From : constant Dimension_Type := Dimensions_Of (From);
-
begin
+ if Ada_Version < Ada_2012 then
+ return;
+ end if;
+
-- Copy the dimension of 'From to 'To' and remove dimension of 'From'
- if Exists (Dims_Of_From) then
- Set_Dimensions (To, Dims_Of_From);
- Remove_Dimensions (From);
- end if;
+ Copy_Dimensions (From, To);
+ Remove_Dimensions (From);
end Move_Dimensions;
------------
end if;
end Remove_Dimensions;
- ------------------------------
- -- Remove_Dimension_In_Call --
- ------------------------------
-
- procedure Remove_Dimension_In_Call (Call : Node_Id) is
- Actual : Node_Id;
-
- begin
- if Ada_Version < Ada_2012 then
- return;
- end if;
-
- Actual := First (Parameter_Associations (Call));
-
- while Present (Actual) loop
- Remove_Dimensions (Actual);
- Next (Actual);
- end loop;
- end Remove_Dimension_In_Call;
-
-----------------------------------
-- Remove_Dimension_In_Statement --
-----------------------------------
Symbol_Table.Set (E, Val);
end Set_Symbol;
+ ---------------------------------
+ -- String_From_Numeric_Literal --
+ ---------------------------------
+
+ function String_From_Numeric_Literal (N : Node_Id) return String_Id is
+ Loc : constant Source_Ptr := Sloc (N);
+ Sbuffer : constant Source_Buffer_Ptr :=
+ Source_Text (Get_Source_File_Index (Loc));
+ Src_Ptr : Source_Ptr := Loc;
+ C : Character := Sbuffer (Src_Ptr);
+ -- Current source program character
+
+ function Belong_To_Numeric_Literal (C : Character) return Boolean;
+ -- Return True if C belongs to a numeric literal
+
+ -------------------------------
+ -- Belong_To_Numeric_Literal --
+ -------------------------------
+
+ function Belong_To_Numeric_Literal (C : Character) return Boolean is
+ begin
+ case C is
+ when '0' .. '9' |
+ '_' |
+ '.' |
+ 'e' |
+ '#' |
+ 'A' |
+ 'B' |
+ 'C' |
+ 'D' |
+ 'E' |
+ 'F' =>
+ return True;
+
+ -- Make sure '+' or '-' is part of an exponent.
+
+ when '+' | '-' =>
+ declare
+ Prev_C : constant Character := Sbuffer (Src_Ptr - 1);
+ begin
+ return Prev_C = 'e' or else Prev_C = 'E';
+ end;
+
+ -- All other character doesn't belong to a numeric literal
+
+ when others =>
+ return False;
+ end case;
+ end Belong_To_Numeric_Literal;
+
+ -- Start of processing for String_From_Numeric_Literal
+
+ begin
+ Start_String;
+ while Belong_To_Numeric_Literal (C) loop
+ Store_String_Char (C);
+ Src_Ptr := Src_Ptr + 1;
+ C := Sbuffer (Src_Ptr);
+ end loop;
+
+ return End_String;
+ end String_From_Numeric_Literal;
+
---------------
-- Symbol_Of --
---------------
function Symbol_Of (E : Entity_Id) return String_Id is
+ Subtype_Symbol : constant String_Id := Symbol_Table.Get (E);
begin
- return Symbol_Table.Get (E);
+ if Subtype_Symbol /= No_String then
+ return Subtype_Symbol;
+ else
+ return From_Dim_To_Str_Of_Unit_Symbols
+ (Dimensions_Of (E), System_Of (Base_Type (E)));
+ end if;
end Symbol_Of;
-----------------------
projects / platform / upstream / gcc48.git / blobdiff