-- Semantic analysis.
-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold
--
-- This program is free software: you can redistribute it and/or modify
-- it under the terms of the GNU General Public License as published by
-- the Free Software Foundation, either version 2 of the License, or
-- (at your option) any later version.
--
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-- GNU General Public License for more details.
--
-- You should have received a copy of the GNU General Public License
-- along with this program. If not, see <gnu.org/licenses>.
with Grt.Algos;
with Errorout; use Errorout;
with Name_Table;
with Str_Table;
with Flags; use Flags;
with Vhdl.Std_Package; use Vhdl.Std_Package;
with Vhdl.Errors; use Vhdl.Errors;
with Vhdl.Utils; use Vhdl.Utils;
with Vhdl.Evaluation; use Vhdl.Evaluation;
with Vhdl.Nodes_Utils; use Vhdl.Nodes_Utils;
with Vhdl.Sem_Scopes; use Vhdl.Sem_Scopes;
with Vhdl.Sem_Names; use Vhdl.Sem_Names;
with Vhdl.Sem;
with Vhdl.Sem_Types;
with Vhdl.Sem_Stmts; use Vhdl.Sem_Stmts;
with Vhdl.Sem_Assocs; use Vhdl.Sem_Assocs;
with Vhdl.Sem_Decls;
with Vhdl.Sem_Psl;
with Vhdl.Xrefs; use Vhdl.Xrefs;
package body Vhdl.Sem_Expr is
-- Replace type of TARGET by A_TYPE.
-- If TARGET has already a type, it must be an overload list, and in this
-- case, this list is freed, or it must be A_TYPE.
-- A_TYPE can't be an overload list.
--
-- This procedure can be called in the second pass, when the type is known.
procedure Replace_Type (Target: Iir; A_Type: Iir)
is
Old_Type: Iir;
begin
pragma Assert (not Is_Overload_List (A_Type));
Old_Type := Get_Type (Target);
if Old_Type /= Null_Iir then
if Is_Overload_List (Old_Type) then
Free_Iir (Old_Type);
elsif Old_Type = A_Type then
return;
else
-- Cannot replace an existing type by another one.
raise Internal_Error;
end if;
end if;
if A_Type = Null_Iir then
return;
end if;
Set_Type (Target, A_Type);
end Replace_Type;
-- Return true if EXPR is overloaded, ie has several meanings.
function Is_Overloaded (Expr : Iir) return Boolean
is
Expr_Type : constant Iir := Get_Type (Expr);
begin
return Expr_Type = Null_Iir or else Is_Overload_List (Expr_Type);
end Is_Overloaded;
-- Return the common type of base types LEFT and RIGHT.
-- LEFT are RIGHT must be really base types (not subtypes).
-- Roughly speaking, it returns LEFT (= RIGHT) if LEFT = RIGHT (ie, same
-- type), null otherwise.
-- However, it handles implicite conversions of universal types.
function Get_Common_Basetype (Left: Iir; Right: Iir)
return Iir is
begin
if Left = Right then
return Left;
end if;
case Get_Kind (Left) is
when Iir_Kind_Integer_Type_Definition =>
if Right = Convertible_Integer_Type_Definition then
return Left;
elsif Left = Convertible_Integer_Type_Definition
and then Get_Kind (Right) = Iir_Kind_Integer_Type_Definition
then
return Right;
end if;
when Iir_Kind_Floating_Type_Definition =>
if Right = Convertible_Real_Type_Definition then
return Left;
elsif Left = Convertible_Real_Type_Definition
and then Get_Kind (Right) = Iir_Kind_Floating_Type_Definition
then
return Right;
end if;
when others =>
null;
end case;
return Null_Iir;
end Get_Common_Basetype;
-- LEFT are RIGHT must be really a type (not a subtype).
function Are_Basetypes_Compatible (Left: Iir; Right: Iir)
return Compatibility_Level is
begin
if Left = Right then
return Fully_Compatible;
end if;
case Get_Kind (Left) is
when Iir_Kind_Integer_Type_Definition =>
if Right = Convertible_Integer_Type_Definition then
if Left = Universal_Integer_Type_Definition then
return Fully_Compatible;
else
return Via_Conversion;
end if;
elsif Left = Convertible_Integer_Type_Definition
and then Get_Kind (Right) = Iir_Kind_Integer_Type_Definition
then
if Right = Universal_Integer_Type_Definition then
return Fully_Compatible;
else
return Via_Conversion;
end if;
end if;
when Iir_Kind_Floating_Type_Definition =>
if Right = Convertible_Real_Type_Definition then
if Left = Universal_Real_Type_Definition then
return Fully_Compatible;
else
return Via_Conversion;
end if;
elsif Left = Convertible_Real_Type_Definition
and then Get_Kind (Right) = Iir_Kind_Floating_Type_Definition
then
if Right = Universal_Real_Type_Definition then
return Fully_Compatible;
else
return Via_Conversion;
end if;
end if;
when others =>
null;
end case;
return Not_Compatible;
end Are_Basetypes_Compatible;
function Are_Types_Compatible (Left: Iir; Right: Iir)
return Compatibility_Level is
begin
return Are_Basetypes_Compatible (Get_Base_Type (Left),
Get_Base_Type (Right));
end Are_Types_Compatible;
function Are_Nodes_Compatible (Left: Iir; Right: Iir)
return Compatibility_Level is
begin
return Are_Types_Compatible (Get_Type (Left), Get_Type (Right));
end Are_Nodes_Compatible;
-- Return TRUE iif LEFT_TYPE and RIGHT_TYPES are compatible. RIGHT_TYPES
-- may be an overload list.
function Compatibility_Types1 (Left_Type : Iir; Right_Types : Iir)
return Compatibility_Level
is
El : Iir;
Right_List : Iir_List;
It : List_Iterator;
Level : Compatibility_Level;
begin
pragma Assert (not Is_Overload_List (Left_Type));
if Is_Overload_List (Right_Types) then
Right_List := Get_Overload_List (Right_Types);
Level := Not_Compatible;
It := List_Iterate (Right_List);
while Is_Valid (It) loop
El := Get_Element (It);
Level := Compatibility_Level'Max
(Level, Are_Types_Compatible (Left_Type, El));
if Level = Fully_Compatible then
return Fully_Compatible;
end if;
Next (It);
end loop;
return Level;
else
return Are_Types_Compatible (Left_Type, Right_Types);
end if;
end Compatibility_Types1;
-- Return compatibility for nodes LEFT and RIGHT.
-- LEFT is expected to be an interface of a function definition.
-- Type of RIGHT can be an overload_list
-- RIGHT might be implicitly converted to LEFT.
function Compatibility_Nodes (Left : Iir; Right : Iir)
return Compatibility_Level
is
Left_Type : constant Iir := Get_Base_Type (Get_Type (Left));
Right_Type : constant Iir := Get_Type (Right);
begin
-- Check.
case Get_Kind (Left_Type) is
when Iir_Kind_Floating_Type_Definition
| Iir_Kind_Enumeration_Type_Definition
| Iir_Kind_Integer_Type_Definition
| Iir_Kind_Record_Type_Definition
| Iir_Kind_File_Type_Definition
| Iir_Kind_Physical_Type_Definition
| Iir_Kind_Access_Type_Definition
| Iir_Kind_Array_Type_Definition =>
null;
when others =>
Error_Kind ("compatibility_nodes", Left_Type);
end case;
return Compatibility_Types1 (Left_Type, Right_Type);
end Compatibility_Nodes;
function Is_String_Type (A_Type : Iir) return Boolean
is
Base_Type : constant Iir := Get_Base_Type (A_Type);
El_Bt : Iir;
begin
-- LRM 7.3.1
-- [...] the type of the literal must be a one-dimensional array ...
if not Is_One_Dimensional_Array_Type (Base_Type) then
return False;
end if;
-- LRM 7.3.1
-- ... of a character type ...
El_Bt := Get_Base_Type (Get_Element_Subtype (Base_Type));
if Get_Kind (El_Bt) /= Iir_Kind_Enumeration_Type_Definition then
return False;
end if;
-- FIXME: character type
return True;
end Is_String_Type;
-- Return TRUE iff A_TYPE can be the type of string or bit string literal
-- EXPR. EXPR is needed to distinguish between string and bit string
-- for VHDL87 rule about the type of a bit string.
function Is_String_Literal_Type (A_Type : Iir; Expr : Iir) return Boolean
is
El_Bt : Iir;
begin
if not Is_String_Type (A_Type) then
return False;
end if;
El_Bt := Get_Base_Type (Get_Element_Subtype (A_Type));
-- LRM87 7.3.1
-- ... (for string literals) or of type BIT (for bit string literals).
if Flags.Vhdl_Std = Vhdl_87
and then Get_Bit_String_Base (Expr) /= Base_None
and then El_Bt /= Bit_Type_Definition
then
return False;
end if;
return True;
end Is_String_Literal_Type;
-- Return TRUE iff A_TYPE can be the type of an aggregate.
function Is_Aggregate_Type (A_Type : Iir) return Boolean is
begin
-- LRM 7.3.2 Aggregates
-- [...] the type of the aggregate must be a composite type.
case Get_Kind (Get_Base_Type (A_Type)) is
when Iir_Kind_Array_Type_Definition
| Iir_Kind_Record_Type_Definition =>
return True;
when others =>
return False;
end case;
end Is_Aggregate_Type;
-- Return TRUE iff A_TYPE can be the type of a null literal.
function Is_Null_Literal_Type (A_Type : Iir) return Boolean is
begin
-- LRM 7.3.1 Literals
-- The literal NULL represents the null access value for any access
-- type.
return
Get_Kind (Get_Base_Type (A_Type)) = Iir_Kind_Access_Type_Definition;
end Is_Null_Literal_Type;
-- Return TRUE iff A_TYPE can be the type of allocator EXPR. Note that
-- the allocator must have been analyzed.
function Is_Allocator_Type (A_Type : Iir; Expr : Iir) return Boolean
is
Base_Type : constant Iir := Get_Base_Type (A_Type);
Designated_Type : Iir;
begin
-- LRM 7.3.6 Allocators
-- [...] the value returned is of an access type having the named
-- designated type.
if Get_Kind (Base_Type) /= Iir_Kind_Access_Type_Definition then
return False;
end if;
Designated_Type := Get_Allocator_Designated_Type (Expr);
pragma Assert (Designated_Type /= Null_Iir);
-- Cheat: there is no allocators on universal types.
return Get_Base_Type (Get_Designated_Type (Base_Type))
= Get_Base_Type (Designated_Type);
end Is_Allocator_Type;
-- Return TRUE iff the type of EXPR is compatible with A_TYPE
function Is_Expr_Compatible (A_Type : Iir; Expr : Iir)
return Compatibility_Level
is
Expr_Type : constant Iir := Get_Type (Expr);
Is_Compatible : Boolean;
begin
if Expr_Type /= Null_Iir then
return Compatibility_Types1 (A_Type, Expr_Type);
end if;
case Get_Kind (Expr) is
when Iir_Kind_Aggregate =>
Is_Compatible := Is_Aggregate_Type (A_Type);
when Iir_Kind_String_Literal8 =>
Is_Compatible := Is_String_Literal_Type (A_Type, Expr);
when Iir_Kind_Null_Literal =>
Is_Compatible := Is_Null_Literal_Type (A_Type);
when Iir_Kind_Allocator_By_Expression
| Iir_Kind_Allocator_By_Subtype =>
Is_Compatible := Is_Allocator_Type (A_Type, Expr);
when Iir_Kind_Parenthesis_Expression =>
return Is_Expr_Compatible (A_Type, Get_Expression (Expr));
when others =>
-- Error while EXPR was typed. FIXME: should create an ERROR
-- node?
Is_Compatible := False;
end case;
if Is_Compatible then
return Fully_Compatible;
else
return Not_Compatible;
end if;
end Is_Expr_Compatible;
function Check_Is_Expression (Expr : Iir; Loc : Iir) return Iir
is
begin
if Expr = Null_Iir then
return Null_Iir;
end if;
case Get_Kind (Expr) is
when Iir_Kind_Type_Declaration
| Iir_Kind_Subtype_Declaration
| Iir_Kinds_Subtype_Definition
| Iir_Kind_Design_Unit
| Iir_Kind_Architecture_Body
| Iir_Kind_Configuration_Declaration
| Iir_Kind_Entity_Declaration
| Iir_Kind_Package_Declaration
| Iir_Kind_Package_Instantiation_Declaration
| Iir_Kinds_Concurrent_Statement
| Iir_Kinds_Sequential_Statement
| Iir_Kind_Library_Declaration
| Iir_Kind_Library_Clause
| Iir_Kind_Component_Declaration
| Iir_Kind_Procedure_Declaration
| Iir_Kind_Range_Array_Attribute
| Iir_Kind_Reverse_Range_Array_Attribute
| Iir_Kind_Element_Declaration
| Iir_Kind_Attribute_Declaration
| Iir_Kind_Psl_Declaration
| Iir_Kind_Signature
| Iir_Kind_Interface_Terminal_Declaration
| Iir_Kind_Terminal_Declaration =>
Error_Msg_Sem (+Loc, "%n not allowed in an expression", +Expr);
return Null_Iir;
when Iir_Kind_Function_Declaration =>
return Expr;
when Iir_Kind_Overload_List =>
return Expr;
when Iir_Kinds_Literal
| Iir_Kind_Character_Literal
| Iir_Kind_Simple_Aggregate
| Iir_Kind_Unit_Declaration
| Iir_Kind_Enumeration_Literal =>
return Expr;
when Iir_Kinds_External_Name =>
return Expr;
when Iir_Kinds_Object_Declaration
| Iir_Kind_Aggregate
| Iir_Kind_Allocator_By_Expression
| Iir_Kind_Allocator_By_Subtype
| Iir_Kind_Qualified_Expression
| Iir_Kind_Overflow_Literal =>
return Expr;
when Iir_Kinds_Dyadic_Operator
| Iir_Kinds_Monadic_Operator =>
return Expr;
when Iir_Kind_Slice_Name
| Iir_Kind_Indexed_Name
| Iir_Kind_Selected_Element
| Iir_Kind_Dereference
| Iir_Kind_Implicit_Dereference
| Iir_Kinds_Expression_Attribute
| Iir_Kind_Attribute_Value
| Iir_Kind_Parenthesis_Expression
| Iir_Kind_Type_Conversion
| Iir_Kind_Function_Call =>
return Expr;
when Iir_Kind_Psl_Endpoint_Declaration
| Iir_Kind_Psl_Prev
| Iir_Kind_Psl_Stable
| Iir_Kind_Psl_Rose
| Iir_Kind_Psl_Fell
| Iir_Kind_Psl_Onehot
| Iir_Kind_Psl_Onehot0 =>
return Expr;
when Iir_Kind_Simple_Name
| Iir_Kind_Parenthesis_Name
| Iir_Kind_Attribute_Name
| Iir_Kind_Selected_Name
| Iir_Kind_Selected_By_All_Name =>
return Expr;
when Iir_Kind_Error =>
return Expr;
when others =>
Error_Kind ("check_is_expression", Expr);
--N := Get_Type (Expr);
--return Expr;
end case;
end Check_Is_Expression;
-- Find a type compatible with A_TYPE in TYPE_LIST (which can be an
-- overload list or a simple type) and return it.
-- In case of failure, return null.
function Search_Overloaded_Type (Type_List: Iir; A_Type: Iir)
return Iir
is
Type_List_List : Iir_List;
It : List_Iterator;
El: Iir;
Com : Iir;
Res : Iir;
begin
if not Is_Overload_List (Type_List) then
return Get_Common_Basetype (Get_Base_Type (Type_List),
Get_Base_Type (A_Type));
else
Type_List_List := Get_Overload_List (Type_List);
Res := Null_Iir;
It := List_Iterate (Type_List_List);
while Is_Valid (It) loop
El := Get_Element (It);
Com := Get_Common_Basetype (Get_Base_Type (El),
Get_Base_Type (A_Type));
if Com /= Null_Iir then
if Res = Null_Iir then
Res := Com;
else
-- Several compatible types.
return Null_Iir;
end if;
end if;
Next (It);
end loop;
return Res;
end if;
end Search_Overloaded_Type;
-- LIST1, LIST2 are either a type node or an overload list of types.
-- Return THE type which is compatible with LIST1 are LIST2.
-- Return null_iir if there is no such type or if there are several types.
function Search_Compatible_Type (List1, List2 : Iir) return Iir
is
List1_List : Iir_List;
It : List_Iterator;
Res : Iir;
El : Iir;
Tmp : Iir;
begin
if Is_Overload_List (List1) then
List1_List := Get_Overload_List (List1);
Res := Null_Iir;
It := List_Iterate (List1_List);
while Is_Valid (It) loop
El := Get_Element (It);
Tmp := Search_Overloaded_Type (List2, El);
if Tmp /= Null_Iir then
if Res = Null_Iir then
Res := Tmp;
else
-- Several types match.
return Null_Iir;
end if;
end if;
Next (It);
end loop;
return Res;
else
return Search_Overloaded_Type (List2, List1);
end if;
end Search_Compatible_Type;
-- Analyze the range expression EXPR.
-- If A_TYPE is not null_iir, EXPR is expected to be of type A_TYPE.
-- LRM93 3.2.1.1
-- FIXME: avoid to run it on an already analyzed node, be careful
-- with range_type_expr.
function Sem_Simple_Range_Expression
(Expr: Iir_Range_Expression; A_Type: Iir; Any_Dir : Boolean)
return Iir_Range_Expression
is
Base_Type: Iir;
Left, Right: Iir;
Left_Type, Right_Type : Iir;
Expr_Type : Iir;
begin
Expr_Type := Get_Type (Expr);
Left := Get_Left_Limit_Expr (Expr);
Right := Get_Right_Limit_Expr (Expr);
if Expr_Type = Null_Iir then
-- Pass 1.
if A_Type = Null_Iir then
Base_Type := Null_Iir;
else
Base_Type := Get_Base_Type (A_Type);
end if;
-- Analyze left and right bounds.
Right := Sem_Expression_Ov (Right, Base_Type);
Left := Sem_Expression_Ov (Left, Base_Type);
if Left = Null_Iir or else Right = Null_Iir then
if A_Type /= Null_Iir then
-- Can continue with the error.
if Left = Null_Iir then
Left := Create_Error_Expr
(Get_Left_Limit_Expr (Expr), A_Type);
end if;
if Right = Null_Iir then
Right := Create_Error_Expr
(Get_Right_Limit_Expr (Expr), A_Type);
end if;
else
-- Error.
return Null_Iir;
end if;
end if;
Left_Type := Get_Type (Left);
Right_Type := Get_Type (Right);
-- Check for string or aggregate literals
-- FIXME: improve error message
if Left_Type = Null_Iir then
Error_Msg_Sem (+Left, "bad expression for a scalar");
return Null_Iir;
end if;
if Right_Type = Null_Iir then
Error_Msg_Sem (+Right, "bad expression for a scalar");
return Null_Iir;
end if;
if Is_Overload_List (Left_Type)
or else Is_Overload_List (Right_Type)
then
if Base_Type /= Null_Iir then
-- Cannot happen, since sem_expression_ov should resolve
-- ambiguties if a type is given.
raise Internal_Error;
end if;
-- Try to find a common type.
Expr_Type := Search_Compatible_Type (Left_Type, Right_Type);
if Expr_Type = Null_Iir then
if Compatibility_Types1 (Universal_Integer_Type_Definition,
Left_Type) /= Not_Compatible
and then
Compatibility_Types1 (Universal_Integer_Type_Definition,
Right_Type) /= Not_Compatible
then
Expr_Type := Universal_Integer_Type_Definition;
elsif Compatibility_Types1 (Universal_Real_Type_Definition,
Left_Type) /= Not_Compatible
and then
Compatibility_Types1 (Universal_Real_Type_Definition,
Right_Type) /= Not_Compatible
then
Expr_Type := Universal_Real_Type_Definition;
else
-- FIXME: handle overload
Error_Msg_Sem
(+Expr,
"left and right expressions of range are not compatible");
return Null_Iir;
end if;
end if;
Left := Sem_Expression (Left, Expr_Type);
Right := Sem_Expression (Right, Expr_Type);
if Left = Null_Iir or else Right = Null_Iir then
return Null_Iir;
end if;
else
Expr_Type := Get_Common_Basetype (Get_Base_Type (Left_Type),
Get_Base_Type (Right_Type));
if Expr_Type = Null_Iir then
Error_Msg_Sem
(+Expr,
"left and right expressions of range are not compatible");
return Null_Iir;
end if;
end if;
-- The type of the range is known, finish analysis.
else
-- Second call.
pragma Assert (A_Type /= Null_Iir);
if Is_Overload_List (Expr_Type) then
-- FIXME: resolve overload
raise Internal_Error;
else
if Are_Types_Compatible (Expr_Type, A_Type) = Not_Compatible then
Error_Msg_Sem
(+Expr, "type of range doesn't match expected type");
return Null_Iir;
end if;
return Expr;
end if;
end if;
Check_Read (Left);
Check_Read (Right);
Left := Eval_Expr_If_Static (Left);
Right := Eval_Expr_If_Static (Right);
Set_Left_Limit_Expr (Expr, Left);
Set_Right_Limit_Expr (Expr, Right);
Set_Left_Limit (Expr, Left);
Set_Right_Limit (Expr, Right);
Set_Expr_Staticness (Expr, Min (Get_Expr_Staticness (Left),
Get_Expr_Staticness (Right)));
if A_Type /= Null_Iir then
if Are_Types_Compatible (Expr_Type, A_Type) = Not_Compatible then
Error_Msg_Sem (+Expr, "type of range doesn't match expected type");
return Null_Iir;
end if;
-- Use A_TYPE for the type of the expression.
Expr_Type := A_Type;
end if;
Set_Type (Expr, Expr_Type);
if Get_Kind (Expr_Type)
not in Iir_Kinds_Scalar_Type_And_Subtype_Definition
then
Error_Msg_Sem (+Expr, "type of range is not a scalar type");
return Null_Iir;
end if;
if Get_Expr_Staticness (Expr) = Locally
and then Get_Type_Staticness (Expr_Type) = Locally
and then Get_Kind (Expr_Type) in Iir_Kinds_Subtype_Definition
then
Eval_Check_Range (Expr, Expr_Type, Any_Dir);