diff options
| -rw-r--r-- | flags.ads | 6 | ||||
| -rw-r--r-- | iirs.adb | 23 | ||||
| -rw-r--r-- | iirs.ads | 10 | ||||
| -rw-r--r-- | options.adb | 3 | ||||
| -rw-r--r-- | scan.adb | 3 | ||||
| -rw-r--r-- | sem_assocs.adb | 17 | ||||
| -rw-r--r-- | sem_decls.adb | 13 | ||||
| -rw-r--r-- | sem_expr.adb | 622 | ||||
| -rw-r--r-- | sem_expr.ads | 18 | ||||
| -rw-r--r-- | sem_names.adb | 7 | ||||
| -rw-r--r-- | sem_scopes.adb | 120 | ||||
| -rw-r--r-- | sem_scopes.ads | 31 | ||||
| -rw-r--r-- | tokens.adb | 11 | ||||
| -rw-r--r-- | tokens.ads | 2 |
14 files changed, 371 insertions, 515 deletions
@@ -134,6 +134,12 @@ package Flags is -- If set, all the design units are analyzed in whole to do the simulation. Flag_Whole_Analyze : Boolean := False; + -- If true, relax some rules: + -- * the scope of an object declaration names start after the declaration, + -- so that it is possible to use the old name in the default expression: + -- constant x : xtype := x; + Flag_Relaxed_Rules : Boolean := False; + -- --warn-undriven --Warn_Undriven : Boolean := False; @@ -5078,6 +5078,29 @@ package body Iirs is Set_Field5 (Target, Expr); end Set_Expression; + procedure Check_Kind_For_Allocator_Designated_Type (Target : Iir) is + begin + case Get_Kind (Target) is + when Iir_Kind_Allocator_By_Expression + | Iir_Kind_Allocator_By_Subtype => + null; + when others => + Failed ("Allocator_Designated_Type", Target); + end case; + end Check_Kind_For_Allocator_Designated_Type; + + function Get_Allocator_Designated_Type (Target : Iir) return Iir is + begin + Check_Kind_For_Allocator_Designated_Type (Target); + return Get_Field2 (Target); + end Get_Allocator_Designated_Type; + + procedure Set_Allocator_Designated_Type (Target : Iir; A_Type : Iir) is + begin + Check_Kind_For_Allocator_Designated_Type (Target); + Set_Field2 (Target, A_Type); + end Set_Allocator_Designated_Type; + procedure Check_Kind_For_Selected_Waveform_Chain (Target : Iir) is begin case Get_Kind (Target) is @@ -2430,6 +2430,10 @@ package Iirs is -- -- Get/Set_Type (Field1) -- + -- To ease analysis: set to the designated type (either the type of the + -- expression or the subtype) + -- Get/Set_Allocator_Designated_Type (Field2) + -- -- Contains the expression for a by expression allocator or the -- subtype indication for a by subtype allocator. -- Get/Set_Expression (Field5) @@ -5028,6 +5032,12 @@ package Iirs is function Get_Expression (Target : Iir) return Iir; procedure Set_Expression (Target : Iir; Expr : Iir); + -- Set to the designated type (either the type of the expression or the + -- subtype) when the expression is analyzed. + -- Field: Field2 + function Get_Allocator_Designated_Type (Target : Iir) return Iir; + procedure Set_Allocator_Designated_Type (Target : Iir; A_Type : Iir); + -- Field: Field7 function Get_Selected_Waveform_Chain (Target : Iir) return Iir; procedure Set_Selected_Waveform_Chain (Target : Iir; Chain : Iir); diff --git a/options.adb b/options.adb index a62b76da1..cd70f319a 100644 --- a/options.adb +++ b/options.adb @@ -114,6 +114,8 @@ package body Options is Bootstrap := True; elsif Opt = "-fexplicit" then Flag_Explicit := True; + elsif Opt = "-frelaxed-rules" then + Flag_Relaxed_Rules := True; elsif Opt = "--syn-binding" then Flag_Syn_Binding := True; elsif Opt = "--no-vital-checks" then @@ -215,6 +217,7 @@ package body Options is -- P (" failure or none"); P ("Extensions:"); P (" -fexplicit give priority to explicitly declared operator"); + P (" -frelaxed-rules relax some LRM rules"); P (" -C --mb-comments allow multi-bytes chars in a comment"); P (" --bootstrap allow --work=std"); P (" --syn-binding use synthesis default binding rule"); @@ -1425,6 +1425,9 @@ package body Scan is Current_Token := Tok_Match_Greater; Pos := Pos + 2; end if; + elsif Source (Pos + 1) = '?' then + Current_Token := Tok_Condition; + Pos := Pos + 2; elsif Source (Pos + 1) = '=' then Current_Token := Tok_Match_Equal; Pos := Pos + 2; diff --git a/sem_assocs.adb b/sem_assocs.adb index c4a9bce74..178bf6d2c 100644 --- a/sem_assocs.adb +++ b/sem_assocs.adb @@ -1204,7 +1204,6 @@ package body Sem_Assocs is Formal : Iir; Formal_Type : Iir; Actual: Iir; - Actual_Types : Iir; Out_Conv, In_Conv : Iir; Expr : Iir; Res_Type : Iir; @@ -1267,12 +1266,7 @@ package body Sem_Assocs is -- Extract conversion from actual. Actual := Get_Actual (Assoc); - Actual_Types := Get_Type (Actual); In_Conv := Null_Iir; - if Actual_Types = Null_Iir then - Match := False; - return; - end if; if Get_Kind (Inter) /= Iir_Kind_Constant_Interface_Declaration then case Get_Kind (Actual) is when Iir_Kind_Function_Call => @@ -1289,7 +1283,6 @@ package body Sem_Assocs is when others => null; end case; - Actual_Types := Get_Type (Actual); end if; -- 4 cases: F:out_conv, G:in_conv. @@ -1298,16 +1291,16 @@ package body Sem_Assocs is -- A => G(B) type of A = type of G -- F(A) => G(B) type of B = type of F, type of A = type of G if Out_Conv = Null_Iir and then In_Conv = Null_Iir then - Match := Compatibility_Types (Formal_Type, Actual_Types); + Match := Is_Expr_Compatible (Formal_Type, Actual); else Match := True; if In_Conv /= Null_Iir then - if not Compatibility_Types (Formal_Type, Get_Type (In_Conv)) then + if not Is_Expr_Compatible (Formal_Type, In_Conv) then Match := False; end if; end if; if Out_Conv /= Null_Iir then - if not Compatibility_Types (Get_Type (Out_Conv), Actual_Types) then + if not Is_Expr_Compatible (Get_Type (Out_Conv), Actual) then Match := False; end if; end if; @@ -1337,9 +1330,9 @@ package body Sem_Assocs is else if Out_Conv /= Null_Iir then Res_Type := Search_Compatible_Type (Get_Type (Out_Conv), - Actual_Types); + Get_Type (Actual)); else - Res_Type := Actual_Types; + Res_Type := Get_Type (Actual); end if; if In_Conv /= Null_Iir then diff --git a/sem_decls.adb b/sem_decls.adb index 83d2448f2..ffe80d566 100644 --- a/sem_decls.adb +++ b/sem_decls.adb @@ -1129,8 +1129,6 @@ package body Sem_Decls is Sem_Scopes.Name_Visible (St_Decl); - Sem_Scopes.Add_Visible_Type (Decl); - -- The implicit subprogram will be added in the -- scope just after. Create_Implicit_Operations (Decl, False); @@ -1144,7 +1142,6 @@ package body Sem_Decls is Set_Type_Declarator (Def, Decl); Sem_Scopes.Name_Visible (Decl); - Sem_Scopes.Add_Visible_Type (Decl); -- The implicit subprogram will be added in the -- scope just after. @@ -1152,7 +1149,6 @@ package body Sem_Decls is when Iir_Kind_Protected_Type_Declaration => Set_Type_Declarator (Def, Decl); - Sem_Scopes.Add_Visible_Type (Decl); St_Decl := Null_Iir; -- No implicit subprograms. @@ -1280,7 +1276,9 @@ package body Sem_Decls is end if; if Deferred_Const = Null_Iir then - Sem_Scopes.Add_Name (Decl); + if not Flag_Relaxed_Rules then + Sem_Scopes.Add_Name (Decl); + end if; Xref_Decl (Decl); else Xref_Ref (Decl, Deferred_Const); @@ -1306,6 +1304,11 @@ package body Sem_Decls is Check_Read (Default_Value); end if; end if; + + if Deferred_Const = Null_Iir and Flag_Relaxed_Rules then + Sem_Scopes.Add_Name (Decl); + end if; + Set_Type (Decl, Atype); Default_Value := Eval_Expr_Check_If_Static (Default_Value, Atype); Set_Default_Value (Decl, Default_Value); diff --git a/sem_expr.adb b/sem_expr.adb index 47c29f87b..ebe7679b1 100644 --- a/sem_expr.adb +++ b/sem_expr.adb @@ -88,10 +88,12 @@ package body Sem_Expr is Set_Type (Target, A_Type); end Replace_Type; - -- Return true if ID is overloaded, ie has several meanings. - function Is_Overloaded (Id: Iir) return Boolean is + -- Return true if EXPR is overloaded, ie has several meanings. + function Is_Overloaded (Expr : Iir) return Boolean + is + Expr_Type : constant Iir := Get_Type (Expr); begin - return Is_Overload_List (Get_Type (Id)); + return Expr_Type = Null_Iir or else Is_Overload_List (Expr_Type); end Is_Overloaded; -- Return the common type of base types LEFT and RIGHT. @@ -148,6 +150,163 @@ package body Sem_Expr is return Are_Types_Compatible (Get_Type (Left), Get_Type (Right)); end Are_Nodes_Compatible; + -- Return TRUE iif LEFT_TYPE and RIGHT_TYPES are compatible. RIGHT_TYPES + -- may be an overload list. + function Compatibility_Types1 (Left_Type : Iir; Right_Types : Iir) + return Boolean + is + El : Iir; + Right_List : Iir_List; + begin + pragma Assert (not Is_Overload_List (Left_Type)); + + if Is_Overload_List (Right_Types) then + Right_List := Get_Overload_List (Right_Types); + for I in Natural loop + El := Get_Nth_Element (Right_List, I); + exit when El = Null_Iir; + if Are_Types_Compatible (Left_Type, El) then + return True; + end if; + end loop; + return False; + else + return Are_Types_Compatible (Left_Type, Right_Types); + end if; + end Compatibility_Types1; + + -- Return compatibility for nodes LEFT and RIGHT. + -- LEFT is expected to be an interface of a function definition. + -- Type of RIGHT can be an overload_list + -- RIGHT might be implicitly converted to LEFT. + function Compatibility_Nodes (Left : Iir; Right : Iir) + return Boolean + is + Left_Type, Right_Type : Iir; + begin + Left_Type := Get_Base_Type (Get_Type (Left)); + Right_Type := Get_Type (Right); + + -- Check. + case Get_Kind (Left_Type) is + when Iir_Kind_Floating_Type_Definition + | Iir_Kind_Enumeration_Type_Definition + | Iir_Kind_Integer_Type_Definition + | Iir_Kind_Record_Type_Definition + | Iir_Kind_File_Type_Definition + | Iir_Kind_Physical_Type_Definition + | Iir_Kind_Access_Type_Definition + | Iir_Kind_Array_Type_Definition => + null; + when others => + Error_Kind ("are_node_compatible_ov", Left_Type); + end case; + + return Compatibility_Types1 (Left_Type, Right_Type); + end Compatibility_Nodes; + + -- Return TRUE iff A_TYPE can be the type of string or bit string literal + -- EXPR. EXPR is needed to distinguish between string and bit string + -- for VHDL87 rule about the type of a bit string. + function Is_String_Literal_Type (A_Type : Iir; Expr : Iir) return Boolean + is + Base_Type : constant Iir := Get_Base_Type (A_Type); + El_Bt : Iir; + begin + -- LRM 7.3.1 + -- [...] the type of the literal must be a one-dimensional array ... + if not Is_Unidim_Array_Type (Base_Type) then + return False; + end if; + -- LRM 7.3.1 + -- ... of a character type ... + El_Bt := Get_Base_Type (Get_Element_Subtype (Base_Type)); + if Get_Kind (El_Bt) /= Iir_Kind_Enumeration_Type_Definition then + return False; + end if; + -- LRM87 7.3.1 + -- ... (for string literals) or of type BIT (for bit string literals). + if Flags.Vhdl_Std = Vhdl_87 + and then Get_Kind (Expr) = Iir_Kind_Bit_String_Literal + and then El_Bt /= Bit_Type_Definition + then + return False; + end if; + return True; + end Is_String_Literal_Type; + + -- Return TRUE iff A_TYPE can be the type of an aggregate. + function Is_Aggregate_Type (A_Type : Iir) return Boolean is + begin + -- LRM 7.3.2 Aggregates + -- [...] the type of the aggregate must be a composite type. + case Get_Kind (Get_Base_Type (A_Type)) is + when Iir_Kind_Array_Type_Definition + | Iir_Kind_Record_Type_Definition => + return True; + when others => + return False; + end case; + end Is_Aggregate_Type; + + -- Return TRUE iff A_TYPE can be the type of a null literal. + function Is_Null_Literal_Type (A_Type : Iir) return Boolean is + begin + -- LRM 7.3.1 Literals + -- The literal NULL represents the null access value for any access + -- type. + return + Get_Kind (Get_Base_Type (A_Type)) = Iir_Kind_Access_Type_Definition; + end Is_Null_Literal_Type; + + -- Return TRUE iff A_TYPE can be the type of allocator EXPR. Note that + -- the allocator must have been analyzed. + function Is_Allocator_Type (A_Type : Iir; Expr : Iir) return Boolean + is + Base_Type : constant Iir := Get_Base_Type (A_Type); + Designated_Type : Iir; + begin + -- LRM 7.3.6 Allocators + -- [...] the value returned is of an access type having the named + -- designated type. + + if Get_Kind (Base_Type) /= Iir_Kind_Access_Type_Definition then + return False; + end if; + Designated_Type := Get_Allocator_Designated_Type (Expr); + pragma Assert (Designated_Type /= Null_Iir); + -- Cheat: there is no allocators on universal types. + return Get_Base_Type (Get_Designated_Type (Base_Type)) + = Get_Base_Type (Designated_Type); + end Is_Allocator_Type; + + -- Return TRUE iff the type of EXPR is compatible with A_TYPE + function Is_Expr_Compatible (A_Type : Iir; Expr : Iir) return Boolean + is + Expr_Type : constant Iir := Get_Type (Expr); + begin + if Expr_Type /= Null_Iir then + return Compatibility_Types1 (A_Type, Expr_Type); + end if; + + case Get_Kind (Expr) is + when Iir_Kind_Aggregate => + return Is_Aggregate_Type (A_Type); + when Iir_Kind_String_Literal + | Iir_Kind_Bit_String_Literal => + return Is_String_Literal_Type (A_Type, Expr); + when Iir_Kind_Null_Literal => + return Is_Null_Literal_Type (A_Type); + when Iir_Kind_Allocator_By_Expression + | Iir_Kind_Allocator_By_Subtype => + return Is_Allocator_Type (A_Type, Expr); + when others => + -- Error while EXPR was typed. FIXME: should create an ERROR + -- node? + return False; + end case; + end Is_Expr_Compatible; + function Check_Is_Expression (Expr : Iir; Loc : Iir) return Iir is begin @@ -335,103 +494,6 @@ package body Sem_Expr is end if; end Search_Compatible_Type; - -- Return compatibility for type nodes LEFT and RIGHT. - function Compatibility (Left_Type, Right_Type : Iir) - return Boolean - is - Right_Base_Type : Iir; - Left_Base_Type : Iir; - begin - Right_Base_Type := Get_Base_Type (Right_Type); - Left_Base_Type := Get_Base_Type (Left_Type); - if Right_Base_Type = Left_Base_Type then - return True; - end if; - if Get_Kind (Left_Base_Type) = Iir_Kind_Integer_Type_Definition - and then Right_Base_Type = Convertible_Integer_Type_Definition - then - return True; - end if; - if Get_Kind (Left_Base_Type) = Iir_Kind_Floating_Type_Definition - and then Right_Base_Type = Convertible_Real_Type_Definition - then - return True; - end if; - return False; - end Compatibility; - - function Compatibility_Types1 (Left_Type : Iir; Right_Types : Iir) - return Boolean - is - El : Iir; - Right_List : Iir_List; - begin - if Is_Overload_List (Right_Types) then - Right_List := Get_Overload_List (Right_Types); - for I in Natural loop - El := Get_Nth_Element (Right_List, I); - exit when El = Null_Iir; - if Compatibility (Left_Type, El) then - return True; - end if; - end loop; - return False; - else - return Compatibility (Left_Type, Right_Types); - end if; - end Compatibility_Types1; - - -- Return compatibility for nodes LEFT and RIGHT. - -- LEFT is expected to be an interface of a function definition. - -- Type of RIGHT can be an overload_list - -- RIGHT might be implicitly converted to LEFT. - function Compatibility_Nodes (Left : Iir; Right : Iir) - return Boolean - is - Left_Type, Right_Type : Iir; - begin - Left_Type := Get_Base_Type (Get_Type (Left)); - Right_Type := Get_Type (Right); - - -- Check. - case Get_Kind (Left_Type) is - when Iir_Kind_Floating_Type_Definition - | Iir_Kind_Enumeration_Type_Definition - | Iir_Kind_Integer_Type_Definition - | Iir_Kind_Record_Type_Definition - | Iir_Kind_File_Type_Definition - | Iir_Kind_Physical_Type_Definition - | Iir_Kind_Access_Type_Definition - | Iir_Kind_Array_Type_Definition => - null; - when others => - Error_Kind ("are_node_compatible_ov", Left_Type); - end case; - - return Compatibility_Types1 (Left_Type, Right_Type); - end Compatibility_Nodes; - - function Compatibility_Types (Left_Types : Iir; Right_Types : Iir) - return Boolean - is - El : Iir; - Left_List : Iir_List; - begin - if Is_Overload_List (Left_Types) then - Left_List := Get_Overload_List (Left_Types); - for I in Natural loop - El := Get_Nth_Element (Left_List, I); - exit when El = Null_Iir; - if Compatibility_Types1 (El, Right_Types) then - return True; - end if; - end loop; - return False; - else - return Compatibility_Types1 (Left_Types, Right_Types); - end if; - end Compatibility_Types; - -- Semantize the range expression EXPR. -- If A_TYPE is not null_iir, EXPR is expected to be of type A_TYPE. -- LRM93 3.2.1.1 @@ -1528,7 +1590,7 @@ package body Sem_Expr is Set_Type (Expr, Get_Return_Type (Decl)); Interface_Chain := Get_Interface_Declaration_Chain (Decl); Err := False; - if Is_Overload_List (Get_Type (Left)) then + if Is_Overloaded (Left) then Left := Sem_Expression_Ov (Left, Get_Base_Type (Get_Type (Interface_Chain))); if Left = Null_Iir then @@ -1543,7 +1605,7 @@ package body Sem_Expr is end if; Check_Read (Left); if Arity = 2 then - if Is_Overload_List (Get_Type (Right)) then + if Is_Overloaded (Right) then Right := Sem_Expression_Ov (Right, Get_Base_Type (Get_Type (Get_Chain (Interface_Chain)))); @@ -1626,7 +1688,8 @@ package body Sem_Expr is -- Check return type. if Res_Type /= Null_Iir - and then not Compatibility (Res_Type, Get_Return_Type (Decl)) + and then + not Are_Types_Compatible (Res_Type, Get_Return_Type (Decl)) then goto Next; end if; @@ -1634,16 +1697,26 @@ package body Sem_Expr is Interface_Chain := Get_Interface_Declaration_Chain (Decl); -- Check arity. + + -- LRM93 2.5.2 Operator overloading + -- The subprogram specification of a unary operator must have + -- a single parameter [...] + -- The subprogram specification of a binary operator must have + -- two parameters [...] + -- + -- GHDL: So even in presence of default expression in a parameter, + -- a unary operation has to match with a binary operator. if Iir_Chains.Get_Chain_Length (Interface_Chain) /= Arity then goto Next; end if; -- Check operands. - if not Compatibility_Nodes (Interface_Chain, Left) then + if not Is_Expr_Compatible (Get_Type (Interface_Chain), Left) then goto Next; end if; if Arity = 2 then - if not Compatibility_Nodes (Get_Chain (Interface_Chain), Right) + if not Is_Expr_Compatible + (Get_Type (Get_Chain (Interface_Chain)), Right) then goto Next; end if; @@ -1740,7 +1813,7 @@ package body Sem_Expr is Decl := Get_Nth_Element (Overload_List, I); exit when Decl = Null_Iir; -- FIXME: wrong: compatibilty with return type and args. - if Compatibility (Get_Return_Type (Decl), Res_Type) then + if Are_Types_Compatible (Get_Return_Type (Decl), Res_Type) then if Full_Compat /= Null_Iir then Error_Operator_Overload (Overload_List); return Null_Iir; @@ -1754,37 +1827,6 @@ package body Sem_Expr is end if; end Sem_Operator; - -- Create a subtype for a string literal. - -- The literal must have been typed, with a type or a subtype. - -- FIXME: not general at all! - function Check_Type_For_String_Literal (A_Type : Iir; Expr : Iir) - return Boolean - is - Base_Type : constant Iir := Get_Base_Type (A_Type); - El_Bt : Iir; - begin - -- LRM 7.3.1 - -- [...] the type of the literal must be a one-dimensional array ... - if not Is_Unidim_Array_Type (Base_Type) then - return False; - end if; - -- LRM 7.3.1 - -- ... of a character type ... - El_Bt := Get_Base_Type (Get_Element_Subtype (Base_Type)); - if Get_Kind (El_Bt) /= Iir_Kind_Enumeration_Type_Definition then - return False; - end if; - -- LRM87 7.3.1 - -- ... (for string literals) or of type BIT (for bit string literals). - if Flags.Vhdl_Std = Vhdl_87 - and then Get_Kind (Expr) = Iir_Kind_Bit_String_Literal - and then El_Bt /= Bit_Type_Definition - then - return False; - end if; - return True; - end Check_Type_For_String_Literal; - -- Semantize LIT whose elements must be of type EL_TYPE, and return -- the length. -- FIXME: the errors are reported, but there is no mark of that. @@ -2135,7 +2177,7 @@ package body Sem_Expr is end if; end Sem_String_Choices_Range; - function Is_Name (Name : Iir) return Boolean + function Is_Choice_Name (Name : Iir) return Boolean is begin case Get_Kind (Name) is @@ -2147,7 +2189,7 @@ package body Sem_Expr is when others => return False; end case; - end Is_Name; + end Is_Choice_Name; procedure Sem_Choices_Range (Choice_Chain : in out Iir; @@ -2193,7 +2235,7 @@ package body Sem_Expr is Expr := Get_Expression (El); if Get_Kind (El) = Iir_Kind_Choice_By_Range then Expr := Sem_Discrete_Range_Expression (Expr, Sub_Type, True); - elsif Is_Name (Expr) then + elsif Is_Choice_Name (Expr) then declare Name : Iir; N_Choice : Iir; @@ -3388,96 +3430,74 @@ package body Sem_Expr is begin Arg := Get_Expression (Expr); Set_Expr_Staticness (Expr, None); - if Get_Type (Expr) = Null_Iir then - if Get_Kind (Expr) = Iir_Kind_Allocator_By_Expression then - if Get_Kind (Arg) /= Iir_Kind_Qualified_Expression then - raise Internal_Error; - end if; - Arg := Sem_Expression (Arg, Null_Iir); - if Arg = Null_Iir then - return Null_Iir; - end if; - Check_Read (Arg); - Arg_Type := Get_Type (Arg); - else - Arg := Sem_Types.Sem_Subtype_Indication (Arg); - if Arg = Null_Iir then - return Null_Iir; - end if; - -- LRM93 §7.3.6 - -- If an allocator includes a subtype indication and if the - -- type of the object created is an array type, then the - -- subtype indication must either denote a constrained - -- subtype or include an explicit index constraint. - if not Is_Fully_Constrained_Type (Arg) then - Error_Msg_Sem ("allocator of unconstrained " & - Disp_Node (Arg) & " is not allowed", Expr); - end if; - -- LRM93 7.3.6 - -- A subtype indication that is part of an allocator must - -- not include a resolution function. - if Is_Anonymous_Type_Definition (Arg) - and then Get_Resolution_Function (Arg) /= Null_Iir - then - Error_Msg_Sem ("subtype indication must not include" - & " a resolution function", Expr); - end if; - Arg_Type := Arg; - end if; + + Arg_Type := Get_Allocator_Designated_Type (Expr); + + if Arg_Type = Null_Iir then + -- Expression was not analyzed. + case Iir_Kinds_Allocator (Get_Kind (Expr)) is + when Iir_Kind_Allocator_By_Expression => + if Get_Kind (Arg) /= Iir_Kind_Qualified_Expression then + raise Internal_Error; + end if; + Arg := Sem_Expression (Arg, Null_Iir); + if Arg = Null_Iir then + return Null_Iir; + end if; + Check_Read (Arg); + Arg_Type := Get_Type (Arg); + when Iir_Kind_Allocator_By_Subtype => + Arg := Sem_Types.Sem_Subtype_Indication (Arg); + if Arg = Null_Iir then + return Null_Iir; + end if; + -- LRM93 §7.3.6 + -- If an allocator includes a subtype indication and if the + -- type of the object created is an array type, then the + -- subtype indication must either denote a constrained + -- subtype or include an explicit index constraint. + if not Is_Fully_Constrained_Type (Arg) then + Error_Msg_Sem + ("allocator of unconstrained " & + Disp_Node (Arg) & " is not allowed", Expr); + end if; + -- LRM93 7.3.6 + -- A subtype indication that is part of an allocator must + -- not include a resolution function. + if Is_Anonymous_Type_Definition (Arg) + and then Get_Resolution_Function (Arg) /= Null_Iir + then + Error_Msg_Sem ("subtype indication must not include" + & " a resolution function", Expr); + end if; + Arg_Type := Arg; + end case; Set_Expression (Expr, Arg); - else - if Get_Kind (Expr) = Iir_Kind_Allocator_By_Expression then - Arg_Type := Get_Type (Arg); - else - Arg_Type := Arg; - end if; + Set_Allocator_Designated_Type (Expr, Arg_Type); end if; + -- LRM 7.3.6 Allocators + -- The type of the access value returned by an allocator must be + -- determinable solely from the context, but using the fact that the + -- value returned is of an access type having the named designated + -- type. if A_Type = Null_Iir then - -- Pass 1. - -- LRM 7.3.6 Allocators - -- The type of the access value returned by an allocator must be - -- determinable solely from the context, but using the fact that the - -- value returned is of an access type having the named designated - -- type. - declare - Index : Visible_Type_Index_Type; - Vtype : Iir; - Btype : Iir; - Dtype : Iir; - List : Iir_List; - begin - List := Create_Iir_List; - Index := Get_First_Visible_Type; - while Index /= No_Visible_Type_Index loop - Vtype := Get_Visible_Type_Decl (Index); - Btype := Get_Base_Type (Get_Type (Vtype)); - if Get_Kind (Btype) = Iir_Kind_Access_Type_Definition then - Dtype := Get_Base_Type (Get_Designated_Type (Btype)); - if Dtype = Get_Base_Type (Arg_Type) then - Add_Element (List, Dtype); - end if; - end if; - Index := Get_Next_Visible_Type (Index); - end loop; - Set_Type (Expr, Simplify_Overload_List (List)); - end; + -- Type of the context is not yet known. + return Expr; else - if Get_Kind (A_Type) /= Iir_Kind_Access_Type_Definition then - if Get_Kind (A_Type) /= Iir_Kind_Error then - Error_Msg_Sem ("expected type is not an access type", Expr); + if not Is_Allocator_Type (A_Type, Expr) then + if Get_Kind (A_Type) /= Iir_Kind_Access_Type_Definition then + if Get_Kind (A_Type) /= Iir_Kind_Error then + Error_Msg_Sem ("expected type is not an access type", Expr); + end if; + else + Not_Match (Expr, A_Type); end if; return Null_Iir; end if; - if not Are_Types_Compatible (Arg_Type, Get_Designated_Type (A_Type)) - then - Not_Match (Expr, A_Type); - return Null_Iir; - end if; - Free_Old_Iir (Get_Type (Expr)); Set_Type (Expr, A_Type); + return Expr; end if; - return Expr; end Sem_Allocator; procedure Check_Read_Aggregate (Aggr : Iir) @@ -3810,87 +3830,31 @@ package body Sem_Expr is when Iir_Kind_String_Literal | Iir_Kind_Bit_String_Literal => - if A_Type /= Null_Iir then - if not Check_Type_For_String_Literal (A_Type, Expr) then - Not_Match (Expr, A_Type); - return Null_Iir; - end if; - -- It is enough ? - -- FIXME: check against LRM. + -- LRM93 7.3.1 Literals + -- The type of a string or bit string literal must be + -- determinable solely from the context in whcih the literal + -- appears, excluding the literal itself [...] + if A_Type = Null_Iir then + return Expr; + end if; + + if not Is_String_Literal_Type (A_Type, Expr) then + Not_Match (Expr, A_Type); + return Null_Iir; + else Replace_Type (Expr, A_Type); Sem_String_Literal (Expr); return Expr; end if; - -- Look on every visible declaration of unidimensional array. - declare - Vt: Visible_Type_Index_Type; - Vt_Type : Iir; - Decl: Iir; - List: Iir_List; - begin - Vt := Get_First_Visible_Type; - List := Create_Iir_List; - while Vt /= No_Visible_Type_Index loop - Vt_Type := Get_Type (Get_Visible_Type_Decl (Vt)); - Decl := Get_Base_Type (Vt_Type); - if Check_Type_For_String_Literal (Decl, Expr) then - Append_Element (List, Decl); - end if; - Vt := Get_Next_Visible_Type (Vt); - end loop; - case Get_Nbr_Elements (List) is - when 0 => - Destroy_Iir_List (List); - Error_Msg_Sem - ("no character type for string literal", Expr); - return Null_Iir; - when 1 => - Set_Type (Expr, Get_First_Element (List)); - Destroy_Iir_List (List); - Sem_String_Literal (Expr); - return Expr; - when others => - Set_Type (Expr, Create_Overload_List (List)); - return Expr; - end case; - end; - when Iir_Kind_Null_Literal => Set_Expr_Staticness (Expr, Locally); + -- GHDL: the LRM doesn't explain how the type of NULL is + -- determined. Use the same rule as string or aggregates. if A_Type = Null_Iir then - declare - Vt: Visible_Type_Index_Type; - Vt_Type : Iir; - Decl: Iir; - List: Iir_List; - begin - Vt := Get_First_Visible_Type; - List := Create_Iir_List; - while Vt /= No_Visible_Type_Index loop - Vt_Type := Get_Type (Get_Visible_Type_Decl (Vt)); - Decl := Get_Base_Type (Vt_Type); - if Get_Kind (Decl) = Iir_Kind_Access_Type_Definition then - Append_Element (List, Decl); - end if; - Vt := Get_Next_Visible_Type (Vt); - end loop; - case Get_Nbr_Elements (List) is - when 0 => - Error_Msg_Sem - ("no visible access type for null literal", Expr); - Destroy_Iir_List (List); - return Null_Iir; - when 1 => - Set_Type (Expr, Get_First_Element (List)); - Destroy_Iir_List (List); - return Expr; - when others => - Set_Type (Expr, Create_Overload_List (List)); - return Expr; - end case; - end; - elsif Get_Kind (A_Type) /= Iir_Kind_Access_Type_Definition then + return Expr; + end if; + if not Is_Null_Literal_Type (A_Type) then Error_Msg_Sem ("null literal can only be access type", Expr); return Null_Iir; else @@ -3898,6 +3862,17 @@ package body Sem_Expr is return Expr; end if; + when Iir_Kind_Aggregate => + -- LRM93 7.3.2 Aggregates + -- The type of an aggregate must be determinable solely from the + -- context in which the aggregate appears, excluding the aggregate + -- itself but [...] + if A_Type = Null_Iir then + return Expr; + else + return Sem_Aggregate (Expr, A_Type); + end if; + when Iir_Kind_Qualified_Expression => declare N_Type: Iir; @@ -3931,48 +3906,6 @@ package body Sem_Expr is | Iir_Kind_Allocator_By_Subtype => return Sem_Allocator (Expr, A_Type); - when Iir_Kind_Aggregate => - if A_Type = Null_Iir then - declare - Vt: Visible_Type_Index_Type; - Vt_Type : Iir; - Decl: Iir; - List: Iir_List; - Res : Iir; - begin - Vt := Get_First_Visible_Type; - List := Create_Iir_List; - while Vt /= No_Visible_Type_Index loop - Vt_Type := Get_Type (Get_Visible_Type_Decl (Vt)); - Decl := Get_Base_Type (Vt_Type); - case Get_Kind (Decl) is - when Iir_Kind_Array_Type_Definition - | Iir_Kind_Record_Type_Definition => - Append_Element (List, Decl); - when others => - null; - end case; - Vt := Get_Next_Visible_Type (Vt); - end loop; - case Get_Nbr_Elements (List) is - when 0 => - Destroy_Iir_List (List); - Error_Msg_Sem - ("no visible composite type for aggregate", Expr); - return Null_Iir; - when 1 => - Res := Sem_Aggregate (Expr, Get_First_Element (List)); - Destroy_Iir_List (List); - return Res; - when others => - Set_Type (Expr, Create_Overload_List (List)); - return Expr; - end case; - end; - else - return Sem_Aggregate (Expr, A_Type); - end if; - when Iir_Kinds_Procedure_Declaration => Error_Msg_Sem (Disp_Node (Expr) & " cannot be used as an expression", Expr); @@ -4027,7 +3960,7 @@ package body Sem_Expr is if A_Type = Null_Iir then Res := Sem_Expression_Ov (Expr, Null_Iir); else - if not Check_Type_For_String_Literal (A_Type, Expr) then + if not Is_String_Literal_Type (A_Type, Expr) then Not_Match (Expr, A_Type); return Null_Iir; end if; @@ -4040,8 +3973,12 @@ package body Sem_Expr is end case; if Res /= Null_Iir and then Is_Overloaded (Res) then + -- FIXME: clarify between overload and not determinable from the + -- context. Error_Overload (Expr); - Disp_Overload_List (Get_Overload_List (Get_Type (Res)), Expr); + if Get_Type (Res) /= Null_Iir then + Disp_Overload_List (Get_Overload_List (Get_Type (Res)), Expr); + end if; return Null_Iir; end if; return Res; @@ -4104,6 +4041,17 @@ package body Sem_Expr is return Null_Iir; end if; Expr_Type := Get_Type (Expr1); + if Expr_Type = Null_Iir then + -- Possible only if the type cannot be determined without the + -- context (aggregate or string literal). + Error_Msg_Sem + ("cannot determine the type of choice expression", Expr); + if Get_Kind (Expr1) = Iir_Kind_Aggregate then + Error_Msg_Sem + ("(use a qualified expression of the form T'(xxx).)", Expr); + end if; + return Null_Iir; + end if; if not Is_Overload_List (Expr_Type) then return Expr1; end if; diff --git a/sem_expr.ads b/sem_expr.ads index 5b56cae40..3304923c7 100644 --- a/sem_expr.ads +++ b/sem_expr.ads @@ -92,14 +92,6 @@ package Sem_Expr is -- If EXPR is NULL_IIR, NULL_IIR is silently returned. function Check_Is_Expression (Expr : Iir; Loc : Iir) return Iir; - -- LEFT are RIGHT must be really a type (not a subtype). - function Are_Basetypes_Compatible (Left: Iir; Right: Iir) - return Boolean; - - -- Return TRUE iif types of LEFT and RIGHT are compatible. - function Are_Nodes_Compatible (Left: Iir; Right: Iir) - return Boolean; - -- Semantize a procedure_call or a concurrent_procedure_call_statement. procedure Sem_Procedure_Call (Call : Iir_Procedure_Call; Stmt : Iir); @@ -163,9 +155,17 @@ package Sem_Expr is -- one-dimensional character array type. procedure Sem_String_Choices_Range (Choice_Chain : Iir; Sel : Iir); - function Compatibility_Types (Left_Types : Iir; Right_Types : Iir) + -- LEFT are RIGHT must be really a type (not a subtype). + function Are_Basetypes_Compatible (Left: Iir; Right: Iir) return Boolean; + -- Return TRUE iif types of LEFT and RIGHT are compatible. + function Are_Nodes_Compatible (Left: Iir; Right: Iir) + return Boolean; + + -- Return TRUE iff the type of EXPR is compatible with A_TYPE + function Is_Expr_Compatible (A_Type : Iir; Expr : Iir) return Boolean; + -- LIST1, LIST2 are either a type node or an overload list of types. -- Return THE type which is compatible with LIST1 are LIST2. -- Return null_iir if there is no such type or if there are several types. diff --git a/sem_names.adb b/sem_names.adb index f56dabcb6..31de9a8d5 100644 --- a/sem_names.adb +++ b/sem_names.adb @@ -1998,6 +1998,13 @@ package body Sem_Names is when Iir_Kinds_Function_Declaration => Sem_Parenthesis_Function (Prefix); if Res = Null_Iir then + declare + Match : Boolean; + begin + Sem_Association_Chain + (Get_Interface_Declaration_Chain (Prefix), + Assoc_Chain, True, Missing_Parameter, Name, Match); + end; Error_Msg_Sem ("prefix is neither a function name " & "nor can it be sliced or indexed", Name); diff --git a/sem_scopes.adb b/sem_scopes.adb index ab7dbef17..c5483e49e 100644 --- a/sem_scopes.adb +++ b/sem_scopes.adb @@ -32,9 +32,6 @@ package body Sem_Scopes is procedure Disp_Scopes; pragma Unreferenced (Disp_Scopes); - procedure Disp_Visible_Types; - pragma Unreferenced (Disp_Visible_Types); - procedure Disp_Detailed_Interpretations (Ident : Name_Id); pragma Unreferenced (Disp_Detailed_Interpretations); @@ -90,18 +87,6 @@ package body Sem_Scopes is Id: Name_Id; end record; - type Visible_Type_Cell is record - Id: Name_Id; - Decl: Iir; - end record; - - package Visible_Types is new GNAT.Table - (Table_Component_Type => Visible_Type_Cell, - Table_Index_Type => Visible_Type_Index_Type, - Table_Low_Bound => No_Visible_Type_Index + 1, - Table_Initial => 32, - Table_Increment => 10); - package Interpretations is new GNAT.Table (Table_Component_Type => Interpretation_Cell, Table_Index_Type => Name_Interpretation_Type, @@ -119,8 +104,6 @@ package body Sem_Scopes is -- Index into Interpretations marking the last interpretation of -- the previous (immediate) declarative region. Current_Scope_Start: Name_Interpretation_Type := No_Name_Interpretation; - Current_Composite_Types_Start : Visible_Type_Index_Type := - No_Visible_Type_Index; function Valid_Interpretation (Inter : Name_Interpretation_Type) return Boolean is @@ -206,7 +189,7 @@ package body Sem_Scopes is Scopes.Increment_Last; Scopes.Table (Scopes.Last) := (Kind => Region_Start, Inter => Current_Scope_Start, - Id => Name_Id (Visible_Types.Last)); + Id => Null_Identifier); Current_Scope_Start := Interpretations.Last; end Open_Declarative_Region; @@ -221,8 +204,6 @@ package body Sem_Scopes is Interpretations.Set_Last (Current_Scope_Start); -- Restore Current_Scope_Start. Current_Scope_Start := Scopes.Table (Scopes.Last).Inter; - Visible_Types.Set_Last - (Visible_Type_Index_Type (Scopes.Table (Scopes.Last).Id)); Scopes.Decrement_Last; return; when Save_Cell => @@ -315,14 +296,13 @@ package body Sem_Scopes is Scopes.Table (Scopes.Last) := (Kind => Barrier_End, Inter => Interpretations.Last, - Id => Name_Id (Current_Composite_Types_Start)); + Id => Null_Identifier); -- Start a completly new scope. Current_Scope_Start := Interpretations.Last + 1; -- Keep the last barrier. Current_Barrier := Scopes.Last + 1; - Current_Composite_Types_Start := Visible_Types.Last; pragma Debug (Name_Table.Assert_No_Infos); end Push_Interpretations; @@ -344,8 +324,6 @@ package body Sem_Scopes is -- Restore the stack pointer of interpretations. Interpretations.Set_Last (Scopes.Table (Scopes.Last).Inter); - Current_Composite_Types_Start := - Visible_Type_Index_Type (Scopes.Table (Scopes.Last).Id); Scopes.Decrement_Last; -- Restore all name interpretations. @@ -397,78 +375,6 @@ package body Sem_Scopes is end case; end Is_Overloadable; - -- Return true if DECL declare a type that is visible. - -- This is used to build the list of visible types, ie types that must - -- be considered for certains expression: access for NULL literals, - -- arrays and records for aggregates, arrays for string literals. --- function Is_Visible_Type (Decl: Iir) return Boolean --- is --- Def: Iir; --- begin --- case Get_Kind (Decl) is --- when Iir_Kind_Array_Type_Definition --- | Iir_Kind_Array_Subtype_Definition => --- raise Internal_Error; --- when Iir_Kind_Type_Declaration => --- Def := Get_Type (Decl); --- when others => --- return False; --- end case; --- case Get_Kind (Def) is --- when Iir_Kind_Array_Type_Definition --- | Iir_Kind_Array_Subtype_Definition => --- return True; --- when Iir_Kind_Record_Type_Definition => --- return True; --- when Iir_Kind_Access_Type_Definition --- | Iir_Kind_Access_Subtype_Definition => --- return True; --- when others => --- return False; --- end case; --- end Is_Visible_Type; - - function Get_Visible_Type (Vt: Visible_Type_Index_Type) - return Visible_Type_Index_Type - is - Pt: Visible_Type_Index_Type := Vt; - begin - if True then - return Pt; - else - while Pt > Current_Composite_Types_Start loop - if Get_Declaration - (Get_Interpretation (Visible_Types.Table (Pt).Id)) - = Visible_Types.Table (Pt).Decl - then - return Pt; - end if; - Pt := Pt - 1; - end loop; - return No_Visible_Type_Index; - end if; - end Get_Visible_Type; - - -- Get the first visible declaration of unidim array. - function Get_First_Visible_Type return Visible_Type_Index_Type is - begin - return Get_Visible_Type (Visible_Types.Last); - end Get_First_Visible_Type; - - -- Get the next visible declaration of unidim array in the list. - function Get_Next_Visible_Type (Index: Visible_Type_Index_Type) - return Visible_Type_Index_Type is - begin - return Get_Visible_Type (Index - 1); - end Get_Next_Visible_Type; - - -- Get the declaration corresponding to an uni_array_visible_type. - function Get_Visible_Type_Decl (Index : Visible_Type_Index_Type) - return Iir is - begin - return Visible_Types.Table (Index).Decl; - end Get_Visible_Type_Decl; - -- Return TRUE if INTER was made direclty visible in the current -- declarative region. function Is_In_Current_Declarative_Region (Inter: Name_Interpretation_Type) @@ -510,11 +416,6 @@ package body Sem_Scopes is -- end case; -- end Redeclaration_Allowed; - procedure Add_Visible_Type (Decl : Iir) is - begin - Visible_Types.Append ((Id => Get_Identifier (Decl), Decl => Decl)); - end Add_Visible_Type; - -- Add interpretation DECL to the identifier of DECL. -- POTENTIALLY is true if the identifier comes from a use clause. procedure Add_Name (Decl: Iir; Ident: Name_Id; Potentially: Boolean) @@ -973,11 +874,8 @@ package body Sem_Scopes is when Iir_Kind_Library_Clause => Add_Name (Get_Library_Declaration (Decl), Get_Identifier (Decl), Potentially); - when Iir_Kind_Type_Declaration => - Add_Name (Decl, Get_Identifier (Decl), Potentially); - Add_Visible_Type (Decl); when Iir_Kind_Anonymous_Type_Declaration => - Add_Visible_Type (Decl); + null; when others => Add_Name (Decl, Get_Identifier (Decl), Potentially); end case; @@ -1157,18 +1055,6 @@ package body Sem_Scopes is end Extend_Scope_Of_Block_Declarations; -- Debugging - procedure Disp_Visible_Types - is - use Ada.Text_IO; - Index: Visible_Type_Index_Type; - begin - Index := Get_First_Visible_Type; - while Index /= No_Visible_Type_Index loop - Put_Line (Disp_Node (Get_Visible_Type_Decl (Index))); - Index := Get_Next_Visible_Type (Index); - end loop; - end Disp_Visible_Types; - procedure Disp_Detailed_Interpretations (Ident : Name_Id) is use Ada.Text_IO; diff --git a/sem_scopes.ads b/sem_scopes.ads index b8f7664de..7126d388c 100644 --- a/sem_scopes.ads +++ b/sem_scopes.ads @@ -53,9 +53,6 @@ package Sem_Scopes is -- Set the visible_flag of DECL to true. procedure Name_Visible (Decl : Iir); - -- Add DECL is the list of visible types. - procedure Add_Visible_Type (Decl : Iir); - -- Replace the interpretation OLD of ID by DECL. -- ID must have a uniq interpretation OLD (ie, it must not be overloaded). -- The interpretation must have been done in the current scope. @@ -181,31 +178,6 @@ package Sem_Scopes is -- declarations added can be removed with Close_Scope_Extension. procedure Extend_Scope_Of_Block_Declarations (Decl : Iir); - -- It is necessary to keep trace of all visible type definition of - -- arrays, record and access. This is used by string, bit string, aggregate - -- and null literal. - -- This is for the user a simple linked list. - - -- list element type. - type Visible_Type_Index_Type is private; - - -- End of the list element. - No_Visible_Type_Index: constant Visible_Type_Index_Type; - - -- Get the first visible type declaration. - function Get_First_Visible_Type return Visible_Type_Index_Type; - pragma Inline (Get_First_Visible_Type); - - -- Get the visible type declaration after INDEX. - function Get_Next_Visible_Type (Index: Visible_Type_Index_Type) - return Visible_Type_Index_Type; - pragma Inline (Get_Next_Visible_Type); - - -- Get the declaration corresponding to INDEX. - function Get_Visible_Type_Decl (Index: Visible_Type_Index_Type) - return Iir; - pragma Inline (Get_Visible_Type_Decl); - -- Call HANDLE_DECL for each declaration found in DECL. -- This will generally call HANDLE_DECL with DECL. -- For types, HANDLE_DECL is first called with the type declaration, then @@ -235,7 +207,4 @@ private No_Name_Interpretation : constant Name_Interpretation_Type := 0; Conflict_Interpretation : constant Name_Interpretation_Type := 1; First_Valid_Interpretation : constant Name_Interpretation_Type := 2; - - type Visible_Type_Index_Type is new Nat32; - No_Visible_Type_Index: constant Visible_Type_Index_Type := 0; end Sem_Scopes; diff --git a/tokens.adb b/tokens.adb index ffbad10be..415486cab 100644 --- a/tokens.adb +++ b/tokens.adb @@ -105,11 +105,14 @@ package body Tokens is return "+"; when Tok_Minus => return "-"; - -- and adding_operator + -- and adding_operator when Tok_Ampersand => return "&"; - -- multiplying operator + when Tok_Condition => + return "??"; + + -- multiplying operator when Tok_Star => return "*"; when Tok_Slash => @@ -119,7 +122,7 @@ package body Tokens is when Tok_Rem => return "rem"; - -- relation token: + -- relation token: when Tok_And => return "and"; when Tok_Or => @@ -133,7 +136,7 @@ package body Tokens is when Tok_Xnor => return "xnor"; - -- Key words. + -- Reserved words. when Tok_Abs => return "abs"; when Tok_Access => diff --git a/tokens.ads b/tokens.ads index 41b50f24d..bb431b95a 100644 --- a/tokens.ads +++ b/tokens.ads @@ -70,6 +70,8 @@ package Tokens is -- and adding_operator Tok_Ampersand, -- & + Tok_Condition, + -- PSL Tok_And_And, -- && Tok_Bar_Bar, -- || |