-- Semantic analysis pass.
-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold
--
-- GHDL 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, or (at your option) any later
-- version.
--
-- GHDL 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 GHDL; see the file COPYING. If not, write to the Free
-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
-- 02111-1307, USA.
with Errorout; use Errorout;
with Libraries;
with Std_Names;
with Flags; use Flags;
with Str_Table;
with Vhdl.Errors; use Vhdl.Errors;
with Vhdl.Std_Package; use Vhdl.Std_Package;
with Vhdl.Ieee.Std_Logic_1164;
with Vhdl.Sem_Scopes; use Vhdl.Sem_Scopes;
with Vhdl.Sem_Expr; use Vhdl.Sem_Expr;
with Vhdl.Sem_Names; use Vhdl.Sem_Names;
with Vhdl.Sem_Specs; use Vhdl.Sem_Specs;
with Vhdl.Sem_Decls; use Vhdl.Sem_Decls;
with Vhdl.Sem_Assocs; use Vhdl.Sem_Assocs;
with Vhdl.Sem_Inst;
with Vhdl.Sem_Lib; use Vhdl.Sem_Lib;
with Vhdl.Sem_Psl;
with Vhdl.Utils; use Vhdl.Utils;
with Vhdl.Sem_Utils;
with Vhdl.Sem_Stmts; use Vhdl.Sem_Stmts;
with Vhdl.Nodes_Utils;
with Vhdl.Xrefs; use Vhdl.Xrefs;
package body Vhdl.Sem is
-- Forward declarations.
procedure Sem_Context_Clauses (Unit: Iir);
procedure Sem_Block_Configuration
(Block_Conf : Iir_Block_Configuration; Father: Iir);
procedure Sem_Component_Configuration
(Conf : Iir_Component_Configuration; Father : Iir);
procedure Add_Dependence (Unit : Iir)
is
Targ : constant Iir := Get_Current_Design_Unit;
begin
-- During normal analysis, there is a current design unit. But not
-- during debugging outside of any context.
if Targ = Null_Iir then
return;
end if;
Add_Dependence (Targ, Unit);
end Add_Dependence;
-- LRM 1.1 Entity declaration.
procedure Sem_Entity_Declaration (Entity : Iir_Entity_Declaration) is
begin
Xrefs.Xref_Decl (Entity);
Sem_Scopes.Add_Name (Entity);
Set_Visible_Flag (Entity, True);
Set_Is_Within_Flag (Entity, True);
-- LRM 10.1
-- 1. An entity declaration, together with a corresponding architecture
-- body.
Open_Declarative_Region;
-- Sem generics.
Sem_Interface_Chain (Get_Generic_Chain (Entity), Generic_Interface_List);
-- Sem ports.
Sem_Interface_Chain (Get_Port_Chain (Entity), Port_Interface_List);
-- Entity declarative part and concurrent statements.
Sem_Block (Entity);
Close_Declarative_Region;
Set_Is_Within_Flag (Entity, False);
end Sem_Entity_Declaration;
-- Get the entity unit for LIBRARY_UNIT (an architecture or a
-- configuration declaration).
-- Return NULL_IIR in case of error (not found, bad library).
function Sem_Entity_Name (Library_Unit : Iir) return Iir
is
Name : Iir;
Library : Iir_Library_Declaration;
Entity : Iir;
begin
-- Get the library of architecture/configuration.
Library := Get_Library
(Get_Design_File (Get_Design_Unit (Library_Unit)));
-- Resolve the name.
Name := Get_Entity_Name (Library_Unit);
if Is_Error (Name) then
pragma Assert (Flags.Flag_Force_Analysis);
return Null_Iir;
end if;
if Get_Kind (Name) = Iir_Kind_Simple_Name then
-- LRM93 10.1 Declarative Region
-- LRM08 12.1 Declarative Region
-- a) An entity declaration, tohether with a corresponding
-- architecture body.
--
-- GHDL: simple name needs to be handled specially. Because
-- architecture body is in the declarative region of its entity,
-- the entity name is directly visible. But we cannot really use
-- that rule as is, as we don't know which is the entity.
Entity := Load_Primary_Unit
(Library, Get_Identifier (Name), Library_Unit);
if Entity = Null_Iir then
Error_Msg_Sem (+Name, "entity %n was not analysed", +Name);
return Null_Iir;
end if;
Entity := Get_Library_Unit (Entity);
Set_Named_Entity (Name, Entity);
Xrefs.Xref_Ref (Name, Entity);
else
-- Certainly an expanded name. Use the standard name analysis.
Name := Sem_Denoting_Name (Name);
Set_Entity_Name (Library_Unit, Name);
Entity := Get_Named_Entity (Name);
end if;
if Get_Kind (Entity) /= Iir_Kind_Entity_Declaration then
Error_Class_Match (Name, "entity");
return Null_Iir;
end if;
-- LRM 1.2 Architecture bodies
-- For a given design entity, both the entity declaration and the
-- associated architecture body must reside in the same library.
-- LRM 1.3 Configuration Declarations
-- For a configuration of a given design entity, both the
-- configuration declaration and the corresponding entity
-- declaration must reside in the same library.
if Get_Library (Get_Design_File (Get_Design_Unit (Entity))) /= Library
then
Error_Msg_Sem
(+Library_Unit, "%n does not reside in %n", (+Entity, +Library));
return Null_Iir;
end if;
return Entity;
end Sem_Entity_Name;
-- LRM 1.2 Architecture bodies.
procedure Sem_Architecture_Body (Arch: Iir_Architecture_Body)
is
Entity_Unit : Iir_Design_Unit;
Entity_Library : Iir_Entity_Declaration;
begin
Xrefs.Xref_Decl (Arch);
-- First, find the entity.
Entity_Library := Sem_Entity_Name (Arch);
if Entity_Library = Null_Iir then
return;
end if;
Entity_Unit := Get_Design_Unit (Entity_Library);
-- LRM93 11.4
-- In each case, the second unit depends on the first unit.
-- GHDL: an architecture depends on its entity.
Add_Dependence (Entity_Unit);
Add_Context_Clauses (Entity_Unit);
Set_Is_Within_Flag (Arch, True);
Set_Is_Within_Flag (Entity_Library, True);
-- Makes the entity name visible.
-- FIXME: quote LRM.
Sem_Scopes.Add_Name
(Entity_Library, Get_Identifier (Entity_Library), False);
-- LRM 10.1 Declarative Region
-- 1. An entity declaration, together with a corresponding architecture
-- body.
Open_Declarative_Region;
Sem_Scopes.Add_Entity_Declarations (Entity_Library);
-- LRM02 1.2 Architecture bodies
-- For the purpose of interpreting the scope and visibility of the
-- identifier (see 10.2 and 10.3), the declaration of the identifier is
-- considered to occur after the final declarative item of the entity
-- declarative part of the corresponding entity declaration.
--
-- FIXME: before VHDL-02, an architecture is not a declaration.
Sem_Scopes.Add_Name (Arch, Get_Identifier (Arch), True);
Set_Visible_Flag (Arch, True);
-- LRM02 10.1 Declarative region
-- The declarative region associated with an architecture body is
-- considered to occur immediatly within the declarative region
-- associated with the entity declaration corresponding to the given
-- architecture body.
--
-- GHDL: this is only in vhdl-2002.
if Vhdl_Std = Vhdl_02 then
Open_Declarative_Region;
end if;
Current_Psl_Default_Clock := Null_Iir;
Sem_Block (Arch);
if Vhdl_Std = Vhdl_02 then
Close_Declarative_Region;
end if;
Close_Declarative_Region;
Set_Is_Within_Flag (Arch, False);
Set_Is_Within_Flag (Entity_Library, False);
end Sem_Architecture_Body;
-- Return the real resolver used for (sub) object OBJ.
-- Return NULL_IIR if none.
function Get_Resolver (Obj : Iir) return Iir
is
Obj_Type : Iir;
Res : Iir;
begin
case Get_Kind (Obj) is
when Iir_Kind_Indexed_Name
| Iir_Kind_Slice_Name
| Iir_Kind_Selected_Element =>
Res := Get_Resolver (Get_Prefix (Obj));
if Res /= Null_Iir then
return Res;
end if;
when Iir_Kind_Signal_Declaration
| Iir_Kind_Interface_Signal_Declaration
| Iir_Kind_Guard_Signal_Declaration =>
null;
when Iir_Kind_Object_Alias_Declaration =>
return Get_Resolver (Get_Name (Obj));
when Iir_Kind_Simple_Name
| Iir_Kind_Selected_Name =>
return Get_Resolver (Get_Named_Entity (Obj));
when others =>
Error_Kind ("get_resolved", Obj);
end case;
Obj_Type := Get_Type (Obj);
if Get_Kind (Obj_Type) in Iir_Kinds_Subtype_Definition then
return Get_Resolution_Indication (Obj_Type);
else
return Null_Iir;
end if;
end Get_Resolver;
-- Return TRUE iff the actual of ASSOC can be the formal.
-- ASSOC must be an association_element_by_expression.
function Can_Collapse_Signals (Assoc : Iir; Formal : Iir) return Boolean
is
Actual : Iir;
Actual_Res : Iir;
Formal_Res : Iir;
Formal_Base : Iir;
Actual_Base : Iir;
begin
-- If there is a conversion, signals types are not necessarily
-- the same, and sharing is not possible.
-- FIXME: optimize type conversions
-- (unsigned <-> signed <-> std_ulogic_vector <-> ...)
if Get_Actual_Conversion (Assoc) /= Null_Iir
or else Get_Formal_Conversion (Assoc) /= Null_Iir
then
return False;
end if;
-- Here we may assume formal and actual have the same type and the
-- same lengths. This is caught at elaboration time.
Actual := Name_To_Object (Get_Actual (Assoc));
if Actual = Null_Iir then
-- This is an expression.
return False;
end if;
Formal_Base := Get_Object_Prefix (Formal);
Actual_Base := Get_Object_Prefix (Actual);
-- If the formal is of mode IN, then it has no driving value, and its
-- effective value is the effective value of the actual.
-- Always collapse in this case.
if Get_Mode (Formal_Base) = Iir_In_Mode then
return True;
end if;
-- Otherwise, these rules are applied:
--
-- In this table, E means element, S means signal.
-- Er means the element is resolved,
-- Sr means the signal is resolved (at the signal level).
--
-- Actual
-- | E,S | Er,S | E,Sr | Er,Sr |
-- ------+-------+-------+-------+-------+
-- E,S |collap | no(3) | no(3) | no(3) |
-- ------+-------+-------+-------+-------+
-- Er,S | no(1) |if same| no(2) | no(2) |
-- Formal ------+-------+-------+-------+-------+
-- E,Sr | no(1) | no(2) |if same| no(4) |
-- ------+-------+-------+-------+-------+
-- Er,Sr | no(1) | no(2) | no(4) |if same|
-- ------+-------+-------+-------+-------+
--
-- Notes: (1): formal may have several sources.
-- (2): resolver is not the same.
-- (3): this prevents to catch several sources error in instance.
-- (4): resolver is not the same, because the types are not the
-- same.
--
-- Furthermore, signals cannot be collapsed if the kind (none, bus or
-- register) is not the same.
--
-- Default value: default value is the effective value.
-- Resolution function.
Actual_Res := Get_Resolver (Actual);
Formal_Res := Get_Resolver (Formal);
-- If the resolutions are not the same, signals cannot be collapsed.
if Actual_Res /= Formal_Res then
return False;
end if;
-- If neither the actual nor the formal is resolved, then collapsing is
-- possible.
-- (this is case ES/ES).
if Actual_Res = Null_Iir and Formal_Res = Null_Iir then
return True;
end if;
-- If the formal can have sources and is guarded, but the actual is
-- not guarded (or has not the same kind of guard), signals cannot
-- be collapsed.
if (Get_Guarded_Signal_Flag (Formal_Base)
/= Get_Guarded_Signal_Flag (Actual_Base))
or else (Get_Signal_Kind (Formal_Base)
/= Get_Signal_Kind (Actual_Base))
then
return False;
end if;
return True;
end Can_Collapse_Signals;
-- INTER_PARENT contains generics interfaces;
-- ASSOC_PARENT constains generic aspects.
function Sem_Generic_Association_Chain
(Inter_Parent : Iir; Assoc_Parent : Iir) return Boolean
is
El : Iir;
Match : Compatibility_Level;
Assoc_Chain : Iir;
Inter_Chain : Iir;
Miss : Missing_Type;
begin
-- LRM08 6.5.6.2 Generic clauses
-- If no such actual is specified for a given formal generic constant
-- (either because the formal generic is unassociated or because the
-- actual is open), and if a default expression is specified for that
-- generic, the value of this expression is the value of the generic.
-- It is an error if no actual is specified for a given formal generic
-- constant and no default expression is present in the corresponding
-- interface element.
-- Note: CHECK_MATCH argument of sem_subprogram_arguments must be
-- true if parent is a component instantiation.
case Get_Kind (Assoc_Parent) is
when Iir_Kind_Component_Instantiation_Statement =>
-- LRM 9.6 Component Instantiation Statement
-- Each local generic (or subelement or slice thereof) must be
-- associated {VHDL87: exactly}{VHDL93: at most} once.
-- ...
-- Each local port (or subelement or slice therof) must be
-- associated {VHDL87: exactly}{VHDL93: at most} once.
-- GHDL: for a direct instantiation, follow rules of
-- LRM 1.1.1.1 Generic and LRM 1.1.1.2 Ports.
-- The difference between 87 and 93 is simply a clarification:
-- missing association are left open, but need a default
-- expression in the formal declaration.
Miss := Missing_Generic;
when Iir_Kind_Binding_Indication =>
-- LRM 5.2.1.2 Generic map and port map aspects
Miss := Missing_Allowed;
when Iir_Kind_Block_Header =>
Miss := Missing_Generic;
when Iir_Kind_Package_Instantiation_Declaration
| Iir_Kind_Interface_Package_Declaration
| Iir_Kind_Package_Header =>
-- LRM08 4.9
-- Each formal generic (or member thereof) shall be associated
-- at most once.
Miss := Missing_Generic;
when others =>
Error_Kind ("sem_generic_association_list", Assoc_Parent);
end case;
-- The generics
Inter_Chain := Get_Generic_Chain (Inter_Parent);
Assoc_Chain := Get_Generic_Map_Aspect_Chain (Assoc_Parent);
-- Extract non-object associations, as the actual cannot be analyzed
-- as an expression.
Assoc_Chain := Extract_Non_Object_Association (Assoc_Chain, Inter_Chain);
Set_Generic_Map_Aspect_Chain (Assoc_Parent, Assoc_Chain);
if not Sem_Actual_Of_Association_Chain (Assoc_Chain) then
return False;
end if;
Sem_Association_Chain
(Inter_Chain, Assoc_Chain, True, Miss, Assoc_Parent, Match);
Set_Generic_Map_Aspect_Chain (Assoc_Parent, Assoc_Chain);
if Match = Not_Compatible then
return False;
end if;
-- LRM 5.2.1.2 Generic map and port map aspects
-- An actual associated with a formal generic map aspect must be an
-- expression or the reserved word open;
El := Assoc_Chain;
while El /= Null_Iir loop
case Get_Kind (El) is
when Iir_Kind_Association_Element_By_Expression =>
Check_Read (Get_Actual (El));
when Iir_Kind_Association_Element_Open
| Iir_Kind_Association_Element_By_Individual
| Iir_Kind_Association_Element_Package
| Iir_Kind_Association_Element_Type
| Iir_Kind_Association_Element_Subprogram =>
null;
when others =>
Error_Kind ("sem_generic_association_chain(1)", El);
end case;
El := Get_Chain (El);
end loop;
return True;
end Sem_Generic_Association_Chain;
procedure Sem_Generic_Association_Chain
(Inter_Parent : Iir; Assoc_Parent : Iir)
is
Res : Boolean;
pragma Unreferenced (Res);
begin
Res := Sem_Generic_Association_Chain (Inter_Parent, Assoc_Parent);
end Sem_Generic_Association_Chain;
-- LRM08 6.5.6.3 Port clauses
function Sem_Insert_Anonymous_Signal (Formal : Iir; Actual : Iir)
return Iir
is
Sig : Iir;
Res : Iir;
begin
-- LRM08 6.5.6.3 Port clauses
-- If a formal port of mode IN is associated with an expression that is
-- not globally static (see 9.4.1) and the formal is of an unconstrained
-- or partially constrained composite type requiring determination of
-- index ranges from the actual according to the rules of 5.3.2.2, then
-- the expression shall be one of the following:
-- - The name of an object whose subtype is globally static
-- - An indexed name whose prefix is one of the members of this list
-- - A slice name whose prefix is one of the members of this list and
-- whose discrete range is a globally static discrete range
-- - An aggregate, provided all choices are locally static and all
-- expressions in element associations are expressions described in
-- this list
-- - A function call whose return type mark denotes a globally static
-- subtype
-- - A qualified expression or type conversion whose type mark denotes
-- a globally static subtype
-- - An expression described in this list and enclosed in parentheses
-- GHDL: FIXME: could this be simplified simply by `subtype is globally
-- static` ?
-- FIXME: what about conversions ?
-- Create the anonymous signal.
Sig := Create_Iir (Iir_Kind_Anonymous_Signal_Declaration);
Location_Copy (Sig, Actual);
Set_Expression (Sig, Actual);
Set_Type (Sig, Get_Type (Formal));
Set_Expr_Staticness (Sig, None);
-- Declare it.
Add_Implicit_Declaration (Sig);
-- Return a reference to it.
-- FIXME: The referenced name is not a name.
Res := Create_Iir (Iir_Kind_Reference_Name);
Location_Copy (Res, Actual);
Set_Referenced_Name (Res, Sig);
Set_Named_Entity (Res, Sig);
Set_Type (Res, Get_Type (Sig));
Set_Expr_Staticness (Res, None);
return Res;
end Sem_Insert_Anonymous_Signal;
procedure Sem_Signal_Port_Association
(Assoc : Iir; Formal : Iir; Formal_Base : Iir)
is
Actual : Iir;
Prefix : Iir;
Object : Iir;
begin
if Get_Kind (Assoc) = Iir_Kind_Association_Element_By_Expression then
Actual := Get_Actual (Assoc);
-- There has been an error, exit from the loop.
if Actual = Null_Iir then
return;
end if;
Object := Name_To_Object (Actual);
if Is_Valid (Object) and then Is_Signal_Object (Object) then
-- Port or signal.
Set_Collapse_Signal_Flag
(Assoc, Can_Collapse_Signals (Assoc, Formal));
if Get_Name_Staticness (Object) < Globally then
Error_Msg_Sem (+Actual, "actual must be a static name");
end if;
Check_Port_Association_Bounds_Restrictions
(Formal, Actual, Assoc);
Prefix := Get_Object_Prefix (Object);
case Get_Kind (Prefix) is
when Iir_Kind_Interface_Signal_Declaration =>
declare
P : Boolean;
pragma Unreferenced (P);
begin
P := Check_Port_Association_Mode_Restrictions
(Formal_Base, Prefix, Assoc);
end;
when Iir_Kind_Signal_Declaration =>
Set_Use_Flag (Prefix, True);
when others =>
-- FIXME: attributes ?
null;
end case;
else
-- Expression.
Set_Collapse_Signal_Flag (Assoc, False);
pragma Assert (Is_Null (Get_Actual_Conversion (Assoc)));
if Flags.Vhdl_Std >= Vhdl_93c then
-- LRM93 1.1.1.2 Ports
-- Moreover, the ports of a block may be associated
-- with an expression, in order to provide these ports
-- with constant driving values; such ports must be
-- of mode in.
if Get_Mode (Formal_Base) /= Iir_In_Mode then
Error_Msg_Sem
(+Assoc, "only 'in' ports may be associated with "
& "expression");
end if;
-- Is it possible to have a globally static name that is
-- not readable ?
Check_Read (Actual);
-- LRM93 1.1.1.2 Ports
-- The actual, if an expression, must be a globally
-- static expression.
if Get_Expr_Staticness (Actual) < Globally then
if Flags.Vhdl_Std >= Vhdl_08 then
-- LRM08 6.5.6.3 Port clauses
Actual := Sem_Insert_Anonymous_Signal (Formal, Actual);
Set_Actual (Assoc, Actual);
Set_Collapse_Signal_Flag (Assoc, True);
else
Error_Msg_Sem
(+Actual,
"actual expression must be globally static");
end if;
end if;
else
Error_Msg_Sem
(+Assoc,
"cannot associate ports with expression in vhdl87");
end if;
end if;
end if;
end Sem_Signal_Port_Association;
-- INTER_PARENT contains ports interfaces;
-- ASSOC_PARENT constains ports map aspects.
procedure Sem_Port_Association_Chain
(Inter_Parent : Iir; Assoc_Parent : Iir)
is
Assoc : Iir;
Match : Compatibility_Level;
Assoc_Chain : Iir;
Inter_Chain : Iir;
Miss : Missing_Type;
Inter : Iir;
Formal : Iir;
Formal_Base : Iir;
begin
-- Note: CHECK_MATCH argument of sem_subprogram_arguments must be
-- true if parent is a component instantiation.
case Get_Kind (Assoc_Parent) is
when Iir_Kind_Component_Instantiation_Statement =>
-- LRM 9.6 Component Instantiation Statement
-- Each local generic (or subelement or slice thereof) must be
-- associated {VHDL87: exactly}{VHDL93: at most} once.
-- ...
-- Each local port (or subelement or slice therof) must be
-- associated {VHDL87: exactly}{VHDL93: at most} once.
-- GHDL: for a direct instantiation, follow rules of
-- LRM 1.1.1.1 Generic and LRM 1.1.1.2 Ports.
Miss := Missing_Port;
when Iir_Kind_Binding_Indication =>
-- LRM 5.2.1.2 Generic map and port map aspects
Miss := Missing_Allowed;
when Iir_Kind_Block_Header =>
-- FIXME: it is possible to have port unassociated ?
Miss := Missing_Port;
when others =>
Error_Kind ("sem_port_association_list", Assoc_Parent);
end case;
-- The ports
Assoc_Chain := Get_Port_Map_Aspect_Chain (Assoc_Parent);
Inter_Chain := Get_Port_Chain (Inter_Parent);
if AMS_Vhdl then
-- Mutate terminal associations, so that their formals are not
-- analyzed as an expression.
Assoc_Chain :=
Extract_Non_Object_Association (Assoc_Chain, Inter_Chain);
end if;
if not Sem_Actual_Of_Association_Chain (Assoc_Chain) then
return;
end if;
Sem_Association_Chain (Inter_Chain, Assoc_Chain,
True, Miss, Assoc_Parent, Match);
Set_Port_Map_Aspect_Chain (Assoc_Parent, Assoc_Chain);
if Match = Not_Compatible then
-- TODO: mark actual as used to avoid warnings.
return;
end if;
-- LRM 5.2.1.2 Generic map and port map aspects
-- [...]; an actual associated with a formal port in a port map aspect
-- must be a signal, an expression, or the reserved word open.
--
-- Certain restriction apply to the actual associated with a formal in
-- a port map aspect; these restrictions are described in 1.1.1.2
-- LRM93 1.1.1.2
-- The actual, if a port or signal, must be denoted by a static name.
-- The actual, if an expression, must be a globally static expression.
Assoc := Assoc_Chain;
Inter := Get_Port_Chain (Inter_Parent);
while Assoc /= Null_Iir loop
Formal := Get_Association_Formal (Assoc, Inter);
Formal_Base := Get_Interface_Of_Formal (Formal);
case Get_Kind (Formal_Base) is
when Iir_Kind_Interface_Signal_Declaration =>
Sem_Signal_Port_Association (Assoc, Formal, Formal_Base);
when others =>
null;
end case;
Next_Association_Interface (Assoc, Inter);
end loop;
end Sem_Port_Association_Chain;
-- INTER_PARENT contains generics and ports interfaces;
-- ASSOC_PARENT constains generics and ports map aspects.
procedure Sem_Generic_Port_Association_Chain
(Inter_Parent : Iir; Assoc_Parent : Iir)
is
Res : Boolean;
pragma Unreferenced (Res);
begin
Sem_Generic_Association_Chain (Inter_Parent, Assoc_Parent);
Sem_Port_Association_Chain (Inter_Parent, Assoc_Parent);
end Sem_Generic_Port_Association_Chain;
-- LRM 1.3 Configuration Declarations.
procedure Sem_Configuration_Declaration (Decl: Iir)
is
Entity: Iir_Entity_Declaration;
Entity_Unit : Iir_Design_Unit;
begin
Xref_Decl (Decl);
-- LRM 1.3
-- The entity name identifies the name of the entity declaration that
-- defines the design entity at the apex of the design hierarchy.
Entity := Sem_Entity_Name (Decl);
if Entity = Null_Iir then
return;
end if;
Entity_Unit := Get_Design_Unit (Entity);
-- LRM 11.4
-- A primary unit whose name is referenced within a given design unit
-- must be analyzed prior to the analysis of the given design unit.
Add_Dependence (Entity_Unit);
Sem_Scopes.Add_Name (Decl);
Set_Visible_Flag (Decl, True);
-- LRM 10.1 Declarative Region
-- 2. A configuration declaration.
Open_Declarative_Region;
-- LRM93 10.2
-- In addition to the above rules, the scope of any declaration that
-- includes the end of the declarative part of a given block (whether
-- it be an external block defined by a design entity or an internal
-- block defined by a block statement) extends into a configuration
-- declaration that configures the given block.
Add_Context_Clauses (Entity_Unit);
Sem_Scopes.Add_Entity_Declarations (Entity);
Sem_Declaration_Chain (Decl);
-- GHDL: no need to check for missing subprogram bodies, since they are
-- not allowed in configuration declarations.
Sem_Block_Configuration (Get_Block_Configuration (Decl), Decl);
Close_Declarative_Region;
end Sem_Configuration_Declaration;
-- Analyze the block specification of a block statement or of a generate
-- statement. Return the corresponding block statement, generate
-- statement body, or Null_Iir in case of error.
function Sem_Block_Specification_Of_Statement
(Block_Conf : Iir_Block_Configuration; Father : Iir) return Iir
is
Block_Spec : Iir;
Block_Name : Iir;
Block_Stmts : Iir;
Prev : Iir_Block_Configuration;
Block : Iir;
Res : Iir;
Assoc : Iir;
Clause : Iir;
Gen_Spec : Iir;
begin
Block_Spec := Get_Block_Specification (Block_Conf);
case Get_Kind (Block_Spec) is
when Iir_Kind_Simple_Name =>
Block_Name := Block_Spec;
when Iir_Kind_Parenthesis_Name
| Iir_Kind_Slice_Name =>
Block_Name := Get_Prefix (Block_Spec);
when others =>
Error_Msg_Sem (+Block_Spec, "label expected");
return Null_Iir;
end case;
-- Analyze the label and generate specification.
Block_Name := Sem_Denoting_Name (Block_Name);
Block := Get_Named_Entity (Block_Name);
case Get_Kind (Block) is
when Iir_Kind_Block_Statement =>
if Get_Kind (Block_Spec) /= Iir_Kind_Simple_Name then
Error_Msg_Sem (+Block_Spec,
"label does not denote a generate statement");
end if;
Set_Block_Specification (Block_Conf, Block_Name);
Prev := Get_Block_Block_Configuration (Block);
Res := Block;
when Iir_Kind_For_Generate_Statement =>
Res := Get_Generate_Statement_Body (Block);
Set_Named_Entity (Block_Name, Res);
Prev := Get_Generate_Block_Configuration (Res);
case Get_Kind (Block_Spec) is
when Iir_Kind_Simple_Name =>
Set_Block_Specification (Block_Conf, Block_Name);
when Iir_Kind_Parenthesis_Name =>
Block_Spec := Sem_Index_Specification
(Block_Spec,
Get_Type (Get_Parameter_Specification (Block)));
if Block_Spec /= Null_Iir then
Set_Prefix (Block_Spec, Block_Name);
Set_Block_Specification (Block_Conf, Block_Spec);
end if;
when others =>
raise Internal_Error;
end case;
when Iir_Kind_If_Generate_Statement =>
case Get_Kind (Block_Spec) is
when Iir_Kind_Simple_Name =>
-- LRM08 3.4.2 Block configuration
-- If no generate specification appears in such a block
-- configuration, then it applies to exactly one of the
-- following sets of blocks:
-- [...]
-- - The implicit block generated by the corresponding
-- generate statement, if and only if the corresponding
-- generate is an if generate statement and if the first
-- condition after IF evaluates to TRUE.
Res := Get_Generate_Statement_Body (Block);
-- LRM08 3.4.2 Block configuration
-- If the block specification of a block configuration
-- contains a generate statement label that denotes an if
-- generate statement, and if the first condition after IF
-- has an alternative label, then it is an error if the
-- generate statement label does not contain a generate
-- specification that is an alternative label.
if Get_Has_Label (Res) then
Error_Msg_Sem
(+Block_Spec,
"alternative label required in block specification");
end if;
Set_Block_Specification (Block_Conf, Block_Name);
when Iir_Kind_Parenthesis_Name =>
if Vhdl_Std < Vhdl_08 then
Error_Msg_Sem
(+Block_Spec,
"alternative label only allowed by vhdl08");
return Null_Iir;
end if;
Assoc := Get_Association_Chain (Block_Spec);
pragma Assert
(Get_Kind (Assoc)
= Iir_Kind_Association_Element_By_Expression);
Gen_Spec := Get_Actual (Assoc);
if Get_Kind (Gen_Spec) /= Iir_Kind_Simple_Name then
Error_Msg_Sem
(+Gen_Spec,
"alternative label expected for if-generate");
return Null_Iir;
end if;
-- Search label.
Clause := Block;
while Clause /= Null_Iir loop
Res := Get_Generate_Statement_Body (Clause);
exit when Get_Alternative_Label (Res)
= Get_Identifier (Gen_Spec);
Clause := Get_Generate_Else_Clause (Clause);
end loop;
if Clause = Null_Iir then
Error_Msg_Sem
(+Gen_Spec,
"alternative label %i not found for if-generate",
+Gen_Spec);
return Null_Iir;
end if;
Set_Named_Entity (Block_Spec, Res);
Xref_Ref (Gen_Spec, Res);
Set_Prefix (Block_Spec, Block_Name);
Set_Block_Specification (Block_Conf, Block_Spec);
when others =>
raise Internal_Error;
end case;
Set_Named_Entity (Block_Name, Res);
Prev := Get_Generate_Block_Configuration (Res);
when Iir_Kind_Case_Generate_Statement =>
case Get_Kind (Block_Spec) is
when Iir_Kind_Simple_Name =>
-- LRM08 3.4.2 Block configuration
-- If no generate specification appears in such a block
-- configuration, [...]
-- GHDL: doesn't apply to case generate statement
Error_Msg_Sem
(+Block_Spec,
"missing alternative label for a case-generate");
return Null_Iir;
when Iir_Kind_Parenthesis_Name =>
Assoc := Get_Association_Chain (Block_Spec);
pragma Assert
(Get_Kind (Assoc)
= Iir_Kind_Association_Element_By_Expression);
Gen_Spec := Get_Actual (Assoc);
if Get_Kind (Gen_Spec) /= Iir_Kind_Simple_Name then
Error_Msg_Sem
(+Gen_Spec,
"alternative label expected for case-generate");
return Null_Iir;
end if;
-- Search label.
Clause := Get_Case_Statement_Alternative_Chain (Block);
while Clause /= Null_Iir loop
Res := Get_Associated_Block (Clause);
exit when Get_Alternative_Label (Res)
= Get_Identifier (Gen_Spec);
Clause := Get_Chain (Clause);
end loop;
if Clause = Null_Iir then
Error_Msg_Sem
(+Gen_Spec,
"alternative label %i not found for case-generate",
+Gen_Spec);
return Null_Iir;
end if;
Set_Named_Entity (Block_Spec, Res);
Xref_Ref (Gen_Spec, Res);
Set_Prefix (Block_Spec, Block_Name);
Set_Block_Specification (Block_Conf, Block_Spec);
when others =>
raise Internal_Error;
end case;
Set_Named_Entity (Block_Name, Res);
Prev := Get_Generate_Block_Configuration (Res);
when others =>
Error_Msg_Sem (+Block_Conf,
"block or generate statement label expected");
return Null_Iir;
end case;
-- LRM93 1.3.1 / LRM08 3.4.2 Block configuration
-- [...], and the label must denote a block statement or generate
-- statement that is contained immediatly within the block denoted by
-- the block specification of the containing block configuration.
Block_Stmts := Get_Concurrent_Statement_Chain
(Get_Block_From_Block_Specification
(Get_Block_Specification (Father)));
if not Is_In_Chain (Block_Stmts, Block) then
Error_Msg_Sem (+Block_Conf,
"label does not denotes an inner block statement");
return Null_Iir;
end if;
case Get_Kind (Block) is
when Iir_Kind_Block_Statement =>
-- LRM93 1.3
-- It is an error if, in a given block configuration, more than
-- one configuration item is defined for the same block [or
-- component instance].
if Prev /= Null_Iir then
Error_Msg_Sem
(+Block_Conf,
"%n was already configured at %l", (+Block, +Prev));
return Null_Iir;
end if;
Set_Block_Block_Configuration (Res, Block_Conf);
when Iir_Kind_If_Generate_Statement
| Iir_Kind_Case_Generate_Statement =>
-- LRM93 1.3
-- It is an error if, in a given block configuration, more than
-- one configuration item is defined for the same block [or
-- component instance].
if Prev /= Null_Iir then
Error_Msg_Sem
(+Block_Conf,
"%n was already configured at %l", (+Block, +Prev));
return Null_Iir;
end if;
Set_Generate_Block_Configuration (Res, Block_Conf);
when Iir_Kind_For_Generate_Statement =>
-- LRM93 1.3
-- For any name that is the label of a generate statement
-- immediately wihin a given block, one or more corresponding
-- block configuration may appear as configuration items
-- immediately within a block configuration corresponding to the
-- given block.
-- GHDL: keep them in a linked list, but don't try to detect
-- duplicate as values may not be static. FIXME: try for
-- static values only ?
Set_Prev_Block_Configuration (Block_Conf, Prev);
Set_Generate_Block_Configuration (Res, Block_Conf);
when others =>
raise Internal_Error;
end case;
return Res;
end Sem_Block_Specification_Of_Statement;
-- LRM 1.3.1 Block Configuration.
-- FATHER is the block_configuration, configuration_declaration,
-- component_configuration containing the block_configuration BLOCK_CONF.
procedure Sem_Block_Configuration
(Block_Conf : Iir_Block_Configuration; Father: Iir)
is
El : Iir;
Block : Iir;
begin
case Get_Kind (Father) is
when Iir_Kind_Configuration_Declaration =>
-- LRM93 1.3.1
-- If a block configuration appears immediately within a
-- configuration declaration, then the block specification of that
-- block configuration must be an architecture name, and that
-- architecture name must denote a design entity body whose
-- interface is defined by the entity declaration denoted by the
-- entity name of the enclosing configuration declaration.
declare
Block_Spec : Iir;
Arch : Iir_Architecture_Body;
Design: Iir_Design_Unit;
begin
Block_Spec := Get_Block_Specification (Block_Conf);
-- FIXME: handle selected name.
if Get_Kind (Block_Spec) /= Iir_Kind_Simple_Name then
Error_Msg_Sem (+Block_Spec, "architecture name expected");
return;
end if;
-- LRM 10.3 rule b)
-- For an architecture body associated with a given entity
-- declaration: at the place of the block specification in a
-- block configuration for an external block whose interface
-- is defined by that entity declaration.
Design := Load_Secondary_Unit
(Get_Design_Unit (Get_Entity (Father)),
Get_Identifier (Block_Spec),
Block_Conf);
if Design = Null_Iir then
Error_Msg_Sem
(+Block_Conf, "no architecture %i", +Block_Spec);
return;
end if;
Arch := Get_Library_Unit (Design);
Set_Named_Entity (Block_Spec, Arch);
Xref_Ref (Block_Spec, Arch);
Block := Arch;
Add_Dependence (Design);
end;
when Iir_Kind_Component_Configuration =>
-- LRM93 1.3.1
-- If a block configuration appears immediately within a component
-- configuration, then the corresponding components must be
-- fully bound, the block specification of that block
-- configuration must be an architecture name, and that
-- architecture name must denote the same architecture body as
-- that to which the corresponding components are bound.
declare
Block_Spec : Iir;
Arch : Iir_Architecture_Body;
Design: Iir_Design_Unit;
Entity_Aspect : Iir;
Entity : Iir;
Comp_Arch : Iir;
begin
Entity_Aspect :=
Get_Entity_Aspect (Get_Binding_Indication (Father));
if Entity_Aspect = Null_Iir or else
Get_Kind (Entity_Aspect) /= Iir_Kind_Entity_Aspect_Entity
then
Error_Msg_Sem
(+Block_Conf, "corresponding component not fully bound");
end if;
Block_Spec := Get_Block_Specification (Block_Conf);
-- FIXME: handle selected name.
if Get_Kind (Block_Spec) /= Iir_Kind_Simple_Name then
Error_Msg_Sem (+Block_Spec, "architecture name expected");
return;
end if;
Comp_Arch := Get_Architecture (Entity_Aspect);
if Comp_Arch /= Null_Iir then
pragma Assert (Get_Kind (Comp_Arch) = Iir_Kind_Simple_Name);
if Get_Identifier (Comp_Arch) /= Get_Identifier (Block_Spec)
then
Error_Msg_Sem
(+Block_Spec, "block specification name is different "
& "from component architecture name");
return;
end if;
end if;
Entity := Get_Entity (Entity_Aspect);
if Entity = Null_Iir then
return;
end if;
Design := Load_Secondary_Unit (Get_Design_Unit (Entity),
Get_Identifier (Block_Spec),
Block_Conf);
if Design = Null_Iir then
Error_Msg_Sem
(+Block_Conf, "no architecture %i", +Block_Spec);
return;
end if;
Add_Dependence (Design);
Arch := Get_Library_Unit (Design);
Set_Named_Entity (Block_Spec, Arch);
Xref_Ref (Block_Spec, Arch);
Block := Arch;
end;
when Iir_Kind_Block_Configuration =>
-- LRM93 1.3.1 / LRM08 3.4.2 Block configuration
-- If a block configuration appears immediately within another
-- block configuration, then the block specification of the
-- contained block configuration must be a block statement or
-- generate statement label, and the label must denote a block
-- statement or generate statement that is contained immediatly
-- within the block denoted by the block specification of the
-- containing block configuration.
Block := Sem_Block_Specification_Of_Statement (Block_Conf, Father);
if Block = Null_Iir then
return;
end if;
when others =>
Error_Kind ("sem_block_configuration", Father);
end case;
-- LRM93 �10.1
-- 10. A block configuration
Sem_Scopes.Open_Scope_Extension;
-- LRM 10.3
-- In addition, any declaration that is directly visible at the end of
-- the declarative part of a given block is directly visible in a block
-- configuration that configure the given block. This rule holds unless
-- a use clause that makes a homograph of the declaration potentially
-- visible (see 10.4) appears in the corresponding configuration
-- declaration, and if the scope of that use clause encompasses all or
-- part of those configuration items. If such a use clause appears,
-- then the declaration will be directly visible within the
-- corresponding configuration items, except at hose places that fall
-- within the scope of the additional use clause. At such places,
-- neither name will be directly visible.
-- FIXME: handle use clauses.
Sem_Scopes.Extend_Scope_Of_Block_Declarations (Block);
declare
El : Iir;
begin
El := Get_Declaration_Chain (Block_Conf);
while El /= Null_Iir loop
case Get_Kind (El) is
when Iir_Kind_Use_Clause =>
Sem_Use_Clause (El);
when others =>
-- Parse checks there are only use clauses.
raise Internal_Error;
end case;
El := Get_Chain (El);
end loop;
end;
-- VHDL 87: do not remove configuration specification in generate stmts.
Clear_Instantiation_Configuration (Block);
El := Get_Configuration_Item_Chain (Block_Conf);
while El /= Null_Iir loop
case Get_Kind (El) is
when Iir_Kind_Block_Configuration =>
Sem_Block_Configuration (El, Block_Conf);
when Iir_Kind_Component_Configuration =>
Sem_Component_Configuration (El, Block_Conf);
when others =>
Error_Kind ("sem_block_configuration(2)", El);
end case;
El := Get_Chain (El);
end loop;
Sem_Scopes.Close_Scope_Extension;
end Sem_Block_Configuration;
-- Check that incremental binding of the component configuration CONF only
-- rebinds non associated ports of each instantiations of CONFIGURED_BLOCK
-- which CONF applies to.
procedure Check_Incremental_Binding (Configured_Block : Iir; Conf : Iir)
is
Comp : constant Iir := Get_Named_Entity (Get_Component_Name (Conf));
Inter_Chain : constant Iir := Get_Port_Chain (Comp);
Binding : constant Iir := Get_Binding_Indication (Conf);
Inst : Iir;
begin
-- Check each component instantiation of the block configured by CONF.
Inst := Get_Concurrent_Statement_Chain (Configured_Block);
while Inst /= Null_Iir loop
if Get_Kind (Inst) = Iir_Kind_Component_Instantiation_Statement
and then Get_Component_Configuration (Inst) = Conf
then
-- Check this instantiation.
declare
Primary_Binding : constant Iir := Get_Binding_Indication
(Get_Configuration_Specification (Inst));
F_Chain : constant Iir :=
Get_Port_Map_Aspect_Chain (Primary_Binding);
S_El : Iir;
S_Inter : Iir;
F_El : Iir;
Formal : Iir;
begin
S_El := Get_Port_Map_Aspect_Chain (Binding);
S_Inter := Inter_Chain;
while S_El /= Null_Iir loop
-- Find S_EL formal in F_CHAIN.
Formal := Get_Association_Interface (S_El, S_Inter);
F_El := Find_First_Association_For_Interface
(F_Chain, Inter_Chain, Formal);
if F_El /= Null_Iir
and then
Get_Kind (F_El) /= Iir_Kind_Association_Element_Open
then
Error_Msg_Sem
(+S_El,
"%n already associated in primary binding", +Formal);
end if;
Next_Association_Interface (S_El, S_Inter);
end loop;
end;
end if;
Inst := Get_Chain (Inst);
end loop;
end Check_Incremental_Binding;
-- LRM 1.3.2
procedure Sem_Component_Configuration
(Conf : Iir_Component_Configuration; Father : Iir)
is
Block : Iir;
Configured_Block : Iir;
Binding : Iir;
Entity : Iir_Design_Unit;
Comp : Iir_Component_Declaration;
Primary_Entity_Aspect : Iir;
begin
-- LRM 10.1 Declarative Region
-- 11. A component configuration.
Open_Declarative_Region;
-- LRM93 10.2
-- If a component configuration appears as a configuration item
-- immediatly within a block configuration that configures a given
-- block, and the scope of a given declaration includes the end of the
-- declarative part of that block, then the scope of the given
-- declaration extends from the beginning to the end of the
-- declarative region associated with the given component configuration.
-- GHDL: this is for labels of component instantiation statements, and
-- for local ports and generics of the component.
if Get_Kind (Father) = Iir_Kind_Block_Configuration then
Configured_Block := Get_Block_Specification (Father);
pragma Assert (Get_Kind (Configured_Block) /= Iir_Kind_Design_Unit);
Configured_Block :=
Get_Block_From_Block_Specification (Configured_Block);
Sem_Scopes.Extend_Scope_Of_Block_Declarations (Configured_Block);
else
-- Can a component configuration not be just inside a block
-- configuration ?
raise Internal_Error;
end if;
-- FIXME: this is wrong (all declarations should be considered).
Sem_Component_Specification
(Configured_Block, Conf, Primary_Entity_Aspect);
Comp := Get_Named_Entity (Get_Component_Name (Conf));
if Get_Kind (Comp) /= Iir_Kind_Component_Declaration then
-- There has been an error in sem_component_specification.
-- Leave here.
Close_Declarative_Region;
return;
end if;
-- FIXME: (todo)
-- If a given component instance is unbound in the corresponding block,
-- then any explicit component configuration for that instance that does
-- not contain an explicit binding indication will contain an implicit,
-- default binding indication (see 5.2.2). Similarly, if a given
-- component instance is unbound in the corresponding block, then any
-- implicit component configuration for that instance will contain an
-- implicit, default binding indication.
Open_Declarative_Region;
Sem_Scopes.Add_Component_Declarations (Comp);
Binding := Get_Binding_Indication (Conf);
if Binding /= Null_Iir then
Sem_Binding_Indication (Binding, Conf, Primary_Entity_Aspect);
if Primary_Entity_Aspect /= Null_Iir then
-- LRM93 5.2.1 Binding Indication
-- It is an error if a formal port appears in the port map aspect
-- of the incremental binding indication and it is a formal
-- port that is associated with an actual other than OPEN in one
-- of the primary binding indications.
Check_Incremental_Binding (Configured_Block, Conf);
end if;
elsif Primary_Entity_Aspect = Null_Iir then
-- LRM93 5.2.1
-- If the generic map aspect or port map aspect of a primary binding
-- indication is not present, then the default rules as described
-- in 5.2.2 apply.
-- Create a default binding indication.
Entity := Get_Visible_Entity_Declaration (Comp);
Binding := Sem_Create_Default_Binding_Indication
(Comp, Entity, Conf, False, False);
if Binding /= Null_Iir then
-- Remap to defaults.
Set_Default_Entity_Aspect (Binding, Get_Entity_Aspect (Binding));
Set_Entity_Aspect (Binding, Null_Iir);
Set_Binding_Indication (Conf, Binding);
end if;
end if;
Close_Declarative_Region;
-- External block.
Block := Get_Block_Configuration (Conf);
if Block /= Null_Iir and then Binding /= Null_Iir then
Sem_Block_Configuration (Block, Conf);
end if;
Close_Declarative_Region;
end Sem_Component_Configuration;
function Are_Trees_Chain_Equal (Left, Right : Iir) return Boolean
is
El_Left, El_Right : Iir;
begin
if Left = Right then
return True;
end if;
El_Left := Left;
El_Right := Right;
loop
if El_Left = Null_Iir and El_Right = Null_Iir then
return True;
end if;
if El_Left = Null_Iir or El_Right = Null_Iir then
return False;
end if;
if not Are_Trees_Equal (El_Left, El_Right) then
return False;
end if;
El_Left := Get_Chain (El_Left);
El_Right := Get_Chain (El_Right);
end loop;
end Are_Trees_Chain_Equal;
-- Return TRUE iff LEFT and RIGHT are (in depth) equal.
-- This corresponds to conformance rules, LRM93 2.7
function Are_Trees_Equal (Left, Right : Iir) return Boolean
is
El_Left, El_Right : Iir;
begin
-- Short-cut to speed up.
if Left = Right then
return True;
end if;
-- Handle null_iir.
if Left = Null_Iir or Right = Null_Iir then
-- Note: LEFT *xor* RIGHT is null_iir.
return False;
end if;
-- LRM 2.7 Conformance Rules
-- A simple name can be replaced by an expanded name in which this
-- simple name is the selector, if and only if at both places the
-- meaning of the simple name is given by the same declaration.
case Get_Kind (Left) is
when Iir_Kind_Simple_Name
| Iir_Kind_Selected_Name =>
case Get_Kind (Right) is
when Iir_Kind_Simple_Name
| Iir_Kind_Selected_Name =>
return Are_Trees_Equal (Get_Named_Entity (Left),
Get_Named_Entity (Right));
when others =>
return False;
end case;
when others =>
null;
end case;
-- If nodes are not of the same kind, then they are not equals!
if Get_Kind (Left) /= Get_Kind (Right) then
return False;
end if;
case Get_Kind (Left) is
when Iir_Kind_Procedure_Declaration =>
return Are_Trees_Chain_Equal
(Get_Interface_Declaration_Chain (Left),
Get_Interface_Declaration_Chain (Right));
when Iir_Kind_Function_Declaration =>
if not Are_Trees_Equal (Get_Return_Type (Left),
Get_Return_Type (Right))
then
return False;
end if;
if Get_Pure_Flag (Left) /= Get_Pure_Flag (Right) then
return False;
end if;
if not Are_Trees_Chain_Equal
(Get_Interface_Declaration_Chain (Left),
Get_Interface_Declaration_Chain (Right))
then
return False;
end if;
return True;
when Iir_Kind_Interface_Constant_Declaration
| Iir_Kind_Interface_Variable_Declaration
| Iir_Kind_Interface_Signal_Declaration
| Iir_Kind_Interface_File_Declaration =>
if Get_Identifier (Left) /= Get_Identifier (Right) then
return False;
end if;
if Get_Has_Mode (Left) /= Get_Has_Mode (Right)
or else Get_Has_Class (Left) /= Get_Has_Class (Right)
or else (Get_Has_Identifier_List (Left)
/= Get_Has_Identifier_List (Right))
or else Get_Mode (Left) /= Get_Mode (Right)
then
return False;
end if;
if not Are_Trees_Equal (Get_Type (Left), Get_Type (Right)) then
return False;
end if;
El_Left := Get_Default_Value (Left);
El_Right := Get_Default_Value (Right);
if (El_Left = Null_Iir) xor (El_Right = Null_Iir) then
return False;
end if;
if El_Left /= Null_Iir
and then Are_Trees_Equal (El_Left, El_Right) = False
then
return False;
end if;
return True;
when Iir_Kind_Integer_Subtype_Definition
| Iir_Kind_Enumeration_Subtype_Definition
| Iir_Kind_Floating_Subtype_Definition
| Iir_Kind_Physical_Subtype_Definition =>
if Get_Base_Type (Left) /= Get_Base_Type (Right) then
return False;
end if;
if Get_Type_Declarator (Left) /= Get_Type_Declarator (Right) then
return False;
end if;
if not Are_Trees_Equal (Get_Resolution_Indication (Left),
Get_Resolution_Indication (Right))
then
return False;
end if;
if Are_Trees_Equal (Get_Range_Constraint (Left),
Get_Range_Constraint (Right)) = False
then
return False;
end if;
return True;
when Iir_Kind_Array_Subtype_Definition =>
if Get_Base_Type (Left) /= Get_Base_Type (Right) then
return False;
end if;
if not Are_Trees_Equal (Get_Resolution_Indication (Left),
Get_Resolution_Indication (Right))
then
return False;
end if;
declare
L_Left : constant Iir_Flist := Get_Index_Subtype_List (Left);
L_Right : constant Iir_Flist := Get_Index_Subtype_List (Right);
begin
if Get_Nbr_Elements (L_Left) /= Get_Nbr_Elements (L_Right) then
return False;
end if;
for I in Flist_First .. Flist_Last (L_Left) loop
El_Left := Get_Nth_Element (L_Left, I);
El_Right := Get_Nth_Element (L_Right, I);
if not Are_Trees_Equal (El_Left, El_Right) then
return False;
end if;
end loop;
end;
return True;
when Iir_Kind_Record_Subtype_Definition =>
if Get_Base_Type (Left) /= Get_Base_Type (Right) then
return False;
end if;
if not Are_Trees_Equal (Get_Resolution_Indication (Left),
Get_Resolution_Indication (Right))
then
return False;
end if;
declare
L_Left : constant Iir_Flist :=
Get_Elements_Declaration_List (Left);
L_Right : constant Iir_Flist :=
Get_Elements_Declaration_List (Right);
begin
for I in Flist_First .. Flist_Last (L_Left) loop
El_Left := Get_Nth_Element (L_Left, I);
El_Right := Get_Nth_Element (L_Right, I);
if not Are_Trees_Equal (El_Left, El_Right) then
return False;
end if;
end loop;
end;
return True;
when Iir_Kind_Integer_Literal =>
if Get_Value (Left) /= Get_Value (Right) then
return False;
end if;
return Are_Trees_Equal (Get_Literal_Origin (Left),
Get_Literal_Origin (Right));
when Iir_Kind_Enumeration_Literal =>
if Get_Enum_Pos (Left) /= Get_Enum_Pos (Right) then
return False;
end if;
return Are_Trees_Equal (Get_Literal_Origin (Left),
Get_Literal_Origin (Right));
when Iir_Kind_Physical_Int_Literal =>
if Get_Value (Left) /= Get_Value (Right)
or else not Are_Trees_Equal (Get_Unit_Name (Left),
Get_Unit_Name (Right))
then
return False;
end if;
return Are_Trees_Equal (Get_Literal_Origin (Left),
Get_Literal_Origin (Right));
when Iir_Kind_Physical_Fp_Literal =>
if Get_Fp_Value (Left) /= Get_Fp_Value (Right)
or else not Are_Trees_Equal (Get_Unit_Name (Left),
Get_Unit_Name (Right))
then
return False;
end if;
return Are_Trees_Equal (Get_Literal_Origin (Left),
Get_Literal_Origin (Right));
when Iir_Kind_Unit_Declaration =>
return Left = Right;
when Iir_Kind_Floating_Point_Literal =>
if Get_Fp_Value (Left) /= Get_Fp_Value (Right) then
return False;
end if;
return Are_Trees_Equal (Get_Literal_Origin (Left),
Get_Literal_Origin (Right));
when Iir_Kinds_Dyadic_Operator =>
return Are_Trees_Equal (Get_Left (Left), Get_Left (Right))
and then Are_Trees_Equal (Get_Right (Left), Get_Right (Right));
when Iir_Kinds_Monadic_Operator =>
return Are_Trees_Equal (Get_Operand (Left), Get_Operand (Right));
when Iir_Kind_Function_Call =>
return Are_Trees_Equal (Get_Prefix (Left), Get_Prefix (Right))
and then
Are_Trees_Chain_Equal (Get_Parameter_Association_Chain (Left),
Get_Parameter_Association_Chain (Right));
when Iir_Kind_Association_Element_By_Expression =>
return Are_Trees_Equal (Get_Actual (Left), Get_Actual (Right))
and then Are_Trees_Equal (Get_Formal (Left), Get_Formal (Right))
and then Are_Trees_Equal (Get_Actual_Conversion (Left),
Get_Actual_Conversion (Right))
and then Are_Trees_Equal (Get_Formal_Conversion (Left),
Get_Formal_Conversion (Right));
when Iir_Kind_Type_Conversion =>
return Are_Trees_Equal (Get_Type_Mark (Left),
Get_Type_Mark (Right))
and then
Are_Trees_Equal (Get_Expression (Left),
Get_Expression (Right));
when Iir_Kind_Access_Type_Definition
| Iir_Kind_Record_Type_Definition
| Iir_Kind_Array_Type_Definition
| Iir_Kind_Enumeration_Type_Definition
| Iir_Kind_File_Type_Definition =>
return Left = Right;
when Iir_Kind_Range_Expression =>
if Get_Type (Left) /= Get_Type (Right)
or else Get_Direction (Left) /= Get_Direction (Right)
then
return False;
end if;
if not Are_Trees_Equal (Get_Left_Limit (Left),
Get_Left_Limit (Right))
or else not Are_Trees_Equal (Get_Right_Limit (Left),
Get_Right_Limit (Right))
then
return False;
end if;
return True;
when Iir_Kind_High_Type_Attribute
| Iir_Kind_Low_Type_Attribute
| Iir_Kind_Left_Type_Attribute
| Iir_Kind_Right_Type_Attribute
| Iir_Kind_Ascending_Type_Attribute =>
return Are_Trees_Equal (Get_Prefix (Left), Get_Prefix (Right));
when Iir_Kind_String_Literal8 =>
if Get_Bit_String_Base (Left) /= Get_Bit_String_Base (Right) then
return False;
end if;
declare
use Str_Table;
Len : constant Nat32 := Get_String_Length (Left);
L_Id : constant String8_Id := Get_String8_Id (Left);
R_Id : constant String8_Id := Get_String8_Id (Right);
begin
if Get_String_Length (Right) /= Len then
return False;
end if;
for I in 1 .. Len loop
if Element_String8 (L_Id, I) /= Element_String8 (R_Id, I)
then
return False;
end if;
end loop;
return True;
end;
when Iir_Kind_Aggregate =>
if not Are_Trees_Equal (Get_Type (Left), Get_Type (Right)) then
return False;
end if;
declare
El_L, El_R : Iir;
begin
El_L := Get_Association_Choices_Chain (Left);
El_R := Get_Association_Choices_Chain (Right);
loop
exit when El_L = Null_Iir and El_R = Null_Iir;
if not Are_Trees_Equal (El_L, El_R) then
return False;
end if;
El_L := Get_Chain (El_L);
El_R := Get_Chain (El_R);
end loop;
return True;
end;
when Iir_Kind_Choice_By_None
| Iir_Kind_Choice_By_Others =>
return Are_Trees_Equal (Get_Associated_Expr (Left),
Get_Associated_Expr (Right));
when Iir_Kind_Choice_By_Name =>
if not Are_Trees_Equal (Get_Choice_Name (Left),
Get_Choice_Name (Right))
then
return False;
end if;
return Are_Trees_Equal (Get_Associated_Expr (Left),
Get_Associated_Expr (Right));
when Iir_Kind_Choice_By_Expression =>
if not Are_Trees_Equal (Get_Choice_Expression (Left),
Get_Choice_Expression (Right)) then
return False;
end if;
return Are_Trees_Equal (Get_Associated_Expr (Left),
Get_Associated_Expr (Right));
when Iir_Kind_Choice_By_Range =>
if not Are_Trees_Equal (Get_Choice_Range (Left),
Get_Choice_Range (Right)) then
return False;
end if;
return Are_Trees_Equal (Get_Associated_Expr (Left),
Get_Associated_Expr (Right));
when Iir_Kind_Character_Literal =>
return Are_Trees_Equal (Get_Named_Entity (Left),
Get_Named_Entity (Right));
when Iir_Kind_Allocator_By_Subtype =>
return Are_Trees_Equal (Get_Subtype_Indication (Left),
Get_Subtype_Indication (Right));
when Iir_Kind_Allocator_By_Expression =>
return Are_Trees_Equal (Get_Expression (Left),
Get_Expression (Right));
when others =>
Error_Kind ("are_trees_equal", Left);
end case;
end Are_Trees_Equal;
-- LRM 2.7 Conformance Rules.
procedure Check_Conformance_Rules (Subprg, Spec: Iir) is
begin
if not Are_Trees_Equal (Subprg, Spec) then
-- FIXME: should explain why it does not conform ?
Error_Msg_Sem
(+Subprg, "body of %n does not conform with specification at %l",
(+Subprg, +Spec));
end if;
end Check_Conformance_Rules;
-- Return the specification corresponding to a declaration DECL, or
-- null_Iir if none.
-- FIXME: respect rules of LRM93 2.7
function Find_Subprogram_Specification (Decl: Iir) return Iir
is
Interpretation : Name_Interpretation_Type;
Decl1: Iir;
Hash : Iir_Int32;
begin
Hash := Get_Subprogram_Hash (Decl);
Interpretation := Get_Interpretation (Get_Identifier (Decl));
while Valid_Interpretation (Interpretation) loop
if not Is_In_Current_Declarative_Region (Interpretation) then
-- The declaration does not belong to the current declarative
-- region, neither will the following one. So, we do not found
-- it.
return Null_Iir;
end if;
Decl1 := Get_Declaration (Interpretation);
-- Should be sure DECL1 and DECL belongs to the same declarative
-- region, ie DECL1 was not made visible via a USE clause.
--
-- Also, only check for explicitly subprograms (and not
-- implicit one).
if not Is_Implicit_Subprogram (Decl1)
and then Get_Kind (Decl1) in Iir_Kinds_Subprogram_Declaration
and then not Is_Potentially_Visible (Interpretation)
and then Get_Subprogram_Hash (Decl1) = Hash
and then Is_Same_Profile (Decl, Decl1)
then
return Decl1;
end if;
Interpretation := Get_Next_Interpretation (Interpretation);
end loop;
return Null_Iir;
end Find_Subprogram_Specification;
procedure Set_Subprogram_Overload_Number (Decl : Iir)
is
Id : constant Name_Id := Get_Identifier (Decl);
Inter : Name_Interpretation_Type;
Prev : Iir;
Num : Iir_Int32;
begin
Inter := Get_Interpretation (Id);
while Valid_Interpretation (Inter)
and then Is_In_Current_Declarative_Region (Inter)
loop
-- There is a previous declaration with the same name in the
-- current declarative region.
Prev := Get_Declaration (Inter);
case Get_Kind (Prev) is
when Iir_Kind_Function_Declaration
| Iir_Kind_Procedure_Declaration =>
if Is_Implicit_Subprogram (Prev) then
-- Implicit declarations aren't taken into account (as they
-- are mangled differently).
Inter := Get_Next_Interpretation (Inter);
else
-- The previous declaration is a user subprogram.
Num := Get_Overload_Number (Prev) + 1;
if Num = 1
and then Get_Parent (Prev) = Get_Parent (Decl)
then
-- The previous was not (yet) overloaded. Mark it as
-- overloaded.
-- Do not mark it if it is not in the same declarative
-- part (ie, do not change a subprogram declaration in
-- the package while analyzing the body).
Set_Overload_Number (Prev, 1);
Num := 2;
end if;
Set_Overload_Number (Decl, Num);
return;
end if;
when Iir_Kind_Enumeration_Literal =>
-- Enumeration literal are ignored for overload number.
Inter := Get_Next_Interpretation (Inter);
when Iir_Kind_Non_Object_Alias_Declaration =>
-- Subprogram aliases aren't considered, just skip them.
-- (No subprogram is created by an alias).
Inter := Get_Next_Interpretation (Inter);
when others =>
-- Case of user error: redefinition of an identifier.
-- Error message is generated by sem_scope.
Set_Overload_Number (Decl, 0);
return;
end case;
end loop;
-- No previous declaration in the current declarative region.
Set_Overload_Number (Decl, 0);
end Set_Subprogram_Overload_Number;
-- Check requirements on number of interfaces for subprogram specification
-- SUBPRG. Requirements only concern operators, and are defined in
-- LRM 2.3.1
procedure Check_Operator_Requirements (Id : Name_Id; Subprg : Iir)
is
use Std_Names;
Nbr_Interfaces : Natural;
Is_Method : Boolean;
begin
Nbr_Interfaces := Vhdl.Nodes_Utils.Get_Chain_Length
(Get_Interface_Declaration_Chain (Subprg));
-- For vhdl-02, the protected variable is an implicit parameter.
if Flags.Vhdl_Std >= Vhdl_02
and then Is_Subprogram_Method (Subprg)
then
Nbr_Interfaces := Nbr_Interfaces + 1;
else
Is_Method := False;
end if;
case Id is
when Name_Abs
| Name_Not =>
-- LRM93 2.3.1
-- The subprogram specification of a unary operator must have a
-- single parameter.
-- LRM02 2.3.1
-- ..., unless the subprogram specification is a method (see
-- 3.5.1) of a protected type. In this latter case, the
-- subprogram specification must have no parameters.
if Nbr_Interfaces = 1 then
return;
end if;
Error_Msg_Sem
(+Subprg, "unary operator must have a single parameter");
when Name_Mod
| Name_Rem
| Name_Op_Mul
| Name_Op_Div
| Name_Relational_Operators
| Name_Op_Concatenation
| Name_Shift_Operators
| Name_Op_Exp =>
-- LRM93 2.3.1
-- The subprogram specification of a binary operator must have
-- two parameters.
-- LRM02 2.3.1
-- ..., unless the subprogram specification is a method of a
-- protected type, in which case, the subprogram specification
-- must have a single parameter.
if Nbr_Interfaces = 2 then
return;
end if;
Error_Msg_Sem
(+Subprg, "binary operators must have two parameters");
when Name_Logical_Operators
| Name_Xnor =>
-- LRM08 4.5.2 Operator overloading
-- For each of the "+", "-", "and", "or", "xor", "nand", "nor"
-- and "xnor", overloading is allowed both as a unary operator
-- and as a binary operator.
if Nbr_Interfaces = 2 then
return;
end if;
if Nbr_Interfaces = 1 then
if Vhdl_Std >= Vhdl_08 then
return;
end if;
Error_Msg_Sem
(+Subprg,
"logical operators must have two parameters before vhdl08");
else
Error_Msg_Sem
(+Subprg, "logical operators must have two parameters");
end if;
when Name_Op_Plus
| Name_Op_Minus =>
-- LRM93 2.3.1
-- For each of the operators "+" and "-", overloading is allowed
-- both as a unary operator and as a binary operator.
if Nbr_Interfaces in 1 .. 2 then
return;
end if;
Error_Msg_Sem
(+Subprg,
"""+"" and ""-"" operators must have 1 or 2 parameters");
when others =>
return;
end case;
if Is_Method then
Error_Msg_Sem
(+Subprg,
" (the protected object is an implicit parameter of methods)");
end if;
end Check_Operator_Requirements;
procedure Sem_Subprogram_Specification (Subprg: Iir)
is
Interface_Chain : Iir;
Return_Type : Iir;
begin
-- LRM 10.1 Declarative Region
-- 3. A subprogram declaration, together with the corresponding
-- subprogram body.
Open_Declarative_Region;
-- Sem interfaces.
Interface_Chain := Get_Interface_Declaration_Chain (Subprg);
case Get_Kind (Subprg) is
when Iir_Kind_Function_Declaration
| Iir_Kind_Interface_Function_Declaration =>
Sem_Interface_Chain
(Interface_Chain, Function_Parameter_Interface_List);
Return_Type := Get_Return_Type_Mark (Subprg);
Return_Type := Sem_Type_Mark (Return_Type);
Set_Return_Type_Mark (Subprg, Return_Type);
Return_Type := Get_Type (Return_Type);
Set_Return_Type (Subprg, Return_Type);
Set_All_Sensitized_State (Subprg, Unknown);
-- LRM08 4.2 Subprogram declarations
-- It is an error if the result subtype of a function denotes
-- either a file type or a protected type. Moreover, it is an
-- error if the result subtype of a pure function denotes an
-- access type or a subtype that has a subelement of an access
-- type.
-- GHDL: this was added by VHDL 2008, but vital packages don't
-- follow that rule. So, it is not retroactive.
case Get_Kind (Return_Type) is
when Iir_Kind_File_Type_Definition =>
Error_Msg_Sem
(+Subprg, "result subtype cannot denote a file type");
when Iir_Kind_Protected_Type_Declaration =>
Error_Msg_Sem
(+Subprg, "result subtype cannot denote a protected type");
when Iir_Kind_Access_Type_Definition
| Iir_Kind_Access_Subtype_Definition =>
if Vhdl_Std >= Vhdl_08
and then Get_Pure_Flag (Subprg)
then
Error_Msg_Sem_Relaxed
(Subprg, Warnid_Pure,
"result subtype of a pure function cannot denote an"
& " access type");
end if;
when others =>
if Vhdl_Std >= Vhdl_08
and then not Get_Signal_Type_Flag (Return_Type)
and then Get_Pure_Flag (Subprg)
then
Error_Msg_Sem_Relaxed
(Subprg, Warnid_Pure,
"result subtype of a pure function cannot have"
& " access subelements");
end if;
end case;
when Iir_Kind_Interface_Procedure_Declaration =>
Sem_Interface_Chain
(Interface_Chain, Procedure_Parameter_Interface_List);
when Iir_Kind_Procedure_Declaration =>
Sem_Interface_Chain
(Interface_Chain, Procedure_Parameter_Interface_List);
-- Unless the body is analyzed, the procedure purity is unknown.
Set_Purity_State (Subprg, Unknown);
-- Check if the procedure is passive.
Set_Passive_Flag (Subprg, True);
Set_All_Sensitized_State (Subprg, Unknown);
declare
Inter : Iir;
begin
Inter := Interface_Chain;
while Inter /= Null_Iir loop
if Get_Kind (Inter) = Iir_Kind_Interface_Signal_Declaration
and then Get_Mode (Inter) /= Iir_In_Mode
then
-- There is a driver for this signal interface.
Set_Passive_Flag (Subprg, False);
exit;
end if;
Inter := Get_Chain (Inter);
end loop;
end;
-- Mark the procedure as suspendable, unless in a std packages.
-- This is a minor optimization.
if Get_Library (Get_Design_File (Get_Current_Design_Unit))
/= Libraries.Std_Library
then
Set_Suspend_Flag (Subprg, True);
end if;
when others =>
Error_Kind ("sem_subprogram_declaration", Subprg);
end case;
Check_Operator_Requirements (Get_Identifier (Subprg), Subprg);
Sem_Utils.Compute_Subprogram_Hash (Subprg);
-- The specification has been analyzed, close the declarative region
-- now.
Close_Declarative_Region;
end Sem_Subprogram_Specification;
-- LRM 2.1 Subprogram Declarations.
procedure Sem_Subprogram_Declaration (Subprg: Iir)
is
Parent : constant Iir := Get_Parent (Subprg);
Spec: Iir;
Subprg_Body : Iir;
begin
-- Set depth.
case Get_Kind (Parent) is
when Iir_Kind_Function_Declaration
| Iir_Kind_Procedure_Declaration =>
raise Internal_Error;
when Iir_Kind_Function_Body
| Iir_Kind_Procedure_Body =>
Set_Subprogram_Depth
(Subprg,
Get_Subprogram_Depth
(Get_Subprogram_Specification (Parent)) + 1);
when others =>
-- FIXME: protected type ?
Set_Subprogram_Depth (Subprg, 0);
end case;
Sem_Subprogram_Specification (Subprg);
-- Look if there is an associated body (the next node).
Subprg_Body := Get_Chain (Subprg);
if Subprg_Body /= Null_Iir
and then Get_Kind (Subprg_Body) in Iir_Kinds_Subprogram_Body
then
Spec := Find_Subprogram_Specification (Subprg);
else
Spec := Null_Iir;
end if;
if Spec /= Null_Iir then
-- SUBPRG is the body of the specification SPEC.
if Get_Subprogram_Body (Spec) /= Null_Iir then
Error_Msg_Sem (+Subprg, "%n body already defined at %l",
(+Spec, +Get_Subprogram_Body (Spec)));
-- Kill warning.
Set_Use_Flag (Subprg, True);
else
Check_Conformance_Rules (Subprg, Spec);
Xref_Body (Subprg, Spec);
Set_Subprogram_Body (Subprg, Subprg_Body);
Set_Subprogram_Specification (Subprg_Body, Spec);
Set_Subprogram_Body (Spec, Subprg_Body);
end if;
else
-- Forward declaration or specification followed by body.
Set_Subprogram_Overload_Number (Subprg);
Sem_Scopes.Add_Name (Subprg);
Name_Visible (Subprg);
Xref_Decl (Subprg);
end if;
end Sem_Subprogram_Declaration;
procedure Add_Analysis_Checks_List (El : Iir)
is
Design : constant Iir := Get_Current_Design_Unit;
List : Iir_List;
begin
List := Get_Analysis_Checks_List (Design);
if List = Null_Iir_List then
List := Create_Iir_List;
Set_Analysis_Checks_List (Design, List);
end if;
Add_Element (List, El);
end Add_Analysis_Checks_List;
procedure Sem_Subprogram_Body (Subprg : Iir)
is
Spec : constant Iir := Get_Subprogram_Specification (Subprg);
Warn_Hide_Enabled : constant Boolean := Is_Warning_Enabled (Warnid_Hide);
El : Iir;
begin
Set_Impure_Depth (Subprg, Iir_Depth_Pure);
-- LRM 10.1 Declarative regions
-- 3. A subprogram declaration, together with the corresponding
-- subprogram body.
Open_Declarative_Region;
Set_Is_Within_Flag (Spec, True);
-- Add the interface names into the current declarative region.
-- (Do not emit warnings for hiding, they were already emitted during
-- analysis of the subprogram spec).
Enable_Warning (Warnid_Hide, False);
El := Get_Interface_Declaration_Chain (Spec);
while El /= Null_Iir loop
Add_Name (El, Get_Identifier (El), False);
if Get_Kind (El) = Iir_Kind_Interface_Signal_Declaration then
Set_Has_Active_Flag (El, False);
end if;
El := Get_Chain (El);
end loop;
Enable_Warning (Warnid_Hide, Warn_Hide_Enabled);
Sem_Sequential_Statements (Spec, Subprg);
Set_Is_Within_Flag (Spec, False);
Close_Declarative_Region;
case Get_Kind (Spec) is
when Iir_Kind_Procedure_Declaration =>
if Get_Suspend_Flag (Subprg)
and then not Get_Suspend_Flag (Spec)
then
-- Incoherence: procedures declared in std library are not
-- expected to suspend. This is an internal check.
Error_Msg_Sem (+Subprg, "unexpected suspendable procedure");
end if;
-- Update purity state of procedure if there are no callees.
case Get_Purity_State (Spec) is
when Pure
| Maybe_Impure =>
-- We can't know this yet.
raise Internal_Error;
when Impure =>
null;
when Unknown =>
if Get_Callees_List (Subprg) = Null_Iir_List then
-- Since there are no callees, purity state can
-- be updated.
if Get_Impure_Depth (Subprg) = Iir_Depth_Pure then
Set_Purity_State (Spec, Pure);
else
Set_Purity_State (Spec, Maybe_Impure);
end if;
end if;
end case;
-- Update wait state if the state of all callees is known.
if Get_Wait_State (Spec) = Unknown then
declare
Callees : constant Iir_List := Get_Callees_List (Subprg);
Callees_It : List_Iterator;
Callee : Iir;
State : Tri_State_Type;
begin
-- Per default, has no wait.
Set_Wait_State (Spec, False);
Callees_It := List_Iterate_Safe (Callees);
while Is_Valid (Callees_It) loop
Callee := Get_Element (Callees_It);
case Get_Kind (Callee) is
when Iir_Kind_Function_Declaration =>
null;
when Iir_Kind_Procedure_Declaration =>
State := Get_Wait_State (Callee);
case State is
when False =>
null;
when Unknown =>
-- Yet unknown, but can be TRUE.
Set_Wait_State (Spec, Unknown);
when True =>
-- Can this happen ?
raise Internal_Error;
--Set_Wait_State (Spec, True);
--exit;
end case;
when others =>
Error_Kind ("sem_subprogram_body(2)", Callee);
end case;
Next (Callees_It);
end loop;
end;
end if;
-- Do not add to Analysis_Checks_List as procedures can't
-- generate purity/wait/all-sensitized errors by themselves.
when Iir_Kind_Function_Declaration =>
if Get_Callees_List (Subprg) /= Null_Iir_List then
-- Purity calls to be checked later.
-- No wait statements in procedures called.
Add_Analysis_Checks_List (Spec);
end if;
when others =>
Error_Kind ("sem_subprogram_body", Spec);
end case;
-- Set All_Sensitized_State in trivial cases.
if Get_All_Sensitized_State (Spec) = Unknown
and then Get_Callees_List (Subprg) = Null_Iir_List
then
Set_All_Sensitized_State (Spec, No_Signal);
end if;
end Sem_Subprogram_Body;
-- Return the subprogram body of SPEC. If there is no body, and if SPEC
-- is an instance, returns the body of the generic specification but only
-- if known.
function Get_Subprogram_Body_Or_Generic (Spec : Iir) return Iir
is
Bod : Iir;
Orig : Iir;
begin
Bod := Get_Subprogram_Body (Spec);
if Bod /= Null_Iir then
return Bod;
end if;
Orig := Sem_Inst.Get_Origin (Spec);
if Orig = Null_Iir then
return Null_Iir;
end if;
return Get_Subprogram_Body (Orig);
end Get_Subprogram_Body_Or_Generic;
-- Status of Update_And_Check_Pure_Wait.
type Update_Pure_Status is
(
-- The purity/wait/all-sensitized are computed and known.
Update_Pure_Done,
-- A missing body prevents from computing the purity/wait/all-sensitized
Update_Pure_Missing,
-- Purity/wait/all-sensitized is unknown (recursion).
Update_Pure_Unknown
);
function Update_And_Check_Pure_Wait (Subprg : Iir) return Update_Pure_Status
is
procedure Error_Wait (Caller : Iir; Callee : Iir) is
begin
Report_Start_Group;
Error_Msg_Sem
(+Caller, "%n must not contain wait statement, but calls", +Caller);
Error_Msg_Sem
(+Callee, "%n which has (indirectly) a wait statement", +Callee);
Report_End_Group;
end Error_Wait;
-- Kind of subprg.
type Caller_Kind is (K_Function, K_Process, K_Procedure);
Kind : Caller_Kind;
Callees_List : Iir_List;
Callees_List_Holder : Iir;
Callees_It : List_Iterator;
Callee : Iir;
Callee_Bod : Iir;
Subprg_Depth : Iir_Int32;
Subprg_Bod : Iir;
-- Current purity depth of SUBPRG.
Depth : Iir_Int32;
Depth_Callee : Iir_Int32;
Has_Wait_Errors : Boolean := False;
New_List : Iir_List;
Res, Res1 : Update_Pure_Status;
begin
case Get_Kind (Subprg) is
when Iir_Kind_Function_Declaration =>
Kind := K_Function;
Subprg_Bod := Get_Subprogram_Body_Or_Generic (Subprg);
if Subprg_Bod = Null_Iir then
return Update_Pure_Missing;
end if;
Subprg_Depth := Get_Subprogram_Depth (Subprg);
Callees_List_Holder := Subprg_Bod;
if Get_Pure_Flag (Subprg) then
Depth := Iir_Depth_Pure;
else
Depth := Iir_Depth_Impure;
end if;
when Iir_Kind_Procedure_Declaration =>
Kind := K_Procedure;
Subprg_Bod := Get_Subprogram_Body_Or_Generic (Subprg);
if Subprg_Bod = Null_Iir then
return Update_Pure_Missing;
end if;
if Get_Purity_State (Subprg) = Impure
and then Get_Wait_State (Subprg) /= Unknown
and then Get_All_Sensitized_State (Subprg) /= Unknown
then
-- No need to go further.
if Get_All_Sensitized_State (Subprg) = No_Signal
or else Vhdl_Std < Vhdl_08
then
Callees_List := Get_Callees_List (Subprg_Bod);
Destroy_Iir_List (Callees_List);
Set_Callees_List (Subprg_Bod, Null_Iir_List);
end if;
return Update_Pure_Done;
end if;
Subprg_Depth := Get_Subprogram_Depth (Subprg);
Depth := Get_Impure_Depth (Subprg_Bod);
Callees_List_Holder := Subprg_Bod;
when Iir_Kind_Sensitized_Process_Statement =>
Kind := K_Process;
Subprg_Bod := Null_Iir;
Subprg_Depth := Iir_Depth_Top;
Depth := Iir_Depth_Impure;
Callees_List_Holder := Subprg;
when others =>
Error_Kind ("update_and_check_pure_wait(1)", Subprg);
end case;
-- If the subprogram has no callee list, there is nothing to do.
Callees_List := Get_Callees_List (Callees_List_Holder);
if Callees_List = Null_Iir_List then
-- There are two reasons why a callees_list is null:
-- * either because SUBPRG does not call any procedure
-- in this case, the status are already known and we should have
-- returned in the above case.
-- * or because of a recursion
-- in this case the status are still unknown here.
return Update_Pure_Unknown;
end if;
-- By default we don't know the status.
Res := Update_Pure_Unknown;
-- This subprogram is being considered.
-- To avoid infinite loop, suppress its callees list.
Set_Callees_List (Callees_List_Holder, Null_Iir_List);
-- First loop: check without recursion.
-- Second loop: recurse if necessary.
for J in 0 .. 1 loop
New_List := Create_Iir_List;
Callees_It := List_Iterate (Callees_List);
while Is_Valid (Callees_It) loop
Callee := Get_Element (Callees_It);
-- Note:
-- Pure functions should not be in the list.
-- Impure functions must have directly set Purity_State.
-- The body of subprograms may not be set for instances.
-- Use the body from the generic (if any).
-- This is meaningful for non macro-expanded package interface,
-- because there is no associated body and because the call
-- tree is known (if there were an interface subprogram, it
-- would have been macro-expanded).
-- Do not set the body, as it would trigger an assert during
-- macro-expansion (maybe this shouldn't be called for macro
-- expanded packages).
Callee_Bod := Get_Subprogram_Body_Or_Generic (Callee);
-- Check pure.
if Callee_Bod = Null_Iir then
-- No body yet for the subprogram called.
-- Nothing can be extracted from it, postpone the checks until
-- elaboration.
Res := Update_Pure_Missing;
else
-- Second loop: recurse if a state is not known.
if J = 1
and then
((Get_Kind (Callee) = Iir_Kind_Procedure_Declaration
and then Get_Purity_State (Callee) = Unknown)
or else Get_Wait_State (Callee) = Unknown
or else Get_All_Sensitized_State (Callee) = Unknown)
then
Res1 := Update_And_Check_Pure_Wait (Callee);
if Res1 = Update_Pure_Missing then
Res := Update_Pure_Missing;
end if;
end if;
-- Check purity only if the subprogram is not impure.
if Depth /= Iir_Depth_Impure then
Depth_Callee := Get_Impure_Depth (Callee_Bod);
-- Check purity depth.
if Depth_Callee < Subprg_Depth then
-- The call is an impure call because it calls an outer
-- subprogram (or an impure subprogram).
-- FIXME: check the compare.
Depth_Callee := Iir_Depth_Impure;
if Kind = K_Function then
-- FIXME: report call location
Error_Pure (Elaboration, Subprg_Bod, Callee, Null_Iir);
end if;
end if;
-- Update purity depth.
if Depth_Callee < Depth then
Depth := Depth_Callee;
if Kind = K_Procedure then
-- Update for recursivity.
Set_Impure_Depth (Subprg_Bod, Depth);
if Depth = Iir_Depth_Impure then
Set_Purity_State (Subprg, Impure);
end if;
end if;
end if;
end if;
end if;
-- Check wait.
if Has_Wait_Errors = False
and then Get_Wait_State (Callee) = True
then
if Kind = K_Procedure then
Set_Wait_State (Subprg, True);
else
Error_Wait (Subprg, Callee);
Has_Wait_Errors := True;
end if;
end if;
if Get_All_Sensitized_State (Callee) = Invalid_Signal then
case Kind is
when K_Function | K_Procedure =>
Set_All_Sensitized_State (Subprg, Invalid_Signal);
when K_Process =>
-- LRM08 11.3
--
-- It is an error if a process statement with the
-- reserved word ALL as its process sensitivity list
-- is the parent of a subprogram declared in a design
-- unit other than that containing the process statement
-- and the subprogram reads an explicitly declared
-- signal that is not a formal signal parameter or
-- member of a formal signal parameter of the
-- subprogram or of any of its parents. Similarly,
-- it is an error if such subprogram reads an implicit
-- signal whose explicit ancestor is not a formal signal
-- parameter or member of a formal parameter of
-- the subprogram or of any of its parents.
Report_Start_Group;
Error_Msg_Sem
(+Subprg, "all-sensitized %n can't call %n",
(+Subprg, +Callee));
Error_Msg_Sem
(+Subprg,
" (as this subprogram reads (indirectly) a signal)");
Report_End_Group;
end case;
end if;
-- Keep in list.
if Callee_Bod = Null_Iir
or else
(Get_Kind (Callee) = Iir_Kind_Procedure_Declaration
and then Get_Purity_State (Callee) = Unknown
and then Depth /= Iir_Depth_Impure)
or else
(Get_Wait_State (Callee) = Unknown
and then (Kind /= K_Procedure
or else Get_Wait_State (Subprg) = Unknown))
or else
(Vhdl_Std >= Vhdl_08
and then
(Get_All_Sensitized_State (Callee) = Unknown
or else Get_All_Sensitized_State (Callee) = Read_Signal))
then
Append_Element (New_List, Callee);
end if;
Next (Callees_It);
end loop;
-- End of callee loop.
if Is_Empty (New_List) then
Destroy_Iir_List (Callees_List);
Callees_List := Null_Iir_List;
Destroy_Iir_List (New_List);
if Kind = K_Procedure then
if Get_Purity_State (Subprg) = Unknown then
Set_Purity_State (Subprg, Maybe_Impure);
end if;
if Get_Wait_State (Subprg) = Unknown then
Set_Wait_State (Subprg, False);
end if;
end if;
if Kind = K_Procedure or Kind = K_Function then
if Get_All_Sensitized_State (Subprg) = Unknown then
Set_All_Sensitized_State (Subprg, No_Signal);
end if;
end if;
Res := Update_Pure_Done;
exit;
else
Destroy_Iir_List (Callees_List);
Callees_List := New_List;
end if;
end loop;
Set_Callees_List (Callees_List_Holder, New_List);
return Res;
end Update_And_Check_Pure_Wait;
-- Check pure/wait/all-sensitized issues for SUBPRG (subprogram or
-- process). Return False if the analysis is incomplete (and must
-- be deferred).
function Root_Update_And_Check_Pure_Wait (Subprg : Iir) return Boolean
is
Res : Update_Pure_Status;
begin
Res := Update_And_Check_Pure_Wait (Subprg);
case Res is
when Update_Pure_Done =>
return True;
when Update_Pure_Missing =>
return False;
when Update_Pure_Unknown =>
-- The purity/wait is unknown, but all callee were walked.
-- This means there are recursive calls but without violations.
if Get_Kind (Subprg) = Iir_Kind_Procedure_Declaration then
if Get_Purity_State (Subprg) = Unknown then
Set_Purity_State (Subprg, Maybe_Impure);
end if;
if Get_Wait_State (Subprg) = Unknown then
Set_Wait_State (Subprg, False);
end if;
end if;
if Get_Kind (Subprg) in Iir_Kinds_Subprogram_Declaration then
if Get_All_Sensitized_State (Subprg) = Unknown then
Set_All_Sensitized_State (Subprg, No_Signal);
end if;
end if;
return True;
end case;
end Root_Update_And_Check_Pure_Wait;
procedure Sem_Analysis_Checks_List (Unit : Iir_Design_Unit;
Emit_Warnings : Boolean)
is
List : Iir_List;
El : Iir;
It : List_Iterator;
Keep : Boolean;
New_List : Iir_List;
begin
List := Get_Analysis_Checks_List (Unit);
if List = Null_Iir_List then
-- Return now if there is nothing to check.
return;
end if;
New_List := Create_Iir_List;
It := List_Iterate (List);
while Is_Valid (It) loop
El := Get_Element (It);
Keep := False;
case Get_Kind (El) is
when Iir_Kind_Function_Declaration =>
-- FIXME: remove from list if fully tested ?
if not Root_Update_And_Check_Pure_Wait (El) then
Keep := True;
if Emit_Warnings then
declare
Bod : constant Iir := Get_Subprogram_Body (El);
Callees : constant Iir_List := Get_Callees_List (Bod);
pragma Assert (Callees /= Null_Iir_List);
Callee : constant Iir := Get_First_Element (Callees);
begin
Report_Start_Group;
Warning_Msg_Sem
(Warnid_Delayed_Checks, +El,
"can't assert that all calls in %n"
& " are pure or have not wait;"
& " will be checked at elaboration", +El);
-- FIXME: could improve this message by displaying
-- the chain of calls until the first subprograms in
-- unknown state.
Warning_Msg_Sem
(Warnid_Delayed_Checks, +Callee,
"(first such call is to %n)", +Callee);
Report_End_Group;
end;
end if;
end if;
when Iir_Kind_Sensitized_Process_Statement =>
if not Root_Update_And_Check_Pure_Wait (El) then
Keep := True;
if Emit_Warnings then
Warning_Msg_Sem
(Warnid_Delayed_Checks, +El,
"can't assert that %n has no wait; "
& "will be checked at elaboration", +El);
end if;
end if;
when others =>
Error_Kind ("sem_analysis_checks_list", El);
end case;
if Keep then
Append_Element (New_List, El);
end if;
Next (It);
end loop;
if Is_Empty (New_List) then
Destroy_Iir_List (New_List);
New_List := Null_Iir_List; -- OK, redundant but clearer.
end if;
Destroy_Iir_List (List);
Set_Analysis_Checks_List (Unit, New_List);
end Sem_Analysis_Checks_List;
-- Return true if package declaration DECL needs a body.
-- Ie, it contains subprogram specification or deferred constants.
function Package_Need_Body_P (Decl: Iir_Package_Declaration)
return Boolean
is
El: Iir;
Def : Iir;
begin
El := Get_Declaration_Chain (Decl);
while El /= Null_Iir loop
case Get_Kind (El) is
when Iir_Kind_Function_Declaration
| Iir_Kind_Procedure_Declaration =>
if not Is_Implicit_Subprogram (El) then
return True;
end if;
when Iir_Kind_Constant_Declaration =>
if Get_Default_Value (El) = Null_Iir then
return True;
end if;
when Iir_Kind_Variable_Declaration
| Iir_Kind_File_Declaration
| Iir_Kind_Signal_Declaration
| Iir_Kind_Object_Alias_Declaration
| Iir_Kind_Non_Object_Alias_Declaration
| Iir_Kind_Group_Template_Declaration
| Iir_Kind_Group_Declaration =>
null;
when Iir_Kind_Type_Declaration =>
Def := Get_Type_Definition (El);
if Def /= Null_Iir
and then Get_Kind (Def) = Iir_Kind_Protected_Type_Declaration
then
return True;
end if;
when Iir_Kind_Anonymous_Type_Declaration
| Iir_Kind_Subtype_Declaration =>
null;
when Iir_Kind_Attribute_Declaration
| Iir_Kind_Attribute_Specification =>
null;
when Iir_Kind_Disconnection_Specification =>
null;
when Iir_Kind_Use_Clause =>
null;
when Iir_Kind_Component_Declaration =>
null;
when Iir_Kind_Protected_Type_Body =>
null;
when Iir_Kind_Package_Declaration =>
-- LRM08 4.8 Package bodies
-- A package body that is not a library unit shall appear
-- immediately within the same declarative region as the
-- corresponding package declaration and textually subsequent
-- to that package declaration.
if Get_Need_Body (El) then
return True;
end if;
when Iir_Kind_Package_Body =>
null;
when Iir_Kind_Package_Instantiation_Declaration =>
null;
when Iir_Kind_Nature_Declaration
| Iir_Kind_Subnature_Declaration =>
null;
when Iir_Kind_Terminal_Declaration =>
null;
when others =>
pragma Assert (Flags.Flag_Force_Analysis);
null;
end case;
El := Get_Chain (El);
end loop;
return False;
end Package_Need_Body_P;
-- Return true if package declaration DECL contains at least one package
-- instantiation that needs a body.
function Package_Need_Instance_Bodies_P (Decl: Iir_Package_Declaration)
return Boolean
is
El: Iir;
begin
El := Get_Declaration_Chain (Decl);
while El /= Null_Iir loop
case Get_Kind (El) is
when Iir_Kind_Package_Instantiation_Declaration =>
declare
Pkg : constant Iir := Get_Uninstantiated_Package_Decl (El);
begin
if not Is_Error (Pkg)
and then Get_Need_Body (Pkg)
then
return True;
end if;
end;
when others =>
null;
end case;
El := Get_Chain (El);
end loop;
return False;
end Package_Need_Instance_Bodies_P;
-- Return true if uninstantiated pckage DECL must be macro-expanded (at
-- least one interface type).
function Is_Package_Macro_Expanded
(Decl : Iir_Package_Declaration) return Boolean
is
Header : constant Iir := Get_Package_Header (Decl);
Inter : Iir;
begin
Inter := Get_Generic_Chain (Header);
while Is_Valid (Inter) loop
case Iir_Kinds_Interface_Declaration (Get_Kind (Inter)) is
when Iir_Kinds_Interface_Object_Declaration
| Iir_Kind_Interface_Terminal_Declaration =>
null;
when Iir_Kind_Interface_Type_Declaration =>
return True;
when Iir_Kind_Interface_Package_Declaration =>
declare
Pkg : constant Iir :=
Get_Uninstantiated_Package_Decl (Inter);
begin
if Get_Macro_Expanded_Flag (Pkg) then
return True;
end if;
end;
when Iir_Kinds_Interface_Subprogram_Declaration =>
return True;
end case;
Inter := Get_Chain (Inter);
end loop;
return False;
end Is_Package_Macro_Expanded;
-- LRM 2.5 Package Declarations.
procedure Sem_Package_Declaration (Pkg : Iir_Package_Declaration)
is
Unit : constant Iir_Design_Unit := Get_Design_Unit (Pkg);
Header : constant Iir := Get_Package_Header (Pkg);
Implicit : Implicit_Signal_Declaration_Type;
begin
Sem_Scopes.Add_Name (Pkg);
Set_Visible_Flag (Pkg, True);
Xref_Decl (Pkg);
Set_Is_Within_Flag (Pkg, True);
-- Identify IEEE.Std_Logic_1164 for VHDL08.
if Get_Identifier (Pkg) = Std_Names.Name_Std_Logic_1164
and then (Get_Identifier (Get_Library (Get_Design_File (Unit)))
= Std_Names.Name_Ieee)
then
Vhdl.Ieee.Std_Logic_1164.Std_Logic_1164_Pkg := Pkg;
end if;
-- LRM93 10.1 Declarative Region
-- 4. A package declaration, together with the corresponding
-- body (if any).
Open_Declarative_Region;
Push_Signals_Declarative_Part (Implicit, Pkg);
if Header /= Null_Iir then
declare
Generic_Chain : constant Iir := Get_Generic_Chain (Header);
Generic_Map : constant Iir :=
Get_Generic_Map_Aspect_Chain (Header);
Assoc_El : Iir;
Inter_El : Iir;
Inter : Iir;
begin
Sem_Interface_Chain (Generic_Chain, Generic_Interface_List);
if Generic_Map /= Null_Iir then
-- Generic-mapped packages are not macro-expanded.
Set_Macro_Expanded_Flag (Pkg, False);
if Sem_Generic_Association_Chain (Header, Header) then
-- For generic-mapped packages, use the actual type for
-- interface type.
Assoc_El := Get_Generic_Map_Aspect_Chain (Header);
Inter_El := Generic_Chain;
while Is_Valid (Assoc_El) loop
if Get_Kind (Assoc_El) = Iir_Kind_Association_Element_Type
then
Inter :=
Get_Association_Interface (Assoc_El, Inter_El);
Sem_Inst.Substitute_On_Chain
(Generic_Chain,
Get_Type (Inter),
Get_Type (Get_Named_Entity
(Get_Actual (Assoc_El))));
end if;
Next_Association_Interface (Assoc_El, Inter_El);
end loop;
end if;
else
-- Uninstantiated package. Maybe macro expanded.
Set_Macro_Expanded_Flag
(Pkg, Is_Package_Macro_Expanded (Pkg));
end if;
end;
else
-- Simple packages are never expanded.
Set_Macro_Expanded_Flag (Pkg, False);
end if;
Sem_Declaration_Chain (Pkg);
-- GHDL: subprogram bodies appear in package body.
Pop_Signals_Declarative_Part (Implicit);
Close_Declarative_Region;
Set_Is_Within_Flag (Pkg, False);
Set_Need_Body (Pkg, Package_Need_Body_P (Pkg));
if Vhdl_Std >= Vhdl_08 then
Set_Need_Instance_Bodies
(Pkg, Package_Need_Instance_Bodies_P (Pkg));
end if;
end Sem_Package_Declaration;
-- LRM 2.6 Package Bodies.
procedure Sem_Package_Body (Decl : Iir)
is
Package_Ident : constant Name_Id := Get_Identifier (Decl);
Package_Decl : Iir;
begin
-- First, find the package declaration.
if not Is_Nested_Package (Decl) then
declare
Design_Unit: Iir_Design_Unit;
begin
Design_Unit := Load_Primary_Unit
(Get_Library (Get_Design_File (Get_Current_Design_Unit)),
Package_Ident, Decl);
if Design_Unit = Null_Iir then
Error_Msg_Sem
(+Decl, "package %i was not analysed", +Package_Ident);
return;
end if;
Package_Decl := Get_Library_Unit (Design_Unit);
if Get_Kind (Package_Decl) /= Iir_Kind_Package_Declaration then
Error_Msg_Sem
(+Decl, "primary unit %i is not a package", +Package_Ident);
return;
end if;
-- LRM08 13.5 Order of analysis
-- In each case, the second unit depends on the first unit
Add_Dependence (Design_Unit);
Add_Name (Design_Unit);
-- Add the context clauses from the primary unit.
Add_Context_Clauses (Design_Unit);
end;
else
declare
Interp : Name_Interpretation_Type;
begin
Interp := Get_Interpretation (Get_Identifier (Decl));
if not Valid_Interpretation (Interp)
or else not Is_In_Current_Declarative_Region (Interp)
or else Is_Potentially_Visible (Interp)
then
Error_Msg_Sem
(+Decl, "no corresponding package declaration for %i",
+Package_Ident);
return;
end if;
Package_Decl := Get_Declaration (Interp);
if Get_Kind (Package_Decl) /= Iir_Kind_Package_Declaration then
Error_Msg_Sem
(+Decl, "declaration %i is not a package", +Package_Ident);
return;
end if;
end;
end if;
-- Emit a warning is a body is not necessary.
if not Get_Need_Body (Package_Decl) then
Warning_Msg_Sem (Warnid_Body, +Decl,
"%n does not require a body", +Package_Decl);
end if;
Set_Package (Decl, Package_Decl);
Xref_Body (Decl, Package_Decl);
Set_Package_Body (Package_Decl, Decl);
Set_Is_Within_Flag (Package_Decl, True);
-- LRM93 10.1 Declarative Region
-- 4. A package declaration, together with the corresponding
-- body (if any).
Open_Declarative_Region;
Sem_Scopes.Add_Package_Declarations (Package_Decl);
Sem_Declaration_Chain (Decl);
Check_Full_Declaration (Decl, Decl);
Check_Full_Declaration (Package_Decl, Decl);
Close_Declarative_Region;
Set_Is_Within_Flag (Package_Decl, False);
end Sem_Package_Body;
function Sem_Uninstantiated_Package_Name (Decl : Iir) return Iir
is
Name : Iir;
Pkg : Iir;
begin
Name := Sem_Denoting_Name (Get_Uninstantiated_Package_Name (Decl));
Set_Uninstantiated_Package_Name (Decl, Name);
Pkg := Get_Named_Entity (Name);
if Is_Error (Pkg) then
null;
elsif Get_Kind (Pkg) /= Iir_Kind_Package_Declaration then
Error_Class_Match (Name, "package");
Pkg := Create_Error (Pkg);
elsif not Is_Uninstantiated_Package (Pkg) then
Error_Msg_Sem (+Name, "%n is not an uninstantiated package", +Pkg);
Pkg := Create_Error (Pkg);
end if;
Set_Uninstantiated_Package_Decl (Decl, Pkg);
return Pkg;
end Sem_Uninstantiated_Package_Name;
-- LRM08 4.9 Package Instantiation Declaration
procedure Sem_Package_Instantiation_Declaration (Decl : Iir)
is
Hdr : Iir;
Pkg : Iir;
Bod : Iir_Design_Unit;
begin
Sem_Scopes.Add_Name (Decl);
Set_Visible_Flag (Decl, True);
Xref_Decl (Decl);
-- LRM08 4.9
-- The uninstantiated package name shall denote an uninstantiated
-- package declared in a package declaration.
Pkg := Sem_Uninstantiated_Package_Name (Decl);
if Pkg = Null_Iir or Is_Error (Pkg) then
-- What could be done ?
return;
end if;
-- LRM08 4.9
-- The generic map aspect, if present, optionally associates a single
-- actual with each formal generic (or member thereof) in the
-- corresponding package declaration. Each formal generic (or member
-- thereof) shall be associated at most once.
-- GHDL: the generics are first instantiated (ie copied) and then
-- the actuals are associated with the instantiated formal.
-- FIXME: do it in Instantiate_Package_Declaration ?
Hdr := Get_Package_Header (Pkg);
if not Sem_Generic_Association_Chain (Hdr, Decl) then
-- FIXME: stop analysis here ?
return;
end if;
-- FIXME: unless the parent is a package declaration library unit, the
-- design unit depends on the body.
if Get_Need_Body (Pkg) and then not Is_Nested_Package (Pkg) then
Bod := Get_Package_Body (Pkg);
if Is_Null (Bod) then
Bod := Load_Secondary_Unit
(Get_Design_Unit (Pkg), Null_Identifier, Decl);
else
Bod := Get_Design_Unit (Bod);
end if;
if Is_Null (Bod) then
Error_Msg_Sem (+Decl, "cannot find package body of %n", +Pkg);
else
Add_Dependence (Bod);
end if;
end if;
-- Instantiate the declaration after analyse of the body. So that
-- the use_flag on the declaration can be propagated to the instance.
Sem_Inst.Instantiate_Package_Declaration (Decl, Pkg);
end Sem_Package_Instantiation_Declaration;
-- LRM 10.4 Use Clauses.
procedure Sem_Use_Clause_Name (Clause : Iir)
is
Name: Iir;
Prefix: Iir;
Name_Prefix : Iir;
begin
-- LRM93 10.4
-- A use clause achieves direct visibility of declarations that are
-- visible by selection.
-- Each selected name is a use clause identifies one or more
-- declarations that will potentialy become directly visible.
Name := Get_Selected_Name (Clause);
if Name = Null_Iir then
pragma Assert (Flags.Flag_Force_Analysis);
return;
end if;
case Get_Kind (Name) is
when Iir_Kind_Selected_By_All_Name
| Iir_Kind_Selected_Name =>
Name_Prefix := Get_Prefix (Name);
when others =>
Error_Msg_Sem (+Name, "use clause allows only selected name");
Set_Selected_Name (Clause, Create_Error_Name (Name));
return;
end case;
case Get_Kind (Name_Prefix) is
when Iir_Kind_Simple_Name
| Iir_Kind_Selected_Name =>
null;
when others =>
Error_Msg_Sem
(+Name_Prefix,
"use clause prefix must be a name or a selected name");
Set_Selected_Name (Clause, Create_Error_Name (Name));
return;
end case;
Name_Prefix := Sem_Denoting_Name (Name_Prefix);
Set_Prefix (Name, Name_Prefix);
Prefix := Get_Named_Entity (Name_Prefix);
if Is_Error (Prefix) then
Set_Selected_Name (Clause, Create_Error_Name (Name));
return;
end if;
-- LRM 10.4 Use Clauses
--
-- If the suffix of the selected name is [...], then the
-- selected name identifies only the declaration(s) of that
-- [...] contained within the package or library denoted by
-- the prefix of the selected name.
--
-- If the suffix is the reserved word ALL, then the selected name
-- identifies all declarations that are contained within the package
-- or library denoted by the prefix of the selected name.
--
-- GHDL: therefore, the suffix must be either a package or a library.
case Get_Kind (Prefix) is
when Iir_Kind_Library_Declaration =>
null;
when Iir_Kind_Package_Instantiation_Declaration
| Iir_Kind_Interface_Package_Declaration =>
null;
when Iir_Kind_Package_Declaration =>
-- LRM08 12.4 Use clauses
-- It is an error if the prefix of a selected name in a use
-- clause denotes an uninstantiated package.
if Is_Uninstantiated_Package (Prefix) then
Error_Msg_Sem
(+Name_Prefix,
"use of uninstantiated package is not allowed");
Set_Prefix (Name, Create_Error_Name (Name_Prefix));
return;
end if;
when others =>
Error_Msg_Sem
(+Prefix, "prefix must designate a package or a library");
Set_Prefix (Name, Create_Error_Name (Name_Prefix));
return;
end case;
case Get_Kind (Name) is
when Iir_Kind_Selected_Name =>
Sem_Name (Name, True);
case Get_Kind (Get_Named_Entity (Name)) is
when Iir_Kind_Error =>
-- Continue in case of error.
null;
when Iir_Kind_Overload_List =>
-- Analyze is correct as is.
null;
when others =>
Name := Finish_Sem_Name (Name);
Set_Selected_Name (Clause, Name);
end case;
when Iir_Kind_Selected_By_All_Name =>
null;
when others =>
raise Internal_Error;
end case;
end Sem_Use_Clause_Name;
-- LRM 10.4 Use Clauses.
procedure Sem_Use_Clause (Clauses: Iir_Use_Clause)
is
Clause : Iir_Use_Clause;
begin
Clause := Clauses;
loop
Sem_Use_Clause_Name (Clause);
Clause := Get_Use_Clause_Chain (Clause);
exit when Clause = Null_Iir;
end loop;
-- LRM 10.4
-- For each use clause, there is a certain region of text called the
-- scope of the use clause. This region starts immediatly after the
-- use clause.
Sem_Scopes.Add_Use_Clause (Clauses);
end Sem_Use_Clause;
-- LRM 11.2 Design Libraries.
procedure Sem_Library_Clause (Decl: Iir_Library_Clause)
is
Ident : Name_Id;
Lib: Iir;
begin
-- GHDL: 'redeclaration' is handled in sem_scopes.
Ident := Get_Identifier (Decl);
Lib := Libraries.Get_Library (Ident, Get_Location (Decl));
if Lib = Null_Iir then
Error_Msg_Sem (+Decl, "no resource library %i", +Ident);
else
Set_Library_Declaration (Decl, Lib);
Sem_Scopes.Add_Name (Lib, Ident, False);
Set_Visible_Flag (Lib, True);
Xref_Ref (Decl, Lib);
end if;
end Sem_Library_Clause;
-- LRM08 13.4 Context clauses.
procedure Sem_One_Context_Reference (Ref : Iir)
is
Name : Iir;
Ent : Iir;
begin
Name := Get_Selected_Name (Ref);
if Get_Kind (Name) /= Iir_Kind_Selected_Name then
Error_Msg_Sem
(+Name, "context reference only allows selected names");
return;
end if;
Name := Sem_Denoting_Name (Name);
Set_Selected_Name (Ref, Name);
Ent := Get_Named_Entity (Name);
if Is_Error (Ent) then
return;
end if;
-- LRM08 13.4 Context clauses
-- It is an error if a selected name in a context reference does not
-- denote a context declaration.
if Get_Kind (Ent) /= Iir_Kind_Context_Declaration then
Error_Msg_Sem (+Name, "name must denote a context declaration");
Set_Named_Entity (Name, Null_Iir);
return;
end if;
end Sem_One_Context_Reference;
-- LRM08 13.4 Context clauses.
procedure Sem_Context_Reference (Ctxt : Iir)
is
Ref : Iir;
begin
Ref := Ctxt;
loop
Sem_One_Context_Reference (Ref);
Ref := Get_Context_Reference_Chain (Ref);
exit when Ref = Null_Iir;
end loop;
-- FIXME: must be done clause after clause ?
Add_Context_Reference (Ctxt);
end Sem_Context_Reference;
-- LRM 11.3 Context Clauses.
procedure Sem_Context_Clauses (Unit: Iir)
is
El: Iir;
begin
El := Get_Context_Items (Unit);
while El /= Null_Iir loop
case Get_Kind (El) is
when Iir_Kind_Use_Clause =>
Sem_Use_Clause (El);
when Iir_Kind_Library_Clause =>
Sem_Library_Clause (El);
when Iir_Kind_Context_Reference =>
Sem_Context_Reference (El);
when others =>
Error_Kind ("sem_context_clauses", El);
end case;
El := Get_Chain (El);
end loop;
end Sem_Context_Clauses;
-- LRM08 13.3 Context declarations
procedure Sem_Context_Declaration (Decl: Iir)
is
-- Return TRUE iff the first prefix of NAME denotes library WORK.
function Has_Work_Library_Prefix (Name : Iir) return Boolean
is
Prefix : Iir;
begin
Prefix := Name;
while Get_Kind (Prefix) = Iir_Kind_Selected_Name
or else Get_Kind (Prefix) = Iir_Kind_Selected_By_All_Name
loop
Prefix := Get_Prefix (Prefix);
end loop;
return Get_Kind (Prefix) = Iir_Kind_Simple_Name
and then Get_Identifier (Prefix) = Std_Names.Name_Work
and then (Get_Kind (Get_Named_Entity (Prefix))
= Iir_Kind_Library_Declaration);
end Has_Work_Library_Prefix;
procedure Error_Work_Prefix (Loc : Iir) is
begin
Error_Msg_Sem
(+Loc, "'work' not allowed as prefix in context declaration");
end Error_Work_Prefix;
El : Iir;
El1 : Iir;
begin
Sem_Scopes.Add_Name (Decl);
Xref_Decl (Decl);
Sem_Context_Clauses (Decl);
El := Get_Context_Items (Decl);
while El /= Null_Iir loop
case Get_Kind (El) is
when Iir_Kind_Library_Clause =>
-- LRM08 13.3 Context declarations
-- It is an error if a library clause in a context declaration
-- defines the library logical name WORK, [...]
if Get_Identifier (El) = Std_Names.Name_Work then
Error_Msg_Sem
(+El, "'library work' not allowed in context declaration");
end if;
when Iir_Kind_Use_Clause =>
-- LRM08 13.3 Context declarations
-- [...] or if a selected name in a use clause [or a context
-- reference] in a context declaration has the library logic
-- name WORK as a prefix.
El1 := El;
while El1 /= Null_Iir loop
if Has_Work_Library_Prefix (Get_Selected_Name (El1)) then
Error_Work_Prefix (El1);
exit;
end if;
El1 := Get_Use_Clause_Chain (El1);
end loop;
when Iir_Kind_Context_Reference =>
-- LRM08 13.3 Context declarations
-- [...] or if a selected name in [a use clause or] a context
-- reference in a context declaration has the library logic
-- name WORK as a prefix.
El1 := El;
while El1 /= Null_Iir loop
if Has_Work_Library_Prefix (Get_Selected_Name (El1)) then
Error_Work_Prefix (El1);
exit;
end if;
El1 := Get_Context_Reference_Chain (El1);
end loop;
when others =>
raise Internal_Error;
end case;
El := Get_Chain (El);
end loop;
-- GHDL: forbid self-reference by making declaration visible at the end.
-- This violates LRM08 12.3 Visibility: A declaration is visible only
-- within a certain part of its scope; ...
Set_Visible_Flag (Decl, True);
end Sem_Context_Declaration;
-- Access to the current design unit. This is set, saved, restored, cleared
-- by the procedure semantic.
Current_Design_Unit: Iir_Design_Unit := Null_Iir;
function Get_Current_Design_Unit return Iir_Design_Unit is
begin
return Current_Design_Unit;
end Get_Current_Design_Unit;
-- LRM 11.1 Design units.
procedure Semantic (Design_Unit : Iir_Design_Unit)
is
Library_Unit : constant Iir := Get_Library_Unit (Design_Unit);
Library : constant Iir := Get_Library (Get_Design_File (Design_Unit));
Prev_Unit : Iir;
Old_Design_Unit : Iir_Design_Unit;
Implicit : Implicit_Signal_Declaration_Type;
begin
-- Sanity check: can analyze either previously analyzed unit or just
-- parsed unit.
case Get_Date (Design_Unit) is
when Date_Parsed =>
Set_Date (Design_Unit, Date_Analyzing);
when Date_Valid =>
null;
when Date_Obsolete =>
-- This happens only when design files are added into the library
-- and keeping obsolete units (eg: to pretty print a file).
Set_Date (Design_Unit, Date_Analyzing);
when others =>
raise Internal_Error;
end case;
-- If there is already a unit with the same name, mark it as being
-- replaced.
if Library_Unit /= Null_Iir then
if Get_Kind (Library_Unit) in Iir_Kinds_Primary_Unit then
Prev_Unit := Libraries.Find_Primary_Unit
(Library, Get_Identifier (Library_Unit));
if Is_Valid (Prev_Unit) and then Prev_Unit /= Design_Unit then
Set_Date (Prev_Unit, Date_Replacing);
end if;
end if;
end if;
-- Save and set current_design_unit.
Old_Design_Unit := Current_Design_Unit;
Current_Design_Unit := Design_Unit;
Push_Signals_Declarative_Part (Implicit, Null_Iir);
-- Have a clean and empty state for scopes.
Push_Interpretations;
-- LRM02 10.1 Declarative Region.
-- In addition to the above declarative region, there is a root
-- declarative region, not associated with a portion of the text of the
-- description, but encompassing any given primary unit. At the
-- beginning of the analysis of a given primary unit, there are no
-- declarations whose scopes (see 10.2) are within the root declarative
-- region. Moreover, the root declarative region associated with any
-- given secondary unit is the root declarative region of the
-- corresponding primary unit.
-- GHDL: for any revision of VHDL, a root declarative region is created,
-- due to reasons given by LCS 3 (VHDL Issue # 1028).
Open_Declarative_Region;
-- LRM 11.2
-- Every design unit is assumed to contain the following implicit
-- context items as part of its context clause:
-- library STD, WORK; use STD.STANDARD.all;
Sem_Scopes.Add_Name (Libraries.Std_Library, Std_Names.Name_Std, False);
Sem_Scopes.Add_Name (Library, Std_Names.Name_Work, False);
Sem_Scopes.Use_All_Names (Standard_Package);
if Get_Dependence_List (Design_Unit) = Null_Iir_List then
Set_Dependence_List (Design_Unit, Create_Iir_List);
end if;
Add_Dependence (Std_Standard_Unit);
-- Analyze context clauses.
Sem_Context_Clauses (Design_Unit);
-- Analyze the library unit.
if Library_Unit /= Null_Iir then
-- Can be null_iir in case of parse error.
case Iir_Kinds_Library_Unit (Get_Kind (Library_Unit)) is
when Iir_Kind_Entity_Declaration =>
Sem_Entity_Declaration (Library_Unit);
when Iir_Kind_Architecture_Body =>
Sem_Architecture_Body (Library_Unit);
when Iir_Kind_Package_Declaration =>
Sem_Package_Declaration (Library_Unit);
when Iir_Kind_Package_Body =>
Sem_Package_Body (Library_Unit);
when Iir_Kind_Configuration_Declaration =>
Sem_Configuration_Declaration (Library_Unit);
when Iir_Kind_Package_Instantiation_Declaration =>
Sem_Package_Instantiation_Declaration (Library_Unit);
when Iir_Kind_Context_Declaration =>
Sem_Context_Declaration (Library_Unit);
when Iir_Kinds_Verification_Unit =>
Sem_Psl.Sem_Psl_Verification_Unit (Library_Unit);
end case;
end if;
Close_Declarative_Region;
Pop_Interpretations;
if Get_Date (Design_Unit) = Date_Analyzing then
Set_Date (Design_Unit, Date_Analyzed);
end if;
if Get_Analysis_Checks_List (Design_Unit) /= Null_Iir_List then
Sem_Analysis_Checks_List (Design_Unit, False);
end if;
-- Restore current_design_unit.
Current_Design_Unit := Old_Design_Unit;
Pop_Signals_Declarative_Part (Implicit);
end Semantic;
end Vhdl.Sem;