aboutsummaryrefslogtreecommitdiffstats
path: root/src/sem_types.adb
diff options
context:
space:
mode:
authorTristan Gingold <tgingold@free.fr>2014-11-04 20:14:19 +0100
committerTristan Gingold <tgingold@free.fr>2014-11-04 20:14:19 +0100
commit9c195bf5d86d67ea5eb419ccf6e48dc153e57c68 (patch)
tree575346e529b99e26382b4a06f6ff2caa0b391ab2 /src/sem_types.adb
parent184a123f91e07c927292d67462561dc84f3a920d (diff)
downloadghdl-9c195bf5d86d67ea5eb419ccf6e48dc153e57c68.tar.gz
ghdl-9c195bf5d86d67ea5eb419ccf6e48dc153e57c68.tar.bz2
ghdl-9c195bf5d86d67ea5eb419ccf6e48dc153e57c68.zip
Move sources to src/ subdirectory.
Diffstat (limited to 'src/sem_types.adb')
-rw-r--r--src/sem_types.adb2210
1 files changed, 2210 insertions, 0 deletions
diff --git a/src/sem_types.adb b/src/sem_types.adb
new file mode 100644
index 000000000..12f276be1
--- /dev/null
+++ b/src/sem_types.adb
@@ -0,0 +1,2210 @@
+-- Semantic analysis.
+-- 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 Libraries;
+with Flags; use Flags;
+with Types; use Types;
+with Errorout; use Errorout;
+with Evaluation; use Evaluation;
+with Sem;
+with Sem_Expr; use Sem_Expr;
+with Sem_Scopes; use Sem_Scopes;
+with Sem_Names; use Sem_Names;
+with Sem_Decls;
+with Sem_Inst;
+with Name_Table;
+with Std_Names;
+with Iirs_Utils; use Iirs_Utils;
+with Std_Package; use Std_Package;
+with Ieee.Std_Logic_1164;
+with Xrefs; use Xrefs;
+
+package body Sem_Types is
+ -- Mark the resolution function (this may be required by the back-end to
+ -- generate resolver).
+ procedure Mark_Resolution_Function (Subtyp : Iir)
+ is
+ Func : Iir_Function_Declaration;
+ begin
+ if not Get_Resolved_Flag (Subtyp) then
+ return;
+ end if;
+
+ Func := Has_Resolution_Function (Subtyp);
+ -- Maybe the type is resolved through its elements.
+ if Func /= Null_Iir then
+ Set_Resolution_Function_Flag (Func, True);
+ end if;
+ end Mark_Resolution_Function;
+
+ procedure Set_Type_Has_Signal (Atype : Iir)
+ is
+ Orig : Iir;
+ begin
+ -- Sanity check: ATYPE can be a signal type (eg: not an access type)
+ if not Get_Signal_Type_Flag (Atype) then
+ -- Do not crash since this may be called on an erroneous design.
+ return;
+ end if;
+
+ -- If the type is already marked, nothing to do.
+ if Get_Has_Signal_Flag (Atype) then
+ return;
+ end if;
+
+ -- This type is used to declare a signal.
+ Set_Has_Signal_Flag (Atype, True);
+
+ -- If this type was instantiated, also mark the origin.
+ Orig := Sem_Inst.Get_Origin (Atype);
+ if Orig /= Null_Iir then
+ Set_Type_Has_Signal (Orig);
+ end if;
+
+ -- Mark resolution function, and for composite types, also mark type
+ -- of elements.
+ case Get_Kind (Atype) is
+ when Iir_Kind_Integer_Type_Definition
+ | Iir_Kind_Enumeration_Type_Definition
+ | Iir_Kind_Physical_Type_Definition
+ | Iir_Kind_Floating_Type_Definition =>
+ null;
+ when Iir_Kinds_Scalar_Subtype_Definition
+ | Iir_Kind_Record_Subtype_Definition =>
+ Set_Type_Has_Signal (Get_Base_Type (Atype));
+ Mark_Resolution_Function (Atype);
+ when Iir_Kind_Array_Subtype_Definition =>
+ Set_Type_Has_Signal (Get_Base_Type (Atype));
+ Mark_Resolution_Function (Atype);
+ Set_Type_Has_Signal (Get_Element_Subtype (Atype));
+ when Iir_Kind_Array_Type_Definition =>
+ Set_Type_Has_Signal (Get_Element_Subtype (Atype));
+ when Iir_Kind_Record_Type_Definition =>
+ declare
+ El_List : constant Iir_List :=
+ Get_Elements_Declaration_List (Atype);
+ El : Iir;
+ begin
+ for I in Natural loop
+ El := Get_Nth_Element (El_List, I);
+ exit when El = Null_Iir;
+ Set_Type_Has_Signal (Get_Type (El));
+ end loop;
+ end;
+ when Iir_Kind_Error =>
+ null;
+ when Iir_Kind_Incomplete_Type_Definition =>
+ -- No need to copy the flag.
+ null;
+ when others =>
+ Error_Kind ("set_type_has_signal(2)", Atype);
+ end case;
+ end Set_Type_Has_Signal;
+
+ -- Sem a range expression that appears in an integer, real or physical
+ -- type definition.
+ --
+ -- Both left and right bounds must be of the same type class, ie
+ -- integer types, or if INT_ONLY is false, real types.
+ -- However, the two bounds need not have the same type.
+ function Sem_Type_Range_Expression (Expr : Iir; Int_Only : Boolean)
+ return Iir
+ is
+ Left, Right: Iir;
+ Bt_L_Kind, Bt_R_Kind : Iir_Kind;
+ begin
+ Left := Sem_Expression_Universal (Get_Left_Limit (Expr));
+ Right := Sem_Expression_Universal (Get_Right_Limit (Expr));
+ if Left = Null_Iir or Right = Null_Iir then
+ return Null_Iir;
+ end if;
+
+ -- Emit error message for overflow and replace with a value to avoid
+ -- error storm.
+ if Get_Kind (Left) = Iir_Kind_Overflow_Literal then
+ Error_Msg_Sem ("overflow in left bound", Left);
+ Left := Build_Extreme_Value
+ (Get_Direction (Expr) = Iir_Downto, Left);
+ end if;
+ if Get_Kind (Right) = Iir_Kind_Overflow_Literal then
+ Error_Msg_Sem ("overflow in right bound", Right);
+ Right := Build_Extreme_Value
+ (Get_Direction (Expr) = Iir_To, Right);
+ end if;
+ Set_Left_Limit (Expr, Left);
+ Set_Right_Limit (Expr, Right);
+
+ Set_Expr_Staticness (Expr, Min (Get_Expr_Staticness (Left),
+ Get_Expr_Staticness (Right)));
+
+ Bt_L_Kind := Get_Kind (Get_Base_Type (Get_Type (Left)));
+ Bt_R_Kind := Get_Kind (Get_Base_Type (Get_Type (Right)));
+
+ if Int_Only then
+ if Bt_L_Kind /= Iir_Kind_Integer_Type_Definition
+ and then Bt_R_Kind = Iir_Kind_Integer_Type_Definition
+ then
+ Error_Msg_Sem ("left bound must be an integer expression", Left);
+ return Null_Iir;
+ end if;
+ if Bt_R_Kind /= Iir_Kind_Integer_Type_Definition
+ and then Bt_L_Kind = Iir_Kind_Integer_Type_Definition
+ then
+ Error_Msg_Sem ("right bound must be an integer expression", Left);
+ return Null_Iir;
+ end if;
+ if Bt_R_Kind /= Iir_Kind_Integer_Type_Definition
+ and then Bt_L_Kind /= Iir_Kind_Integer_Type_Definition
+ then
+ Error_Msg_Sem ("each bound must be an integer expression", Expr);
+ return Null_Iir;
+ end if;
+ else
+ if Bt_L_Kind /= Bt_R_Kind then
+ Error_Msg_Sem
+ ("left and right bounds must be of the same type class", Expr);
+ return Null_Iir;
+ end if;
+ case Bt_L_Kind is
+ when Iir_Kind_Integer_Type_Definition
+ | Iir_Kind_Floating_Type_Definition =>
+ null;
+ when others =>
+ -- Enumeration range are not allowed to define a new type.
+ Error_Msg_Sem
+ ("bad range type, only integer or float is allowed", Expr);
+ return Null_Iir;
+ end case;
+ end if;
+
+ return Expr;
+ end Sem_Type_Range_Expression;
+
+ function Create_Integer_Type (Loc : Iir; Constraint : Iir; Decl : Iir)
+ return Iir
+ is
+ Ntype: Iir_Integer_Subtype_Definition;
+ Ndef: Iir_Integer_Type_Definition;
+ begin
+ Ntype := Create_Iir (Iir_Kind_Integer_Subtype_Definition);
+ Location_Copy (Ntype, Loc);
+ Ndef := Create_Iir (Iir_Kind_Integer_Type_Definition);
+ Location_Copy (Ndef, Loc);
+ Set_Base_Type (Ndef, Ndef);
+ Set_Type_Declarator (Ndef, Decl);
+ Set_Type_Staticness (Ndef, Locally);
+ Set_Signal_Type_Flag (Ndef, True);
+ Set_Base_Type (Ntype, Ndef);
+ Set_Type_Declarator (Ntype, Decl);
+ Set_Range_Constraint (Ntype, Constraint);
+ Set_Type_Staticness (Ntype, Get_Expr_Staticness (Constraint));
+ Set_Resolved_Flag (Ntype, False);
+ Set_Signal_Type_Flag (Ntype, True);
+ if Get_Type_Staticness (Ntype) /= Locally then
+ Error_Msg_Sem ("range constraint of type must be locally static",
+ Decl);
+ end if;
+ return Ntype;
+ end Create_Integer_Type;
+
+ function Range_Expr_To_Type_Definition (Expr : Iir; Decl: Iir)
+ return Iir
+ is
+ Rng : Iir;
+ Res : Iir;
+ Base_Type : Iir;
+ begin
+ if Sem_Type_Range_Expression (Expr, False) = Null_Iir then
+ return Null_Iir;
+ end if;
+ Rng := Eval_Range_If_Static (Expr);
+ if Get_Expr_Staticness (Rng) /= Locally then
+ -- FIXME: create an artificial range to avoid error storm ?
+ null;
+ end if;
+
+ case Get_Kind (Get_Base_Type (Get_Type (Get_Left_Limit (Rng)))) is
+ when Iir_Kind_Integer_Type_Definition =>
+ Res := Create_Integer_Type (Expr, Rng, Decl);
+ when Iir_Kind_Floating_Type_Definition =>
+ declare
+ Ntype: Iir_Floating_Subtype_Definition;
+ Ndef: Iir_Floating_Type_Definition;
+ begin
+ Ntype := Create_Iir (Iir_Kind_Floating_Subtype_Definition);
+ Location_Copy (Ntype, Expr);
+ Ndef := Create_Iir (Iir_Kind_Floating_Type_Definition);
+ Location_Copy (Ndef, Expr);
+ Set_Base_Type (Ndef, Ndef);
+ Set_Type_Declarator (Ndef, Decl);
+ Set_Type_Staticness (Ndef, Get_Expr_Staticness (Expr));
+ Set_Signal_Type_Flag (Ndef, True);
+ Set_Base_Type (Ntype, Ndef);
+ Set_Type_Declarator (Ntype, Decl);
+ Set_Range_Constraint (Ntype, Rng);
+ Set_Resolved_Flag (Ntype, False);
+ Set_Type_Staticness (Ntype, Get_Expr_Staticness (Expr));
+ Set_Signal_Type_Flag (Ntype, True);
+ Res := Ntype;
+ end;
+ when others =>
+ -- sem_range_expression should catch such errors.
+ raise Internal_Error;
+ end case;
+
+ -- A type and a subtype were declared. The type of the bounds are now
+ -- used for the implicit subtype declaration. But the type of the
+ -- bounds aren't of the type of the type declaration (this is 'obvious'
+ -- because they exist before the type declaration). Override their
+ -- type. This is doable without destroying information as they are
+ -- either literals (of type convertible_xx_type_definition) or an
+ -- evaluated literal.
+ --
+ -- Overriding makes these implicit subtype homogenous with explicit
+ -- subtypes.
+ Base_Type := Get_Base_Type (Res);
+ Set_Type (Rng, Base_Type);
+ Set_Type (Get_Left_Limit (Rng), Base_Type);
+ Set_Type (Get_Right_Limit (Rng), Base_Type);
+
+ return Res;
+ end Range_Expr_To_Type_Definition;
+
+ function Create_Physical_Literal (Val : Iir_Int64; Unit : Iir) return Iir
+ is
+ Lit : Iir;
+ begin
+ Lit := Create_Iir (Iir_Kind_Physical_Int_Literal);
+ Set_Value (Lit, Val);
+ Set_Unit_Name (Lit, Unit);
+ Set_Expr_Staticness (Lit, Locally);
+ Set_Type (Lit, Get_Type (Unit));
+ Location_Copy (Lit, Unit);
+ return Lit;
+ end Create_Physical_Literal;
+
+ -- Analyze a physical type definition. Create a subtype.
+ function Sem_Physical_Type_Definition (Range_Expr: Iir; Decl : Iir)
+ return Iir_Physical_Subtype_Definition
+ is
+ Unit: Iir_Unit_Declaration;
+ Unit_Name : Iir;
+ Def : Iir_Physical_Type_Definition;
+ Sub_Type: Iir_Physical_Subtype_Definition;
+ Range_Expr1: Iir;
+ Val : Iir;
+ Lit : Iir_Physical_Int_Literal;
+ begin
+ Def := Get_Type (Range_Expr);
+
+ -- LRM93 4.1
+ -- The simple name declared by a type declaration denotes the
+ -- declared type, unless the type declaration declares both a base
+ -- type and a subtype of the base type, in which case the simple name
+ -- denotes the subtype, and the base type is anonymous.
+ Set_Type_Declarator (Def, Decl);
+ Set_Base_Type (Def, Def);
+ Set_Resolved_Flag (Def, False);
+ Set_Type_Staticness (Def, Locally);
+ Set_Signal_Type_Flag (Def, True);
+
+ -- Set the type definition of the type declaration (it was currently the
+ -- range expression). Do it early so that the units can be referenced
+ -- by expanded names.
+ Set_Type_Definition (Decl, Def);
+
+ -- LRM93 3.1.3
+ -- Each bound of a range constraint that is used in a physical type
+ -- definition must be a locally static expression of some integer type
+ -- but the two bounds need not have the same integer type.
+ case Get_Kind (Range_Expr) is
+ when Iir_Kind_Range_Expression =>
+ Range_Expr1 := Sem_Type_Range_Expression (Range_Expr, True);
+ when others =>
+ Error_Kind ("sem_physical_type_definition", Range_Expr);
+ end case;
+ if Range_Expr1 /= Null_Iir then
+ if Get_Expr_Staticness (Range_Expr1) /= Locally then
+ Error_Msg_Sem
+ ("range constraint for a physical type must be static",
+ Range_Expr1);
+ Range_Expr1 := Null_Iir;
+ else
+ Range_Expr1 := Eval_Range_If_Static (Range_Expr1);
+ end if;
+ end if;
+
+ -- Create the subtype.
+ Sub_Type := Create_Iir (Iir_Kind_Physical_Subtype_Definition);
+ Location_Copy (Sub_Type, Range_Expr);
+ Set_Base_Type (Sub_Type, Def);
+ Set_Signal_Type_Flag (Sub_Type, True);
+
+ -- Analyze the primary unit.
+ Unit := Get_Unit_Chain (Def);
+
+ Unit_Name := Build_Simple_Name (Unit, Unit);
+ Lit := Create_Physical_Literal (1, Unit_Name);
+ Set_Physical_Unit_Value (Unit, Lit);
+
+ Sem_Scopes.Add_Name (Unit);
+ Set_Type (Unit, Def);
+ Set_Expr_Staticness (Unit, Locally);
+ Set_Name_Staticness (Unit, Locally);
+ Set_Visible_Flag (Unit, True);
+ Xref_Decl (Unit);
+
+ if Range_Expr1 /= Null_Iir then
+ declare
+ -- Convert an integer literal to a physical literal.
+ -- This is used to convert bounds.
+ function Lit_To_Phys_Lit (Lim : Iir_Integer_Literal)
+ return Iir_Physical_Int_Literal
+ is
+ Res : Iir_Physical_Int_Literal;
+ begin
+ Res := Create_Iir (Iir_Kind_Physical_Int_Literal);
+ Location_Copy (Res, Lim);
+ Set_Type (Res, Def);
+ Set_Value (Res, Get_Value (Lim));
+ Set_Unit_Name (Res, Get_Primary_Unit_Name (Def));
+ Set_Expr_Staticness (Res, Locally);
+ Set_Literal_Origin (Res, Lim);
+ return Res;
+ end Lit_To_Phys_Lit;
+
+ Phys_Range : Iir_Range_Expression;
+ begin
+ -- Create the physical range.
+ Phys_Range := Create_Iir (Iir_Kind_Range_Expression);
+ Location_Copy (Phys_Range, Range_Expr1);
+ Set_Type (Phys_Range, Def);
+ Set_Direction (Phys_Range, Get_Direction (Range_Expr1));
+ Set_Left_Limit
+ (Phys_Range, Lit_To_Phys_Lit (Get_Left_Limit (Range_Expr1)));
+ Set_Right_Limit
+ (Phys_Range, Lit_To_Phys_Lit (Get_Right_Limit (Range_Expr1)));
+ Set_Expr_Staticness
+ (Phys_Range, Get_Expr_Staticness (Range_Expr1));
+
+ Set_Range_Constraint (Sub_Type, Phys_Range);
+ -- This must be locally...
+ Set_Type_Staticness (Sub_Type, Get_Expr_Staticness (Range_Expr1));
+
+ -- FIXME: the original range is not used. Reuse it ?
+ Free_Iir (Range_Expr);
+ end;
+ end if;
+ Set_Resolved_Flag (Sub_Type, False);
+
+ -- Analyze secondary units.
+ Unit := Get_Chain (Unit);
+ while Unit /= Null_Iir loop
+ Sem_Scopes.Add_Name (Unit);
+ Val := Sem_Expression (Get_Physical_Literal (Unit), Def);
+ if Val /= Null_Iir then
+ Set_Physical_Literal (Unit, Val);
+ Val := Eval_Physical_Literal (Val);
+ Set_Physical_Unit_Value (Unit, Val);
+
+ -- LRM93 §3.1
+ -- The position number of unit names need not lie within the range
+ -- specified by the range constraint.
+ -- GHDL: this was not true in VHDL87.
+ -- GHDL: This is not so simple if 1 is not included in the range.
+ if False and then Flags.Vhdl_Std = Vhdl_87
+ and then Range_Expr1 /= Null_Iir
+ then
+ if not Eval_Int_In_Range (Get_Value (Unit), Range_Expr1) then
+ Error_Msg_Sem
+ ("physical literal does not lie within the range", Unit);
+ end if;
+ end if;
+ else
+ -- Avoid errors storm.
+ Set_Physical_Literal (Unit, Get_Primary_Unit (Def));
+ Set_Physical_Unit_Value (Unit, Lit);
+ end if;
+
+ Set_Type (Unit, Def);
+ Set_Expr_Staticness (Unit, Locally);
+ Set_Name_Staticness (Unit, Locally);
+ Sem_Scopes.Name_Visible (Unit);
+ Xref_Decl (Unit);
+ Unit := Get_Chain (Unit);
+ end loop;
+
+ return Sub_Type;
+ end Sem_Physical_Type_Definition;
+
+ -- Return true iff decl is std.textio.text
+ function Is_Text_Type_Declaration (Decl : Iir_Type_Declaration)
+ return Boolean
+ is
+ use Std_Names;
+ P : Iir;
+ begin
+ if Get_Identifier (Decl) /= Name_Text then
+ return False;
+ end if;
+ P := Get_Parent (Decl);
+ if Get_Kind (P) /= Iir_Kind_Package_Declaration
+ or else Get_Identifier (P) /= Name_Textio
+ then
+ return False;
+ end if;
+ -- design_unit, design_file, library_declaration.
+ P := Get_Library (Get_Design_File (Get_Design_Unit (P)));
+ if P /= Libraries.Std_Library then
+ return False;
+ end if;
+ return True;
+ end Is_Text_Type_Declaration;
+
+ procedure Check_No_File_Type (El_Type : Iir; Loc : Iir) is
+ begin
+ case Get_Kind (El_Type) is
+ when Iir_Kind_File_Type_Definition =>
+ Error_Msg_Sem
+ ("element of file type is not allowed in a composite type", Loc);
+ when others =>
+ null;
+ end case;
+ end Check_No_File_Type;
+
+ -- Semantize the array_element type of array type DEF.
+ -- Set resolved_flag of DEF.
+ procedure Sem_Array_Element (Def : Iir)
+ is
+ El_Type : Iir;
+ begin
+ El_Type := Get_Element_Subtype_Indication (Def);
+ El_Type := Sem_Subtype_Indication (El_Type);
+ if El_Type = Null_Iir then
+ Set_Type_Staticness (Def, None);
+ Set_Resolved_Flag (Def, False);
+ return;
+ end if;
+ Set_Element_Subtype_Indication (Def, El_Type);
+
+ El_Type := Get_Type_Of_Subtype_Indication (El_Type);
+ Set_Element_Subtype (Def, El_Type);
+ Check_No_File_Type (El_Type, Def);
+ Set_Signal_Type_Flag (Def, Get_Signal_Type_Flag (El_Type));
+
+ -- LRM93 §3.2.1.1
+ -- The same requirement exists [must define a constrained
+ -- array subtype] [...] for the element subtype indication
+ -- of an array type definition, if the type of the array
+ -- element is itself an array type.
+ if Vhdl_Std < Vhdl_08
+ and then not Is_Fully_Constrained_Type (El_Type)
+ then
+ Error_Msg_Sem ("array element of unconstrained "
+ & Disp_Node (El_Type) & " is not allowed", Def);
+ end if;
+ Set_Resolved_Flag (Def, Get_Resolved_Flag (El_Type));
+ end Sem_Array_Element;
+
+ procedure Sem_Protected_Type_Declaration (Type_Decl : Iir_Type_Declaration)
+ is
+ Decl : Iir_Protected_Type_Declaration;
+ El : Iir;
+ begin
+ Decl := Get_Type_Definition (Type_Decl);
+ Set_Base_Type (Decl, Decl);
+ Set_Resolved_Flag (Decl, False);
+ Set_Signal_Type_Flag (Decl, False);
+ Set_Type_Staticness (Decl, None);
+
+ -- LRM 10.3 Visibility
+ -- [...] except in the declaration of a design_unit or a protected type
+ -- declaration, in which case it starts immediatly after the reserved
+ -- word is occuring after the identifier of the design unit or
+ -- protected type declaration.
+ Set_Visible_Flag (Type_Decl, True);
+
+ -- LRM 10.1
+ -- n) A protected type declaration, together with the corresponding
+ -- body.
+ Open_Declarative_Region;
+
+ Sem_Decls.Sem_Declaration_Chain (Decl);
+ El := Get_Declaration_Chain (Decl);
+ while El /= Null_Iir loop
+ case Get_Kind (El) is
+ when Iir_Kind_Use_Clause
+ | Iir_Kind_Attribute_Specification =>
+ null;
+ when Iir_Kind_Procedure_Declaration
+ | Iir_Kind_Function_Declaration =>
+ declare
+ Inter : Iir;
+ Inter_Type : Iir;
+ begin
+ Inter := Get_Interface_Declaration_Chain (El);
+ while Inter /= Null_Iir loop
+ Inter_Type := Get_Type (Inter);
+ if Inter_Type /= Null_Iir
+ and then Get_Signal_Type_Flag (Inter_Type) = False
+ and then Get_Kind (Inter_Type)
+ /= Iir_Kind_Protected_Type_Declaration
+ then
+ Error_Msg_Sem
+ ("formal parameter method must not be "
+ & "access or file type", Inter);
+ end if;
+ Inter := Get_Chain (Inter);
+ end loop;
+ if Get_Kind (El) = Iir_Kind_Function_Declaration then
+ Inter_Type := Get_Return_Type (El);
+ if Inter_Type /= Null_Iir
+ and then Get_Signal_Type_Flag (Inter_Type) = False
+ then
+ Error_Msg_Sem
+ ("method return type must not be access of file",
+ El);
+ end if;
+ end if;
+ end;
+ when others =>
+ Error_Msg_Sem
+ (Disp_Node (El)
+ & " are not allowed in protected type declaration", El);
+ end case;
+ El := Get_Chain (El);
+ end loop;
+
+ Close_Declarative_Region;
+ end Sem_Protected_Type_Declaration;
+
+ procedure Sem_Protected_Type_Body (Bod : Iir)
+ is
+ Inter : Name_Interpretation_Type;
+ Type_Decl : Iir;
+ Decl : Iir;
+ El : Iir;
+ begin
+ -- LRM 3.5 Protected types.
+ -- Each protected type declaration appearing immediatly within a given
+ -- declaration region must have exactly one corresponding protected type
+ -- body appearing immediatly within the same declarative region and
+ -- textually subsequent to the protected type declaration.
+ --
+ -- Similarly, each protected type body appearing immediatly within a
+ -- given declarative region must have exactly one corresponding
+ -- protected type declaration appearing immediatly within the same
+ -- declarative region and textually prior to the protected type body.
+ Inter := Get_Interpretation (Get_Identifier (Bod));
+ if Valid_Interpretation (Inter)
+ and then Is_In_Current_Declarative_Region (Inter)
+ then
+ Type_Decl := Get_Declaration (Inter);
+ if Get_Kind (Type_Decl) = Iir_Kind_Type_Declaration then
+ Decl := Get_Type_Definition (Type_Decl);
+ else
+ Decl := Null_Iir;
+ end if;
+ else
+ Decl := Null_Iir;
+ end if;
+
+ if Decl /= Null_Iir
+ and then Get_Kind (Decl) = Iir_Kind_Protected_Type_Declaration
+ then
+ Set_Protected_Type_Declaration (Bod, Decl);
+ if Get_Protected_Type_Body (Decl) /= Null_Iir then
+ Error_Msg_Sem
+ ("protected type body already declared for "
+ & Disp_Node (Decl), Bod);
+ Error_Msg_Sem
+ ("(previous body)", Get_Protected_Type_Body (Decl));
+ Decl := Null_Iir;
+ elsif not Get_Visible_Flag (Type_Decl) then
+ -- Can this happen ?
+ Error_Msg_Sem
+ ("protected type declaration not yet visible", Bod);
+ Error_Msg_Sem
+ ("(location of protected type declaration)", Decl);
+ Decl := Null_Iir;
+ else
+ Set_Protected_Type_Body (Decl, Bod);
+ end if;
+ else
+ Error_Msg_Sem
+ ("no protected type declaration for this body", Bod);
+ if Decl /= Null_Iir then
+ Error_Msg_Sem
+ ("(found " & Disp_Node (Decl) & " declared here)", Decl);
+ Decl := Null_Iir;
+ end if;
+ end if;
+
+ -- LRM 10.1
+ -- n) A protected type declaration, together with the corresponding
+ -- body.
+ Open_Declarative_Region;
+
+ if Decl /= Null_Iir then
+ Xref_Body (Bod, Decl);
+ Add_Protected_Type_Declarations (Decl);
+ end if;
+
+ Sem_Decls.Sem_Declaration_Chain (Bod);
+
+ El := Get_Declaration_Chain (Bod);
+ while El /= Null_Iir loop
+ case Get_Kind (El) is
+ when Iir_Kind_Procedure_Declaration
+ | Iir_Kind_Function_Declaration
+ | Iir_Kind_Implicit_Procedure_Declaration
+ | Iir_Kind_Implicit_Function_Declaration =>
+ null;
+ when Iir_Kind_Procedure_Body
+ | Iir_Kind_Function_Body =>
+ null;
+ when Iir_Kind_Type_Declaration
+ | Iir_Kind_Anonymous_Type_Declaration =>
+ null;
+ when Iir_Kind_Subtype_Declaration
+ | Iir_Kind_Constant_Declaration
+ | Iir_Kind_Variable_Declaration
+ | Iir_Kind_File_Declaration =>
+ null;
+ when Iir_Kind_Object_Alias_Declaration
+ | Iir_Kind_Non_Object_Alias_Declaration =>
+ null;
+ when Iir_Kind_Attribute_Declaration
+ | Iir_Kind_Attribute_Specification
+ | Iir_Kind_Use_Clause
+ | Iir_Kind_Group_Template_Declaration
+ | Iir_Kind_Group_Declaration =>
+ null;
+ when others =>
+ Error_Msg_Sem
+ (Disp_Node (El) & " not allowed in a protected type body",
+ El);
+ end case;
+ El := Get_Chain (El);
+ end loop;
+ Sem_Decls.Check_Full_Declaration (Bod, Bod);
+
+ -- LRM 3.5.2 Protected type bodies
+ -- Each subprogram declaration appearing in a given protected type
+ -- declaration shall have a corresponding subprogram body appearing in
+ -- the corresponding protected type body.
+ if Decl /= Null_Iir then
+ Sem_Decls.Check_Full_Declaration (Decl, Bod);
+ end if;
+
+ Close_Declarative_Region;
+ end Sem_Protected_Type_Body;
+
+ -- Return the constraint state from CONST (the initial state) and ATYPE,
+ -- as if ATYPE was a new element of a record.
+ function Update_Record_Constraint (Const : Iir_Constraint; Atype : Iir)
+ return Iir_Constraint is
+ begin
+ if Get_Kind (Atype) not in Iir_Kinds_Composite_Type_Definition then
+ return Const;
+ end if;
+
+ case Const is
+ when Fully_Constrained
+ | Unconstrained =>
+ if Get_Constraint_State (Atype) = Const then
+ return Const;
+ else
+ return Partially_Constrained;
+ end if;
+ when Partially_Constrained =>
+ return Partially_Constrained;
+ end case;
+ end Update_Record_Constraint;
+
+ function Get_Array_Constraint (Def : Iir) return Iir_Constraint
+ is
+ El_Type : constant Iir := Get_Element_Subtype (Def);
+ Index : constant Boolean :=
+ Get_Kind (Def) = Iir_Kind_Array_Subtype_Definition
+ and then Get_Index_Constraint_Flag (Def);
+ begin
+ if Get_Kind (El_Type) in Iir_Kinds_Composite_Type_Definition then
+ case Get_Constraint_State (El_Type) is
+ when Fully_Constrained =>
+ if Index then
+ return Fully_Constrained;
+ else
+ return Partially_Constrained;
+ end if;
+ when Partially_Constrained =>
+ return Partially_Constrained;
+ when Unconstrained =>
+ if not Index then
+ return Unconstrained;
+ else
+ return Partially_Constrained;
+ end if;
+ end case;
+ else
+ if Index then
+ return Fully_Constrained;
+ else
+ return Unconstrained;
+ end if;
+ end if;
+ end Get_Array_Constraint;
+
+ function Sem_Enumeration_Type_Definition (Def: Iir; Decl: Iir) return Iir
+ is
+ begin
+ Set_Base_Type (Def, Def);
+ Set_Type_Staticness (Def, Locally);
+ Set_Signal_Type_Flag (Def, True);
+
+ -- Makes all literal visible.
+ declare
+ El: Iir;
+ Literal_List: Iir_List;
+ Only_Characters : Boolean := True;
+ begin
+ Literal_List := Get_Enumeration_Literal_List (Def);
+ for I in Natural loop
+ El := Get_Nth_Element (Literal_List, I);
+ exit when El = Null_Iir;
+ Set_Expr_Staticness (El, Locally);
+ Set_Name_Staticness (El, Locally);
+ Set_Type (El, Def);
+ Set_Enumeration_Decl (El, El);
+ Sem.Compute_Subprogram_Hash (El);
+ Sem_Scopes.Add_Name (El);
+ Name_Visible (El);
+ Xref_Decl (El);
+ if Only_Characters
+ and then not Name_Table.Is_Character (Get_Identifier (El))
+ then
+ Only_Characters := False;
+ end if;
+ end loop;
+ Set_Only_Characters_Flag (Def, Only_Characters);
+ end;
+ Set_Resolved_Flag (Def, False);
+
+ Create_Range_Constraint_For_Enumeration_Type (Def);
+
+ -- Identifier IEEE.Std_Logic_1164.Std_Ulogic.
+ if Get_Identifier (Decl) = Std_Names.Name_Std_Ulogic
+ and then
+ Get_Parent (Decl) = Ieee.Std_Logic_1164.Std_Logic_1164_Pkg
+ then
+ Ieee.Std_Logic_1164.Std_Ulogic_Type := Def;
+ end if;
+
+ return Def;
+ end Sem_Enumeration_Type_Definition;
+
+ function Sem_Record_Type_Definition (Def: Iir) return Iir
+ is
+ -- Semantized type of previous element
+ Last_Type : Iir;
+
+ El_List : constant Iir_List := Get_Elements_Declaration_List (Def);
+ El: Iir;
+ El_Type : Iir;
+ Resolved_Flag : Boolean;
+ Staticness : Iir_Staticness;
+ Constraint : Iir_Constraint;
+ begin
+ -- LRM 10.1
+ -- 5. A record type declaration,
+ Open_Declarative_Region;
+
+ Resolved_Flag := True;
+ Last_Type := Null_Iir;
+ Staticness := Locally;
+ Constraint := Fully_Constrained;
+ Set_Signal_Type_Flag (Def, True);
+
+ for I in Natural loop
+ El := Get_Nth_Element (El_List, I);
+ exit when El = Null_Iir;
+
+ El_Type := Get_Subtype_Indication (El);
+ if El_Type /= Null_Iir then
+ -- Be careful for a declaration list (r,g,b: integer).
+ El_Type := Sem_Subtype_Indication (El_Type);
+ Set_Subtype_Indication (El, El_Type);
+ El_Type := Get_Type_Of_Subtype_Indication (El_Type);
+ Last_Type := El_Type;
+ else
+ El_Type := Last_Type;
+ end if;
+ if El_Type /= Null_Iir then
+ Set_Type (El, El_Type);
+ Check_No_File_Type (El_Type, El);
+ if not Get_Signal_Type_Flag (El_Type) then
+ Set_Signal_Type_Flag (Def, False);
+ end if;
+
+ -- LRM93 3.2.1.1
+ -- The same requirement [must define a constrained array
+ -- subtype] exits for the subtype indication of an
+ -- element declaration, if the type of the record
+ -- element is an array type.
+ if Vhdl_Std < Vhdl_08
+ and then not Is_Fully_Constrained_Type (El_Type)
+ then
+ Error_Msg_Sem
+ ("element declaration of unconstrained "
+ & Disp_Node (El_Type) & " is not allowed", El);
+ end if;
+ Resolved_Flag :=
+ Resolved_Flag and Get_Resolved_Flag (El_Type);
+ Staticness := Min (Staticness,
+ Get_Type_Staticness (El_Type));
+ Constraint := Update_Record_Constraint
+ (Constraint, El_Type);
+ else
+ Staticness := None;
+ end if;
+ Sem_Scopes.Add_Name (El);
+ Name_Visible (El);
+ Xref_Decl (El);
+ end loop;
+ Close_Declarative_Region;
+ Set_Base_Type (Def, Def);
+ Set_Resolved_Flag (Def, Resolved_Flag);
+ Set_Type_Staticness (Def, Staticness);
+ Set_Constraint_State (Def, Constraint);
+ return Def;
+ end Sem_Record_Type_Definition;
+
+ function Sem_Unbounded_Array_Type_Definition (Def: Iir) return Iir
+ is
+ Index_List : constant Iir_List :=
+ Get_Index_Subtype_Definition_List (Def);
+ Index_Type : Iir;
+ begin
+ Set_Base_Type (Def, Def);
+
+ for I in Natural loop
+ Index_Type := Get_Nth_Element (Index_List, I);
+ exit when Index_Type = Null_Iir;
+
+ Index_Type := Sem_Type_Mark (Index_Type);
+ Replace_Nth_Element (Index_List, I, Index_Type);
+
+ Index_Type := Get_Type (Index_Type);
+ if Get_Kind (Index_Type) not in Iir_Kinds_Discrete_Type_Definition
+ then
+ Error_Msg_Sem ("an index type of an array must be a discrete type",
+ Index_Type);
+ -- FIXME: disp type Index_Type ?
+ end if;
+ end loop;
+
+ Set_Index_Subtype_List (Def, Index_List);
+
+ Sem_Array_Element (Def);
+ Set_Constraint_State (Def, Get_Array_Constraint (Def));
+
+ -- According to LRM93 7.4.1, an unconstrained array type is not static.
+ Set_Type_Staticness (Def, None);
+
+ return Def;
+ end Sem_Unbounded_Array_Type_Definition;
+
+ -- Return the subtype declaration corresponding to the base type of ATYPE
+ -- (for integer and real types), or the type for enumerated types. To say
+ -- that differently, it returns the type or subtype which defines the
+ -- original range.
+ function Get_First_Subtype_Declaration (Atype : Iir) return Iir is
+ Base_Type : constant Iir := Get_Base_Type (Atype);
+ Base_Decl : constant Iir := Get_Type_Declarator (Base_Type);
+ begin
+ if Get_Kind (Base_Type) = Iir_Kind_Enumeration_Type_Definition then
+ pragma Assert (Get_Kind (Base_Decl) = Iir_Kind_Type_Declaration);
+ return Base_Decl;
+ else
+ return Get_Type_Declarator (Get_Subtype_Definition (Base_Decl));
+ end if;
+ end Get_First_Subtype_Declaration;
+
+ function Sem_Constrained_Array_Type_Definition (Def: Iir; Decl: Iir)
+ return Iir
+ is
+ Index_Type : Iir;
+ Index_Name : Iir;
+ Index_List : Iir_List;
+ Base_Index_List : Iir_List;
+ El_Type : Iir;
+ Staticness : Iir_Staticness;
+
+ -- array_type_definition, which is the same as the subtype,
+ -- but without any constraint in the indexes.
+ Base_Type: Iir;
+ begin
+ -- LRM08 5.3.2.1 Array types
+ -- A constrained array definition similarly defines both an array
+ -- type and a subtype of this type.
+ -- - The array type is an implicitely declared anonymous type,
+ -- this type is defined by an (implicit) unbounded array
+ -- definition in which the element subtype indication either
+ -- denotes the base type of the subtype denoted by the element
+ -- subtype indication of the constrained array definition, if
+ -- that subtype is a composite type, or otherwise is the
+ -- element subtype indication of the constrained array
+ -- definition, and in which the type mark of each index subtype
+ -- definition denotes the subtype defined by the corresponding
+ -- discrete range.
+ -- - The array subtype is the subtype obtained by imposition of
+ -- the index constraint on the array type and if the element
+ -- subtype indication of the constrained array definition
+ -- denotes a fully or partially constrained composite subtype,
+ -- imposition of the constraint of that subtype as an array
+ -- element constraint on the array type.
+
+ -- FIXME: all indexes must be either constrained or
+ -- unconstrained.
+ -- If all indexes are unconstrained, this is really a type
+ -- otherwise, this is a subtype.
+
+ -- Create a definition for the base type of subtype DEF.
+ Base_Type := Create_Iir (Iir_Kind_Array_Type_Definition);
+ Location_Copy (Base_Type, Def);
+ Set_Base_Type (Base_Type, Base_Type);
+ Set_Type_Declarator (Base_Type, Decl);
+ Base_Index_List := Create_Iir_List;
+ Set_Index_Subtype_Definition_List (Base_Type, Base_Index_List);
+ Set_Index_Subtype_List (Base_Type, Base_Index_List);
+
+ Staticness := Locally;
+ Index_List := Get_Index_Constraint_List (Def);
+ for I in Natural loop
+ Index_Type := Get_Nth_Element (Index_List, I);
+ exit when Index_Type = Null_Iir;
+
+ Index_Name := Sem_Discrete_Range_Integer (Index_Type);
+ if Index_Name /= Null_Iir then
+ Index_Name := Range_To_Subtype_Indication (Index_Name);
+ else
+ -- Avoid errors.
+ Index_Name :=
+ Build_Simple_Name (Natural_Subtype_Declaration, Index_Type);
+ Set_Type (Index_Name, Natural_Subtype_Definition);
+ end if;
+
+ Replace_Nth_Element (Index_List, I, Index_Name);
+
+ Index_Type := Get_Index_Type (Index_Name);
+ Staticness := Min (Staticness, Get_Type_Staticness (Index_Type));
+
+ -- Set the index subtype definition for the array base type.
+ if Get_Kind (Index_Name) in Iir_Kinds_Denoting_Name then
+ Index_Type := Index_Name;
+ else
+ pragma Assert
+ (Get_Kind (Index_Name) in Iir_Kinds_Subtype_Definition);
+ Index_Type := Get_Subtype_Type_Mark (Index_Name);
+ if Index_Type = Null_Iir then
+ -- From a range expression like '1 to 4' or from an attribute
+ -- name.
+ declare
+ Subtype_Decl : constant Iir :=
+ Get_First_Subtype_Declaration (Index_Name);
+ begin
+ Index_Type := Build_Simple_Name (Subtype_Decl, Index_Name);
+ Set_Type (Index_Type, Get_Type (Subtype_Decl));
+ end;
+ end if;
+ end if;
+ Append_Element (Base_Index_List, Index_Type);
+ end loop;
+ Set_Index_Subtype_List (Def, Index_List);
+
+ -- Element type.
+ Set_Element_Subtype_Indication (Base_Type, Get_Element_Subtype (Def));
+ Sem_Array_Element (Base_Type);
+ El_Type := Get_Element_Subtype (Base_Type);
+ Set_Element_Subtype (Def, El_Type);
+
+ Set_Signal_Type_Flag (Def, Get_Signal_Type_Flag (Base_Type));
+
+ -- According to LRM93 §7.4.1, an unconstrained array type
+ -- is not static.
+ Set_Type_Staticness (Base_Type, None);
+ Set_Type_Staticness (Def, Min (Staticness,
+ Get_Type_Staticness (El_Type)));
+
+ Set_Type_Declarator (Base_Type, Decl);
+ Set_Resolved_Flag (Base_Type, Get_Resolved_Flag (Def));
+ Set_Index_Constraint_Flag (Def, True);
+ Set_Constraint_State (Def, Get_Array_Constraint (Def));
+ Set_Constraint_State (Base_Type, Get_Array_Constraint (Base_Type));
+ Set_Base_Type (Def, Base_Type);
+ Set_Subtype_Type_Mark (Def, Null_Iir);
+ return Def;
+ end Sem_Constrained_Array_Type_Definition;
+
+ function Sem_Access_Type_Definition (Def: Iir) return Iir
+ is
+ D_Type : Iir;
+ begin
+ D_Type := Sem_Subtype_Indication
+ (Get_Designated_Subtype_Indication (Def), True);
+ Set_Designated_Subtype_Indication (Def, D_Type);
+
+ D_Type := Get_Type_Of_Subtype_Indication (D_Type);
+ if D_Type /= Null_Iir then
+ case Get_Kind (D_Type) is
+ when Iir_Kind_Incomplete_Type_Definition =>
+ Append_Element (Get_Incomplete_Type_List (D_Type), Def);
+ when Iir_Kind_File_Type_Definition =>
+ -- LRM 3.3
+ -- The designated type must not be a file type.
+ Error_Msg_Sem ("designated type must not be a file type", Def);
+ when others =>
+ null;
+ end case;
+ Set_Designated_Type (Def, D_Type);
+ end if;
+ Set_Base_Type (Def, Def);
+ Set_Type_Staticness (Def, None);
+ Set_Resolved_Flag (Def, False);
+ Set_Signal_Type_Flag (Def, False);
+ return Def;
+ end Sem_Access_Type_Definition;
+
+ function Sem_File_Type_Definition (Def: Iir; Decl: Iir) return Iir
+ is
+ Type_Mark : Iir;
+ begin
+ Type_Mark := Sem_Type_Mark (Get_File_Type_Mark (Def));
+ Set_File_Type_Mark (Def, Type_Mark);
+
+ Type_Mark := Get_Type (Type_Mark);
+
+ if Get_Kind (Type_Mark) = Iir_Kind_Error then
+ null;
+ elsif Get_Signal_Type_Flag (Type_Mark) = False then
+ -- LRM 3.4
+ -- The base type of this subtype must not be a file type
+ -- or an access type.
+ -- If the base type is a composite type, it must not
+ -- contain a subelement of an access type.
+ Error_Msg_Sem
+ (Disp_Node (Type_Mark) & " cannot be a file type", Def);
+ elsif Get_Kind (Type_Mark) in Iir_Kinds_Array_Type_Definition then
+ -- LRM 3.4
+ -- If the base type is an array type, it must be a one
+ -- dimensional array type.
+ if not Is_One_Dimensional_Array_Type (Type_Mark) then
+ Error_Msg_Sem
+ ("multi-dimensional " & Disp_Node (Type_Mark)
+ & " cannot be a file type", Def);
+ end if;
+ end if;
+
+ Set_Base_Type (Def, Def);
+ Set_Resolved_Flag (Def, False);
+ Set_Text_File_Flag (Def, Is_Text_Type_Declaration (Decl));
+ Set_Signal_Type_Flag (Def, False);
+ Set_Type_Staticness (Def, None);
+ return Def;
+ end Sem_File_Type_Definition;
+
+ function Sem_Type_Definition (Def: Iir; Decl: Iir) return Iir is
+ begin
+ case Get_Kind (Def) is
+ when Iir_Kind_Enumeration_Type_Definition =>
+ return Sem_Enumeration_Type_Definition (Def, Decl);
+
+ when Iir_Kind_Range_Expression =>
+ if Get_Type (Def) /= Null_Iir then
+ return Sem_Physical_Type_Definition (Def, Decl);
+ else
+ return Range_Expr_To_Type_Definition (Def, Decl);
+ end if;
+
+ when Iir_Kind_Range_Array_Attribute
+ | Iir_Kind_Attribute_Name
+ | Iir_Kind_Parenthesis_Name =>
+ if Get_Type (Def) /= Null_Iir then
+ return Sem_Physical_Type_Definition (Def, Decl);
+ end if;
+ -- Nb: the attribute is expected to be a 'range or
+ -- a 'reverse_range attribute.
+ declare
+ Res : Iir;
+ begin
+ Res := Sem_Discrete_Range_Expression (Def, Null_Iir, True);
+ if Res = Null_Iir then
+ return Null_Iir;
+ end if;
+ -- This cannot be a floating range.
+ return Create_Integer_Type (Def, Res, Decl);
+ end;
+
+ when Iir_Kind_Array_Subtype_Definition =>
+ return Sem_Constrained_Array_Type_Definition (Def, Decl);
+
+ when Iir_Kind_Array_Type_Definition =>
+ return Sem_Unbounded_Array_Type_Definition (Def);
+
+ when Iir_Kind_Record_Type_Definition =>
+ return Sem_Record_Type_Definition (Def);
+
+ when Iir_Kind_Access_Type_Definition =>
+ return Sem_Access_Type_Definition (Def);
+
+ when Iir_Kind_File_Type_Definition =>
+ return Sem_File_Type_Definition (Def, Decl);
+
+ when Iir_Kind_Protected_Type_Declaration =>
+ Sem_Protected_Type_Declaration (Decl);
+ return Def;
+
+ when others =>
+ Error_Kind ("sem_type_definition", Def);
+ return Def;
+ end case;
+ end Sem_Type_Definition;
+
+ function Range_To_Subtype_Indication (A_Range: Iir) return Iir
+ is
+ Sub_Type: Iir;
+ Range_Type : Iir;
+ begin
+ case Get_Kind (A_Range) is
+ when Iir_Kind_Range_Expression
+ | Iir_Kind_Range_Array_Attribute
+ | Iir_Kind_Reverse_Range_Array_Attribute =>
+ -- Create a sub type.
+ Range_Type := Get_Type (A_Range);
+ when Iir_Kind_Simple_Name
+ | Iir_Kind_Selected_Name =>
+ return A_Range;
+ when Iir_Kinds_Discrete_Type_Definition =>
+ -- A_RANGE is already a subtype definition.
+ return A_Range;
+ when others =>
+ Error_Kind ("range_to_subtype_indication", A_Range);
+ return Null_Iir;
+ end case;
+
+ case Get_Kind (Range_Type) is
+ when Iir_Kind_Enumeration_Type_Definition
+ | Iir_Kind_Enumeration_Subtype_Definition =>
+ Sub_Type := Create_Iir (Iir_Kind_Enumeration_Subtype_Definition);
+ when Iir_Kind_Integer_Type_Definition
+ | Iir_Kind_Integer_Subtype_Definition =>
+ Sub_Type := Create_Iir (Iir_Kind_Integer_Subtype_Definition);
+ when Iir_Kind_Floating_Type_Definition
+ | Iir_Kind_Floating_Subtype_Definition =>
+ Sub_Type := Create_Iir (Iir_Kind_Floating_Subtype_Definition);
+ when others =>
+ raise Internal_Error;
+ end case;
+ Location_Copy (Sub_Type, A_Range);
+ Set_Range_Constraint (Sub_Type, A_Range);
+ Set_Base_Type (Sub_Type, Get_Base_Type (Range_Type));
+ Set_Type_Staticness (Sub_Type, Get_Expr_Staticness (A_Range));
+ Set_Signal_Type_Flag (Sub_Type, True);
+ return Sub_Type;
+ end Range_To_Subtype_Indication;
+
+ -- Return TRUE iff FUNC is a resolution function for ATYPE.
+ function Is_A_Resolution_Function (Func: Iir; Atype: Iir) return Boolean
+ is
+ Decl: Iir;
+ Decl_Type : Iir;
+ Ret_Type : Iir;
+ begin
+ -- LRM93 2.4
+ -- A resolution function must be a [pure] function;
+ if Get_Kind (Func) not in Iir_Kinds_Function_Declaration then
+ return False;
+ end if;
+ Decl := Get_Interface_Declaration_Chain (Func);
+ -- LRM93 2.4
+ -- moreover, it must have a single input parameter of class constant
+ if Decl = Null_Iir or else Get_Chain (Decl) /= Null_Iir then
+ return False;
+ end if;
+ if Get_Kind (Decl) /= Iir_Kind_Interface_Constant_Declaration then
+ return False;
+ end if;
+ -- LRM93 2.4
+ -- that is a one-dimensional, unconstrained array
+ Decl_Type := Get_Type (Decl);
+ if Get_Kind (Decl_Type) /= Iir_Kind_Array_Type_Definition then
+ return False;
+ end if;
+ if not Is_One_Dimensional_Array_Type (Decl_Type) then
+ return False;
+ end if;
+ -- LRM93 2.4
+ -- whose element type is that of the resolved signal.
+ -- The type of the return value of the function must also be that of
+ -- the signal.
+ Ret_Type := Get_Return_Type (Func);
+ if Get_Base_Type (Get_Element_Subtype (Decl_Type))
+ /= Get_Base_Type (Ret_Type)
+ then
+ return False;
+ end if;
+ if Atype /= Null_Iir
+ and then Get_Base_Type (Ret_Type) /= Get_Base_Type (Atype)
+ then
+ return False;
+ end if;
+ -- LRM93 2.4
+ -- A resolution function must be a [pure] function;
+ if Flags.Vhdl_Std >= Vhdl_93 and then Get_Pure_Flag (Func) = False then
+ if Atype /= Null_Iir then
+ Error_Msg_Sem
+ ("resolution " & Disp_Node (Func) & " must be pure", Atype);
+ end if;
+ return False;
+ end if;
+ return True;
+ end Is_A_Resolution_Function;
+
+ -- Note: this sets resolved_flag.
+ procedure Sem_Resolution_Function (Name : Iir; Atype : Iir)
+ is
+ Func : Iir;
+ Res: Iir;
+ El : Iir;
+ List : Iir_List;
+ Has_Error : Boolean;
+ Name1 : Iir;
+ begin
+ Sem_Name (Name);
+
+ Func := Get_Named_Entity (Name);
+ if Func = Error_Mark then
+ return;
+ end if;
+
+ Res := Null_Iir;
+
+ if Is_Overload_List (Func) then
+ List := Get_Overload_List (Func);
+ Has_Error := False;
+ for I in Natural loop
+ El := Get_Nth_Element (List, I);
+ exit when El = Null_Iir;
+ if Is_A_Resolution_Function (El, Atype) then
+ if Res /= Null_Iir then
+ if not Has_Error then
+ Has_Error := True;
+ Error_Msg_Sem
+ ("can't resolve overload for resolution function",
+ Atype);
+ Error_Msg_Sem ("candidate functions are:", Atype);
+ Error_Msg_Sem (" " & Disp_Subprg (Func), Func);
+ end if;
+ Error_Msg_Sem (" " & Disp_Subprg (El), El);
+ else
+ Res := El;
+ end if;
+ end if;
+ end loop;
+ Free_Overload_List (Func);
+ if Has_Error then
+ return;
+ end if;
+ Set_Named_Entity (Name, Res);
+ else
+ if Is_A_Resolution_Function (Func, Atype) then
+ Res := Func;
+ end if;
+ end if;
+
+ if Res = Null_Iir then
+ Error_Msg_Sem ("no matching resolution function for "
+ & Disp_Node (Name), Atype);
+ else
+ Name1 := Finish_Sem_Name (Name);
+ Mark_Subprogram_Used (Res);
+ Set_Resolved_Flag (Atype, True);
+ Set_Resolution_Indication (Atype, Name1);
+ end if;
+ end Sem_Resolution_Function;
+
+ -- Analyze the constraint DEF + RESOLUTION for type TYPE_MARK. The
+ -- result is always a subtype definition.
+ function Sem_Subtype_Constraint
+ (Def : Iir; Type_Mark : Iir; Resolution : Iir)
+ return Iir;
+
+ -- DEF is an incomplete subtype_indication or array_constraint,
+ -- TYPE_MARK is the base type of the subtype_indication.
+ function Sem_Array_Constraint
+ (Def : Iir; Type_Mark : Iir; Resolution : Iir)
+ return Iir
+ is
+ El_Type : constant Iir := Get_Element_Subtype (Type_Mark);
+ Res : Iir;
+ Type_Index, Subtype_Index: Iir;
+ Base_Type : Iir;
+ El_Def : Iir;
+ Staticness : Iir_Staticness;
+ Error_Seen : Boolean;
+ Type_Index_List : Iir_List;
+ Subtype_Index_List : Iir_List;
+ Resolv_Func : Iir := Null_Iir;
+ Resolv_El : Iir := Null_Iir;
+ Resolv_Ind : Iir;
+ begin
+ if Resolution /= Null_Iir then
+ -- A resolution indication is present.
+ case Get_Kind (Resolution) is
+ when Iir_Kinds_Denoting_Name =>
+ Resolv_Func := Resolution;
+ when Iir_Kind_Array_Element_Resolution =>
+ Resolv_El := Get_Resolution_Indication (Resolution);
+ when Iir_Kind_Record_Resolution =>
+ Error_Msg_Sem
+ ("record resolution not allowed for array subtype",
+ Resolution);
+ when others =>
+ Error_Kind ("sem_array_constraint(resolution)", Resolution);
+ end case;
+ end if;
+
+ if Def = Null_Iir then
+ -- There is no element_constraint.
+ pragma Assert (Resolution /= Null_Iir);
+ Res := Copy_Subtype_Indication (Type_Mark);
+ else
+ case Get_Kind (Def) is
+ when Iir_Kind_Subtype_Definition =>
+ -- This is the case of "subtype new_array is [func] old_array".
+ -- def must be a constrained array.
+ if Get_Range_Constraint (Def) /= Null_Iir then
+ Error_Msg_Sem
+ ("cannot use a range constraint for array types", Def);
+ return Copy_Subtype_Indication (Type_Mark);
+ end if;
+
+ -- LRM08 6.3 Subtype declarations
+ --
+ -- If the subtype indication does not include a constraint, the
+ -- subtype is the same as that denoted by the type mark.
+ if Resolution = Null_Iir then
+ -- FIXME: is it reachable ?
+ Free_Name (Def);
+ return Type_Mark;
+ end if;
+
+ Res := Copy_Subtype_Indication (Type_Mark);
+ Location_Copy (Res, Def);
+ Free_Name (Def);
+
+ -- No element constraint.
+ El_Def := Null_Iir;
+
+ when Iir_Kind_Array_Subtype_Definition =>
+ -- Case of a constraint for an array.
+ -- Check each index constraint against array type.
+
+ Base_Type := Get_Base_Type (Type_Mark);
+ Set_Base_Type (Def, Base_Type);
+ El_Def := Get_Element_Subtype (Def);
+
+ Staticness := Get_Type_Staticness (El_Type);
+ Error_Seen := False;
+ Type_Index_List :=
+ Get_Index_Subtype_Definition_List (Base_Type);
+ Subtype_Index_List := Get_Index_Constraint_List (Def);
+
+ -- LRM08 5.3.2.2
+ -- If an array constraint of the first form (including an index
+ -- constraint) applies to a type or subtype, then the type or
+ -- subtype shall be an unconstrained or partially constrained
+ -- array type with no index constraint applying to the index
+ -- subtypes, or an access type whose designated type is such
+ -- a type.
+ if Get_Kind (Type_Mark) = Iir_Kind_Array_Subtype_Definition
+ and then Get_Index_Constraint_Flag (Type_Mark)
+ then
+ Error_Msg_Sem ("constrained array cannot be re-constrained",
+ Def);
+ end if;
+ if Subtype_Index_List = Null_Iir_List then
+ -- Array is not constrained.
+ Set_Index_Constraint_Flag (Def, False);
+ Set_Index_Subtype_List (Def, Type_Index_List);
+ else
+ for I in Natural loop
+ Type_Index := Get_Nth_Element (Type_Index_List, I);
+ Subtype_Index := Get_Nth_Element (Subtype_Index_List, I);
+ exit when Type_Index = Null_Iir
+ and Subtype_Index = Null_Iir;
+
+ if Type_Index = Null_Iir then
+ Error_Msg_Sem
+ ("subtype has more indexes than "
+ & Disp_Node (Type_Mark)
+ & " defined at " & Disp_Location (Type_Mark),
+ Subtype_Index);
+ -- Forget extra indexes.
+ Set_Nbr_Elements (Subtype_Index_List, I);
+ exit;
+ end if;
+ if Subtype_Index = Null_Iir then
+ if not Error_Seen then
+ Error_Msg_Sem
+ ("subtype has less indexes than "
+ & Disp_Node (Type_Mark)
+ & " defined at "
+ & Disp_Location (Type_Mark), Def);
+ Error_Seen := True;
+ end if;
+ else
+ Subtype_Index := Sem_Discrete_Range_Expression
+ (Subtype_Index, Get_Index_Type (Type_Index), True);
+ if Subtype_Index /= Null_Iir then
+ Subtype_Index :=
+ Range_To_Subtype_Indication (Subtype_Index);
+ Staticness := Min
+ (Staticness,
+ Get_Type_Staticness
+ (Get_Type_Of_Subtype_Indication
+ (Subtype_Index)));
+ end if;
+ end if;
+ if Subtype_Index = Null_Iir then
+ -- Create a fake subtype from type_index.
+ -- FIXME: It is too fake.
+ Subtype_Index := Type_Index;
+ Staticness := None;
+ end if;
+ if Error_Seen then
+ Append_Element (Subtype_Index_List, Subtype_Index);
+ else
+ Replace_Nth_Element
+ (Subtype_Index_List, I, Subtype_Index);
+ end if;
+ end loop;
+ Set_Index_Subtype_List (Def, Subtype_Index_List);
+ Set_Index_Constraint_Flag (Def, True);
+ end if;
+ Set_Type_Staticness (Def, Staticness);
+ Set_Signal_Type_Flag (Def, Get_Signal_Type_Flag (Type_Mark));
+ Res := Def;
+
+ when others =>
+ -- LRM93 3.2.1.1 / LRM08 5.3.2.2
+ -- Index Constraints and Discrete Ranges
+ --
+ -- If an index constraint appears after a type mark [...]
+ -- The type mark must denote either an unconstrained array
+ -- type, or an access type whose designated type is such
+ -- an array type.
+ Error_Msg_Sem
+ ("only unconstrained array type may be contrained "
+ &"by index", Def);
+ Error_Msg_Sem
+ (" (type mark is " & Disp_Node (Type_Mark) & ")",
+ Type_Mark);
+ return Type_Mark;
+ end case;
+ end if;
+
+ -- Element subtype.
+ if Resolv_El /= Null_Iir or else El_Def /= Null_Iir then
+ El_Def := Sem_Subtype_Constraint (El_Def, El_Type, Resolv_El);
+ end if;
+ if El_Def = Null_Iir then
+ El_Def := Get_Element_Subtype (Type_Mark);
+ end if;
+ Set_Element_Subtype (Res, El_Def);
+
+ Set_Constraint_State (Res, Get_Array_Constraint (Res));
+
+ if Resolv_Func /= Null_Iir then
+ Sem_Resolution_Function (Resolv_Func, Res);
+ elsif Resolv_El /= Null_Iir then
+ Set_Resolution_Indication (Res, Resolution);
+ -- FIXME: may a resolution indication for a record be incomplete ?
+ Set_Resolved_Flag (Res, Get_Resolved_Flag (El_Def));
+ elsif Get_Kind (Type_Mark) = Iir_Kind_Array_Subtype_Definition then
+ Resolv_Ind := Get_Resolution_Indication (Type_Mark);
+ if Resolv_Ind /= Null_Iir then
+ case Get_Kind (Resolv_Ind) is
+ when Iir_Kinds_Denoting_Name =>
+ Error_Kind ("sem_array_constraint(resolution)", Resolv_Ind);
+ when Iir_Kind_Array_Element_Resolution =>
+ -- Already applied to the element.
+ Resolv_Ind := Null_Iir;
+ when others =>
+ Error_Kind ("sem_array_constraint(resolution2)", Resolv_Ind);
+ end case;
+ Set_Resolution_Indication (Res, Resolv_Ind);
+ end if;
+ Set_Resolved_Flag (Res, Get_Resolved_Flag (Type_Mark));
+ end if;
+
+ return Res;
+ end Sem_Array_Constraint;
+
+ function Reparse_As_Record_Element_Constraint (Name : Iir) return Iir
+ is
+ Prefix : Iir;
+ Parent : Iir;
+ El : Iir;
+ begin
+ if Get_Kind (Name) /= Iir_Kind_Parenthesis_Name then
+ Error_Msg_Sem ("record element constraint expected", Name);
+ return Null_Iir;
+ else
+ Prefix := Get_Prefix (Name);
+ Parent := Name;
+ while Get_Kind (Prefix) = Iir_Kind_Parenthesis_Name loop
+ Parent := Prefix;
+ Prefix := Get_Prefix (Prefix);
+ end loop;
+ if Get_Kind (Prefix) /= Iir_Kind_Simple_Name then
+ Error_Msg_Sem ("record element name must be a simple name",
+ Prefix);
+ return Null_Iir;
+ else
+ El := Create_Iir (Iir_Kind_Record_Element_Constraint);
+ Location_Copy (El, Prefix);
+ Set_Identifier (El, Get_Identifier (Prefix));
+ Set_Type (El, Name);
+ Set_Prefix (Parent, Null_Iir);
+ Free_Name (Prefix);
+ return El;
+ end if;
+ end if;
+ end Reparse_As_Record_Element_Constraint;
+
+ function Reparse_As_Record_Constraint (Def : Iir) return Iir
+ is
+ Res : Iir;
+ Chain : Iir;
+ El_List : Iir_List;
+ El : Iir;
+ begin
+ if Get_Prefix (Def) /= Null_Iir then
+ raise Internal_Error;
+ end if;
+ Res := Create_Iir (Iir_Kind_Record_Subtype_Definition);
+ Location_Copy (Res, Def);
+ El_List := Create_Iir_List;
+ Set_Elements_Declaration_List (Res, El_List);
+ Chain := Get_Association_Chain (Def);
+ while Chain /= Null_Iir loop
+ if Get_Kind (Chain) /= Iir_Kind_Association_Element_By_Expression
+ or else Get_Formal (Chain) /= Null_Iir
+ then
+ Error_Msg_Sem ("badly formed record constraint", Chain);
+ else
+ El := Reparse_As_Record_Element_Constraint (Get_Actual (Chain));
+ if El /= Null_Iir then
+ Append_Element (El_List, El);
+ end if;
+ end if;
+ Chain := Get_Chain (Chain);
+ end loop;
+ return Res;
+ end Reparse_As_Record_Constraint;
+
+ function Reparse_As_Array_Constraint (Def : Iir; Def_Type : Iir) return Iir
+ is
+ Parent : Iir;
+ Name : Iir;
+ Prefix : Iir;
+ Res : Iir;
+ Chain : Iir;
+ El_List : Iir_List;
+ Def_El_Type : Iir;
+ begin
+ Name := Def;
+ Prefix := Get_Prefix (Name);
+ Parent := Null_Iir;
+ while Prefix /= Null_Iir
+ and then Get_Kind (Prefix) = Iir_Kind_Parenthesis_Name
+ loop
+ Parent := Name;
+ Name := Prefix;
+ Prefix := Get_Prefix (Name);
+ end loop;
+ -- Detach prefix.
+ if Parent /= Null_Iir then
+ Set_Prefix (Parent, Null_Iir);
+ end if;
+ Res := Create_Iir (Iir_Kind_Array_Subtype_Definition);
+ Location_Copy (Res, Name);
+ Chain := Get_Association_Chain (Name);
+ if Get_Kind (Chain) = Iir_Kind_Association_Element_Open then
+ if Get_Chain (Chain) /= Null_Iir then
+ Error_Msg_Sem ("'open' must be alone", Chain);
+ end if;
+ else
+ El_List := Create_Iir_List;
+ Set_Index_Constraint_List (Res, El_List);
+ while Chain /= Null_Iir loop
+ if Get_Kind (Chain) /= Iir_Kind_Association_Element_By_Expression
+ or else Get_Formal (Chain) /= Null_Iir
+ then
+ Error_Msg_Sem ("bad form of array constraint", Chain);
+ else
+ Append_Element (El_List, Get_Actual (Chain));
+ end if;
+ Chain := Get_Chain (Chain);
+ end loop;
+ end if;
+
+ Def_El_Type := Get_Element_Subtype (Def_Type);
+ if Parent /= Null_Iir then
+ case Get_Kind (Def_El_Type) is
+ when Iir_Kinds_Array_Type_Definition =>
+ Set_Element_Subtype_Indication
+ (Res, Reparse_As_Array_Constraint (Def, Def_El_Type));
+ when others =>
+ Error_Kind ("reparse_as_array_constraint", Def_El_Type);
+ end case;
+ end if;
+ return Res;
+ end Reparse_As_Array_Constraint;
+
+ function Sem_Record_Constraint
+ (Def : Iir; Type_Mark : Iir; Resolution : Iir)
+ return Iir
+ is
+ Res : Iir;
+ El_List, Tm_El_List : Iir_List;
+ El : Iir;
+ Tm_El : Iir;
+ Tm_El_Type : Iir;
+ El_Type : Iir;
+ Res_List : Iir_List;
+
+ Index_List : Iir_List;
+ Index_El : Iir;
+ begin
+ Res := Create_Iir (Iir_Kind_Record_Subtype_Definition);
+ Location_Copy (Res, Def);
+ Set_Base_Type (Res, Get_Base_Type (Type_Mark));
+ Set_Type_Staticness (Res, Get_Type_Staticness (Type_Mark));
+ if Get_Kind (Type_Mark) = Iir_Kind_Record_Subtype_Definition then
+ Set_Resolution_Indication
+ (Res, Get_Resolution_Indication (Type_Mark));
+ end if;
+
+ case Get_Kind (Def) is
+ when Iir_Kind_Subtype_Definition =>
+ Free_Name (Def);
+ Set_Signal_Type_Flag (Res, Get_Signal_Type_Flag (Type_Mark));
+ Set_Constraint_State (Res, Get_Constraint_State (Type_Mark));
+ El_List := Null_Iir_List;
+
+ when Iir_Kind_Array_Subtype_Definition =>
+ -- Record constraints are parsed as array constraints.
+ if Get_Kind (Def) /= Iir_Kind_Array_Subtype_Definition then
+ raise Internal_Error;
+ end if;
+ Index_List := Get_Index_Constraint_List (Def);
+ El_List := Create_Iir_List;
+ Set_Elements_Declaration_List (Res, El_List);
+ for I in Natural loop
+ Index_El := Get_Nth_Element (Index_List, I);
+ exit when Index_El = Null_Iir;
+ El := Reparse_As_Record_Element_Constraint (Index_El);
+ if El /= Null_Iir then
+ Append_Element (El_List, El);
+ end if;
+ end loop;
+
+ when Iir_Kind_Record_Subtype_Definition =>
+ El_List := Get_Elements_Declaration_List (Def);
+ Set_Elements_Declaration_List (Res, El_List);
+
+ when others =>
+ Error_Kind ("sem_record_constraint", Def);
+ end case;
+
+ Res_List := Null_Iir_List;
+ if Resolution /= Null_Iir then
+ case Get_Kind (Resolution) is
+ when Iir_Kinds_Denoting_Name =>
+ null;
+ when Iir_Kind_Record_Subtype_Definition =>
+ Res_List := Get_Elements_Declaration_List (Resolution);
+ when Iir_Kind_Array_Subtype_Definition =>
+ Error_Msg_Sem
+ ("resolution indication must be an array element resolution",
+ Resolution);
+ when others =>
+ Error_Kind ("sem_record_constraint(resolution)", Resolution);
+ end case;
+ end if;
+
+ Tm_El_List := Get_Elements_Declaration_List (Type_Mark);
+ if El_List /= Null_Iir_List or Res_List /= Null_Iir_List then
+ declare
+ Nbr_Els : constant Natural := Get_Nbr_Elements (Tm_El_List);
+ Els : Iir_Array (0 .. Nbr_Els - 1) := (others => Null_Iir);
+ Res_Els : Iir_Array (0 .. Nbr_Els - 1) := (others => Null_Iir);
+ Pos : Natural;
+ Constraint : Iir_Constraint;
+ begin
+ -- Fill ELS.
+ if El_List /= Null_Iir_List then
+ for I in Natural loop
+ El := Get_Nth_Element (El_List, I);
+ exit when El = Null_Iir;
+ Tm_El := Find_Name_In_List (Tm_El_List, Get_Identifier (El));
+ if Tm_El = Null_Iir then
+ Error_Msg_Sem (Disp_Node (Type_Mark)
+ & "has no " & Disp_Node (El), El);
+ else
+ Set_Element_Declaration (El, Tm_El);
+ Pos := Natural (Get_Element_Position (Tm_El));
+ if Els (Pos) /= Null_Iir then
+ Error_Msg_Sem
+ (Disp_Node (El) & " was already constrained", El);
+ Error_Msg_Sem
+ (" (location of previous constrained)", Els (Pos));
+ else
+ Els (Pos) := El;
+ Set_Parent (El, Res);
+ end if;
+ El_Type := Get_Type (El);
+ Tm_El_Type := Get_Type (Tm_El);
+ if Get_Kind (El_Type) = Iir_Kind_Parenthesis_Name then
+ case Get_Kind (Tm_El_Type) is
+ when Iir_Kinds_Array_Type_Definition =>
+ El_Type := Reparse_As_Array_Constraint
+ (El_Type, Tm_El_Type);
+ when Iir_Kind_Record_Type_Definition
+ | Iir_Kind_Record_Subtype_Definition =>
+ El_Type := Reparse_As_Record_Constraint
+ (El_Type);
+ when others =>
+ Error_Msg_Sem
+ ("only composite types may be constrained",
+ El_Type);
+ end case;
+ end if;
+ Set_Type (El, El_Type);
+ end if;
+ end loop;
+ Destroy_Iir_List (El_List);
+ end if;
+
+ -- Fill Res_Els.
+ if Res_List /= Null_Iir_List then
+ for I in Natural loop
+ El := Get_Nth_Element (Res_List, I);
+ exit when El = Null_Iir;
+ Tm_El := Find_Name_In_List (Tm_El_List, Get_Identifier (El));
+ if Tm_El = Null_Iir then
+ Error_Msg_Sem (Disp_Node (Type_Mark)
+ & "has no " & Disp_Node (El), El);
+ else
+ Pos := Natural (Get_Element_Position (Tm_El));
+ if Res_Els (Pos) /= Null_Iir then
+ Error_Msg_Sem
+ (Disp_Node (El) & " was already resolved", El);
+ Error_Msg_Sem
+ (" (location of previous constrained)", Els (Pos));
+ else
+ Res_Els (Pos) := Get_Element_Declaration (El);
+ end if;
+ end if;
+ --Free_Iir (El);
+ end loop;
+ Destroy_Iir_List (Res_List);
+ end if;
+
+ -- Build elements list.
+ El_List := Create_Iir_List;
+ Set_Elements_Declaration_List (Res, El_List);
+ Constraint := Fully_Constrained;
+ for I in Els'Range loop
+ Tm_El := Get_Nth_Element (Tm_El_List, I);
+ if Els (I) = Null_Iir and Res_Els (I) = Null_Iir then
+ El := Tm_El;
+ else
+ if Els (I) = Null_Iir then
+ El := Create_Iir (Iir_Kind_Record_Element_Constraint);
+ Location_Copy (El, Tm_El);
+ Set_Element_Declaration (El, Tm_El);
+ Set_Element_Position (El, Get_Element_Position (Tm_El));
+ El_Type := Null_Iir;
+ else
+ El := Els (I);
+ El_Type := Get_Type (El);
+ end if;
+ El_Type := Sem_Subtype_Constraint (El_Type,
+ Get_Type (Tm_El),
+ Res_Els (I));
+ Set_Type (El, El_Type);
+ end if;
+ Append_Element (El_List, El);
+ Constraint := Update_Record_Constraint
+ (Constraint, Get_Type (El));
+ end loop;
+ Set_Constraint_State (Res, Constraint);
+ end;
+ else
+ Set_Elements_Declaration_List (Res, Tm_El_List);
+ Set_Constraint_State (Res, Get_Constraint_State (Type_Mark));
+ end if;
+
+ Set_Signal_Type_Flag (Res, Get_Signal_Type_Flag (Type_Mark));
+
+ if Resolution /= Null_Iir
+ and then Get_Kind (Resolution) in Iir_Kinds_Denoting_Name
+ then
+ Sem_Resolution_Function (Resolution, Res);
+ end if;
+
+ return Res;
+ end Sem_Record_Constraint;
+
+ -- Return a scalar subtype definition (even in case of error).
+ function Sem_Range_Constraint
+ (Def : Iir; Type_Mark : Iir; Resolution : Iir)
+ return Iir
+ is
+ Res : Iir;
+ A_Range : Iir;
+ Tolerance : Iir;
+ begin
+ if Def = Null_Iir then
+ Res := Copy_Subtype_Indication (Type_Mark);
+ elsif Get_Kind (Def) /= Iir_Kind_Subtype_Definition then
+ -- FIXME: find the correct sentence from LRM
+ -- GHDL: subtype_definition may also be used just to add
+ -- a resolution function.
+ Error_Msg_Sem ("only scalar types may be constrained by range", Def);
+ Error_Msg_Sem (" (type mark is " & Disp_Node (Type_Mark) & ")",
+ Type_Mark);
+ Res := Copy_Subtype_Indication (Type_Mark);
+ else
+ Tolerance := Get_Tolerance (Def);
+
+ if Get_Range_Constraint (Def) = Null_Iir
+ and then Resolution = Null_Iir
+ and then Tolerance = Null_Iir
+ then
+ -- This defines an alias, and must have been handled just
+ -- before the case statment.
+ raise Internal_Error;
+ end if;
+
+ -- There are limits. Create a new subtype.
+ if Get_Kind (Type_Mark) = Iir_Kind_Enumeration_Type_Definition then
+ Res := Create_Iir (Iir_Kind_Enumeration_Subtype_Definition);
+ else
+ Res := Create_Iir (Get_Kind (Type_Mark));
+ end if;
+ Location_Copy (Res, Def);
+ Set_Base_Type (Res, Get_Base_Type (Type_Mark));
+ Set_Resolution_Indication (Res, Get_Resolution_Indication (Def));
+ A_Range := Get_Range_Constraint (Def);
+ if A_Range = Null_Iir then
+ A_Range := Get_Range_Constraint (Type_Mark);
+ else
+ A_Range := Sem_Range_Expression (A_Range, Type_Mark, True);
+ if A_Range = Null_Iir then
+ -- Avoid error propagation.
+ A_Range := Get_Range_Constraint (Type_Mark);
+ end if;
+ end if;
+ Set_Range_Constraint (Res, A_Range);
+ Set_Type_Staticness (Res, Get_Expr_Staticness (A_Range));
+ Free_Name (Def);
+ Set_Signal_Type_Flag (Res, Get_Signal_Type_Flag (Type_Mark));
+ if Tolerance /= Null_Iir then
+ -- LRM93 4.2 Subtype declarations
+ -- It is an error in this case the subtype is not a nature
+ -- type
+ --
+ -- FIXME: should be moved into sem_subtype_indication
+ if Get_Kind (Res) /= Iir_Kind_Floating_Subtype_Definition then
+ Error_Msg_Sem ("tolerance allowed only for floating subtype",
+ Tolerance);
+ else
+ -- LRM93 4.2 Subtype declarations
+ -- If the subtype indication includes a tolerance aspect, then
+ -- the string expression must be a static expression
+ Tolerance := Sem_Expression (Tolerance, String_Type_Definition);
+ if Tolerance /= Null_Iir
+ and then Get_Expr_Staticness (Tolerance) /= Locally
+ then
+ Error_Msg_Sem ("tolerance must be a static string",
+ Tolerance);
+ end if;
+ Set_Tolerance (Res, Tolerance);
+ end if;
+ end if;
+ end if;
+
+ if Resolution /= Null_Iir then
+ -- LRM08 6.3 Subtype declarations.
+ if Get_Kind (Resolution) not in Iir_Kinds_Denoting_Name then
+ Error_Msg_Sem ("resolution indication must be a function name",
+ Resolution);
+ else
+ Sem_Resolution_Function (Resolution, Res);
+ end if;
+ end if;
+ return Res;
+ end Sem_Range_Constraint;
+
+ function Sem_Subtype_Constraint
+ (Def : Iir; Type_Mark : Iir; Resolution : Iir)
+ return Iir is
+ begin
+ case Get_Kind (Type_Mark) is
+ when Iir_Kind_Array_Subtype_Definition
+ | Iir_Kind_Array_Type_Definition =>
+ return Sem_Array_Constraint (Def, Type_Mark, Resolution);
+ when Iir_Kind_Integer_Subtype_Definition
+ | Iir_Kind_Floating_Subtype_Definition
+ | Iir_Kind_Enumeration_Subtype_Definition
+ | Iir_Kind_Physical_Subtype_Definition
+ | Iir_Kind_Enumeration_Type_Definition=>
+ return Sem_Range_Constraint (Def, Type_Mark, Resolution);
+ when Iir_Kind_Record_Type_Definition
+ | Iir_Kind_Record_Subtype_Definition =>
+ return Sem_Record_Constraint (Def, Type_Mark, Resolution);
+ when Iir_Kind_Access_Type_Definition
+ | Iir_Kind_Access_Subtype_Definition =>
+ -- LRM93 4.2
+ -- A subtype indication denoting an access type [or a file type]
+ -- may not contain a resolution function.
+ if Resolution /= Null_Iir then
+ Error_Msg_Sem
+ ("resolution function not allowed for an access type", Def);
+ end if;
+
+ case Get_Kind (Def) is
+ when Iir_Kind_Subtype_Definition =>
+ Free_Name (Def);
+ return Copy_Subtype_Indication (Type_Mark);
+ when Iir_Kind_Array_Subtype_Definition =>
+ -- LRM93 3.3
+ -- The only form of constraint that is allowed after a name
+ -- of an access type in a subtype indication is an index
+ -- constraint.
+ declare
+ Sub_Type : Iir;
+ Base_Type : Iir;
+ Res : Iir;
+ begin
+ Base_Type := Get_Designated_Type (Type_Mark);
+ Sub_Type := Sem_Array_Constraint
+ (Def, Base_Type, Null_Iir);
+ Res := Create_Iir (Iir_Kind_Access_Subtype_Definition);
+ Location_Copy (Res, Def);
+ Set_Base_Type (Res, Type_Mark);
+ Set_Designated_Subtype_Indication (Res, Sub_Type);
+ Set_Signal_Type_Flag (Res, False);
+ return Res;
+ end;
+ when others =>
+ raise Internal_Error;
+ end case;
+
+ when Iir_Kind_File_Type_Definition =>
+ -- LRM08 6.3 Subtype declarations
+ -- A subtype indication denoting a subtype of [...] a file
+ -- type [...] shall not contain a constraint.
+ if Get_Kind (Def) /= Iir_Kind_Subtype_Definition
+ or else Get_Range_Constraint (Def) /= Null_Iir
+ then
+ Error_Msg_Sem ("file types can't be constrained", Def);
+ return Type_Mark;
+ end if;
+
+ -- LRM93 4.2
+ -- A subtype indication denoting [an access type or] a file type
+ -- may not contain a resolution function.
+ if Resolution /= Null_Iir then
+ Error_Msg_Sem
+ ("resolution function not allowed for file types", Def);
+ return Type_Mark;
+ end if;
+ Free_Name (Def);
+ return Type_Mark;
+
+ when Iir_Kind_Protected_Type_Declaration =>
+ -- LRM08 6.3 Subtype declarations
+ -- A subtype indication denoting a subtype of [...] a protected
+ -- type [...] shall not contain a constraint.
+ if Get_Kind (Def) /= Iir_Kind_Subtype_Definition
+ or else Get_Range_Constraint (Def) /= Null_Iir
+ then
+ Error_Msg_Sem ("protected types can't be constrained", Def);
+ return Type_Mark;
+ end if;
+
+ -- LRM08 6.3 Subtype declarations
+ -- A subtype indication denoting [...] a protected type shall
+ -- not contain a resolution function.
+ if Resolution /= Null_Iir then
+ Error_Msg_Sem
+ ("resolution function not allowed for file types", Def);
+ return Type_Mark;
+ end if;
+ Free_Name (Def);
+ return Type_Mark;
+
+ when others =>
+ Error_Kind ("sem_subtype_constraint", Type_Mark);
+ return Type_Mark;
+ end case;
+ end Sem_Subtype_Constraint;
+
+ function Sem_Subtype_Indication (Def: Iir; Incomplete : Boolean := False)
+ return Iir
+ is
+ Type_Mark_Name : Iir;
+ Type_Mark: Iir;
+ Res : Iir;
+ begin
+ -- LRM08 6.3 Subtype declarations
+ --
+ -- If the subtype indication does not include a constraint, the subtype
+ -- is the same as that denoted by the type mark.
+ if Get_Kind (Def) in Iir_Kinds_Denoting_Name then
+ Type_Mark := Sem_Type_Mark (Def, Incomplete);
+ return Type_Mark;
+ end if;
+
+ -- Semantize the type mark.
+ Type_Mark_Name := Get_Subtype_Type_Mark (Def);
+ Type_Mark_Name := Sem_Type_Mark (Type_Mark_Name);
+ Set_Subtype_Type_Mark (Def, Type_Mark_Name);
+ Type_Mark := Get_Type (Type_Mark_Name);
+ -- FIXME: incomplete type ?
+ if Get_Kind (Type_Mark) = Iir_Kind_Error then
+ -- FIXME: handle inversion such as "subtype BASETYPE RESOLV", which
+ -- should emit "resolution function must precede type name".
+
+ -- Discard the subtype definition and only keep the type mark.
+ return Type_Mark_Name;
+ end if;
+
+ Res := Sem_Subtype_Constraint
+ (Def, Type_Mark, Get_Resolution_Indication (Def));
+ Set_Subtype_Type_Mark (Res, Type_Mark_Name);
+ return Res;
+ end Sem_Subtype_Indication;
+
+ function Copy_Subtype_Indication (Def : Iir) return Iir
+ is
+ Res : Iir;
+ begin
+ case Get_Kind (Def) is
+ when Iir_Kind_Integer_Subtype_Definition
+ | Iir_Kind_Floating_Subtype_Definition
+ | Iir_Kind_Enumeration_Subtype_Definition
+ | Iir_Kind_Physical_Subtype_Definition =>
+ Res := Create_Iir (Get_Kind (Def));
+ Set_Range_Constraint (Res, Get_Range_Constraint (Def));
+ Set_Resolution_Indication
+ (Res, Get_Resolution_Indication (Def));
+ when Iir_Kind_Enumeration_Type_Definition =>
+ Res := Create_Iir (Iir_Kind_Enumeration_Subtype_Definition);
+ Set_Range_Constraint (Res, Get_Range_Constraint (Def));
+
+ when Iir_Kind_Access_Subtype_Definition
+ | Iir_Kind_Access_Type_Definition =>
+ Res := Create_Iir (Iir_Kind_Access_Subtype_Definition);
+ Set_Designated_Type (Res, Get_Designated_Type (Def));
+
+ when Iir_Kind_Array_Type_Definition =>
+ Res := Create_Iir (Iir_Kind_Array_Subtype_Definition);
+ Set_Type_Staticness (Res, Get_Type_Staticness (Def));
+ Set_Resolved_Flag (Res, Get_Resolved_Flag (Def));
+ Set_Index_Constraint_List (Res, Null_Iir_List);
+ Set_Index_Subtype_List
+ (Res, Get_Index_Subtype_Definition_List (Def));
+ Set_Element_Subtype (Res, Get_Element_Subtype (Def));
+ Set_Index_Constraint_Flag (Res, False);
+ Set_Constraint_State (Res, Get_Constraint_State (Def));
+ when Iir_Kind_Array_Subtype_Definition =>
+ Res := Create_Iir (Iir_Kind_Array_Subtype_Definition);
+ Set_Resolution_Indication (Res, Get_Resolution_Indication (Def));
+ Set_Resolved_Flag (Res, Get_Resolved_Flag (Def));
+ Set_Index_Subtype_List (Res, Get_Index_Subtype_List (Def));
+ Set_Element_Subtype (Res, Get_Element_Subtype (Def));
+ Set_Index_Constraint_Flag
+ (Res, Get_Index_Constraint_Flag (Def));
+ Set_Constraint_State (Res, Get_Constraint_State (Def));
+
+ when Iir_Kind_Record_Type_Definition
+ | Iir_Kind_Record_Subtype_Definition =>
+ Res := Create_Iir (Iir_Kind_Record_Subtype_Definition);
+ Set_Type_Staticness (Res, Get_Type_Staticness (Def));
+ if Get_Kind (Def) = Iir_Kind_Record_Subtype_Definition then
+ Set_Resolution_Indication
+ (Res, Get_Resolution_Indication (Def));
+ end if;
+ Set_Resolved_Flag (Res, Get_Resolved_Flag (Def));
+ Set_Constraint_State (Res, Get_Constraint_State (Def));
+ Set_Elements_Declaration_List
+ (Res, Get_Elements_Declaration_List (Def));
+ when others =>
+ -- FIXME: todo (protected type ?)
+ Error_Kind ("copy_subtype_indication", Def);
+ end case;
+ Location_Copy (Res, Def);
+ Set_Base_Type (Res, Get_Base_Type (Def));
+ Set_Type_Staticness (Res, Get_Type_Staticness (Def));
+ Set_Signal_Type_Flag (Res, Get_Signal_Type_Flag (Def));
+ return Res;
+ end Copy_Subtype_Indication;
+
+ function Sem_Subnature_Indication (Def: Iir) return Iir
+ is
+ Nature_Mark: Iir;
+ Res : Iir;
+ begin
+ -- LRM 4.8 Nature declatation
+ --
+ -- If the subnature indication does not include a constraint, the
+ -- subnature is the same as that denoted by the type mark.
+ case Get_Kind (Def) is
+ when Iir_Kind_Scalar_Nature_Definition =>
+ -- Used for reference declared by a nature
+ return Def;
+ when Iir_Kinds_Denoting_Name =>
+ Nature_Mark := Sem_Denoting_Name (Def);
+ Res := Get_Named_Entity (Nature_Mark);
+ if Get_Kind (Res) /= Iir_Kind_Scalar_Nature_Definition then
+ Error_Class_Match (Nature_Mark, "nature");
+ raise Program_Error; -- TODO
+ else
+ return Nature_Mark;
+ end if;
+ when others =>
+ raise Program_Error; -- TODO
+ end case;
+ end Sem_Subnature_Indication;
+
+end Sem_Types;