1-- Iir to ortho translator. 2-- Copyright (C) 2002 - 2014 Tristan Gingold 3-- 4-- This program is free software: you can redistribute it and/or modify 5-- it under the terms of the GNU General Public License as published by 6-- the Free Software Foundation, either version 2 of the License, or 7-- (at your option) any later version. 8-- 9-- This program is distributed in the hope that it will be useful, 10-- but WITHOUT ANY WARRANTY; without even the implied warranty of 11-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12-- GNU General Public License for more details. 13-- 14-- You should have received a copy of the GNU General Public License 15-- along with this program. If not, see <gnu.org/licenses>. 16 17with Simple_IO; 18with Name_Table; 19with Str_Table; 20with Vhdl.Utils; use Vhdl.Utils; 21with Vhdl.Nodes_Utils; use Vhdl.Nodes_Utils; 22with Vhdl.Std_Package; use Vhdl.Std_Package; 23with Errorout; use Errorout; 24with Vhdl.Errors; use Vhdl.Errors; 25with Flags; use Flags; 26with Vhdl.Canon; 27with Vhdl.Evaluation; use Vhdl.Evaluation; 28with Trans.Chap3; 29with Trans.Chap4; 30with Trans.Chap6; 31with Trans.Chap8; 32with Trans.Chap14; 33with Trans.Rtis; 34with Trans_Decls; use Trans_Decls; 35with Trans.Helpers2; use Trans.Helpers2; 36with Trans.Foreach_Non_Composite; 37 38package body Trans.Chap7 is 39 use Trans.Helpers; 40 procedure Copy_Range (Dest : Mnode; Src : Mnode); 41 42 procedure Create_Operator_Instance (Interfaces : in out O_Inter_List; 43 Info : Operator_Info_Acc) is 44 begin 45 Subprgs.Add_Subprg_Instance_Interfaces 46 (Interfaces, Info.Operator_Instance); 47 end Create_Operator_Instance; 48 49 procedure Start_Operator_Instance_Use (Info : Operator_Info_Acc) is 50 begin 51 Subprgs.Start_Subprg_Instance_Use (Info.Operator_Instance); 52 end Start_Operator_Instance_Use; 53 54 procedure Finish_Operator_Instance_Use (Info : Operator_Info_Acc) is 55 begin 56 Subprgs.Finish_Subprg_Instance_Use (Info.Operator_Instance); 57 end Finish_Operator_Instance_Use; 58 59 function Translate_Static_Implicit_Conv 60 (Expr : O_Cnode; Expr_Type : Iir; Res_Type : Iir) return O_Cnode 61 is 62 Expr_Info : Type_Info_Acc; 63 Res_Info : Type_Info_Acc; 64 Val : Var_Type; 65 Res : O_Cnode; 66 List : O_Record_Aggr_List; 67 Layout : Var_Type; 68 begin 69 if Res_Type = Expr_Type then 70 return Expr; 71 end if; 72 73 -- EXPR must be already constrained. 74 pragma Assert (Get_Kind (Expr_Type) = Iir_Kind_Array_Subtype_Definition); 75 if Get_Kind (Res_Type) = Iir_Kind_Array_Subtype_Definition 76 and then Get_Constraint_State (Res_Type) = Fully_Constrained 77 then 78 -- constrained to constrained. 79 if Chap3.Locally_Array_Match (Expr_Type, Res_Type) /= True then 80 -- Sem should have replaced the expression by an overflow. 81 raise Internal_Error; 82 -- Chap6.Gen_Bound_Error (Loc); 83 end if; 84 85 -- Constrained to constrained should be OK, as already checked by 86 -- sem. 87 return Expr; 88 end if; 89 90 -- Handle only constrained to unconstrained conversion. 91 pragma Assert (Get_Kind (Res_Type) in Iir_Kinds_Array_Type_Definition); 92 93 Expr_Info := Get_Info (Expr_Type); 94 Res_Info := Get_Info (Res_Type); 95 Val := Create_Global_Const 96 (Create_Uniq_Identifier, Expr_Info.Ortho_Type (Mode_Value), 97 O_Storage_Private, Expr); 98 Layout := Expr_Info.S.Composite_Layout; 99 if Layout = Null_Var then 100 Layout := Create_Global_Const 101 (Create_Uniq_Identifier, Expr_Info.B.Layout_Type, 102 O_Storage_Private, 103 Chap3.Create_Static_Composite_Subtype_Layout (Expr_Type)); 104 Expr_Info.S.Composite_Layout := Layout; 105 end if; 106 107 Start_Record_Aggr (List, Res_Info.Ortho_Type (Mode_Value)); 108 New_Record_Aggr_El 109 (List, New_Global_Address (New_Global (Get_Var_Label (Val)), 110 Res_Info.B.Base_Ptr_Type (Mode_Value))); 111 New_Record_Aggr_El 112 (List, New_Global_Address (New_Global_Selected_Element 113 (New_Global (Get_Var_Label (Layout)), 114 Expr_Info.B.Layout_Bounds), 115 Expr_Info.B.Bounds_Ptr_Type)); 116 Finish_Record_Aggr (List, Res); 117 118 return Res; 119 end Translate_Static_Implicit_Conv; 120 121 function Is_Static_Constant (Decl : Iir_Constant_Declaration) return Boolean 122 is 123 Expr : constant Iir := Get_Default_Value (Decl); 124 Atype : Iir; 125 Info : Iir; 126 begin 127 if Expr = Null_Iir then 128 -- Deferred constant. 129 return False; 130 end if; 131 132 -- Only aggregates are specially handled. 133 if not Is_Static_Construct (Expr) 134 or else Get_Kind (Expr) /= Iir_Kind_Aggregate 135 then 136 return False; 137 end if; 138 139 Atype := Get_Type (Decl); 140 141 -- Currently, only array aggregates are handled. 142 if Get_Kind (Get_Base_Type (Atype)) /= Iir_Kind_Array_Type_Definition 143 then 144 return False; 145 end if; 146 147 Info := Get_Aggregate_Info (Expr); 148 while Info /= Null_Iir loop 149 if Get_Aggr_Dynamic_Flag (Info) then 150 raise Internal_Error; 151 end if; 152 153 -- Currently, only positionnal aggregates are handled. 154 if Get_Aggr_Named_Flag (Info) then 155 return False; 156 end if; 157 -- Currently, others choice are not handled. 158 if Get_Aggr_Others_Flag (Info) then 159 return False; 160 end if; 161 162 Info := Get_Sub_Aggregate_Info (Info); 163 end loop; 164 return True; 165 end Is_Static_Constant; 166 167 procedure Translate_Static_String_Literal8_Inner 168 (List : in out O_Array_Aggr_List; 169 Str : Iir; 170 El_Type : Iir) 171 is 172 Literal_List : constant Iir_Flist := 173 Get_Enumeration_Literal_List (Get_Base_Type (El_Type)); 174 Len : constant Nat32 := Get_String_Length (Str); 175 Id : constant String8_Id := Get_String8_Id (Str); 176 Lit : Iir; 177 begin 178 for I in 1 .. Len loop 179 Lit := Get_Nth_Element 180 (Literal_List, Natural (Str_Table.Element_String8 (Id, I))); 181 New_Array_Aggr_El (List, Get_Ortho_Literal (Lit)); 182 end loop; 183 end Translate_Static_String_Literal8_Inner; 184 185 procedure Translate_Static_Array_Aggregate_1 186 (List : in out O_Array_Aggr_List; 187 Aggr : Iir; 188 Aggr_Type : Iir; 189 Dim : Positive) 190 is 191 Nbr_Dims : constant Natural := Get_Nbr_Dimensions (Aggr_Type); 192 El_Type : constant Iir := Get_Element_Subtype (Aggr_Type); 193 begin 194 case Get_Kind (Aggr) is 195 when Iir_Kind_Aggregate => 196 declare 197 Index_Type : constant Iir := 198 Get_Index_Type (Aggr_Type, Dim - 1); 199 Index_Range : constant Iir := Eval_Static_Range (Index_Type); 200 Len : constant Int64 := 201 Eval_Discrete_Range_Length (Index_Range); 202 Assocs : constant Iir := Get_Association_Choices_Chain (Aggr); 203 Vect : Iir_Array (0 .. Integer (Len - 1)); 204 begin 205 if Len = 0 then 206 -- Should be automatically handled, but fails with some 207 -- old versions of gnat (gnatgpl 2014 with -O). 208 return; 209 end if; 210 211 Build_Array_Choices_Vector (Vect, Index_Range, Assocs); 212 213 if Dim = Nbr_Dims then 214 declare 215 Idx : Natural; 216 Assoc : Iir; 217 Expr : Iir; 218 El : Iir; 219 Assoc_Len : Iir_Index32; 220 begin 221 Idx := 0; 222 while Idx < Natural (Len) loop 223 Assoc := Vect (Idx); 224 Expr := Get_Associated_Expr (Assoc); 225 if Get_Element_Type_Flag (Assoc) then 226 New_Array_Aggr_El 227 (List, 228 Translate_Static_Expression (Expr, El_Type)); 229 Idx := Idx + 1; 230 else 231 Assoc_Len := Iir_Index32 232 (Eval_Discrete_Range_Length 233 (Get_Choice_Range (Assoc))); 234 for I in 0 .. Assoc_Len - 1 loop 235 El := Eval_Indexed_Name_By_Offset (Expr, I); 236 New_Array_Aggr_El 237 (List, 238 Translate_Static_Expression (El, El_Type)); 239 Idx := Idx + 1; 240 end loop; 241 end if; 242 end loop; 243 end; 244 else 245 for I in Vect'Range loop 246 Translate_Static_Array_Aggregate_1 247 (List, Get_Associated_Expr (Vect (I)), 248 Aggr_Type, Dim + 1); 249 end loop; 250 end if; 251 end; 252 when Iir_Kind_String_Literal8 => 253 pragma Assert (Dim = Nbr_Dims); 254 Translate_Static_String_Literal8_Inner (List, Aggr, El_Type); 255 when others => 256 Error_Kind ("translate_static_array_aggregate_1", Aggr); 257 end case; 258 end Translate_Static_Array_Aggregate_1; 259 260 function Translate_Static_Aggregate (Aggr : Iir) return O_Cnode 261 is 262 Aggr_Type : constant Iir := Get_Type (Aggr); 263 List : O_Array_Aggr_List; 264 Res : O_Cnode; 265 begin 266 Chap3.Translate_Anonymous_Subtype_Definition (Aggr_Type, False); 267 Start_Array_Aggr 268 (List, Get_Ortho_Type (Aggr_Type, Mode_Value), 269 Unsigned_32 (Chap3.Get_Static_Array_Length (Aggr_Type))); 270 271 Translate_Static_Array_Aggregate_1 (List, Aggr, Aggr_Type, 1); 272 Finish_Array_Aggr (List, Res); 273 return Res; 274 end Translate_Static_Aggregate; 275 276 function Translate_Static_Simple_Aggregate (Aggr : Iir) return O_Cnode 277 is 278 Aggr_Type : constant Iir := Get_Type (Aggr); 279 El_List : constant Iir_Flist := Get_Simple_Aggregate_List (Aggr); 280 El_Type : constant Iir := Get_Element_Subtype (Aggr_Type); 281 El : Iir; 282 List : O_Array_Aggr_List; 283 Res : O_Cnode; 284 begin 285 Chap3.Translate_Anonymous_Subtype_Definition (Aggr_Type, False); 286 Start_Array_Aggr (List, 287 Get_Ortho_Type (Aggr_Type, Mode_Value), 288 Unsigned_32 (Get_Nbr_Elements (El_List))); 289 290 for I in Flist_First .. Flist_Last (El_List) loop 291 El := Get_Nth_Element (El_List, I); 292 New_Array_Aggr_El 293 (List, Translate_Static_Expression (El, El_Type)); 294 end loop; 295 296 Finish_Array_Aggr (List, Res); 297 return Res; 298 end Translate_Static_Simple_Aggregate; 299 300 function Translate_Static_String_Literal8 (Str : Iir) return O_Cnode 301 is 302 Lit_Type : constant Iir := Get_Type (Str); 303 Element_Type : constant Iir := Get_Element_Subtype (Lit_Type); 304 Arr_Type : O_Tnode; 305 List : O_Array_Aggr_List; 306 Res : O_Cnode; 307 begin 308 Chap3.Translate_Anonymous_Subtype_Definition (Lit_Type, False); 309 Arr_Type := Get_Ortho_Type (Lit_Type, Mode_Value); 310 311 Start_Array_Aggr 312 (List, Arr_Type, 313 Unsigned_32 (Chap3.Get_Static_Array_Length (Lit_Type))); 314 315 Translate_Static_String_Literal8_Inner (List, Str, Element_Type); 316 317 Finish_Array_Aggr (List, Res); 318 return Res; 319 end Translate_Static_String_Literal8; 320 321 -- Create a variable (constant) for string or bit string literal STR. 322 -- The type of the literal element is ELEMENT_TYPE, and the ortho type 323 -- of the string (a constrained array type) is STR_TYPE. 324 function Create_String_Literal_Var_Inner 325 (Str : Iir; Element_Type : Iir; Arr_Type : O_Tnode) return Var_Type 326 is 327 Val_Aggr : O_Array_Aggr_List; 328 Res : O_Cnode; 329 begin 330 Start_Array_Aggr 331 (Val_Aggr, Arr_Type, Unsigned_32 (Get_String_Length (Str))); 332 case Get_Kind (Str) is 333 when Iir_Kind_String_Literal8 => 334 Translate_Static_String_Literal8_Inner 335 (Val_Aggr, Str, Element_Type); 336 when others => 337 raise Internal_Error; 338 end case; 339 Finish_Array_Aggr (Val_Aggr, Res); 340 341 return Create_Global_Const 342 (Create_Uniq_Identifier, Arr_Type, O_Storage_Private, Res); 343 end Create_String_Literal_Var_Inner; 344 345 -- Create a variable (constant) for string or bit string literal STR. 346 function Create_String_Literal_Var (Str : Iir) return Var_Type 347 is 348 Str_Type : constant Iir := Get_Type (Str); 349 El_Type : constant Iir := Get_Element_Subtype (Str_Type); 350 Arr_Type : O_Tnode; 351 Arr_St : O_Tnode; 352 begin 353 -- Create the string value. 354 Arr_Type := Get_Info (Str_Type).B.Base_Type (Mode_Value); 355 Arr_St := New_Array_Subtype 356 (Arr_Type, 357 Get_Ortho_Type (El_Type, Mode_Value), 358 New_Index_Lit (Unsigned_64 (Get_String_Length (Str)))); 359 return Create_String_Literal_Var_Inner (Str, El_Type, Arr_St); 360 end Create_String_Literal_Var; 361 362 -- Some strings literal have an unconstrained array type, 363 -- eg: 'image of constant. Its type is not constrained 364 -- because it is not so in VHDL! 365 function Translate_Non_Static_String_Literal (Str : Iir) return O_Enode 366 is 367 Len : constant Nat32 := Get_String_Length (Str); 368 Lit_Type : constant Iir := Get_Type (Str); 369 Type_Info : constant Type_Info_Acc := Get_Info (Lit_Type); 370 Index_Type : constant Iir := Get_Index_Type (Lit_Type, 0); 371 Index_Type_Info : constant Type_Info_Acc := Get_Info (Index_Type); 372 Bound_Aggr : O_Record_Aggr_List; 373 Index_Aggr : O_Record_Aggr_List; 374 Res_Aggr : O_Record_Aggr_List; 375 Res : O_Cnode; 376 Val : Var_Type; 377 Bound : Var_Type; 378 R : O_Enode; 379 begin 380 -- Create the string value. 381 Val := Create_String_Literal_Var (Str); 382 383 if Type_Info.Type_Mode = Type_Mode_Fat_Array then 384 -- Create the string bound. 385 Start_Record_Aggr (Bound_Aggr, Type_Info.B.Bounds_Type); 386 Start_Record_Aggr (Index_Aggr, Index_Type_Info.B.Range_Type); 387 New_Record_Aggr_El 388 (Index_Aggr, 389 New_Signed_Literal 390 (Index_Type_Info.Ortho_Type (Mode_Value), 1)); 391 New_Record_Aggr_El 392 (Index_Aggr, 393 New_Signed_Literal (Index_Type_Info.Ortho_Type (Mode_Value), 394 Integer_64 (Len))); 395 New_Record_Aggr_El 396 (Index_Aggr, Ghdl_Dir_To_Node); 397 New_Record_Aggr_El 398 (Index_Aggr, 399 New_Unsigned_Literal (Ghdl_Index_Type, Unsigned_64 (Len))); 400 Finish_Record_Aggr (Index_Aggr, Res); 401 New_Record_Aggr_El (Bound_Aggr, Res); 402 Finish_Record_Aggr (Bound_Aggr, Res); 403 Bound := Create_Global_Const 404 (Create_Uniq_Identifier, Type_Info.B.Bounds_Type, 405 O_Storage_Private, Res); 406 407 -- The descriptor. 408 Start_Record_Aggr (Res_Aggr, Type_Info.Ortho_Type (Mode_Value)); 409 New_Record_Aggr_El 410 (Res_Aggr, 411 New_Global_Address (New_Global (Get_Var_Label (Val)), 412 Type_Info.B.Base_Ptr_Type (Mode_Value))); 413 New_Record_Aggr_El 414 (Res_Aggr, 415 New_Global_Address (New_Global (Get_Var_Label (Bound)), 416 Type_Info.B.Bounds_Ptr_Type)); 417 Finish_Record_Aggr (Res_Aggr, Res); 418 419 Val := Create_Global_Const 420 (Create_Uniq_Identifier, Type_Info.Ortho_Type (Mode_Value), 421 O_Storage_Private, Res); 422 elsif Type_Info.Type_Mode in Type_Mode_Bounded_Arrays then 423 -- Type of string literal isn't statically known; check the 424 -- length. 425 Chap6.Check_Bound_Error 426 (New_Compare_Op 427 (ON_Neq, 428 New_Lit (New_Index_Lit (Unsigned_64 (Len))), 429 Chap3.Get_Array_Type_Length (Lit_Type), 430 Ghdl_Bool_Type), 431 Str); 432 else 433 raise Internal_Error; 434 end if; 435 436 R := New_Address (Get_Var (Val), 437 Type_Info.Ortho_Ptr_Type (Mode_Value)); 438 return R; 439 end Translate_Non_Static_String_Literal; 440 441 -- Only for Strings of STD.Character. 442 function Translate_Static_String (Str_Type : Iir; Str_Ident : Name_Id) 443 return O_Cnode 444 is 445 Img : constant String := Name_Table.Image (Str_Ident); 446 Literal_List : constant Iir_Flist := 447 Get_Enumeration_Literal_List (Character_Type_Definition); 448 Lit : Iir; 449 List : O_Array_Aggr_List; 450 Res : O_Cnode; 451 begin 452 Chap3.Translate_Anonymous_Subtype_Definition (Str_Type, False); 453 454 Start_Array_Aggr 455 (List, Get_Ortho_Type (Str_Type, Mode_Value), Img'Length); 456 457 for I in Img'Range loop 458 Lit := Get_Nth_Element (Literal_List, Character'Pos (Img (I))); 459 New_Array_Aggr_El (List, Get_Ortho_Literal (Lit)); 460 end loop; 461 462 Finish_Array_Aggr (List, Res); 463 return Res; 464 end Translate_Static_String; 465 466 function Translate_Composite_Literal (Str : Iir; Res_Type : Iir) 467 return O_Enode 468 is 469 Str_Type : constant Iir := Get_Type (Str); 470 Is_Static : Boolean; 471 Vtype : Iir; 472 Var : Var_Type; 473 Info : Type_Info_Acc; 474 Res : O_Cnode; 475 R : O_Enode; 476 begin 477 if Get_Constraint_State (Str_Type) = Fully_Constrained 478 and then Are_Array_Indexes_Locally_Static (Str_Type) 479 then 480 Chap3.Create_Composite_Subtype (Str_Type); 481 case Get_Kind (Str) is 482 when Iir_Kind_String_Literal8 => 483 Res := Translate_Static_String_Literal8 (Str); 484 when Iir_Kind_Simple_Aggregate => 485 Res := Translate_Static_Simple_Aggregate (Str); 486 when Iir_Kind_Simple_Name_Attribute => 487 Res := Translate_Static_String 488 (Get_Type (Str), Get_Simple_Name_Identifier (Str)); 489 when Iir_Kind_Aggregate => 490 Res := Translate_Static_Aggregate (Str); 491 when others => 492 raise Internal_Error; 493 end case; 494 Is_Static := Are_Array_Indexes_Locally_Static (Res_Type); 495 496 if Is_Static then 497 Res := Translate_Static_Implicit_Conv (Res, Str_Type, Res_Type); 498 Vtype := Res_Type; 499 else 500 Vtype := Str_Type; 501 end if; 502 Info := Get_Info (Vtype); 503 Var := Create_Global_Const 504 (Create_Uniq_Identifier, Info.Ortho_Type (Mode_Value), 505 O_Storage_Private, Res); 506 R := New_Address (Get_Var (Var), Info.Ortho_Ptr_Type (Mode_Value)); 507 if not Is_Static then 508 R := Translate_Implicit_Conv 509 (R, Str_Type, Res_Type, Mode_Value, Str); 510 end if; 511 return R; 512 else 513 return Translate_Implicit_Conv 514 (Translate_Non_Static_String_Literal (Str), Str_Type, Res_Type, 515 Mode_Value, Str); 516 end if; 517 end Translate_Composite_Literal; 518 519 function Translate_Enumeration_Literal (Atype : Iir; Pos : Natural) 520 return O_Cnode 521 is 522 Lit_List : constant Iir_Flist := 523 Get_Enumeration_Literal_List (Get_Base_Type (Atype)); 524 Enum : constant Iir := Get_Nth_Element (Lit_List, Pos); 525 begin 526 return Get_Ortho_Literal (Enum); 527 end Translate_Enumeration_Literal; 528 529 function Translate_Numeric_Literal (Expr : Iir; Res_Type : O_Tnode) 530 return O_Cnode is 531 begin 532 case Get_Kind (Expr) is 533 when Iir_Kind_Integer_Literal => 534 return New_Signed_Literal 535 (Res_Type, Integer_64 (Get_Value (Expr))); 536 537 when Iir_Kind_Enumeration_Literal => 538 return Translate_Enumeration_Literal 539 (Get_Type (Expr), Natural (Get_Enum_Pos (Expr))); 540 541 when Iir_Kind_Floating_Point_Literal => 542 return New_Float_Literal 543 (Res_Type, IEEE_Float_64 (Get_Fp_Value (Expr))); 544 545 when Iir_Kind_Physical_Int_Literal 546 | Iir_Kind_Physical_Fp_Literal 547 | Iir_Kind_Unit_Declaration => 548 return New_Signed_Literal 549 (Res_Type, Integer_64 (Get_Physical_Value (Expr))); 550 551 when others => 552 Error_Kind ("translate_numeric_literal", Expr); 553 end case; 554 exception 555 when Constraint_Error => 556 -- Can be raised by Get_Physical_Value. 557 Error_Msg_Elab (Expr, "numeric literal not in range"); 558 return New_Signed_Literal (Res_Type, 0); 559 end Translate_Numeric_Literal; 560 561 function Translate_Numeric_Literal (Expr : Iir; Res_Type : Iir) 562 return O_Cnode 563 is 564 Expr_Type : constant Iir := Get_Type (Expr); 565 Expr_Otype : O_Tnode; 566 Tinfo : Type_Info_Acc; 567 begin 568 Tinfo := Get_Info (Expr_Type); 569 if Res_Type /= Null_Iir then 570 Expr_Otype := Get_Ortho_Type (Res_Type, Mode_Value); 571 else 572 if Tinfo = null then 573 -- FIXME: this is a working kludge, in the case where EXPR_TYPE 574 -- is a subtype which was not yet translated. 575 -- (eg: evaluated array attribute) 576 Tinfo := Get_Info (Get_Base_Type (Expr_Type)); 577 end if; 578 Expr_Otype := Tinfo.Ortho_Type (Mode_Value); 579 end if; 580 return Translate_Numeric_Literal (Expr, Expr_Otype); 581 end Translate_Numeric_Literal; 582 583 function Translate_Static_Expression (Expr : Iir; Res_Type : Iir) 584 return O_Cnode 585 is 586 Expr_Type : constant Iir := Get_Type (Expr); 587 begin 588 case Get_Kind (Expr) is 589 when Iir_Kind_Integer_Literal 590 | Iir_Kind_Enumeration_Literal 591 | Iir_Kind_Floating_Point_Literal 592 | Iir_Kind_Physical_Int_Literal 593 | Iir_Kind_Unit_Declaration 594 | Iir_Kind_Physical_Fp_Literal => 595 return Translate_Numeric_Literal (Expr, Res_Type); 596 597 when Iir_Kind_String_Literal8 => 598 return Translate_Static_Implicit_Conv 599 (Translate_Static_String_Literal8 (Expr), 600 Expr_Type, Res_Type); 601 when Iir_Kind_Simple_Aggregate => 602 return Translate_Static_Implicit_Conv 603 (Translate_Static_Simple_Aggregate (Expr), 604 Expr_Type, Res_Type); 605 when Iir_Kind_Aggregate => 606 return Translate_Static_Implicit_Conv 607 (Translate_Static_Aggregate (Expr), Expr_Type, Res_Type); 608 609 when Iir_Kinds_Denoting_Name => 610 return Translate_Static_Expression 611 (Get_Named_Entity (Expr), Res_Type); 612 when others => 613 Error_Kind ("translate_static_expression", Expr); 614 end case; 615 end Translate_Static_Expression; 616 617 function Translate_Static_Range_Left 618 (Expr : Iir; Range_Type : Iir := Null_Iir) return O_Cnode 619 is 620 Bound : constant Iir := Get_Left_Limit (Expr); 621 Left : O_Cnode; 622 begin 623 Left := Chap7.Translate_Static_Expression (Bound, Range_Type); 624 -- if Range_Type /= Null_Iir 625 -- and then Get_Type (Bound) /= Range_Type then 626 -- Left := New_Convert_Ov 627 -- (Left, Get_Ortho_Type (Range_Type, Mode_Value)); 628 -- end if; 629 return Left; 630 end Translate_Static_Range_Left; 631 632 function Translate_Static_Range_Right 633 (Expr : Iir; Range_Type : Iir := Null_Iir) return O_Cnode 634 is 635 Right : O_Cnode; 636 begin 637 Right := Chap7.Translate_Static_Expression (Get_Right_Limit (Expr), 638 Range_Type); 639 -- if Range_Type /= Null_Iir then 640 -- Right := New_Convert_Ov 641 -- (Right, Get_Ortho_Type (Range_Type, Mode_Value)); 642 -- end if; 643 return Right; 644 end Translate_Static_Range_Right; 645 646 function Translate_Static_Range_Dir (Expr : Iir) return O_Cnode is 647 begin 648 case Get_Direction (Expr) is 649 when Dir_To => 650 return Ghdl_Dir_To_Node; 651 when Dir_Downto => 652 return Ghdl_Dir_Downto_Node; 653 end case; 654 end Translate_Static_Range_Dir; 655 656 function Translate_Static_Range_Length (Expr : Iir) return O_Cnode 657 is 658 Ulen : Unsigned_64; 659 begin 660 Ulen := Unsigned_64 (Eval_Discrete_Range_Length (Expr)); 661 return New_Unsigned_Literal (Ghdl_Index_Type, Ulen); 662 end Translate_Static_Range_Length; 663 664 function Translate_Range_Expression_Left 665 (Expr : Iir; Range_Type : Iir := Null_Iir) return O_Enode 666 is 667 Left : O_Enode; 668 begin 669 Left := Chap7.Translate_Expression (Get_Left_Limit (Expr)); 670 if Range_Type /= Null_Iir then 671 Left := New_Convert_Ov (Left, 672 Get_Ortho_Type (Range_Type, Mode_Value)); 673 end if; 674 return Left; 675 end Translate_Range_Expression_Left; 676 677 function Translate_Range_Expression_Right 678 (Expr : Iir; Range_Type : Iir := Null_Iir) return O_Enode 679 is 680 Right : O_Enode; 681 begin 682 Right := Chap7.Translate_Expression (Get_Right_Limit (Expr)); 683 if Range_Type /= Null_Iir then 684 Right := New_Convert_Ov (Right, 685 Get_Ortho_Type (Range_Type, Mode_Value)); 686 end if; 687 return Right; 688 end Translate_Range_Expression_Right; 689 690 -- Compute the length of LEFT DIR (to/downto) RIGHT. 691 function Compute_Range_Length 692 (Left : O_Enode; Right : O_Enode; Dir : Direction_Type) return O_Enode 693 is 694 Rng_Type : constant O_Tnode := Ghdl_I32_Type; 695 L : constant O_Enode := New_Convert_Ov (Left, Rng_Type); 696 R : constant O_Enode := New_Convert_Ov (Right, Rng_Type); 697 Val : O_Enode; 698 Tmp : O_Dnode; 699 Res : O_Dnode; 700 If_Blk : O_If_Block; 701 begin 702 case Dir is 703 when Dir_To => 704 Val := New_Dyadic_Op (ON_Sub_Ov, R, L); 705 when Dir_Downto => 706 Val := New_Dyadic_Op (ON_Sub_Ov, L, R); 707 end case; 708 709 Res := Create_Temp (Ghdl_Index_Type); 710 Open_Temp; 711 Tmp := Create_Temp (Rng_Type); 712 New_Assign_Stmt (New_Obj (Tmp), Val); 713 Start_If_Stmt 714 (If_Blk, 715 New_Compare_Op (ON_Lt, New_Obj_Value (Tmp), 716 New_Lit (New_Signed_Literal (Rng_Type, 0)), 717 Ghdl_Bool_Type)); 718 Init_Var (Res); 719 New_Else_Stmt (If_Blk); 720 Val := New_Convert_Ov (New_Obj_Value (Tmp), Ghdl_Index_Type); 721 Val := New_Dyadic_Op (ON_Add_Ov, Val, New_Lit (Ghdl_Index_1)); 722 New_Assign_Stmt (New_Obj (Res), Val); 723 Finish_If_Stmt (If_Blk); 724 Close_Temp; 725 return New_Obj_Value (Res); 726 end Compute_Range_Length; 727 728 function Translate_Range_Expression_Length (Expr : Iir) return O_Enode 729 is 730 Left, Right : O_Enode; 731 begin 732 if Get_Expr_Staticness (Expr) = Locally then 733 return New_Lit (Translate_Static_Range_Length (Expr)); 734 else 735 Left := Chap7.Translate_Expression (Get_Left_Limit (Expr)); 736 Right := Chap7.Translate_Expression (Get_Right_Limit (Expr)); 737 738 return Compute_Range_Length (Left, Right, Get_Direction (Expr)); 739 end if; 740 end Translate_Range_Expression_Length; 741 742 function Translate_Range_Length (Expr : Iir) return O_Enode is 743 begin 744 case Get_Kind (Expr) is 745 when Iir_Kind_Range_Expression => 746 return Translate_Range_Expression_Length (Expr); 747 when Iir_Kind_Range_Array_Attribute => 748 return Chap14.Translate_Length_Array_Attribute (Expr, Null_Iir); 749 when others => 750 Error_Kind ("translate_range_length", Expr); 751 end case; 752 end Translate_Range_Length; 753 754 function Translate_Operator_Function_Call 755 (Call : Iir; Left : Iir; Right : Iir; Res_Type : Iir) return O_Enode 756 is 757 Imp : constant Iir := Get_Implementation (Call); 758 759 function Create_Assoc (Actual : Iir) return Iir 760 is 761 R : Iir; 762 begin 763 R := Create_Iir (Iir_Kind_Association_Element_By_Expression); 764 Location_Copy (R, Actual); 765 Set_Actual (R, Actual); 766 return R; 767 end Create_Assoc; 768 769 El_L : Iir; 770 El_R : Iir; 771 Res : O_Enode; 772 begin 773 El_L := Create_Assoc (Left); 774 if Right /= Null_Iir then 775 El_R := Create_Assoc (Right); 776 Set_Chain (El_L, El_R); 777 end if; 778 779 Res := Chap8.Translate_Subprogram_Call (Call, El_L, Null_Iir); 780 781 Free_Iir (El_L); 782 if Right /= Null_Iir then 783 Free_Iir (El_R); 784 end if; 785 786 return Translate_Implicit_Conv 787 (Res, Get_Return_Type (Imp), Res_Type, Mode_Value, Left); 788 end Translate_Operator_Function_Call; 789 790 procedure Convert_Constrained_To_Unconstrained 791 (Res : in out Mnode; Expr : Mnode) 792 is 793 Type_Info : constant Type_Info_Acc := Get_Type_Info (Res); 794 Kind : constant Object_Kind_Type := Get_Object_Kind (Expr); 795 Stable_Expr : Mnode; 796 begin 797 Stable_Expr := Stabilize (Expr); 798 New_Assign_Stmt 799 (M2Lp (Chap3.Get_Composite_Base (Res)), 800 New_Convert_Ov (M2Addr (Chap3.Get_Composite_Base (Stable_Expr)), 801 Type_Info.B.Base_Ptr_Type (Kind))); 802 New_Assign_Stmt 803 (M2Lp (Chap3.Get_Composite_Bounds (Res)), 804 M2Addr (Chap3.Get_Composite_Bounds (Stable_Expr))); 805 end Convert_Constrained_To_Unconstrained; 806 807 function Convert_Constrained_To_Unconstrained 808 (Expr : Mnode; Res_Tinfo : Type_Info_Acc) return Mnode 809 is 810 Mode : constant Object_Kind_Type := Get_Object_Kind (Expr); 811 Res : Mnode; 812 begin 813 Res := Create_Temp (Res_Tinfo, Mode); 814 Convert_Constrained_To_Unconstrained (Res, Expr); 815 return Res; 816 end Convert_Constrained_To_Unconstrained; 817 818 -- Innert procedure for Convert_Unconstrained_To_Constrained. 819 procedure Convert_To_Constrained_Check 820 (Bounds : Mnode; Expr_Type : Iir; Atype : Iir; Failure_Label : O_Snode) 821 is 822 Stable_Bounds : Mnode; 823 begin 824 Open_Temp; 825 Stable_Bounds := Stabilize (Bounds); 826 case Get_Kind (Expr_Type) is 827 when Iir_Kind_Array_Type_Definition 828 | Iir_Kind_Array_Subtype_Definition => 829 declare 830 Expr_Indexes : constant Iir_Flist := 831 Get_Index_Subtype_List (Expr_Type); 832 begin 833 for I in 1 .. Get_Nbr_Elements (Expr_Indexes) loop 834 Gen_Exit_When 835 (Failure_Label, 836 New_Compare_Op 837 (ON_Neq, 838 M2E (Chap3.Range_To_Length 839 (Chap3.Bounds_To_Range 840 (Stable_Bounds, Expr_Type, I))), 841 Chap6.Get_Array_Bound_Length 842 (T2M (Atype, Mode_Value), Atype, I), 843 Ghdl_Bool_Type)); 844 end loop; 845 end; 846 when Iir_Kind_Record_Type_Definition 847 | Iir_Kind_Record_Subtype_Definition => 848 declare 849 Expr_Els : constant Iir_Flist := 850 Get_Elements_Declaration_List (Expr_Type); 851 Atype_Els : constant Iir_Flist := 852 Get_Elements_Declaration_List (Atype); 853 Expr_El, Atype_El : Iir; 854 Expr_El_Type, Atype_El_Type : Iir; 855 begin 856 for I in Flist_First .. Flist_Last (Expr_Els) loop 857 Expr_El := Get_Nth_Element (Expr_Els, I); 858 Atype_El := Get_Nth_Element (Atype_Els, I); 859 Expr_El_Type := Get_Type (Expr_El); 860 Atype_El_Type := Get_Type (Atype_El); 861 if Expr_El_Type /= Atype_El_Type then 862 Convert_To_Constrained_Check 863 (Chap3.Record_Bounds_To_Element_Bounds 864 (Stable_Bounds, Expr_El), 865 Expr_El_Type, Atype_El_Type, Failure_Label); 866 end if; 867 end loop; 868 end; 869 when others => 870 Error_Kind ("convert_unconstrained_to_constrained_check", 871 Expr_Type); 872 end case; 873 Close_Temp; 874 end Convert_To_Constrained_Check; 875 876 function Convert_To_Constrained 877 (Expr : Mnode; Expr_Type : Iir; Atype : Iir; Loc : Iir) return Mnode 878 is 879 Parent_Type : Iir; 880 Expr_Stable : Mnode; 881 Success_Label : O_Snode; 882 Failure_Label : O_Snode; 883 begin 884 -- If ATYPE is a parent type of EXPR_TYPE, then all the constrained 885 -- are inherited and there is nothing to check. 886 Parent_Type := Expr_Type; 887 loop 888 if Parent_Type = Atype then 889 return Expr; 890 end if; 891 exit when (Get_Kind (Parent_Type) 892 not in Iir_Kinds_Composite_Subtype_Definition); 893 Parent_Type := Get_Parent_Type (Parent_Type); 894 end loop; 895 896 Expr_Stable := Stabilize (Expr); 897 898 Open_Temp; 899 -- Check each dimension. 900 Start_Loop_Stmt (Success_Label); 901 Start_Loop_Stmt (Failure_Label); 902 903 Convert_To_Constrained_Check 904 (Chap3.Get_Composite_Bounds (Expr_Stable), Expr_Type, 905 Atype, Failure_Label); 906 907 New_Exit_Stmt (Success_Label); 908 909 Finish_Loop_Stmt (Failure_Label); 910 Chap6.Gen_Bound_Error (Loc); 911 Finish_Loop_Stmt (Success_Label); 912 Close_Temp; 913 914 declare 915 Ainfo : constant Type_Info_Acc := Get_Info (Atype); 916 Kind : constant Object_Kind_Type := Get_Object_Kind (Expr); 917 Nptr : O_Enode; 918 begin 919 -- Pointer to the array. 920 Nptr := M2E (Chap3.Get_Composite_Base (Expr_Stable)); 921 -- Convert it to pointer to the constrained type. 922 Nptr := New_Convert_Ov (Nptr, Ainfo.Ortho_Ptr_Type (Kind)); 923 return E2M (Nptr, Ainfo, Kind); 924 end; 925 end Convert_To_Constrained; 926 927 function Translate_Implicit_Array_Conversion 928 (Expr : Mnode; Expr_Type : Iir; Res_Type : Iir; Loc : Iir) return Mnode 929 is 930 Res_Tinfo : Type_Info_Acc; 931 Einfo : Type_Info_Acc; 932 Mode : Object_Kind_Type; 933 begin 934 pragma Assert 935 (Get_Kind (Expr_Type) in Iir_Kinds_Array_Type_Definition); 936 937 if Res_Type = Expr_Type then 938 return Expr; 939 end if; 940 941 Res_Tinfo := Get_Info (Res_Type); 942 Einfo := Get_Info (Expr_Type); 943 case Res_Tinfo.Type_Mode is 944 when Type_Mode_Unbounded_Array => 945 -- X to unconstrained. 946 case Einfo.Type_Mode is 947 when Type_Mode_Unbounded_Array => 948 -- unconstrained to unconstrained. 949 return Expr; 950 when Type_Mode_Bounded_Arrays => 951 -- constrained to unconstrained. 952 return Convert_Constrained_To_Unconstrained 953 (Expr, Res_Tinfo); 954 when others => 955 raise Internal_Error; 956 end case; 957 when Type_Mode_Static_Array => 958 if Einfo.Type_Mode = Type_Mode_Static_Array then 959 -- FIXME: optimize static vs non-static 960 -- constrained to constrained. 961 if Chap3.Locally_Array_Match (Expr_Type, Res_Type) /= True then 962 -- FIXME: generate a bound error ? 963 -- Even if this is caught at compile-time, 964 -- the code is not required to run. 965 Chap6.Gen_Bound_Error (Loc); 966 end if; 967 -- Convert. For subtypes of arrays with unbounded elements, 968 -- the subtype can be the same but the ortho type can be 969 -- different. 970 Mode := Get_Object_Kind (Expr); 971 return E2M (New_Convert_Ov (M2Addr (Expr), 972 Res_Tinfo.Ortho_Ptr_Type (Mode)), 973 Res_Tinfo, Mode); 974 else 975 -- Unbounded/bounded array to bounded array. 976 return Convert_To_Constrained (Expr, Expr_Type, Res_Type, Loc); 977 end if; 978 when Type_Mode_Complex_Array => 979 return Convert_To_Constrained (Expr, Expr_Type, Res_Type, Loc); 980 when others => 981 raise Internal_Error; 982 end case; 983 end Translate_Implicit_Array_Conversion; 984 985 function Translate_Implicit_Record_Conversion 986 (Expr : Mnode; Expr_Type : Iir; Res_Type : Iir; Loc : Iir) return Mnode 987 is 988 Res_Tinfo : Type_Info_Acc; 989 Einfo : Type_Info_Acc; 990 begin 991 if Res_Type = Expr_Type then 992 return Expr; 993 end if; 994 995 Res_Tinfo := Get_Info (Res_Type); 996 Einfo := Get_Info (Expr_Type); 997 case Res_Tinfo.Type_Mode is 998 when Type_Mode_Unbounded_Record => 999 -- X to unbounded. 1000 case Einfo.Type_Mode is 1001 when Type_Mode_Unbounded_Record => 1002 -- unbounded to unbounded 1003 return Expr; 1004 when Type_Mode_Bounded_Records => 1005 -- bounded to unconstrained. 1006 return Convert_Constrained_To_Unconstrained 1007 (Expr, Res_Tinfo); 1008 when others => 1009 raise Internal_Error; 1010 end case; 1011 when Type_Mode_Bounded_Records => 1012 -- X to bounded 1013 return Convert_To_Constrained (Expr, Expr_Type, Res_Type, Loc); 1014 when others => 1015 raise Internal_Error; 1016 end case; 1017 end Translate_Implicit_Record_Conversion; 1018 1019 -- Convert (if necessary) EXPR translated from EXPR_ORIG to type ATYPE. 1020 function Translate_Implicit_Conv (Expr : O_Enode; 1021 Expr_Type : Iir; 1022 Atype : Iir; 1023 Is_Sig : Object_Kind_Type; 1024 Loc : Iir) 1025 return O_Enode is 1026 begin 1027 -- Same type: nothing to do. 1028 if Atype = Expr_Type then 1029 return Expr; 1030 end if; 1031 1032 if Expr_Type = Universal_Integer_Type_Definition then 1033 return New_Convert_Ov (Expr, Get_Ortho_Type (Atype, Mode_Value)); 1034 elsif Expr_Type = Universal_Real_Type_Definition then 1035 return New_Convert_Ov (Expr, Get_Ortho_Type (Atype, Mode_Value)); 1036 else 1037 case Get_Kind (Expr_Type) is 1038 when Iir_Kinds_Array_Type_Definition => 1039 return M2E (Translate_Implicit_Array_Conversion 1040 (E2M (Expr, Get_Info (Expr_Type), Is_Sig), 1041 Expr_Type, Atype, Loc)); 1042 when Iir_Kind_Record_Type_Definition 1043 | Iir_Kind_Record_Subtype_Definition => 1044 return M2E (Translate_Implicit_Record_Conversion 1045 (E2M (Expr, Get_Info (Expr_Type), Is_Sig), 1046 Expr_Type, Atype, Loc)); 1047 when others => 1048 return Expr; 1049 end case; 1050 end if; 1051 end Translate_Implicit_Conv; 1052 1053 type Predefined_To_Onop_Type is 1054 array (Iir_Predefined_Functions) of ON_Op_Kind; 1055 Predefined_To_Onop : constant Predefined_To_Onop_Type := 1056 (Iir_Predefined_Boolean_Or => ON_Or, 1057 Iir_Predefined_Boolean_Not => ON_Not, 1058 Iir_Predefined_Boolean_And => ON_And, 1059 Iir_Predefined_Boolean_Xor => ON_Xor, 1060 1061 Iir_Predefined_Bit_Not => ON_Not, 1062 Iir_Predefined_Bit_And => ON_And, 1063 Iir_Predefined_Bit_Or => ON_Or, 1064 Iir_Predefined_Bit_Xor => ON_Xor, 1065 1066 Iir_Predefined_Integer_Equality => ON_Eq, 1067 Iir_Predefined_Integer_Inequality => ON_Neq, 1068 Iir_Predefined_Integer_Less_Equal => ON_Le, 1069 Iir_Predefined_Integer_Less => ON_Lt, 1070 Iir_Predefined_Integer_Greater => ON_Gt, 1071 Iir_Predefined_Integer_Greater_Equal => ON_Ge, 1072 Iir_Predefined_Integer_Plus => ON_Add_Ov, 1073 Iir_Predefined_Integer_Minus => ON_Sub_Ov, 1074 Iir_Predefined_Integer_Mul => ON_Mul_Ov, 1075 Iir_Predefined_Integer_Rem => ON_Rem_Ov, 1076 Iir_Predefined_Integer_Mod => ON_Mod_Ov, 1077 Iir_Predefined_Integer_Div => ON_Div_Ov, 1078 Iir_Predefined_Integer_Absolute => ON_Abs_Ov, 1079 Iir_Predefined_Integer_Negation => ON_Neg_Ov, 1080 1081 Iir_Predefined_Enum_Equality => ON_Eq, 1082 Iir_Predefined_Enum_Inequality => ON_Neq, 1083 Iir_Predefined_Enum_Greater_Equal => ON_Ge, 1084 Iir_Predefined_Enum_Greater => ON_Gt, 1085 Iir_Predefined_Enum_Less => ON_Lt, 1086 Iir_Predefined_Enum_Less_Equal => ON_Le, 1087 1088 Iir_Predefined_Physical_Equality => ON_Eq, 1089 Iir_Predefined_Physical_Inequality => ON_Neq, 1090 Iir_Predefined_Physical_Less => ON_Lt, 1091 Iir_Predefined_Physical_Less_Equal => ON_Le, 1092 Iir_Predefined_Physical_Greater => ON_Gt, 1093 Iir_Predefined_Physical_Greater_Equal => ON_Ge, 1094 Iir_Predefined_Physical_Negation => ON_Neg_Ov, 1095 Iir_Predefined_Physical_Absolute => ON_Abs_Ov, 1096 Iir_Predefined_Physical_Minus => ON_Sub_Ov, 1097 Iir_Predefined_Physical_Plus => ON_Add_Ov, 1098 1099 Iir_Predefined_Floating_Greater => ON_Gt, 1100 Iir_Predefined_Floating_Greater_Equal => ON_Ge, 1101 Iir_Predefined_Floating_Less => ON_Lt, 1102 Iir_Predefined_Floating_Less_Equal => ON_Le, 1103 Iir_Predefined_Floating_Equality => ON_Eq, 1104 Iir_Predefined_Floating_Inequality => ON_Neq, 1105 Iir_Predefined_Floating_Minus => ON_Sub_Ov, 1106 Iir_Predefined_Floating_Plus => ON_Add_Ov, 1107 Iir_Predefined_Floating_Mul => ON_Mul_Ov, 1108 Iir_Predefined_Floating_Div => ON_Div_Ov, 1109 Iir_Predefined_Floating_Negation => ON_Neg_Ov, 1110 Iir_Predefined_Floating_Absolute => ON_Abs_Ov, 1111 1112 others => ON_Nil); 1113 1114 function Translate_Shortcircuit_Operator 1115 (Imp : Iir_Function_Declaration; Left, Right : Iir) return O_Enode 1116 is 1117 Rtype : Iir; 1118 Res : O_Dnode; 1119 Res_Type : O_Tnode; 1120 If_Blk : O_If_Block; 1121 Val : Integer; 1122 V : O_Cnode; 1123 Kind : Iir_Predefined_Functions; 1124 Invert : Boolean; 1125 begin 1126 Rtype := Get_Return_Type (Imp); 1127 Res_Type := Get_Ortho_Type (Rtype, Mode_Value); 1128 Res := Create_Temp (Res_Type); 1129 Open_Temp; 1130 New_Assign_Stmt (New_Obj (Res), Chap7.Translate_Expression (Left)); 1131 Close_Temp; 1132 Kind := Get_Implicit_Definition (Imp); 1133 1134 -- Short cut: RIGHT is the result (and must be evaluated) iff 1135 -- LEFT is equal to VAL (ie '0' or false for 0, '1' or true for 1). 1136 case Kind is 1137 when Iir_Predefined_Bit_And 1138 | Iir_Predefined_Boolean_And => 1139 Invert := False; 1140 Val := 1; 1141 when Iir_Predefined_Bit_Nand 1142 | Iir_Predefined_Boolean_Nand => 1143 Invert := True; 1144 Val := 1; 1145 when Iir_Predefined_Bit_Or 1146 | Iir_Predefined_Boolean_Or => 1147 Invert := False; 1148 Val := 0; 1149 when Iir_Predefined_Bit_Nor 1150 | Iir_Predefined_Boolean_Nor => 1151 Invert := True; 1152 Val := 0; 1153 when others => 1154 Error_Kind ("translate_shortcircuit_operator", Kind); 1155 end case; 1156 1157 V := Get_Ortho_Literal 1158 (Get_Nth_Element (Get_Enumeration_Literal_List (Rtype), Val)); 1159 Start_If_Stmt (If_Blk, 1160 New_Compare_Op (ON_Eq, 1161 New_Obj_Value (Res), New_Lit (V), 1162 Ghdl_Bool_Type)); 1163 Open_Temp; 1164 New_Assign_Stmt (New_Obj (Res), Chap7.Translate_Expression (Right)); 1165 Close_Temp; 1166 Finish_If_Stmt (If_Blk); 1167 if Invert then 1168 return New_Monadic_Op (ON_Not, New_Obj_Value (Res)); 1169 else 1170 return New_Obj_Value (Res); 1171 end if; 1172 end Translate_Shortcircuit_Operator; 1173 1174 function Translate_Lib_Operator (Left, Right : O_Enode; Func : O_Dnode) 1175 return O_Enode 1176 is 1177 Constr : O_Assoc_List; 1178 begin 1179 Start_Association (Constr, Func); 1180 New_Association (Constr, Left); 1181 if Right /= O_Enode_Null then 1182 New_Association (Constr, Right); 1183 end if; 1184 return New_Function_Call (Constr); 1185 end Translate_Lib_Operator; 1186 1187 function Translate_Predefined_Lib_Operator 1188 (Left, Right : O_Enode; Func : Iir_Function_Declaration) return O_Enode 1189 is 1190 Info : constant Operator_Info_Acc := Get_Info (Func); 1191 Constr : O_Assoc_List; 1192 begin 1193 Start_Association (Constr, Info.Operator_Node); 1194 Subprgs.Add_Subprg_Instance_Assoc (Constr, Info.Operator_Instance); 1195 New_Association (Constr, Left); 1196 if Right /= O_Enode_Null then 1197 New_Association (Constr, Right); 1198 end if; 1199 return New_Function_Call (Constr); 1200 end Translate_Predefined_Lib_Operator; 1201 1202 function Translate_Predefined_Array_Operator 1203 (Left, Right : O_Enode; Func : Iir) return O_Enode 1204 is 1205 Info : constant Type_Info_Acc := Get_Info (Get_Return_Type (Func)); 1206 Func_Info : constant Operator_Info_Acc := Get_Info (Func); 1207 Res : O_Dnode; 1208 Constr : O_Assoc_List; 1209 begin 1210 Create_Temp_Stack2_Mark; 1211 Res := Create_Temp (Info.Ortho_Type (Mode_Value)); 1212 Start_Association (Constr, Func_Info.Operator_Node); 1213 Subprgs.Add_Subprg_Instance_Assoc (Constr, Func_Info.Operator_Instance); 1214 New_Association (Constr, 1215 New_Address (New_Obj (Res), 1216 Info.Ortho_Ptr_Type (Mode_Value))); 1217 New_Association (Constr, Left); 1218 if Right /= O_Enode_Null then 1219 New_Association (Constr, Right); 1220 end if; 1221 New_Procedure_Call (Constr); 1222 return New_Address (New_Obj (Res), Info.Ortho_Ptr_Type (Mode_Value)); 1223 end Translate_Predefined_Array_Operator; 1224 1225 function Translate_Predefined_Array_Operator_Convert 1226 (Left, Right : O_Enode; Func : Iir; Res_Type : Iir) return O_Enode 1227 is 1228 Ret_Type : constant Iir := Get_Return_Type (Func); 1229 Res : O_Enode; 1230 begin 1231 Res := Translate_Predefined_Array_Operator (Left, Right, Func); 1232 return Translate_Implicit_Conv 1233 (Res, Ret_Type, Res_Type, Mode_Value, Func); 1234 end Translate_Predefined_Array_Operator_Convert; 1235 1236 -- A somewhat complex operation... 1237 -- 1238 -- Previously, concatenation was handled like any other operator. This 1239 -- is not efficient as for a serie of concatenation (like A & B & C & D), 1240 -- this resulted in O(n**2) copies. The current implementation handles 1241 -- many concatenations in a raw. 1242 function Translate_Concatenation 1243 (Concat_Imp : Iir; Left, Right : Iir; Res_Type : Iir) return O_Enode 1244 is 1245 Expr_Type : constant Iir := Get_Return_Type (Concat_Imp); 1246 Index_Type : constant Iir := Get_Index_Type (Expr_Type, 0); 1247 Info : constant Type_Info_Acc := Get_Info (Expr_Type); 1248 Static_Length : Int64 := 0; 1249 Nbr_Dyn_Expr : Natural := 0; 1250 1251 type Handle_Acc is access procedure (E : Iir); 1252 type Handlers_Type is record 1253 Handle_El : Handle_Acc; 1254 Handle_Arr : Handle_Acc; 1255 end record; 1256 1257 -- Call handlers for each leaf of LEFT CONCAT_IMP RIGHT. 1258 -- Handlers.Handle_Arr is called for array leaves, and 1259 -- Handlers.Handle_El for element leaves. 1260 procedure Walk (Handlers : Handlers_Type) 1261 is 1262 Walk_Handlers : Handlers_Type; 1263 1264 -- Call handlers for each leaf of L IMP R. 1265 procedure Walk_Concat (Imp : Iir; L, R : Iir); 1266 1267 -- Call handlers for each leaf of E (an array expression). First 1268 -- check whether E is also a concatenation. 1269 procedure Walk_Arr (E : Iir) 1270 is 1271 Imp : Iir; 1272 Assocs : Iir; 1273 begin 1274 if Get_Kind (E) = Iir_Kind_Concatenation_Operator then 1275 Imp := Get_Implementation (E); 1276 if (Get_Implicit_Definition (Imp) 1277 in Iir_Predefined_Concat_Functions) 1278 and then Get_Return_Type (Imp) = Expr_Type 1279 then 1280 Walk_Concat (Imp, Get_Left (E), Get_Right (E)); 1281 return; 1282 end if; 1283 elsif Get_Kind (E) = Iir_Kind_Function_Call then 1284 -- Also handle "&" (A, B) 1285 -- Note that associations are always 'simple': no formal, no 1286 -- default expression in implicit declarations. 1287 Imp := Get_Implementation (E); 1288 if (Get_Implicit_Definition (Imp) 1289 in Iir_Predefined_Concat_Functions) 1290 and then Get_Return_Type (Imp) = Expr_Type 1291 then 1292 Assocs := Get_Parameter_Association_Chain (E); 1293 Walk_Concat 1294 (Imp, 1295 Get_Actual (Assocs), Get_Actual (Get_Chain (Assocs))); 1296 return; 1297 end if; 1298 end if; 1299 1300 Walk_Handlers.Handle_Arr (E); 1301 end Walk_Arr; 1302 1303 procedure Walk_Concat (Imp : Iir; L, R : Iir) is 1304 begin 1305 case Get_Implicit_Definition (Imp) is 1306 when Iir_Predefined_Array_Array_Concat => 1307 Walk_Arr (L); 1308 Walk_Arr (R); 1309 when Iir_Predefined_Array_Element_Concat => 1310 Walk_Arr (L); 1311 Walk_Handlers.Handle_El (R); 1312 when Iir_Predefined_Element_Array_Concat => 1313 Walk_Handlers.Handle_El (L); 1314 Walk_Arr (R); 1315 when Iir_Predefined_Element_Element_Concat => 1316 Walk_Handlers.Handle_El (L); 1317 Walk_Handlers.Handle_El (R); 1318 when others => 1319 raise Internal_Error; 1320 end case; 1321 end Walk_Concat; 1322 begin 1323 Walk_Handlers := Handlers; 1324 Walk_Concat (Concat_Imp, Left, Right); 1325 end Walk; 1326 1327 -- Return TRUE if the bounds of E are known at analysis time. 1328 function Is_Static_Arr (E : Iir) return Boolean 1329 is 1330 Etype : constant Iir := Get_Type (E); 1331 begin 1332 pragma Assert (Get_Base_Type (Etype) = Expr_Type); 1333 return Is_Fully_Constrained_Type (Etype) 1334 and then Get_Type_Staticness (Get_Index_Type (Etype, 0)) = Locally; 1335 end Is_Static_Arr; 1336 1337 -- Pre_Walk: compute known static length and number of dynamic arrays. 1338 procedure Pre_Walk_El (E : Iir) 1339 is 1340 pragma Unreferenced (E); 1341 begin 1342 Static_Length := Static_Length + 1; 1343 end Pre_Walk_El; 1344 1345 procedure Pre_Walk_Arr (E : Iir) 1346 is 1347 Idx_Type : Iir; 1348 begin 1349 -- Three possibilities: 1350 -- * type is fully constrained, range is static, length is known 1351 -- * type is fully constrained, range is not static, length isn't 1352 -- * type is not constrained 1353 if Is_Static_Arr (E) then 1354 Idx_Type := Get_Index_Type (Get_Type (E), 0); 1355 Static_Length := Static_Length 1356 + Eval_Discrete_Range_Length (Get_Range_Constraint (Idx_Type)); 1357 else 1358 Nbr_Dyn_Expr := Nbr_Dyn_Expr + 1; 1359 end if; 1360 end Pre_Walk_Arr; 1361 1362 -- In order to declare Dyn_Mnodes (below), create a function that can 1363 -- be called now (not possible with procedures). 1364 function Call_Pre_Walk return Natural is 1365 begin 1366 Walk ((Pre_Walk_El'Access, Pre_Walk_Arr'Access)); 1367 return Nbr_Dyn_Expr; 1368 end Call_Pre_Walk; 1369 1370 -- Compute now the number of dynamic expressions. 1371 Nbr_Dyn_Expr1 : constant Natural := Call_Pre_Walk; 1372 pragma Assert (Nbr_Dyn_Expr1 = Nbr_Dyn_Expr); 1373 1374 Var_Bounds : Mnode; 1375 Arr_Ptr : O_Dnode; 1376 Var_Arr : Mnode; 1377 Var_Length : O_Dnode; 1378 1379 Var_Res : O_Dnode; 1380 Res : Mnode; 1381 1382 -- Common subexpression: get the range of the result as a Mnode. 1383 function Get_Res_Range return Mnode is 1384 begin 1385 return Chap3.Bounds_To_Range (Var_Bounds, Expr_Type, 1); 1386 end Get_Res_Range; 1387 1388 type Mnode_Array is array (1 .. Nbr_Dyn_Expr) of Mnode; 1389 Dyn_Mnodes : Mnode_Array; 1390 Dyn_I : Natural; 1391 E_Length : O_Enode; 1392 1393 procedure Nil_El (E : Iir) is 1394 begin 1395 null; 1396 end Nil_El; 1397 1398 -- Evaluate a dynamic parameter. 1399 procedure Eval_Dyn_Arr (E : Iir) 1400 is 1401 E_Val : O_Enode; 1402 begin 1403 if not Is_Static_Arr (E) then 1404 Dyn_I := Dyn_I + 1; 1405 -- First, translate expression. 1406 E_Val := Translate_Expression (E, Expr_Type); 1407 -- Then create Mnode (type info may be computed by 1408 -- translate_expression). 1409 Dyn_Mnodes (Dyn_I) := 1410 Stabilize (E2M (E_Val, Get_Info (Expr_Type), Mode_Value)); 1411 end if; 1412 end Eval_Dyn_Arr; 1413 1414 -- Add contribution to length of result from a dynamic parameter. 1415 procedure Len_Dyn_Arr (E : Iir) 1416 is 1417 Elen : O_Enode; 1418 begin 1419 if not Is_Static_Arr (E) then 1420 Dyn_I := Dyn_I + 1; 1421 Elen := Chap3.Get_Array_Length (Dyn_Mnodes (Dyn_I), Get_Type (E)); 1422 if E_Length = O_Enode_Null then 1423 E_Length := Elen; 1424 else 1425 E_Length := New_Dyadic_Op (ON_Add_Ov, E_Length, Elen); 1426 end if; 1427 end if; 1428 end Len_Dyn_Arr; 1429 1430 -- Offset in the result. 1431 Var_Off : O_Dnode; 1432 1433 -- Assign: write values to the result array. 1434 procedure Assign_El (E : Iir) 1435 is 1436 El_Type : constant Iir := Get_Element_Subtype (Expr_Type); 1437 begin 1438 Chap3.Translate_Object_Copy 1439 (Chap3.Index_Base (Var_Arr, Expr_Type, New_Obj_Value (Var_Off)), 1440 Translate_Expression (E, El_Type), El_Type); 1441 Inc_Var (Var_Off); 1442 end Assign_El; 1443 1444 procedure Assign_Arr (E : Iir) 1445 is 1446 E_Val : O_Enode; 1447 M : Mnode; 1448 V_Arr : O_Dnode; 1449 Var_Sub_Arr : Mnode; 1450 begin 1451 Open_Temp; 1452 if Is_Static_Arr (E) then 1453 -- First, translate expression. 1454 E_Val := Translate_Expression (E, Expr_Type); 1455 -- Then create Mnode (type info may be computed by 1456 -- translate_expression). 1457 M := E2M (E_Val, Get_Info (Expr_Type), Mode_Value); 1458 Stabilize (M); 1459 else 1460 Dyn_I := Dyn_I + 1; 1461 M := Dyn_Mnodes (Dyn_I); 1462 end if; 1463 1464 -- Create a slice of the result 1465 V_Arr := Create_Temp (Info.Ortho_Type (Mode_Value)); 1466 Var_Sub_Arr := Dv2M (V_Arr, Info, Mode_Value); 1467 New_Assign_Stmt 1468 (M2Lp (Chap3.Get_Composite_Bounds (Var_Sub_Arr)), 1469 M2Addr (Chap3.Get_Composite_Bounds (M))); 1470 New_Assign_Stmt 1471 (M2Lp (Chap3.Get_Composite_Base (Var_Sub_Arr)), 1472 New_Convert_Ov 1473 (M2Addr (Chap3.Slice_Base (Var_Arr, 1474 Expr_Type, 1475 New_Obj_Value (Var_Off), 1476 O_Enode_Null)), 1477 Info.B.Base_Ptr_Type (Mode_Value))); 1478 1479 -- Copy 1480 Chap3.Translate_Object_Copy (Var_Sub_Arr, M, Expr_Type); 1481 1482 -- Increase offset 1483 New_Assign_Stmt 1484 (New_Obj (Var_Off), 1485 New_Dyadic_Op (ON_Add_Ov, 1486 New_Obj_Value (Var_Off), 1487 Chap3.Get_Array_Length (M, Expr_Type))); 1488 Close_Temp; 1489 end Assign_Arr; 1490 1491 -- Find last expression. This is used to get the bounds in the case of 1492 -- a null-range result. 1493 Last_Expr : Iir; 1494 Last_Dyn_Expr : Natural; 1495 1496 procedure Find_Last_Arr (E : Iir) is 1497 begin 1498 Last_Expr := E; 1499 if Is_Static_Arr (E) then 1500 Last_Dyn_Expr := 0; 1501 else 1502 Dyn_I := Dyn_I + 1; 1503 Last_Dyn_Expr := Dyn_I; 1504 end if; 1505 end Find_Last_Arr; 1506 1507 -- Copy Left and Dir from SRC to the result. Used for v87. 1508 procedure Copy_Bounds_V87 (Src : Mnode) 1509 is 1510 Src1 : Mnode; 1511 begin 1512 Open_Temp; 1513 Src1 := Stabilize (Src); 1514 New_Assign_Stmt (M2Lv (Chap3.Range_To_Left (Get_Res_Range)), 1515 M2E (Chap3.Range_To_Left (Src1))); 1516 New_Assign_Stmt (M2Lv (Chap3.Range_To_Dir (Get_Res_Range)), 1517 M2E (Chap3.Range_To_Dir (Src1))); 1518 Close_Temp; 1519 end Copy_Bounds_V87; 1520 1521 -- Vhdl 87 bounds: find the first non-null expression and assign 1522 -- left and dir to the result. 1523 Assign_Bounds_V87_Done : Boolean; 1524 type O_If_Block_Array is array 1525 (1 .. Nbr_Dyn_Expr * Boolean'Pos (Flags.Vhdl_Std = Vhdl_87)) 1526 of O_If_Block; 1527 Assign_Bounds_Ifs : O_If_Block_Array; 1528 1529 procedure Assign_Bounds_El_V87 (E : Iir) 1530 is 1531 pragma Unreferenced (E); 1532 begin 1533 if Assign_Bounds_V87_Done then 1534 return; 1535 end if; 1536 1537 Copy_Bounds_V87 (Chap3.Type_To_Range (Get_Index_Type (Expr_Type, 0))); 1538 Assign_Bounds_V87_Done := True; 1539 end Assign_Bounds_El_V87; 1540 1541 procedure Assign_Bounds_Arr_V87 (E : Iir) 1542 is 1543 Idx_Rng : Iir; 1544 begin 1545 if Assign_Bounds_V87_Done then 1546 return; 1547 end if; 1548 1549 if Is_Static_Arr (E) then 1550 Idx_Rng := Get_Range_Constraint 1551 (Get_Index_Type (Get_Type (E), 0)); 1552 if Eval_Discrete_Range_Length (Idx_Rng) = 0 then 1553 return; 1554 end if; 1555 New_Assign_Stmt 1556 (M2Lv (Chap3.Range_To_Left (Get_Res_Range)), 1557 New_Lit (Translate_Static_Range_Left (Idx_Rng, Index_Type))); 1558 New_Assign_Stmt 1559 (M2Lv (Chap3.Range_To_Dir (Get_Res_Range)), 1560 New_Lit (Translate_Static_Range_Dir (Idx_Rng))); 1561 Assign_Bounds_V87_Done := True; 1562 else 1563 Dyn_I := Dyn_I + 1; 1564 Start_If_Stmt 1565 (Assign_Bounds_Ifs (Dyn_I), 1566 New_Compare_Op (ON_Neq, 1567 Chap3.Get_Array_Length (Dyn_Mnodes (Dyn_I), 1568 Expr_Type), 1569 New_Lit (Ghdl_Index_0), 1570 Ghdl_Bool_Type)); 1571 Copy_Bounds_V87 (Chap3.Bounds_To_Range 1572 (Chap3.Get_Composite_Bounds 1573 (Dyn_Mnodes (Dyn_I)), Expr_Type, 1)); 1574 New_Else_Stmt (Assign_Bounds_Ifs (Dyn_I)); 1575 end if; 1576 end Assign_Bounds_Arr_V87; 1577 1578 begin 1579 -- Bounds 1580 Var_Bounds := Dv2M 1581 (Create_Temp (Info.B.Bounds_Type), Info, Mode_Value, 1582 Info.B.Bounds_Type, Info.B.Bounds_Ptr_Type); 1583 1584 -- Base 1585 Arr_Ptr := Create_Temp (Info.B.Base_Ptr_Type (Mode_Value)); 1586 Var_Arr := Dp2M (Arr_Ptr, Info, Mode_Value, 1587 Info.B.Base_Type (Mode_Value), 1588 Info.B.Base_Ptr_Type (Mode_Value)); 1589 1590 -- Result 1591 Var_Res := Create_Temp (Info.Ortho_Type (Mode_Value)); 1592 Res := Dv2M (Var_Res, Info, Mode_Value); 1593 1594 -- Set result bounds. 1595 New_Assign_Stmt 1596 (M2Lp (Chap3.Get_Composite_Bounds (Res)), M2Addr (Var_Bounds)); 1597 1598 -- Evaluate all dynamic expressions 1599 Dyn_I := 0; 1600 Walk ((Nil_El'Access, Eval_Dyn_Arr'Access)); 1601 -- Check that all dynamic expressions have been handled. 1602 pragma Assert (Dyn_I = Dyn_Mnodes'Last); 1603 1604 -- Compute length 1605 if Static_Length /= 0 then 1606 E_Length := New_Lit (New_Index_Lit (Unsigned_64 (Static_Length))); 1607 else 1608 E_Length := O_Enode_Null; 1609 end if; 1610 Dyn_I := 0; 1611 Walk ((Nil_El'Access, Len_Dyn_Arr'Access)); 1612 pragma Assert (Dyn_I = Dyn_Mnodes'Last); 1613 pragma Assert (E_Length /= O_Enode_Null); 1614 Var_Length := Create_Temp_Init (Ghdl_Index_Type, E_Length); 1615 1616 -- Compute bounds. 1617 declare 1618 If_Blk : O_If_Block; 1619 begin 1620 if Static_Length = 0 then 1621 -- The result may have null bounds. Note: we haven't optimize 1622 -- the case when the result is known to have null bounds. 1623 Start_If_Stmt 1624 (If_Blk, New_Compare_Op (ON_Neq, New_Obj_Value (Var_Length), 1625 New_Lit (Ghdl_Index_0), 1626 Ghdl_Bool_Type)); 1627 end if; 1628 1629 -- For a non-null bounds result. 1630 if Flags.Vhdl_Std > Vhdl_87 or Flag_Relaxed_Rules then 1631 -- Vhdl 93 case: lean and simple. 1632 Chap3.Create_Range_From_Length 1633 (Index_Type, Var_Length, Get_Res_Range, Left); 1634 else 1635 -- Vhdl 87 rules are error-prone and not very efficient: 1636 1637 -- LRM87 7.2.4 1638 -- The left bound of this result is the left bound of the left 1639 -- operand, unless the left operand is a null array, in which 1640 -- case the result of the concatenation is the right operand. 1641 -- The direction of the result is the direction of the left 1642 -- operand, unless the left operand is a null array, in which 1643 -- case the direction of the result is that of the right operand. 1644 1645 -- Assign length. 1646 New_Assign_Stmt 1647 (M2Lv (Chap3.Range_To_Length (Get_Res_Range)), 1648 New_Obj_Value (Var_Length)); 1649 1650 -- Left and direction are copied from the first expressions with 1651 -- non-null range. 1652 Dyn_I := 0; 1653 Assign_Bounds_V87_Done := False; 1654 Walk ((Assign_Bounds_El_V87'Access, Assign_Bounds_Arr_V87'Access)); 1655 for I in reverse 1 .. Dyn_I loop 1656 Finish_If_Stmt (Assign_Bounds_Ifs (I)); 1657 end loop; 1658 1659 -- Set right bound. 1660 declare 1661 Idx_Info : constant Type_Info_Acc := Get_Info (Index_Type); 1662 Idx_Otype : constant O_Tnode := 1663 Idx_Info.Ortho_Type (Mode_Value); 1664 Var_Length1 : O_Dnode; 1665 Var_Right : O_Dnode; 1666 If_Blk2 : O_If_Block; 1667 begin 1668 Open_Temp; 1669 Var_Length1 := Create_Temp (Ghdl_Index_Type); 1670 Var_Right := Create_Temp (Idx_Otype); 1671 1672 -- Note this substraction cannot overflow, since LENGTH >= 1. 1673 New_Assign_Stmt 1674 (New_Obj (Var_Length1), 1675 New_Dyadic_Op (ON_Sub_Ov, 1676 New_Obj_Value (Var_Length), 1677 New_Lit (Ghdl_Index_1))); 1678 1679 -- Compute right bound of result: 1680 -- if dir = dir_to then 1681 -- right := left + length_1; 1682 -- else 1683 -- right := left - length_1; 1684 -- end if; 1685 Start_If_Stmt 1686 (If_Blk2, 1687 New_Compare_Op (ON_Eq, 1688 M2E (Chap3.Range_To_Dir (Get_Res_Range)), 1689 New_Lit (Ghdl_Dir_To_Node), 1690 Ghdl_Bool_Type)); 1691 New_Assign_Stmt 1692 (New_Obj (Var_Right), 1693 New_Dyadic_Op (ON_Add_Ov, 1694 M2E (Chap3.Range_To_Left (Get_Res_Range)), 1695 New_Convert_Ov (New_Obj_Value (Var_Length1), 1696 Idx_Otype))); 1697 New_Else_Stmt (If_Blk2); 1698 New_Assign_Stmt 1699 (New_Obj (Var_Right), 1700 New_Dyadic_Op (ON_Sub_Ov, 1701 M2E (Chap3.Range_To_Left (Get_Res_Range)), 1702 New_Convert_Ov (New_Obj_Value (Var_Length1), 1703 Idx_Otype))); 1704 Finish_If_Stmt (If_Blk2); 1705 1706 -- Check the right bounds is inside the bounds of the 1707 -- index type. 1708 Chap3.Check_Range (Var_Right, Null_Iir, Index_Type, Left); 1709 New_Assign_Stmt 1710 (M2Lv (Chap3.Range_To_Right (Get_Res_Range)), 1711 New_Obj_Value (Var_Right)); 1712 Close_Temp; 1713 end; 1714 end if; 1715 1716 if Static_Length = 0 then 1717 New_Else_Stmt (If_Blk); 1718 -- For a null bound result. Same rules for v87 and v93. 1719 -- Find last expression. 1720 Last_Expr := Null_Iir; 1721 Last_Dyn_Expr := 0; 1722 Dyn_I := 0; 1723 Walk ((Nil_El'Access, Find_Last_Arr'Access)); 1724 pragma Assert (Dyn_I = Dyn_Mnodes'Last); 1725 1726 if Last_Dyn_Expr = 0 then 1727 -- The last expression is not dynamic. 1728 Translate_Discrete_Range 1729 (Get_Res_Range, Get_Index_Type (Get_Type (Last_Expr), 0)); 1730 else 1731 Copy_Range 1732 (Get_Res_Range, 1733 Chap3.Bounds_To_Range 1734 (Chap3.Get_Composite_Bounds (Dyn_Mnodes (Last_Dyn_Expr)), 1735 Expr_Type, 1)); 1736 end if; 1737 1738 Finish_If_Stmt (If_Blk); 1739 end if; 1740 end; 1741 1742 -- Allocate result. 1743 New_Assign_Stmt 1744 (New_Obj (Arr_Ptr), 1745 Gen_Alloc (Alloc_Stack, 1746 Chap3.Get_Object_Size (Res, Expr_Type), 1747 Info.B.Base_Ptr_Type (Mode_Value))); 1748 New_Assign_Stmt 1749 (M2Lp (Chap3.Get_Composite_Base (Res)), M2Addr (Var_Arr)); 1750 1751 -- Assign expressions 1752 Open_Temp; 1753 Var_Off := Create_Temp_Init (Ghdl_Index_Type, New_Lit (Ghdl_Index_0)); 1754 Dyn_I := 0; 1755 Walk ((Assign_El'Access, Assign_Arr'Access)); 1756 pragma Assert (Dyn_I = Dyn_Mnodes'Last); 1757 Close_Temp; 1758 1759 return Translate_Implicit_Conv 1760 (M2E (Res), Expr_Type, Res_Type, Mode_Value, Left); 1761 end Translate_Concatenation; 1762 1763 function Translate_Scalar_Min_Max 1764 (Op : ON_Op_Kind; Left, Right : Iir; Res_Type : Iir) return O_Enode 1765 is 1766 Res_Otype : constant O_Tnode := Get_Ortho_Type (Res_Type, Mode_Value); 1767 Res, L, R : O_Dnode; 1768 If_Blk : O_If_Block; 1769 begin 1770 -- Create a variable for the result. 1771 Res := Create_Temp (Res_Otype); 1772 1773 Open_Temp; 1774 L := Create_Temp_Init 1775 (Res_Otype, Translate_Expression (Left, Res_Type)); 1776 R := Create_Temp_Init 1777 (Res_Otype, Translate_Expression (Right, Res_Type)); 1778 1779 Start_If_Stmt (If_Blk, New_Compare_Op (Op, 1780 New_Obj_Value (L), 1781 New_Obj_Value (R), 1782 Ghdl_Bool_Type)); 1783 New_Assign_Stmt (New_Obj (Res), New_Obj_Value (L)); 1784 New_Else_Stmt (If_Blk); 1785 New_Assign_Stmt (New_Obj (Res), New_Obj_Value (R)); 1786 Finish_If_Stmt (If_Blk); 1787 Close_Temp; 1788 1789 return New_Obj_Value (Res); 1790 end Translate_Scalar_Min_Max; 1791 1792 function Translate_Predefined_Vector_Min_Max 1793 (Is_Min : Boolean; Left : Iir; Res_Type : Iir) return O_Enode 1794 is 1795 Res_Otype : constant O_Tnode := Get_Ortho_Type (Res_Type, Mode_Value); 1796 Left_Type : constant Iir := Get_Type (Left); 1797 Res, El, Len : O_Dnode; 1798 Arr : Mnode; 1799 If_Blk : O_If_Block; 1800 Label : O_Snode; 1801 Op : ON_Op_Kind; 1802 begin 1803 -- Create a variable for the result. 1804 Res := Create_Temp (Res_Otype); 1805 1806 Open_Temp; 1807 if Is_Min then 1808 Op := ON_Lt; 1809 else 1810 Op := ON_Gt; 1811 end if; 1812 New_Assign_Stmt 1813 (New_Obj (Res), 1814 Chap14.Translate_High_Low_Type_Attribute (Res_Type, Is_Min)); 1815 1816 El := Create_Temp (Res_Otype); 1817 Arr := Stabilize (E2M (Translate_Expression (Left), 1818 Get_Info (Left_Type), Mode_Value)); 1819 Len := Create_Temp_Init 1820 (Ghdl_Index_Type, 1821 M2E (Chap3.Range_To_Length 1822 (Chap3.Get_Array_Range (Arr, Left_Type, 1)))); 1823 1824 -- Create: 1825 -- loop 1826 -- exit when LEN = 0; 1827 -- LEN := LEN - 1; 1828 -- if ARR[LEN] </> RES then 1829 -- RES := ARR[LEN]; 1830 -- end if; 1831 -- end loop; 1832 Start_Loop_Stmt (Label); 1833 Gen_Exit_When (Label, New_Compare_Op (ON_Eq, New_Obj_Value (Len), 1834 New_Lit (Ghdl_Index_0), 1835 Ghdl_Bool_Type)); 1836 Dec_Var (Len); 1837 New_Assign_Stmt 1838 (New_Obj (El), 1839 M2E (Chap3.Index_Base (Chap3.Get_Composite_Base (Arr), 1840 Left_Type, New_Obj_Value (Len)))); 1841 Start_If_Stmt (If_Blk, New_Compare_Op (Op, 1842 New_Obj_Value (El), 1843 New_Obj_Value (Res), 1844 Ghdl_Bool_Type)); 1845 New_Assign_Stmt (New_Obj (Res), New_Obj_Value (El)); 1846 Finish_If_Stmt (If_Blk); 1847 Finish_Loop_Stmt (Label); 1848 1849 Close_Temp; 1850 1851 return New_Obj_Value (Res); 1852 end Translate_Predefined_Vector_Min_Max; 1853 1854 function Translate_Std_Ulogic_Match 1855 (Func : O_Dnode; L, R : O_Enode; Res_Type : O_Tnode) return O_Enode 1856 is 1857 Constr : O_Assoc_List; 1858 begin 1859 Start_Association (Constr, Func); 1860 New_Association (Constr, New_Convert_Ov (L, Ghdl_I32_Type)); 1861 New_Association (Constr, New_Convert_Ov (R, Ghdl_I32_Type)); 1862 return New_Convert_Ov (New_Function_Call (Constr), Res_Type); 1863 end Translate_Std_Ulogic_Match; 1864 1865 function Translate_To_String (Subprg : O_Dnode; 1866 Res_Type : Iir; 1867 Loc : Iir; 1868 Val : O_Enode; 1869 Arg2 : O_Enode := O_Enode_Null; 1870 Arg3 : O_Enode := O_Enode_Null) 1871 return O_Enode 1872 is 1873 Val_Type : constant Iir := Get_Base_Type (Res_Type); 1874 Res : O_Dnode; 1875 Assoc : O_Assoc_List; 1876 begin 1877 Res := Create_Temp (Std_String_Node); 1878 Create_Temp_Stack2_Mark; 1879 Start_Association (Assoc, Subprg); 1880 New_Association (Assoc, 1881 New_Address (New_Obj (Res), Std_String_Ptr_Node)); 1882 New_Association (Assoc, Val); 1883 if Arg2 /= O_Enode_Null then 1884 New_Association (Assoc, Arg2); 1885 if Arg3 /= O_Enode_Null then 1886 New_Association (Assoc, Arg3); 1887 end if; 1888 end if; 1889 New_Procedure_Call (Assoc); 1890 return M2E (Translate_Implicit_Array_Conversion 1891 (Dv2M (Res, Get_Info (Val_Type), Mode_Value), 1892 Val_Type, Res_Type, Loc)); 1893 end Translate_To_String; 1894 1895 function Translate_Bv_To_String (Subprg : O_Dnode; 1896 Val : O_Enode; 1897 Val_Type : Iir; 1898 Res_Type : Iir; 1899 Loc : Iir) 1900 return O_Enode 1901 is 1902 Arr : Mnode; 1903 begin 1904 Arr := Stabilize (E2M (Val, Get_Info (Val_Type), Mode_Value)); 1905 return Translate_To_String 1906 (Subprg, Res_Type, Loc, 1907 M2E (Chap3.Get_Composite_Base (Arr)), 1908 M2E (Chap3.Range_To_Length 1909 (Chap3.Get_Array_Range (Arr, Val_Type, 1)))); 1910 end Translate_Bv_To_String; 1911 1912 subtype Predefined_Boolean_Logical is Iir_Predefined_Functions range 1913 Iir_Predefined_Boolean_And .. Iir_Predefined_Boolean_Xnor; 1914 1915 function Translate_Predefined_Logical 1916 (Op : Predefined_Boolean_Logical; Left, Right : O_Enode) return O_Enode is 1917 begin 1918 case Op is 1919 when Iir_Predefined_Boolean_And => 1920 return New_Dyadic_Op (ON_And, Left, Right); 1921 when Iir_Predefined_Boolean_Or => 1922 return New_Dyadic_Op (ON_Or, Left, Right); 1923 when Iir_Predefined_Boolean_Nand => 1924 return New_Monadic_Op 1925 (ON_Not, New_Dyadic_Op (ON_And, Left, Right)); 1926 when Iir_Predefined_Boolean_Nor => 1927 return New_Monadic_Op 1928 (ON_Not, New_Dyadic_Op (ON_Or, Left, Right)); 1929 when Iir_Predefined_Boolean_Xor => 1930 return New_Dyadic_Op (ON_Xor, Left, Right); 1931 when Iir_Predefined_Boolean_Xnor => 1932 return New_Monadic_Op 1933 (ON_Not, New_Dyadic_Op (ON_Xor, Left, Right)); 1934 end case; 1935 end Translate_Predefined_Logical; 1936 1937 function Translate_Predefined_TF_Array_Element 1938 (Op : Predefined_Boolean_Logical; 1939 Left, Right : Iir; 1940 Res_Type : Iir; 1941 Loc : Iir) 1942 return O_Enode 1943 is 1944 Arr_Type : constant Iir := Get_Type (Left); 1945 Res_Btype : constant Iir := Get_Base_Type (Res_Type); 1946 Res_Info : constant Type_Info_Acc := Get_Info (Res_Btype); 1947 Base_Ptr_Type : constant O_Tnode := 1948 Res_Info.B.Base_Ptr_Type (Mode_Value); 1949 Arr : Mnode; 1950 El : O_Dnode; 1951 Base : O_Dnode; 1952 Len : O_Dnode; 1953 Label : O_Snode; 1954 Res : Mnode; 1955 begin 1956 -- Translate the array. 1957 Arr := Stabilize (E2M (Translate_Expression (Left), 1958 Get_Info (Arr_Type), Mode_Value)); 1959 1960 -- Extract its length. 1961 Len := Create_Temp_Init 1962 (Ghdl_Index_Type, 1963 M2E (Chap3.Range_To_Length 1964 (Chap3.Get_Array_Range (Arr, Arr_Type, 1)))); 1965 1966 -- Allocate the result array. 1967 Base := Create_Temp_Init 1968 (Base_Ptr_Type, 1969 Gen_Alloc (Alloc_Stack, New_Obj_Value (Len), Base_Ptr_Type)); 1970 1971 Open_Temp; 1972 -- Translate the element. 1973 El := Create_Temp_Init (Get_Ortho_Type (Get_Type (Right), Mode_Value), 1974 Translate_Expression (Right)); 1975 -- Create: 1976 -- loop 1977 -- exit when LEN = 0; 1978 -- LEN := LEN - 1; 1979 -- BASE[LEN] := EL op ARR[LEN]; 1980 -- end loop; 1981 Start_Loop_Stmt (Label); 1982 Gen_Exit_When (Label, New_Compare_Op (ON_Eq, New_Obj_Value (Len), 1983 New_Lit (Ghdl_Index_0), 1984 Ghdl_Bool_Type)); 1985 Dec_Var (Len); 1986 New_Assign_Stmt 1987 (New_Indexed_Acc_Value (New_Obj (Base), 1988 New_Obj_Value (Len)), 1989 Translate_Predefined_Logical 1990 (Op, 1991 New_Obj_Value (El), 1992 M2E (Chap3.Index_Base (Chap3.Get_Composite_Base (Arr), 1993 Arr_Type, New_Obj_Value (Len))))); 1994 Finish_Loop_Stmt (Label); 1995 Close_Temp; 1996 1997 Res := Create_Temp (Res_Info, Mode_Value); 1998 New_Assign_Stmt (M2Lp (Chap3.Get_Composite_Base (Res)), 1999 New_Obj_Value (Base)); 2000 New_Assign_Stmt (M2Lp (Chap3.Get_Composite_Bounds (Res)), 2001 M2Addr (Chap3.Get_Composite_Bounds (Arr))); 2002 2003 return Translate_Implicit_Conv (M2E (Res), Res_Btype, Res_Type, 2004 Mode_Value, Loc); 2005 end Translate_Predefined_TF_Array_Element; 2006 2007 function Translate_Predefined_TF_Reduction 2008 (Op : ON_Op_Kind; Operand : Iir; Res_Type : Iir) return O_Enode 2009 is 2010 Arr_Type : constant Iir := Get_Type (Operand); 2011 Enums : constant Iir_Flist := 2012 Get_Enumeration_Literal_List (Get_Base_Type (Res_Type)); 2013 Init_Enum : Iir; 2014 2015 Res : O_Dnode; 2016 Arr_Expr : O_Enode; 2017 Arr : Mnode; 2018 Len : O_Dnode; 2019 Label : O_Snode; 2020 begin 2021 if Op = ON_And then 2022 Init_Enum := Get_Nth_Element (Enums, 1); 2023 else 2024 Init_Enum := Get_Nth_Element (Enums, 0); 2025 end if; 2026 2027 Res := Create_Temp_Init (Get_Ortho_Type (Res_Type, Mode_Value), 2028 New_Lit (Get_Ortho_Literal (Init_Enum))); 2029 2030 Open_Temp; 2031 -- Translate the array. Note that Translate_Expression may create 2032 -- the info for the array type, so be sure to call it before calling 2033 -- Get_Info. 2034 Arr_Expr := Translate_Expression (Operand); 2035 Arr := Stabilize (E2M (Arr_Expr, Get_Info (Arr_Type), Mode_Value)); 2036 2037 -- Extract its length. 2038 Len := Create_Temp_Init 2039 (Ghdl_Index_Type, 2040 M2E (Chap3.Range_To_Length 2041 (Chap3.Get_Array_Range (Arr, Arr_Type, 1)))); 2042 2043 -- Create: 2044 -- loop 2045 -- exit when LEN = 0; 2046 -- LEN := LEN - 1; 2047 -- RES := RES op ARR[LEN]; 2048 -- end loop; 2049 Start_Loop_Stmt (Label); 2050 Gen_Exit_When (Label, New_Compare_Op (ON_Eq, New_Obj_Value (Len), 2051 New_Lit (Ghdl_Index_0), 2052 Ghdl_Bool_Type)); 2053 Dec_Var (Len); 2054 New_Assign_Stmt 2055 (New_Obj (Res), 2056 New_Dyadic_Op 2057 (Op, 2058 New_Obj_Value (Res), 2059 M2E (Chap3.Index_Base (Chap3.Get_Composite_Base (Arr), 2060 Arr_Type, New_Obj_Value (Len))))); 2061 Finish_Loop_Stmt (Label); 2062 Close_Temp; 2063 2064 return New_Obj_Value (Res); 2065 end Translate_Predefined_TF_Reduction; 2066 2067 function Translate_Predefined_Array_Min_Max 2068 (Is_Min : Boolean; 2069 Left, Right : O_Enode; 2070 Left_Type, Right_Type : Iir; 2071 Res_Type : Iir; 2072 Imp : Iir; 2073 Loc : Iir) 2074 return O_Enode 2075 is 2076 Arr_Type : constant Iir := Get_Base_Type (Left_Type); 2077 Arr_Info : constant Type_Info_Acc := Get_Info (Arr_Type); 2078 L, R : Mnode; 2079 If_Blk : O_If_Block; 2080 Res : Mnode; 2081 begin 2082 Res := Create_Temp (Arr_Info, Mode_Value); 2083 L := Stabilize (E2M (Left, Get_Info (Left_Type), Mode_Value)); 2084 R := Stabilize (E2M (Right, Get_Info (Right_Type), Mode_Value)); 2085 Start_If_Stmt 2086 (If_Blk, 2087 New_Compare_Op 2088 (ON_Eq, 2089 Translate_Predefined_Lib_Operator (M2E (L), M2E (R), Imp), 2090 New_Lit (Ghdl_Compare_Lt), 2091 Std_Boolean_Type_Node)); 2092 if Is_Min then 2093 Copy_Fat_Pointer (Res, Translate_Implicit_Array_Conversion 2094 (L, Left_Type, Arr_Type, Loc)); 2095 else 2096 Copy_Fat_Pointer (Res, Translate_Implicit_Array_Conversion 2097 (R, Right_Type, Arr_Type, Loc)); 2098 end if; 2099 New_Else_Stmt (If_Blk); 2100 if Is_Min then 2101 Copy_Fat_Pointer (Res, Translate_Implicit_Array_Conversion 2102 (R, Right_Type, Arr_Type, Loc)); 2103 else 2104 Copy_Fat_Pointer (Res, Translate_Implicit_Array_Conversion 2105 (L, Left_Type, Arr_Type, Loc)); 2106 end if; 2107 Finish_If_Stmt (If_Blk); 2108 2109 return M2E (Translate_Implicit_Array_Conversion 2110 (Res, Arr_Type, Res_Type, Loc)); 2111 end Translate_Predefined_Array_Min_Max; 2112 2113 function Translate_Predefined_TF_Edge (Is_Rising : Boolean; Left : Iir) 2114 return O_Enode 2115 is 2116 Enums : constant Iir_Flist := 2117 Get_Enumeration_Literal_List (Get_Base_Type (Get_Type (Left))); 2118 Sig : Mnode; 2119 Val : Mnode; 2120 begin 2121 Chap6.Translate_Signal_Name (Left, Sig, Val); 2122 return New_Dyadic_Op 2123 (ON_And, 2124 New_Value (Chap14.Get_Signal_Field (Sig, Ghdl_Signal_Event_Field)), 2125 New_Compare_Op 2126 (ON_Eq, 2127 M2E (Val), 2128 New_Lit (Get_Ortho_Literal 2129 (Get_Nth_Element (Enums, Boolean'Pos (Is_Rising)))), 2130 Std_Boolean_Type_Node)); 2131 end Translate_Predefined_TF_Edge; 2132 2133 function Translate_Predefined_Std_Ulogic_Array_Match 2134 (Subprg : O_Dnode; Left, Right : Iir; Res_Type : Iir) return O_Enode 2135 is 2136 Res_Otype : constant O_Tnode := 2137 Get_Ortho_Type (Res_Type, Mode_Value); 2138 L_Type : constant Iir := Get_Type (Left); 2139 R_Type : constant Iir := Get_Type (Right); 2140 L_Expr, R_Expr : O_Enode; 2141 L, R : Mnode; 2142 Assoc : O_Assoc_List; 2143 2144 Res : O_Dnode; 2145 begin 2146 Res := Create_Temp (Ghdl_I32_Type); 2147 2148 Open_Temp; 2149 -- Translate the arrays. Note that Translate_Expression may create 2150 -- the info for the array type, so be sure to call it before calling 2151 -- Get_Info. 2152 L_Expr := Translate_Expression (Left); 2153 L := Stabilize (E2M (L_Expr, Get_Info (L_Type), Mode_Value)); 2154 2155 R_Expr := Translate_Expression (Right); 2156 R := Stabilize (E2M (R_Expr, Get_Info (R_Type), Mode_Value)); 2157 2158 Start_Association (Assoc, Subprg); 2159 New_Association 2160 (Assoc, 2161 New_Convert_Ov (M2E (Chap3.Get_Composite_Base (L)), Ghdl_Ptr_Type)); 2162 New_Association 2163 (Assoc, 2164 M2E (Chap3.Range_To_Length (Chap3.Get_Array_Range (L, L_Type, 1)))); 2165 2166 New_Association 2167 (Assoc, 2168 New_Convert_Ov (M2E (Chap3.Get_Composite_Base (R)), Ghdl_Ptr_Type)); 2169 New_Association 2170 (Assoc, 2171 M2E (Chap3.Range_To_Length (Chap3.Get_Array_Range (R, R_Type, 1)))); 2172 2173 New_Assign_Stmt (New_Obj (Res), New_Function_Call (Assoc)); 2174 2175 Close_Temp; 2176 2177 return New_Convert_Ov (New_Obj_Value (Res), Res_Otype); 2178 end Translate_Predefined_Std_Ulogic_Array_Match; 2179 2180 function Translate_Predefined_Operator 2181 (Expr : Iir_Function_Declaration; Left, Right : Iir; Res_Type : Iir) 2182 return O_Enode 2183 is 2184 Imp : constant Iir := Get_Implementation (Expr); 2185 Kind : constant Iir_Predefined_Functions := 2186 Get_Implicit_Definition (Imp); 2187 Left_Tree : O_Enode; 2188 Right_Tree : O_Enode; 2189 Left_Type : Iir; 2190 Right_Type : Iir; 2191 Res_Otype : O_Tnode; 2192 Op : ON_Op_Kind; 2193 Inter : Iir; 2194 Res : O_Enode; 2195 begin 2196 case Kind is 2197 when Iir_Predefined_Bit_And 2198 | Iir_Predefined_Bit_Or 2199 | Iir_Predefined_Bit_Nand 2200 | Iir_Predefined_Bit_Nor 2201 | Iir_Predefined_Boolean_And 2202 | Iir_Predefined_Boolean_Or 2203 | Iir_Predefined_Boolean_Nand 2204 | Iir_Predefined_Boolean_Nor => 2205 -- Right operand of shortcircuit operators may not be evaluated. 2206 return Translate_Shortcircuit_Operator (Imp, Left, Right); 2207 2208 when Iir_Predefined_Array_Array_Concat 2209 | Iir_Predefined_Element_Array_Concat 2210 | Iir_Predefined_Array_Element_Concat 2211 | Iir_Predefined_Element_Element_Concat => 2212 return Translate_Concatenation (Imp, Left, Right, Res_Type); 2213 2214 -- Operands of min/max are evaluated in a declare block. 2215 when Iir_Predefined_Enum_Minimum 2216 | Iir_Predefined_Integer_Minimum 2217 | Iir_Predefined_Floating_Minimum 2218 | Iir_Predefined_Physical_Minimum => 2219 return Translate_Scalar_Min_Max (ON_Le, Left, Right, Res_Type); 2220 when Iir_Predefined_Enum_Maximum 2221 | Iir_Predefined_Integer_Maximum 2222 | Iir_Predefined_Floating_Maximum 2223 | Iir_Predefined_Physical_Maximum => 2224 return Translate_Scalar_Min_Max (ON_Ge, Left, Right, Res_Type); 2225 2226 -- Avoid implicit conversion of the array parameters to the 2227 -- unbounded type for optimizing purpose. FIXME: should do the 2228 -- same for the result. 2229 when Iir_Predefined_TF_Array_Element_And => 2230 return Translate_Predefined_TF_Array_Element 2231 (Iir_Predefined_Boolean_And, Left, Right, Res_Type, Expr); 2232 when Iir_Predefined_TF_Element_Array_And => 2233 return Translate_Predefined_TF_Array_Element 2234 (Iir_Predefined_Boolean_And, Right, Left, Res_Type, Expr); 2235 when Iir_Predefined_TF_Array_Element_Or => 2236 return Translate_Predefined_TF_Array_Element 2237 (Iir_Predefined_Boolean_Or, Left, Right, Res_Type, Expr); 2238 when Iir_Predefined_TF_Element_Array_Or => 2239 return Translate_Predefined_TF_Array_Element 2240 (Iir_Predefined_Boolean_Or, Right, Left, Res_Type, Expr); 2241 when Iir_Predefined_TF_Array_Element_Nand => 2242 return Translate_Predefined_TF_Array_Element 2243 (Iir_Predefined_Boolean_Nand, Left, Right, Res_Type, Expr); 2244 when Iir_Predefined_TF_Element_Array_Nand => 2245 return Translate_Predefined_TF_Array_Element 2246 (Iir_Predefined_Boolean_Nand, Right, Left, Res_Type, Expr); 2247 when Iir_Predefined_TF_Array_Element_Nor => 2248 return Translate_Predefined_TF_Array_Element 2249 (Iir_Predefined_Boolean_Nor, Left, Right, Res_Type, Expr); 2250 when Iir_Predefined_TF_Element_Array_Nor => 2251 return Translate_Predefined_TF_Array_Element 2252 (Iir_Predefined_Boolean_Nor, Right, Left, Res_Type, Expr); 2253 when Iir_Predefined_TF_Array_Element_Xor => 2254 return Translate_Predefined_TF_Array_Element 2255 (Iir_Predefined_Boolean_Xor, Left, Right, Res_Type, Expr); 2256 when Iir_Predefined_TF_Element_Array_Xor => 2257 return Translate_Predefined_TF_Array_Element 2258 (Iir_Predefined_Boolean_Xor, Right, Left, Res_Type, Expr); 2259 when Iir_Predefined_TF_Array_Element_Xnor => 2260 return Translate_Predefined_TF_Array_Element 2261 (Iir_Predefined_Boolean_Xnor, Left, Right, Res_Type, Expr); 2262 when Iir_Predefined_TF_Element_Array_Xnor => 2263 return Translate_Predefined_TF_Array_Element 2264 (Iir_Predefined_Boolean_Xnor, Right, Left, Res_Type, Expr); 2265 2266 -- Avoid implicit conversion of the array parameters to the 2267 -- unbounded type for optimizing purpose. 2268 when Iir_Predefined_TF_Reduction_And => 2269 return Translate_Predefined_TF_Reduction 2270 (ON_And, Left, Res_Type); 2271 when Iir_Predefined_TF_Reduction_Or => 2272 return Translate_Predefined_TF_Reduction 2273 (ON_Or, Left, Res_Type); 2274 when Iir_Predefined_TF_Reduction_Nand => 2275 return New_Monadic_Op 2276 (ON_Not, 2277 Translate_Predefined_TF_Reduction (ON_And, Left, Res_Type)); 2278 when Iir_Predefined_TF_Reduction_Nor => 2279 return New_Monadic_Op 2280 (ON_Not, 2281 Translate_Predefined_TF_Reduction (ON_Or, Left, Res_Type)); 2282 when Iir_Predefined_TF_Reduction_Xor => 2283 return Translate_Predefined_TF_Reduction 2284 (ON_Xor, Left, Res_Type); 2285 when Iir_Predefined_TF_Reduction_Xnor => 2286 return New_Monadic_Op 2287 (ON_Not, 2288 Translate_Predefined_TF_Reduction (ON_Xor, Left, Res_Type)); 2289 2290 when Iir_Predefined_Vector_Minimum => 2291 return Translate_Predefined_Vector_Min_Max 2292 (True, Left, Get_Type (Expr)); 2293 when Iir_Predefined_Vector_Maximum => 2294 return Translate_Predefined_Vector_Min_Max 2295 (False, Left, Get_Type (Expr)); 2296 2297 when Iir_Predefined_Bit_Rising_Edge 2298 | Iir_Predefined_Boolean_Rising_Edge => 2299 return Translate_Predefined_TF_Edge (True, Left); 2300 when Iir_Predefined_Bit_Falling_Edge 2301 | Iir_Predefined_Boolean_Falling_Edge => 2302 return Translate_Predefined_TF_Edge (False, Left); 2303 2304 when Iir_Predefined_Std_Ulogic_Array_Match_Equality => 2305 return Translate_Predefined_Std_Ulogic_Array_Match 2306 (Ghdl_Std_Ulogic_Array_Match_Eq, Left, Right, Res_Type); 2307 when Iir_Predefined_Std_Ulogic_Array_Match_Inequality => 2308 return Translate_Predefined_Std_Ulogic_Array_Match 2309 (Ghdl_Std_Ulogic_Array_Match_Ne, Left, Right, Res_Type); 2310 2311 when others => 2312 null; 2313 end case; 2314 2315 -- Evaluate parameters. 2316 Res_Otype := Get_Ortho_Type (Res_Type, Mode_Value); 2317 Inter := Get_Interface_Declaration_Chain (Imp); 2318 if Left = Null_Iir then 2319 Left_Tree := O_Enode_Null; 2320 else 2321 Left_Type := Get_Type (Inter); 2322 Left_Tree := Translate_Expression (Left, Left_Type); 2323 end if; 2324 2325 if Right = Null_Iir then 2326 Right_Tree := O_Enode_Null; 2327 else 2328 Right_Type := Get_Type (Get_Chain (Inter)); 2329 Right_Tree := Translate_Expression (Right, Right_Type); 2330 end if; 2331 2332 Op := Predefined_To_Onop (Kind); 2333 if Op /= ON_Nil then 2334 case Op is 2335 when ON_Eq 2336 | ON_Neq 2337 | ON_Ge 2338 | ON_Gt 2339 | ON_Le 2340 | ON_Lt => 2341 Res := New_Compare_Op (Op, Left_Tree, Right_Tree, 2342 Std_Boolean_Type_Node); 2343 when ON_Add_Ov 2344 | ON_Sub_Ov 2345 | ON_Mul_Ov 2346 | ON_Div_Ov 2347 | ON_Rem_Ov 2348 | ON_Mod_Ov 2349 | ON_Xor => 2350 Res := New_Dyadic_Op (Op, Left_Tree, Right_Tree); 2351 when ON_Abs_Ov 2352 | ON_Neg_Ov 2353 | ON_Not => 2354 Res := New_Monadic_Op (Op, Left_Tree); 2355 when others => 2356 Simple_IO.Put_Line_Err 2357 ("translate_predefined_operator: cannot handle " 2358 & ON_Op_Kind'Image (Op)); 2359 raise Internal_Error; 2360 end case; 2361 Res := Translate_Implicit_Conv 2362 (Res, Get_Return_Type (Imp), Res_Type, Mode_Value, Expr); 2363 return Res; 2364 end if; 2365 2366 case Kind is 2367 when Iir_Predefined_Bit_Xnor 2368 | Iir_Predefined_Boolean_Xnor => 2369 return Translate_Predefined_Logical 2370 (Iir_Predefined_Boolean_Xnor, Left_Tree, Right_Tree); 2371 when Iir_Predefined_Bit_Match_Equality => 2372 return New_Compare_Op (ON_Eq, Left_Tree, Right_Tree, 2373 Get_Ortho_Type (Res_Type, Mode_Value)); 2374 when Iir_Predefined_Bit_Match_Inequality => 2375 return New_Compare_Op (ON_Neq, Left_Tree, Right_Tree, 2376 Get_Ortho_Type (Res_Type, Mode_Value)); 2377 2378 when Iir_Predefined_Bit_Condition => 2379 return New_Compare_Op 2380 (ON_Eq, Left_Tree, New_Lit (Get_Ortho_Literal (Bit_1)), 2381 Std_Boolean_Type_Node); 2382 2383 when Iir_Predefined_Integer_Identity 2384 | Iir_Predefined_Floating_Identity 2385 | Iir_Predefined_Physical_Identity => 2386 return Translate_Implicit_Conv 2387 (Left_Tree, Left_Type, Res_Type, Mode_Value, Expr); 2388 2389 when Iir_Predefined_Access_Equality 2390 | Iir_Predefined_Access_Inequality => 2391 if Is_Composite (Get_Info (Left_Type)) then 2392 -- a fat pointer. 2393 declare 2394 T : Type_Info_Acc; 2395 B : Type_Info_Acc; 2396 L, R : O_Dnode; 2397 V1, V2 : O_Enode; 2398 Op1, Op2 : ON_Op_Kind; 2399 begin 2400 if Kind = Iir_Predefined_Access_Equality then 2401 Op1 := ON_Eq; 2402 Op2 := ON_And; 2403 else 2404 Op1 := ON_Neq; 2405 Op2 := ON_Or; 2406 end if; 2407 T := Get_Info (Left_Type); 2408 B := Get_Info (Get_Designated_Type (Left_Type)); 2409 L := Create_Temp (T.Ortho_Ptr_Type (Mode_Value)); 2410 R := Create_Temp (T.Ortho_Ptr_Type (Mode_Value)); 2411 New_Assign_Stmt (New_Obj (L), Left_Tree); 2412 New_Assign_Stmt (New_Obj (R), Right_Tree); 2413 V1 := New_Compare_Op 2414 (Op1, 2415 New_Value_Selected_Acc_Value 2416 (New_Obj (L), B.B.Base_Field (Mode_Value)), 2417 New_Value_Selected_Acc_Value 2418 (New_Obj (R), B.B.Base_Field (Mode_Value)), 2419 Std_Boolean_Type_Node); 2420 V2 := New_Compare_Op 2421 (Op1, 2422 New_Value_Selected_Acc_Value 2423 (New_Obj (L), B.B.Bounds_Field (Mode_Value)), 2424 New_Value_Selected_Acc_Value 2425 (New_Obj (R), B.B.Bounds_Field (Mode_Value)), 2426 Std_Boolean_Type_Node); 2427 return New_Dyadic_Op (Op2, V1, V2); 2428 end; 2429 else 2430 -- a thin pointer. 2431 if Kind = Iir_Predefined_Access_Equality then 2432 return New_Compare_Op 2433 (ON_Eq, Left_Tree, Right_Tree, Std_Boolean_Type_Node); 2434 else 2435 return New_Compare_Op 2436 (ON_Neq, Left_Tree, Right_Tree, Std_Boolean_Type_Node); 2437 end if; 2438 end if; 2439 2440 when Iir_Predefined_Physical_Integer_Div => 2441 return New_Dyadic_Op (ON_Div_Ov, Left_Tree, 2442 New_Convert_Ov (Right_Tree, Res_Otype)); 2443 when Iir_Predefined_Physical_Physical_Div => 2444 return New_Convert_Ov 2445 (New_Dyadic_Op (ON_Div_Ov, Left_Tree, Right_Tree), Res_Otype); 2446 2447 -- LRM 7.2.6 2448 -- Multiplication of a value P of a physical type Tp by a 2449 -- value I of type INTEGER is equivalent to the following 2450 -- computation: Tp'Val (Tp'Pos (P) * I) 2451 -- FIXME: this is not what is really done... 2452 when Iir_Predefined_Integer_Physical_Mul => 2453 return New_Dyadic_Op (ON_Mul_Ov, 2454 New_Convert_Ov (Left_Tree, Res_Otype), 2455 Right_Tree); 2456 when Iir_Predefined_Physical_Integer_Mul => 2457 return New_Dyadic_Op (ON_Mul_Ov, Left_Tree, 2458 New_Convert_Ov (Right_Tree, Res_Otype)); 2459 2460 -- LRM 7.2.6 2461 -- Multiplication of a value P of a physical type Tp by a 2462 -- value F of type REAL is equivalten to the following 2463 -- computation: Tp'Val (INTEGER (REAL (Tp'Pos (P)) * F)) 2464 -- FIXME: we do not restrict with INTEGER. 2465 when Iir_Predefined_Physical_Real_Mul => 2466 declare 2467 Right_Otype : O_Tnode; 2468 begin 2469 Right_Otype := Get_Ortho_Type (Right_Type, Mode_Value); 2470 return New_Convert_Ov 2471 (New_Dyadic_Op (ON_Mul_Ov, 2472 New_Convert_Ov (Left_Tree, Right_Otype), 2473 Right_Tree), 2474 Res_Otype); 2475 end; 2476 when Iir_Predefined_Physical_Real_Div => 2477 declare 2478 Right_Otype : O_Tnode; 2479 begin 2480 Right_Otype := Get_Ortho_Type (Right_Type, Mode_Value); 2481 return New_Convert_Ov 2482 (New_Dyadic_Op (ON_Div_Ov, 2483 New_Convert_Ov (Left_Tree, Right_Otype), 2484 Right_Tree), 2485 Res_Otype); 2486 end; 2487 when Iir_Predefined_Real_Physical_Mul => 2488 declare 2489 Left_Otype : O_Tnode; 2490 begin 2491 Left_Otype := Get_Ortho_Type (Left_Type, Mode_Value); 2492 return New_Convert_Ov 2493 (New_Dyadic_Op (ON_Mul_Ov, 2494 Left_Tree, 2495 New_Convert_Ov (Right_Tree, Left_Otype)), 2496 Res_Otype); 2497 end; 2498 2499 when Iir_Predefined_Universal_R_I_Mul => 2500 return New_Dyadic_Op (ON_Mul_Ov, 2501 Left_Tree, 2502 New_Convert_Ov (Right_Tree, Res_Otype)); 2503 when Iir_Predefined_Universal_I_R_Mul => 2504 return New_Dyadic_Op (ON_Mul_Ov, 2505 New_Convert_Ov (Left_Tree, Res_Otype), 2506 Right_Tree); 2507 2508 when Iir_Predefined_Floating_Exp => 2509 Res := Translate_Lib_Operator 2510 (New_Convert_Ov (Left_Tree, Std_Real_Otype), 2511 Right_Tree, Ghdl_Real_Exp); 2512 return New_Convert_Ov (Res, Res_Otype); 2513 when Iir_Predefined_Integer_Exp => 2514 declare 2515 Left_Tinfo : constant Type_Info_Acc := 2516 Get_Info (Get_Type (Left)); 2517 Opr : O_Dnode; 2518 Etype : O_Tnode; 2519 begin 2520 case Type_Mode_Integers (Left_Tinfo.Type_Mode) is 2521 when Type_Mode_I32 => 2522 Opr := Ghdl_I32_Exp; 2523 Etype := Ghdl_I32_Type; 2524 when Type_Mode_I64 => 2525 Opr := Ghdl_I64_Exp; 2526 Etype := Ghdl_I64_Type; 2527 end case; 2528 Res := Translate_Lib_Operator 2529 (New_Convert_Ov (Left_Tree, Etype), Right_Tree, Opr); 2530 return New_Convert_Ov (Res, Res_Otype); 2531 end; 2532 2533 when Iir_Predefined_Array_Inequality 2534 | Iir_Predefined_Record_Inequality => 2535 return New_Monadic_Op 2536 (ON_Not, Translate_Predefined_Lib_Operator 2537 (Left_Tree, Right_Tree, Imp)); 2538 when Iir_Predefined_Array_Equality 2539 | Iir_Predefined_Record_Equality => 2540 return Translate_Predefined_Lib_Operator 2541 (Left_Tree, Right_Tree, Imp); 2542 2543 when Iir_Predefined_Array_Greater => 2544 return New_Compare_Op 2545 (ON_Eq, 2546 Translate_Predefined_Lib_Operator (Left_Tree, Right_Tree, 2547 Imp), 2548 New_Lit (Ghdl_Compare_Gt), 2549 Std_Boolean_Type_Node); 2550 when Iir_Predefined_Array_Greater_Equal => 2551 return New_Compare_Op 2552 (ON_Ge, 2553 Translate_Predefined_Lib_Operator (Left_Tree, Right_Tree, 2554 Imp), 2555 New_Lit (Ghdl_Compare_Eq), 2556 Std_Boolean_Type_Node); 2557 when Iir_Predefined_Array_Less => 2558 return New_Compare_Op 2559 (ON_Eq, 2560 Translate_Predefined_Lib_Operator (Left_Tree, Right_Tree, 2561 Imp), 2562 New_Lit (Ghdl_Compare_Lt), 2563 Std_Boolean_Type_Node); 2564 when Iir_Predefined_Array_Less_Equal => 2565 return New_Compare_Op 2566 (ON_Le, 2567 Translate_Predefined_Lib_Operator (Left_Tree, Right_Tree, 2568 Imp), 2569 New_Lit (Ghdl_Compare_Eq), 2570 Std_Boolean_Type_Node); 2571 2572 when Iir_Predefined_TF_Array_And 2573 | Iir_Predefined_TF_Array_Or 2574 | Iir_Predefined_TF_Array_Nand 2575 | Iir_Predefined_TF_Array_Nor 2576 | Iir_Predefined_TF_Array_Xor 2577 | Iir_Predefined_TF_Array_Xnor 2578 | Iir_Predefined_TF_Array_Not 2579 | Iir_Predefined_Array_Srl 2580 | Iir_Predefined_Array_Sra 2581 | Iir_Predefined_Array_Ror => 2582 return Translate_Predefined_Array_Operator_Convert 2583 (Left_Tree, Right_Tree, Imp, Res_Type); 2584 2585 when Iir_Predefined_Array_Sll 2586 | Iir_Predefined_Array_Sla 2587 | Iir_Predefined_Array_Rol => 2588 Right_Tree := New_Monadic_Op (ON_Neg_Ov, Right_Tree); 2589 return Translate_Predefined_Array_Operator_Convert 2590 (Left_Tree, Right_Tree, Imp, Res_Type); 2591 2592 when Iir_Predefined_Array_Array_Concat 2593 | Iir_Predefined_Element_Array_Concat 2594 | Iir_Predefined_Array_Element_Concat 2595 | Iir_Predefined_Element_Element_Concat => 2596 raise Internal_Error; 2597 2598 when Iir_Predefined_Endfile => 2599 return Translate_Lib_Operator 2600 (Left_Tree, O_Enode_Null, Ghdl_File_Endfile); 2601 2602 when Iir_Predefined_Now_Function => 2603 return New_Obj_Value (Ghdl_Now); 2604 2605 when Iir_Predefined_Std_Ulogic_Match_Equality => 2606 return Translate_Std_Ulogic_Match 2607 (Ghdl_Std_Ulogic_Match_Eq, 2608 Left_Tree, Right_Tree, Res_Otype); 2609 when Iir_Predefined_Std_Ulogic_Match_Inequality => 2610 return Translate_Std_Ulogic_Match 2611 (Ghdl_Std_Ulogic_Match_Ne, 2612 Left_Tree, Right_Tree, Res_Otype); 2613 when Iir_Predefined_Std_Ulogic_Match_Less => 2614 return Translate_Std_Ulogic_Match 2615 (Ghdl_Std_Ulogic_Match_Lt, 2616 Left_Tree, Right_Tree, Res_Otype); 2617 when Iir_Predefined_Std_Ulogic_Match_Less_Equal => 2618 return Translate_Std_Ulogic_Match 2619 (Ghdl_Std_Ulogic_Match_Le, 2620 Left_Tree, Right_Tree, Res_Otype); 2621 when Iir_Predefined_Std_Ulogic_Match_Greater => 2622 return Translate_Std_Ulogic_Match 2623 (Ghdl_Std_Ulogic_Match_Lt, 2624 Right_Tree, Left_Tree, Res_Otype); 2625 when Iir_Predefined_Std_Ulogic_Match_Greater_Equal => 2626 return Translate_Std_Ulogic_Match 2627 (Ghdl_Std_Ulogic_Match_Le, 2628 Right_Tree, Left_Tree, Res_Otype); 2629 2630 when Iir_Predefined_Bit_Array_Match_Equality => 2631 return New_Compare_Op 2632 (ON_Eq, 2633 Translate_Predefined_Lib_Operator 2634 (Left_Tree, Right_Tree, Imp), 2635 New_Lit (Std_Boolean_True_Node), 2636 Res_Otype); 2637 when Iir_Predefined_Bit_Array_Match_Inequality => 2638 return New_Compare_Op 2639 (ON_Eq, 2640 Translate_Predefined_Lib_Operator 2641 (Left_Tree, Right_Tree, Imp), 2642 New_Lit (Std_Boolean_False_Node), 2643 Res_Otype); 2644 2645 when Iir_Predefined_Array_Minimum => 2646 return Translate_Predefined_Array_Min_Max 2647 (True, Left_Tree, Right_Tree, Left_Type, Right_Type, 2648 Res_Type, Imp, Expr); 2649 when Iir_Predefined_Array_Maximum => 2650 return Translate_Predefined_Array_Min_Max 2651 (False, Left_Tree, Right_Tree, Left_Type, Right_Type, 2652 Res_Type, Imp, Expr); 2653 2654 when Iir_Predefined_Integer_To_String => 2655 case Get_Info (Left_Type).Type_Mode is 2656 when Type_Mode_I32 => 2657 return Translate_To_String 2658 (Ghdl_To_String_I32, Res_Type, Expr, 2659 New_Convert_Ov (Left_Tree, Ghdl_I32_Type)); 2660 when Type_Mode_I64 => 2661 return Translate_To_String 2662 (Ghdl_To_String_I64, Res_Type, Expr, 2663 New_Convert_Ov (Left_Tree, Ghdl_I64_Type)); 2664 when others => 2665 raise Internal_Error; 2666 end case; 2667 when Iir_Predefined_Enum_To_String => 2668 -- LRM08 5.7 String representations 2669 -- - For a given value of type CHARACTER, [...] 2670 -- 2671 -- So special case for character. 2672 if Get_Base_Type (Left_Type) = Character_Type_Definition then 2673 return Translate_To_String 2674 (Ghdl_To_String_Char, Res_Type, Expr, Left_Tree); 2675 end if; 2676 2677 -- LRM08 5.7 String representations 2678 -- - For a given value of type other than CHARACTER, [...] 2679 declare 2680 Conv : O_Tnode; 2681 Subprg : O_Dnode; 2682 begin 2683 case Get_Info (Left_Type).Type_Mode is 2684 when Type_Mode_B1 => 2685 Subprg := Ghdl_To_String_B1; 2686 Conv := Ghdl_Bool_Type; 2687 when Type_Mode_E8 => 2688 Subprg := Ghdl_To_String_E8; 2689 Conv := Ghdl_I32_Type; 2690 when Type_Mode_E32 => 2691 Subprg := Ghdl_To_String_E32; 2692 Conv := Ghdl_I32_Type; 2693 when others => 2694 raise Internal_Error; 2695 end case; 2696 return Translate_To_String 2697 (Subprg, Res_Type, Expr, 2698 New_Convert_Ov (Left_Tree, Conv), 2699 Rtis.New_Rti_Address (Get_Info (Left_Type).Type_Rti)); 2700 end; 2701 when Iir_Predefined_Floating_To_String => 2702 return Translate_To_String 2703 (Ghdl_To_String_F64, Res_Type, Expr, 2704 New_Convert_Ov (Left_Tree, Ghdl_Real_Type)); 2705 when Iir_Predefined_Real_To_String_Digits => 2706 return Translate_To_String 2707 (Ghdl_To_String_F64_Digits, Res_Type, Expr, 2708 New_Convert_Ov (Left_Tree, Ghdl_Real_Type), 2709 New_Convert_Ov (Right_Tree, Ghdl_I32_Type)); 2710 when Iir_Predefined_Real_To_String_Format => 2711 return Translate_To_String 2712 (Ghdl_To_String_F64_Format, Res_Type, Expr, 2713 New_Convert_Ov (Left_Tree, Ghdl_Real_Type), 2714 Right_Tree); 2715 when Iir_Predefined_Physical_To_String => 2716 declare 2717 Conv : O_Tnode; 2718 Subprg : O_Dnode; 2719 begin 2720 case Get_Info (Left_Type).Type_Mode is 2721 when Type_Mode_P32 => 2722 Subprg := Ghdl_To_String_P32; 2723 Conv := Ghdl_I32_Type; 2724 when Type_Mode_P64 => 2725 Subprg := Ghdl_To_String_P64; 2726 Conv := Ghdl_I64_Type; 2727 when others => 2728 raise Internal_Error; 2729 end case; 2730 return Translate_To_String 2731 (Subprg, Res_Type, Expr, 2732 New_Convert_Ov (Left_Tree, Conv), 2733 Rtis.New_Rti_Address (Get_Info (Left_Type).Type_Rti)); 2734 end; 2735 when Iir_Predefined_Time_To_String_Unit => 2736 return Translate_To_String 2737 (Ghdl_Time_To_String_Unit, Res_Type, Expr, 2738 Left_Tree, Right_Tree, 2739 Rtis.New_Rti_Address (Get_Info (Left_Type).Type_Rti)); 2740 when Iir_Predefined_Bit_Vector_To_Ostring => 2741 return Translate_Bv_To_String 2742 (Ghdl_BV_To_Ostring, Left_Tree, Left_Type, Res_Type, Expr); 2743 when Iir_Predefined_Bit_Vector_To_Hstring => 2744 return Translate_Bv_To_String 2745 (Ghdl_BV_To_Hstring, Left_Tree, Left_Type, Res_Type, Expr); 2746 when Iir_Predefined_Array_Char_To_String => 2747 declare 2748 El_Type : constant Iir := Get_Element_Subtype (Left_Type); 2749 Subprg : O_Dnode; 2750 Arg : Mnode; 2751 begin 2752 Arg := Stabilize 2753 (E2M (Left_Tree, Get_Info (Left_Type), Mode_Value)); 2754 case Get_Info (El_Type).Type_Mode is 2755 when Type_Mode_B1 => 2756 Subprg := Ghdl_Array_Char_To_String_B1; 2757 when Type_Mode_E8 => 2758 Subprg := Ghdl_Array_Char_To_String_E8; 2759 when Type_Mode_E32 => 2760 Subprg := Ghdl_Array_Char_To_String_E32; 2761 when others => 2762 raise Internal_Error; 2763 end case; 2764 return Translate_To_String 2765 (Subprg, Res_Type, Expr, 2766 New_Convert_Ov (M2E (Chap3.Get_Composite_Base (Arg)), 2767 Ghdl_Ptr_Type), 2768 Chap3.Get_Array_Length (Arg, Left_Type), 2769 Rtis.New_Rti_Address (Get_Info (El_Type).Type_Rti)); 2770 end; 2771 2772 when others => 2773 Error_Kind ("translate_predefined_operator(2)", Kind); 2774 end case; 2775 end Translate_Predefined_Operator; 2776 2777 -- Assign EXPR to TARGET. 2778 procedure Translate_Assign 2779 (Target : Mnode; Val : O_Enode; Expr : Iir; Target_Type : Iir; Loc : Iir) 2780 is 2781 T_Info : constant Type_Info_Acc := Get_Info (Target_Type); 2782 begin 2783 case T_Info.Type_Mode is 2784 when Type_Mode_Scalar => 2785 New_Assign_Stmt 2786 (M2Lv (Target), 2787 Chap3.Maybe_Insert_Scalar_Check (Val, Expr, Target_Type)); 2788 when Type_Mode_Acc 2789 | Type_Mode_Bounds_Acc 2790 | Type_Mode_File => 2791 New_Assign_Stmt (M2Lv (Target), Val); 2792 when Type_Mode_Unbounded_Array 2793 | Type_Mode_Unbounded_Record => 2794 declare 2795 T : Mnode; 2796 E : O_Dnode; 2797 EM : Mnode; 2798 begin 2799 T := Stabilize (Target); 2800 E := Create_Temp_Init 2801 (T_Info.Ortho_Ptr_Type (Mode_Value), Val); 2802 EM := Dp2M (E, T_Info, Mode_Value); 2803 Chap3.Check_Composite_Match 2804 (Target_Type, T, Get_Type (Expr), EM, Loc); 2805 Chap3.Translate_Object_Copy (T, EM, Target_Type); 2806 end; 2807 when Type_Mode_Bounded_Arrays 2808 | Type_Mode_Bounded_Records => 2809 -- Source is of type TARGET_TYPE, so no length check is 2810 -- necessary. 2811 Chap3.Translate_Object_Copy 2812 (Target, E2M (Val, T_Info, Mode_Value), Target_Type); 2813 when Type_Mode_Unknown 2814 | Type_Mode_Protected => 2815 raise Internal_Error; 2816 end case; 2817 end Translate_Assign; 2818 2819 procedure Translate_Assign (Target : Mnode; Expr : Iir; Target_Type : Iir) 2820 is 2821 Val : O_Enode; 2822 begin 2823 if Get_Kind (Expr) = Iir_Kind_Aggregate then 2824 -- FIXME: handle overlap between TARGET and EXPR. 2825 Translate_Aggregate (Target, Target_Type, Expr); 2826 else 2827 Open_Temp; 2828 Val := Chap7.Translate_Expression (Expr, Target_Type); 2829 Translate_Assign (Target, Val, Expr, Target_Type, Expr); 2830 Close_Temp; 2831 end if; 2832 end Translate_Assign; 2833 2834 -- If AGGR is of the form (others => (others => EXPR)) (where the 2835 -- number of (others => ) sub-aggregate is at least 1, return EXPR 2836 -- otherwise return NULL_IIR. 2837 function Is_Aggregate_Others (Aggr : Iir_Aggregate) return Iir 2838 is 2839 Chain : Iir; 2840 Aggr1 : Iir; 2841 begin 2842 Aggr1 := Aggr; 2843 loop 2844 Chain := Get_Association_Choices_Chain (Aggr1); 2845 if not Is_Chain_Length_One (Chain) then 2846 return Null_Iir; 2847 end if; 2848 if Get_Kind (Chain) /= Iir_Kind_Choice_By_Others then 2849 return Null_Iir; 2850 end if; 2851 Aggr1 := Get_Associated_Expr (Chain); 2852 case Get_Kind (Aggr1) is 2853 when Iir_Kind_Aggregate => 2854 if Get_Type (Aggr1) /= Null_Iir then 2855 -- Stop when a sub-aggregate is in fact an aggregate. 2856 return Aggr1; 2857 end if; 2858 when Iir_Kind_String_Literal8 => 2859 return Null_Iir; 2860 --Error_Kind ("is_aggregate_others", Aggr1); 2861 when others => 2862 return Aggr1; 2863 end case; 2864 end loop; 2865 end Is_Aggregate_Others; 2866 2867 -- Generate code for (others => EL). 2868 procedure Translate_Aggregate_Others 2869 (Target : Mnode; Target_Type : Iir; El : Iir) 2870 is 2871 Base_Ptr : Mnode; 2872 Info : Type_Info_Acc; 2873 It : O_Dnode; 2874 Len : O_Dnode; 2875 Len_Val : O_Enode; 2876 Label : O_Snode; 2877 Arr_Var : Mnode; 2878 El_Node : Mnode; 2879 begin 2880 Open_Temp; 2881 2882 Info := Get_Info (Target_Type); 2883 case Info.Type_Mode is 2884 when Type_Mode_Unbounded_Array => 2885 Arr_Var := Stabilize (Target); 2886 Base_Ptr := Stabilize (Chap3.Get_Composite_Base (Arr_Var)); 2887 Len_Val := Chap3.Get_Array_Length (Arr_Var, Target_Type); 2888 when Type_Mode_Bounded_Arrays => 2889 Base_Ptr := Stabilize (Chap3.Get_Composite_Base (Target)); 2890 Len_Val := Chap3.Get_Array_Type_Length (Target_Type); 2891 when others => 2892 raise Internal_Error; 2893 end case; 2894 -- FIXME: use this (since this use one variable instead of two): 2895 -- I := length; 2896 -- loop 2897 -- exit when I = 0; 2898 -- I := I - 1; 2899 -- A[I] := xxx; 2900 -- end loop; 2901 Len := Create_Temp_Init (Ghdl_Index_Type, Len_Val); 2902 if True then 2903 It := Create_Temp (Ghdl_Index_Type); 2904 else 2905 New_Var_Decl (It, Wki_I, O_Storage_Local, Ghdl_Index_Type); 2906 end if; 2907 Init_Var (It); 2908 Start_Loop_Stmt (Label); 2909 Gen_Exit_When 2910 (Label, New_Compare_Op (ON_Eq, 2911 New_Obj_Value (It), New_Obj_Value (Len), 2912 Ghdl_Bool_Type)); 2913 El_Node := Chap3.Index_Base (Base_Ptr, Target_Type, 2914 New_Obj_Value (It)); 2915 Translate_Assign (El_Node, El, Get_Element_Subtype (Target_Type)); 2916 Inc_Var (It); 2917 Finish_Loop_Stmt (Label); 2918 2919 Close_Temp; 2920 end Translate_Aggregate_Others; 2921 2922 procedure Translate_Array_Aggregate_Gen_String 2923 (Base_Ptr : Mnode; 2924 Aggr : Iir; 2925 Aggr_Type : Iir; 2926 Var_Index : O_Dnode) 2927 is 2928 Expr_Type : constant Iir := Get_Element_Subtype (Aggr_Type); 2929 Len : constant Nat32 := Get_String_Length (Aggr); 2930 2931 -- Type of the unconstrained array type. 2932 Arr_Type : O_Tnode; 2933 2934 Cst : Var_Type; 2935 Var_I : O_Dnode; 2936 Label : O_Snode; 2937 begin 2938 -- FIXME: check length is matching ? 2939 2940 -- Create a constant for the string. 2941 -- First, create its type, because the literal has no 2942 -- type (subaggregate). 2943 Arr_Type := New_Array_Type 2944 (Get_Ortho_Type (Expr_Type, Mode_Value), Ghdl_Index_Type); 2945 New_Type_Decl (Create_Uniq_Identifier, Arr_Type); 2946 Cst := Create_String_Literal_Var_Inner (Aggr, Expr_Type, Arr_Type); 2947 2948 -- Copy it. 2949 Open_Temp; 2950 Var_I := Create_Temp (Ghdl_Index_Type); 2951 Init_Var (Var_I); 2952 Start_Loop_Stmt (Label); 2953 Gen_Exit_When (Label, 2954 New_Compare_Op (ON_Eq, 2955 New_Obj_Value (Var_I), 2956 New_Lit (New_Index_Lit (Nat32'Pos (Len))), 2957 Ghdl_Bool_Type)); 2958 New_Assign_Stmt 2959 (M2Lv (Chap3.Index_Base (Base_Ptr, Aggr_Type, 2960 New_Obj_Value (Var_Index))), 2961 New_Value (New_Indexed_Element (Get_Var (Cst), 2962 New_Obj_Value (Var_I)))); 2963 Inc_Var (Var_I); 2964 Inc_Var (Var_Index); 2965 Finish_Loop_Stmt (Label); 2966 Close_Temp; 2967 end Translate_Array_Aggregate_Gen_String; 2968 2969 procedure Translate_Array_Aggregate_Gen (Base_Ptr : Mnode; 2970 Bounds_Ptr : Mnode; 2971 Aggr : Iir; 2972 Aggr_Type : Iir; 2973 Dim : Natural; 2974 Var_Index : O_Dnode) 2975 is 2976 Index_List : Iir_Flist; 2977 Expr_Type : Iir; 2978 Final : Boolean; 2979 2980 -- Assign EXPR to current position (defined by index VAR_INDEX), and 2981 -- update VAR_INDEX. Handles sub-aggregates. 2982 procedure Do_Assign (Assoc : Iir; Expr : Iir; Assoc_Len : out Int64) 2983 is 2984 Dest : Mnode; 2985 begin 2986 if Final then 2987 if Get_Element_Type_Flag (Assoc) then 2988 Dest := Chap3.Index_Base (Base_Ptr, Aggr_Type, 2989 New_Obj_Value (Var_Index)); 2990 Translate_Assign (Dest, Expr, Expr_Type); 2991 Assoc_Len := 1; 2992 Inc_Var (Var_Index); 2993 else 2994 Dest := Chap3.Slice_Base (Base_Ptr, Aggr_Type, 2995 New_Obj_Value (Var_Index), 2996 O_Enode_Null); 2997 Translate_Assign (Dest, Expr, Get_Type (Expr)); 2998 -- FIXME: handle non-static expression type (at least for 2999 -- choice by range). 3000 Assoc_Len := Eval_Discrete_Type_Length 3001 (Get_Index_Type (Get_Type (Expr), 0)); 3002 New_Assign_Stmt 3003 (New_Obj (Var_Index), 3004 New_Dyadic_Op 3005 (ON_Add_Ov, 3006 New_Obj_Value (Var_Index), 3007 New_Lit (New_Index_Lit (Unsigned_64 (Assoc_Len))))); 3008 end if; 3009 else 3010 Translate_Array_Aggregate_Gen 3011 (Base_Ptr, Bounds_Ptr, Expr, Aggr_Type, Dim + 1, Var_Index); 3012 Assoc_Len := 1; 3013 end if; 3014 end Do_Assign; 3015 3016 procedure Translate_Array_Aggregate_Gen_Positional 3017 is 3018 P : Natural; 3019 El : Iir; 3020 Assoc_Len : Int64; 3021 begin 3022 -- First, assign positionnal association. 3023 -- FIXME: count the number of positionnal association and generate 3024 -- an error if there is more positionnal association than elements 3025 -- in the array. 3026 El := Get_Association_Choices_Chain (Aggr); 3027 P := 0; 3028 loop 3029 exit when El = Null_Iir; 3030 exit when Get_Kind (El) /= Iir_Kind_Choice_By_None; 3031 Do_Assign (El, Get_Associated_Expr (El), Assoc_Len); 3032 P := P + Natural (Assoc_Len); 3033 El := Get_Chain (El); 3034 end loop; 3035 3036 -- End of chain. 3037 if El = Null_Iir then 3038 return; 3039 end if; 3040 3041 pragma Assert (Get_Kind (El) = Iir_Kind_Choice_By_Others); 3042 3043 -- Handle others. 3044 declare 3045 Var_Len : O_Dnode; 3046 Range_Ptr : Mnode; 3047 Label : O_Snode; 3048 Len_Tmp : O_Enode; 3049 begin 3050 Open_Temp; 3051 -- Create a loop from P to len. 3052 Var_Len := Create_Temp (Ghdl_Index_Type); 3053 3054 Range_Ptr := Chap3.Bounds_To_Range (Bounds_Ptr, Aggr_Type, Dim); 3055 Len_Tmp := M2E (Chap3.Range_To_Length (Range_Ptr)); 3056 if P /= 0 then 3057 Len_Tmp := New_Dyadic_Op 3058 (ON_Sub_Ov, 3059 Len_Tmp, New_Lit (New_Index_Lit (Unsigned_64 (P)))); 3060 end if; 3061 New_Assign_Stmt (New_Obj (Var_Len), Len_Tmp); 3062 3063 -- Start loop. 3064 Start_Loop_Stmt (Label); 3065 -- Check if end of loop. 3066 Gen_Exit_When 3067 (Label, 3068 New_Compare_Op (ON_Eq, 3069 New_Obj_Value (Var_Len), 3070 New_Lit (Ghdl_Index_0), 3071 Ghdl_Bool_Type)); 3072 3073 Do_Assign (El, Get_Associated_Expr (El), Assoc_Len); 3074 pragma Assert (Assoc_Len = 1); 3075 Dec_Var (Var_Len); 3076 Finish_Loop_Stmt (Label); 3077 Close_Temp; 3078 end; 3079 end Translate_Array_Aggregate_Gen_Positional; 3080 3081 procedure Translate_Array_Aggregate_Gen_Named 3082 is 3083 El : Iir; 3084 Assoc_Len : Int64; 3085 begin 3086 El := Get_Association_Choices_Chain (Aggr); 3087 3088 -- Then, assign named or others association. 3089 if Is_Chain_Length_One (El) then 3090 pragma Assert (Get_Info (El) = null); 3091 -- There is only one choice 3092 case Get_Kind (El) is 3093 when Iir_Kind_Choice_By_Others => 3094 -- Handled by positional. 3095 raise Internal_Error; 3096 when Iir_Kind_Choice_By_Expression => 3097 Do_Assign (El, Get_Associated_Expr (El), Assoc_Len); 3098 return; 3099 when Iir_Kind_Choice_By_Range => 3100 -- FIXME: todo. 3101 pragma Assert (Get_Element_Type_Flag (El)); 3102 declare 3103 Var_Length : O_Dnode; 3104 Var_I : O_Dnode; 3105 Label : O_Snode; 3106 begin 3107 Open_Temp; 3108 Var_Length := Create_Temp_Init 3109 (Ghdl_Index_Type, 3110 Chap7.Translate_Range_Length (Get_Choice_Range (El))); 3111 Var_I := Create_Temp (Ghdl_Index_Type); 3112 Init_Var (Var_I); 3113 Start_Loop_Stmt (Label); 3114 Gen_Exit_When (Label, 3115 New_Compare_Op (ON_Eq, 3116 New_Obj_Value (Var_I), 3117 New_Obj_Value (Var_Length), 3118 Ghdl_Bool_Type)); 3119 Do_Assign (El, Get_Associated_Expr (El), Assoc_Len); 3120 Inc_Var (Var_I); 3121 Finish_Loop_Stmt (Label); 3122 Close_Temp; 3123 end; 3124 return; 3125 when others => 3126 Error_Kind ("translate_array_aggregate_gen", El); 3127 end case; 3128 end if; 3129 3130 -- Several choices.. 3131 declare 3132 Range_Type : constant Iir := 3133 Get_Base_Type (Get_Index_Type (Index_List, Dim - 1)); 3134 Rtinfo : constant Type_Info_Acc := Get_Info (Range_Type); 3135 Var_Pos : O_Dnode; 3136 Var_Len : O_Dnode; 3137 Var_Alen : O_Dnode; 3138 Range_Ptr : Mnode; 3139 If_Blk : O_If_Block; 3140 Case_Blk : O_Case_Block; 3141 Label : O_Snode; 3142 Len_Tmp : O_Enode; 3143 Expr : Iir; 3144 begin 3145 Open_Temp; 3146 -- Create a loop from left +- number of positionnals associations 3147 -- to/downto right. 3148 Var_Pos := Create_Temp (Rtinfo.Ortho_Type (Mode_Value)); 3149 Range_Ptr := Stabilize 3150 (Chap3.Bounds_To_Range (Bounds_Ptr, Aggr_Type, Dim)); 3151 New_Assign_Stmt (New_Obj (Var_Pos), 3152 M2E (Chap3.Range_To_Left (Range_Ptr))); 3153 3154 Var_Len := Create_Temp (Ghdl_Index_Type); 3155 Len_Tmp := M2E (Chap3.Range_To_Length (Range_Ptr)); 3156 New_Assign_Stmt (New_Obj (Var_Len), Len_Tmp); 3157 3158 Var_Alen := Create_Temp (Ghdl_Index_Type); 3159 3160 -- Start loop. 3161 Start_Loop_Stmt (Label); 3162 -- Check if end of loop. 3163 Gen_Exit_When (Label, 3164 New_Compare_Op (ON_Eq, 3165 New_Obj_Value (Var_Len), 3166 New_Lit (Ghdl_Index_0), 3167 Ghdl_Bool_Type)); 3168 3169 -- convert aggr into a case statement. 3170 Start_Case_Stmt (Case_Blk, New_Obj_Value (Var_Pos)); 3171 while El /= Null_Iir loop 3172 -- No Expr_Eval. 3173 pragma Assert (Get_Info (El) = null); 3174 3175 Start_Choice (Case_Blk); 3176 Chap8.Translate_Case_Choice (El, Range_Type, Case_Blk); 3177 Finish_Choice (Case_Blk); 3178 if not Get_Same_Alternative_Flag (El) then 3179 Expr := Get_Associated_Expr (El); 3180 end if; 3181 Do_Assign (El, Expr, Assoc_Len); 3182 New_Assign_Stmt 3183 (New_Obj (Var_Alen), 3184 New_Lit (New_Index_Lit (Unsigned_64 (Assoc_Len)))); 3185 El := Get_Chain (El); 3186 end loop; 3187 Finish_Case_Stmt (Case_Blk); 3188 -- Update var_pos 3189 Start_If_Stmt 3190 (If_Blk, 3191 New_Compare_Op (ON_Eq, 3192 M2E (Chap3.Range_To_Dir (Range_Ptr)), 3193 New_Lit (Ghdl_Dir_To_Node), 3194 Ghdl_Bool_Type)); 3195 New_Assign_Stmt 3196 (New_Obj (Var_Pos), 3197 New_Dyadic_Op 3198 (ON_Add_Ov, 3199 New_Obj_Value (Var_Pos), 3200 New_Convert_Ov (New_Obj_Value (Var_Alen), 3201 Rtinfo.Ortho_Type (Mode_Value)))); 3202 New_Else_Stmt (If_Blk); 3203 New_Assign_Stmt 3204 (New_Obj (Var_Pos), 3205 New_Dyadic_Op 3206 (ON_Sub_Ov, 3207 New_Obj_Value (Var_Pos), 3208 New_Convert_Ov (New_Obj_Value (Var_Alen), 3209 Rtinfo.Ortho_Type (Mode_Value)))); 3210 Finish_If_Stmt (If_Blk); 3211 -- Update var_len. 3212 New_Assign_Stmt (New_Obj (Var_Len), 3213 New_Dyadic_Op (ON_Sub_Ov, 3214 New_Obj_Value (Var_Len), 3215 New_Obj_Value (Var_Alen))); 3216 Finish_Loop_Stmt (Label); 3217 Close_Temp; 3218 end; 3219 end Translate_Array_Aggregate_Gen_Named; 3220 3221 Assocs : Iir; 3222 begin 3223 if Get_Kind (Aggr) = Iir_Kind_String_Literal8 then 3224 Translate_Array_Aggregate_Gen_String 3225 (Base_Ptr, Aggr, Aggr_Type, Var_Index); 3226 return; 3227 end if; 3228 3229 pragma Assert (Get_Kind (Aggr) = Iir_Kind_Aggregate); 3230 3231 Index_List := Get_Index_Subtype_List (Aggr_Type); 3232 3233 -- FINAL is true if the elements of the aggregate are elements of 3234 -- the array. 3235 if Get_Nbr_Elements (Index_List) = Dim then 3236 Expr_Type := Get_Element_Subtype (Aggr_Type); 3237 Final:= True; 3238 else 3239 Final := False; 3240 end if; 3241 3242 Assocs := Get_Association_Choices_Chain (Aggr); 3243 3244 case Get_Kind (Assocs) is 3245 when Iir_Kind_Choice_By_None 3246 | Iir_Kind_Choice_By_Others => 3247 Translate_Array_Aggregate_Gen_Positional; 3248 when others => 3249 Translate_Array_Aggregate_Gen_Named; 3250 end case; 3251 end Translate_Array_Aggregate_Gen; 3252 3253 procedure Translate_Record_Aggregate 3254 (Target : Mnode; Target_Type : Iir; Aggr : Iir) 3255 is 3256 El_List : constant Iir_Flist := 3257 Get_Elements_Declaration_List (Target_Type); 3258 El_Index : Natural; 3259 Nbr_El : constant Natural := Get_Nbr_Elements (El_List); 3260 3261 -- Record which elements of the record have been set. The 'others' 3262 -- clause applies to all elements not already set. 3263 type Bool_Array_Type is array (0 .. Nbr_El - 1) of Boolean; 3264 pragma Pack (Bool_Array_Type); 3265 Set_Array : Bool_Array_Type := (others => False); 3266 3267 -- The expression associated. 3268 El_Expr : Iir; 3269 Assoc : Iir; 3270 Targ : Mnode; 3271 3272 -- Set an elements. 3273 procedure Set_El (El : Iir_Element_Declaration) 3274 is 3275 Info : constant Ortho_Info_Acc := Get_Info (Assoc); 3276 El_Type : constant Iir := Get_Type (El); 3277 Dest : Mnode; 3278 begin 3279 Dest := Chap6.Translate_Selected_Element (Targ, El); 3280 if Info /= null then 3281 -- The expression was already evaluated to compute the bounds. 3282 -- Just copy it. 3283 Chap3.Translate_Object_Copy (Dest, Info.Expr_Eval, El_Type); 3284 Clear_Info (Assoc); 3285 else 3286 Translate_Assign (Dest, El_Expr, El_Type); 3287 end if; 3288 Set_Array (Natural (Get_Element_Position (El))) := True; 3289 end Set_El; 3290 3291 N_El_Expr : Iir; 3292 begin 3293 Open_Temp; 3294 Targ := Stabilize (Target); 3295 3296 El_Index := 0; 3297 Assoc := Get_Association_Choices_Chain (Aggr); 3298 while Assoc /= Null_Iir loop 3299 -- Get the associated expression, possibly from the first choice 3300 -- in a lidt of choices. 3301 N_El_Expr := Get_Associated_Expr (Assoc); 3302 if N_El_Expr /= Null_Iir then 3303 El_Expr := N_El_Expr; 3304 end if; 3305 3306 case Get_Kind (Assoc) is 3307 when Iir_Kind_Choice_By_None => 3308 Set_El (Get_Nth_Element (El_List, El_Index)); 3309 El_Index := El_Index + 1; 3310 when Iir_Kind_Choice_By_Name => 3311 El_Index := Natural 3312 (Get_Element_Position 3313 (Get_Named_Entity (Get_Choice_Name (Assoc)))); 3314 Set_El (Get_Nth_Element (El_List, El_Index)); 3315 El_Index := Natural'Last; 3316 when Iir_Kind_Choice_By_Others => 3317 for J in Set_Array'Range loop 3318 if not Set_Array (J) then 3319 Set_El (Get_Nth_Element (El_List, J)); 3320 end if; 3321 end loop; 3322 when others => 3323 Error_Kind ("translate_record_aggregate", Assoc); 3324 end case; 3325 Assoc := Get_Chain (Assoc); 3326 end loop; 3327 Close_Temp; 3328 end Translate_Record_Aggregate; 3329 3330 procedure Translate_Array_Aggregate 3331 (Target : Mnode; Target_Type : Iir; Aggr : Iir) 3332 is 3333 Aggr_Type : constant Iir := Get_Type (Aggr); 3334 Index_List : constant Iir_Flist := 3335 Get_Index_Subtype_List (Aggr_Type); 3336 Targ_Index_List : constant Iir_Flist := 3337 Get_Index_Subtype_List (Target_Type); 3338 3339 Aggr_Info : Iir_Aggregate_Info; 3340 Base : Mnode; 3341 Bounds : Mnode; 3342 Var_Index : O_Dnode; 3343 Targ : Mnode; 3344 3345 Rinfo : Type_Info_Acc; 3346 Bt : Iir; 3347 3348 -- Generate code for: (LVAL lop RNG.left) or (RVAL rop RNG.right) 3349 function Check_Value (Lval : Iir; 3350 Lop : ON_Op_Kind; 3351 Rval : Iir; 3352 Rop : ON_Op_Kind; 3353 Rng : Mnode) 3354 return O_Enode 3355 is 3356 L, R : O_Enode; 3357 begin 3358 L := New_Compare_Op 3359 (Lop, 3360 New_Lit (Translate_Static_Expression (Lval, Bt)), 3361 M2E (Chap3.Range_To_Left (Rng)), 3362 Ghdl_Bool_Type); 3363 R := New_Compare_Op 3364 (Rop, 3365 New_Lit (Translate_Static_Expression (Rval, Bt)), 3366 M2E (Chap3.Range_To_Right (Rng)), 3367 Ghdl_Bool_Type); 3368 return New_Dyadic_Op (ON_Or, L, R); 3369 end Check_Value; 3370 3371 Range_Ptr : Mnode; 3372 Subtarg_Type : Iir; 3373 Subaggr_Type : Iir; 3374 L, H : Iir; 3375 Min : Iir_Int32; 3376 Has_Others : Boolean; 3377 3378 Var_Err : O_Dnode; 3379 E : O_Enode; 3380 If_Blk : O_If_Block; 3381 Op : ON_Op_Kind; 3382 begin 3383 Open_Temp; 3384 Targ := Stabilize (Target); 3385 Base := Stabilize (Chap3.Get_Composite_Base (Targ)); 3386 Bounds := Stabilize (Chap3.Get_Composite_Bounds (Targ)); 3387 Aggr_Info := Get_Aggregate_Info (Aggr); 3388 3389 -- Check type 3390 for I in Flist_First .. Flist_Last (Index_List) loop 3391 Subaggr_Type := Get_Index_Type (Index_List, I); 3392 Subtarg_Type := Get_Index_Type (Targ_Index_List, I); 3393 3394 Bt := Get_Base_Type (Subaggr_Type); 3395 Rinfo := Get_Info (Bt); 3396 3397 if Get_Aggr_Dynamic_Flag (Aggr_Info) then 3398 -- Dynamic range, must evaluate it. 3399 Open_Temp; 3400 declare 3401 A_Range : Mnode; 3402 begin 3403 -- Evaluate the range. 3404 Chap3.Translate_Anonymous_Subtype_Definition 3405 (Subaggr_Type, False); 3406 3407 A_Range := 3408 Dv2M (Create_Temp (Rinfo.B.Range_Type), Rinfo, Mode_Value, 3409 Rinfo.B.Range_Type, Rinfo.B.Range_Ptr_Type); 3410 Chap7.Translate_Range 3411 (A_Range, Get_Range_Constraint (Subaggr_Type), Subaggr_Type); 3412 3413 -- Check range length VS target length. 3414 Chap6.Check_Bound_Error 3415 (New_Compare_Op 3416 (ON_Neq, 3417 M2E (Chap3.Range_To_Length (A_Range)), 3418 M2E (Chap3.Range_To_Length 3419 (Chap3.Bounds_To_Range 3420 (Bounds, Target_Type, I + 1))), 3421 Ghdl_Bool_Type), 3422 Aggr); 3423 end; 3424 Close_Temp; 3425 elsif Get_Type_Staticness (Subaggr_Type) /= Locally 3426 or else Subaggr_Type /= Subtarg_Type 3427 then 3428 -- Note: if the aggregate has no others, then the bounds 3429 -- must be the same, otherwise, aggregate bounds must be 3430 -- inside type bounds. 3431 Has_Others := Get_Aggr_Others_Flag (Aggr_Info); 3432 Min := Get_Aggr_Min_Length (Aggr_Info); 3433 L := Get_Aggr_Low_Limit (Aggr_Info); 3434 3435 if Min > 0 or L /= Null_Iir then 3436 Open_Temp; 3437 3438 -- Pointer to the range. 3439 Range_Ptr := Stabilize 3440 (Chap3.Bounds_To_Range (Bounds, Target_Type, I + 1)); 3441 Var_Err := Create_Temp (Ghdl_Bool_Type); 3442 H := Get_Aggr_High_Limit (Aggr_Info); 3443 3444 if L /= Null_Iir then 3445 -- Check the index range of the aggregrate is equal 3446 -- (or within in presence of 'others') the index range 3447 -- of the target. 3448 Start_If_Stmt 3449 (If_Blk, 3450 New_Compare_Op (ON_Eq, 3451 M2E (Chap3.Range_To_Dir (Range_Ptr)), 3452 New_Lit (Ghdl_Dir_To_Node), 3453 Ghdl_Bool_Type)); 3454 if Has_Others then 3455 E := Check_Value (L, ON_Lt, H, ON_Gt, Range_Ptr); 3456 else 3457 E := Check_Value (L, ON_Neq, H, ON_Neq, Range_Ptr); 3458 end if; 3459 New_Assign_Stmt (New_Obj (Var_Err), E); 3460 New_Else_Stmt (If_Blk); 3461 if Has_Others then 3462 E := Check_Value (H, ON_Gt, L, ON_Lt, Range_Ptr); 3463 else 3464 E := Check_Value (H, ON_Neq, L, ON_Neq, Range_Ptr); 3465 end if; 3466 New_Assign_Stmt (New_Obj (Var_Err), E); 3467 Finish_If_Stmt (If_Blk); 3468 -- If L and H are greather than the minimum length, 3469 -- then there is no need to check with min. 3470 if Iir_Int32 (Eval_Pos (H) - Eval_Pos (L) + 1) >= Min then 3471 Min := 0; 3472 end if; 3473 end if; 3474 3475 if Min > 0 then 3476 -- Check the number of elements is equal (or less in 3477 -- presence of 'others') than the length of the index 3478 -- range of the target. 3479 if Has_Others then 3480 Op := ON_Lt; 3481 else 3482 Op := ON_Neq; 3483 end if; 3484 E := New_Compare_Op 3485 (Op, 3486 M2E (Chap3.Range_To_Length (Range_Ptr)), 3487 New_Lit (New_Unsigned_Literal (Ghdl_Index_Type, 3488 Unsigned_64 (Min))), 3489 Ghdl_Bool_Type); 3490 if L /= Null_Iir then 3491 E := New_Dyadic_Op (ON_Or, E, New_Obj_Value (Var_Err)); 3492 end if; 3493 New_Assign_Stmt (New_Obj (Var_Err), E); 3494 end if; 3495 Chap6.Check_Bound_Error (New_Obj_Value (Var_Err), Aggr); 3496 Close_Temp; 3497 end if; 3498 end if; 3499 3500 -- Next dimension. 3501 Aggr_Info := Get_Sub_Aggregate_Info (Aggr_Info); 3502 end loop; 3503 3504 Var_Index := Create_Temp_Init 3505 (Ghdl_Index_Type, New_Lit (Ghdl_Index_0)); 3506 Translate_Array_Aggregate_Gen 3507 (Base, Bounds, Aggr, Target_Type, 1, Var_Index); 3508 Close_Temp; 3509 3510 -- FIXME: creating aggregate subtype is expensive and rarely used. 3511 -- (one of the current use - only ? - is check_array_match). 3512 Chap3.Translate_Anonymous_Subtype_Definition (Aggr_Type, False); 3513 end Translate_Array_Aggregate; 3514 3515 procedure Translate_Aggregate 3516 (Target : Mnode; Target_Type : Iir; Aggr : Iir) is 3517 begin 3518 case Iir_Kinds_Composite_Type_Definition (Get_Kind (Target_Type)) is 3519 when Iir_Kind_Array_Subtype_Definition 3520 | Iir_Kind_Array_Type_Definition => 3521 declare 3522 El : Iir; 3523 begin 3524 El := Is_Aggregate_Others (Aggr); 3525 if El /= Null_Iir then 3526 Translate_Aggregate_Others (Target, Target_Type, El); 3527 else 3528 Translate_Array_Aggregate (Target, Target_Type, Aggr); 3529 end if; 3530 end; 3531 when Iir_Kind_Record_Type_Definition 3532 | Iir_Kind_Record_Subtype_Definition => 3533 Translate_Record_Aggregate (Target, Target_Type, Aggr); 3534 end case; 3535 end Translate_Aggregate; 3536 3537 procedure Translate_Aggregate_Sub_Bounds (Bounds : Mnode; Aggr : Iir); 3538 3539 procedure Translate_Array_Aggregate_Bounds (Bounds : Mnode; Aggr : Iir) 3540 is 3541 Aggr_Type : constant Iir := Get_Type (Aggr); 3542 Assoc : Iir; 3543 Static_Len : Int64; 3544 Var_Len : O_Dnode; 3545 Expr_Type : Iir; 3546 Range_Type : Iir; 3547 begin 3548 Static_Len := 0; 3549 3550 -- First pass: static length. 3551 Assoc := Get_Association_Choices_Chain (Aggr); 3552 while Assoc /= Null_Iir loop 3553 pragma Assert (Get_Kind (Assoc) = Iir_Kind_Choice_By_None); 3554 if Get_Element_Type_Flag (Assoc) then 3555 Static_Len := Static_Len + 1; 3556 else 3557 Expr_Type := Get_Type (Get_Associated_Expr (Assoc)); 3558 pragma Assert (Is_One_Dimensional_Array_Type (Expr_Type)); 3559 if Get_Constraint_State (Expr_Type) = Fully_Constrained then 3560 Range_Type := Get_Index_Type (Expr_Type, 0); 3561 if Get_Type_Staticness (Range_Type) = Locally then 3562 Static_Len := 3563 Static_Len + Eval_Discrete_Type_Length (Range_Type); 3564 end if; 3565 else 3566 raise Internal_Error; 3567 end if; 3568 end if; 3569 Assoc := Get_Chain (Assoc); 3570 end loop; 3571 3572 -- Second pass: non-static length. 3573 Var_Len := Create_Temp (Ghdl_Index_Type); 3574 New_Assign_Stmt (New_Obj (Var_Len), 3575 New_Lit (New_Index_Lit (Unsigned_64 (Static_Len)))); 3576 Assoc := Get_Association_Choices_Chain (Aggr); 3577 while Assoc /= Null_Iir loop 3578 pragma Assert (Get_Kind (Assoc) = Iir_Kind_Choice_By_None); 3579 if not Get_Element_Type_Flag (Assoc) then 3580 Expr_Type := Get_Type (Get_Associated_Expr (Assoc)); 3581 if Get_Constraint_State (Expr_Type) = Fully_Constrained then 3582 Range_Type := Get_Index_Type (Expr_Type, 0); 3583 if Get_Type_Staticness (Range_Type) /= Locally then 3584 declare 3585 Bnd : Mnode; 3586 L : Mnode; 3587 begin 3588 Bnd := Chap3.Get_Composite_Type_Bounds (Expr_Type); 3589 3590 L := Chap3.Range_To_Length 3591 (Chap3.Bounds_To_Range (Bnd, Expr_Type, 1)); 3592 New_Assign_Stmt 3593 (New_Obj (Var_Len), 3594 New_Dyadic_Op (ON_Add_Ov, 3595 New_Obj_Value (Var_Len), M2E (L))); 3596 end; 3597 end if; 3598 else 3599 raise Internal_Error; 3600 end if; 3601 end if; 3602 Assoc := Get_Chain (Assoc); 3603 end loop; 3604 3605 Chap3.Create_Range_From_Length 3606 (Get_Index_Type (Aggr_Type, 0), Var_Len, 3607 Chap3.Bounds_To_Range (Bounds, Aggr_Type, 1), Aggr); 3608 end Translate_Array_Aggregate_Bounds; 3609 3610 procedure Translate_Record_Aggregate_Bounds (Bounds : Mnode; Aggr : Iir) 3611 is 3612 Stable_Bounds : Mnode; 3613 Aggr_Type : constant Iir := Get_Type (Aggr); 3614 Base_El_List : constant Iir_Flist := 3615 Get_Elements_Declaration_List (Get_Base_Type (Aggr_Type)); 3616 3617 Pos : Natural; 3618 Base_El : Iir; 3619 Base_El_Type : Iir; 3620 3621 Others_Assoc : Iir; 3622 Assoc : Iir; 3623 3624 Expr : Iir; 3625 Expr_Type : Iir; 3626 Val : Mnode; 3627 Info : Ortho_Info_Acc; 3628 begin 3629 Stable_Bounds := Stabilize (Bounds); 3630 3631 Others_Assoc := Null_Iir; 3632 Pos := 0; 3633 Assoc := Get_Association_Choices_Chain (Aggr); 3634 while Assoc /= Null_Iir loop 3635 case Iir_Kinds_Record_Choice (Get_Kind (Assoc)) is 3636 when Iir_Kind_Choice_By_Others => 3637 Others_Assoc := Assoc; 3638 pragma Assert (Get_Chain (Assoc) = Null_Iir); 3639 exit; 3640 when Iir_Kind_Choice_By_None => 3641 null; 3642 when Iir_Kind_Choice_By_Name => 3643 pragma Assert 3644 (Get_Element_Position 3645 (Get_Named_Entity 3646 (Get_Choice_Name (Assoc))) = Iir_Index32 (Pos)); 3647 null; 3648 end case; 3649 Base_El := Get_Nth_Element (Base_El_List, Pos); 3650 Base_El_Type := Get_Type (Base_El); 3651 if Is_Unbounded_Type (Get_Info (Base_El_Type)) then 3652 -- There are corresponding bounds. 3653 Expr := Get_Associated_Expr (Assoc); 3654 Expr_Type := Get_Type (Expr); 3655 if False 3656 and then Get_Constraint_State (Expr_Type) = Fully_Constrained 3657 then 3658 -- Translate subtype, and copy bounds. 3659 raise Internal_Error; 3660 else 3661 if Get_Kind (Expr) = Iir_Kind_Aggregate then 3662 -- Just translate bounds. 3663 Translate_Aggregate_Sub_Bounds 3664 (Chap3.Record_Bounds_To_Element_Bounds 3665 (Stable_Bounds, Base_El), 3666 Expr); 3667 else 3668 -- Eval expr 3669 Val := Translate_Expression (Expr); 3670 Val := Stabilize (Val); 3671 Info := Add_Info (Assoc, Kind_Expr_Eval); 3672 Info.Expr_Eval := Val; 3673 3674 -- Copy bounds. 3675 Chap3.Copy_Bounds 3676 (Chap3.Record_Bounds_To_Element_Bounds 3677 (Stable_Bounds, Base_El), 3678 Chap3.Get_Composite_Bounds (Val), Expr_Type); 3679 end if; 3680 end if; 3681 end if; 3682 3683 Pos := Pos + 1; 3684 Assoc := Get_Chain (Assoc); 3685 end loop; 3686 pragma Assert (Others_Assoc = Null_Iir); -- TODO 3687 end Translate_Record_Aggregate_Bounds; 3688 3689 -- Just create the bounds from AGGR. 3690 procedure Translate_Aggregate_Sub_Bounds (Bounds : Mnode; Aggr : Iir) 3691 is 3692 Aggr_Type : constant Iir := Get_Type (Aggr); 3693 begin 3694 case Iir_Kinds_Composite_Type_Definition (Get_Kind (Aggr_Type)) is 3695 when Iir_Kind_Array_Type_Definition 3696 | Iir_Kind_Array_Subtype_Definition => 3697 Translate_Array_Aggregate_Bounds (Bounds, Aggr); 3698 when Iir_Kind_Record_Type_Definition 3699 | Iir_Kind_Record_Subtype_Definition => 3700 Translate_Record_Aggregate_Bounds (Bounds, Aggr); 3701 end case; 3702 end Translate_Aggregate_Sub_Bounds; 3703 3704 -- Create the bounds and build the type (set size). 3705 procedure Translate_Aggregate_Bounds (Bounds : Mnode; Aggr : Iir) 3706 is 3707 Aggr_Type : constant Iir := Get_Type (Aggr); 3708 begin 3709 case Iir_Kinds_Composite_Type_Definition (Get_Kind (Aggr_Type)) is 3710 when Iir_Kind_Array_Type_Definition 3711 | Iir_Kind_Array_Subtype_Definition => 3712 Translate_Array_Aggregate_Bounds (Bounds, Aggr); 3713 declare 3714 El_Type : constant Iir := Get_Element_Subtype (Aggr_Type); 3715 begin 3716 -- The array aggregate may be unbounded simply because the 3717 -- indexes are not known but its element is bounded. 3718 if Is_Unbounded_Type (Get_Info (El_Type)) then 3719 Chap3.Gen_Call_Type_Builder 3720 (Chap3.Array_Bounds_To_Element_Layout (Bounds, Aggr_Type), 3721 El_Type, Mode_Value); 3722 end if; 3723 end; 3724 when Iir_Kind_Record_Type_Definition 3725 | Iir_Kind_Record_Subtype_Definition => 3726 Translate_Record_Aggregate_Bounds (Bounds, Aggr); 3727 Chap3.Gen_Call_Type_Builder (Bounds, Aggr_Type, Mode_Value); 3728 end case; 3729 end Translate_Aggregate_Bounds; 3730 3731 function Translate_Allocator_By_Expression (Expr : Iir) return O_Enode 3732 is 3733 -- TODO: the constraint from an access subtype is ignored. 3734 A_Type : constant Iir := Get_Base_Type (Get_Type (Expr)); 3735 A_Info : constant Type_Info_Acc := Get_Info (A_Type); 3736 D_Type : constant Iir := Get_Designated_Type (A_Type); 3737 D_Info : constant Type_Info_Acc := Get_Info (D_Type); 3738 Val : O_Enode; 3739 R : Mnode; 3740 begin 3741 -- Compute the expression. 3742 Val := Translate_Expression (Get_Expression (Expr), D_Type); 3743 3744 -- Allocate memory for the object. 3745 case A_Info.Type_Mode is 3746 when Type_Mode_Bounds_Acc => 3747 declare 3748 Res : O_Dnode; 3749 Val_Size : O_Dnode; 3750 Bounds_Size : O_Cnode; 3751 Val_M : Mnode; 3752 begin 3753 Res := Create_Temp (A_Info.Ortho_Type (Mode_Value)); 3754 Val_M := Stabilize (E2M (Val, D_Info, Mode_Value)); 3755 3756 -- Size of the value (object without the bounds). 3757 Val_Size := Create_Temp_Init 3758 (Ghdl_Index_Type, 3759 Chap3.Get_Subtype_Size 3760 (D_Type, Chap3.Get_Composite_Bounds (Val_M), Mode_Value)); 3761 3762 -- Size of the bounds. 3763 Bounds_Size := 3764 New_Sizeof (D_Info.B.Bounds_Type, Ghdl_Index_Type); 3765 3766 -- Allocate the object. 3767 New_Assign_Stmt 3768 (New_Obj (Res), 3769 Gen_Alloc (Alloc_Heap, 3770 New_Dyadic_Op 3771 (ON_Add_Ov, 3772 New_Lit (Bounds_Size), 3773 New_Obj_Value (Val_Size)), 3774 A_Info.Ortho_Type (Mode_Value))); 3775 3776 -- Copy bounds. 3777 Gen_Memcpy 3778 (New_Obj_Value (Res), 3779 M2Addr (Chap3.Get_Composite_Bounds (Val_M)), 3780 New_Lit (Bounds_Size)); 3781 3782 -- Copy values. 3783 Gen_Memcpy 3784 (Chap3.Get_Bounds_Acc_Base (New_Obj_Value (Res), D_Type), 3785 M2Addr (Chap3.Get_Composite_Base (Val_M)), 3786 New_Obj_Value (Val_Size)); 3787 3788 return New_Obj_Value (Res); 3789 end; 3790 when Type_Mode_Acc => 3791 R := Dp2M (Create_Temp (D_Info.Ortho_Ptr_Type (Mode_Value)), 3792 D_Info, Mode_Value); 3793 Chap3.Translate_Object_Allocation 3794 (R, Alloc_Heap, D_Type, Mnode_Null); 3795 Chap3.Translate_Object_Copy 3796 (R, E2M (Val, D_Info, Mode_Value), D_Type); 3797 return New_Convert_Ov (M2Addr (R), A_Info.Ortho_Type (Mode_Value)); 3798 when others => 3799 raise Internal_Error; 3800 end case; 3801 end Translate_Allocator_By_Expression; 3802 3803 function Bounds_Acc_To_Fat_Pointer (Ptr : O_Dnode; Acc_Type : Iir) 3804 return Mnode 3805 is 3806 D_Type : constant Iir := 3807 Get_Designated_Type (Get_Base_Type (Acc_Type)); 3808 D_Info : constant Type_Info_Acc := Get_Info (D_Type); 3809 Res : Mnode; 3810 begin 3811 Res := Dv2M (Create_Temp (D_Info.Ortho_Type (Mode_Value)), 3812 D_Info, Mode_Value); 3813 3814 New_Assign_Stmt 3815 (M2Lp (Chap3.Get_Composite_Bounds (Res)), 3816 New_Convert_Ov (New_Obj_Value (Ptr), D_Info.B.Bounds_Ptr_Type)); 3817 New_Assign_Stmt 3818 (M2Lp (Chap3.Get_Composite_Base (Res)), 3819 Chap3.Get_Bounds_Acc_Base (New_Obj_Value (Ptr), D_Type)); 3820 return Res; 3821 end Bounds_Acc_To_Fat_Pointer; 3822 3823 function Translate_Allocator_By_Subtype (Expr : Iir) return O_Enode 3824 is 3825 A_Type : constant Iir := Get_Type (Expr); 3826 A_Info : constant Type_Info_Acc := Get_Info (A_Type); 3827 D_Type : constant Iir := Get_Designated_Type (A_Type); 3828 D_Info : constant Type_Info_Acc := Get_Info (D_Type); 3829 Bounds : Mnode; 3830 Res : Mnode; 3831 begin 3832 case A_Info.Type_Mode is 3833 when Type_Mode_Bounds_Acc => 3834 declare 3835 Sub_Type : Iir; 3836 Ptr : O_Dnode; 3837 Val_Size : O_Dnode; 3838 Bounds_Size : O_Cnode; 3839 begin 3840 Sub_Type := Get_Subtype_Indication (Expr); 3841 Sub_Type := Get_Type_Of_Subtype_Indication (Sub_Type); 3842 Chap3.Create_Composite_Subtype (Sub_Type); 3843 3844 Ptr := Create_Temp (A_Info.Ortho_Type (Mode_Value)); 3845 3846 -- Size of the value (object without the bounds). 3847 Val_Size := Create_Temp_Init 3848 (Ghdl_Index_Type, 3849 Chap3.Get_Subtype_Size 3850 (D_Type, Chap3.Get_Composite_Type_Bounds (Sub_Type), 3851 Mode_Value)); 3852 3853 -- Size of the bounds. 3854 Bounds_Size := 3855 New_Sizeof (D_Info.B.Bounds_Type, Ghdl_Index_Type); 3856 3857 -- Allocate the object. 3858 New_Assign_Stmt 3859 (New_Obj (Ptr), 3860 Gen_Alloc (Alloc_Heap, 3861 New_Dyadic_Op 3862 (ON_Add_Ov, 3863 New_Lit (Bounds_Size), 3864 New_Obj_Value (Val_Size)), 3865 A_Info.Ortho_Type (Mode_Value))); 3866 3867 -- Copy bounds. 3868 Gen_Memcpy (New_Obj_Value (Ptr), 3869 M2Addr (Chap3.Get_Composite_Type_Bounds (Sub_Type)), 3870 New_Lit (Bounds_Size)); 3871 3872 -- Create a fat pointer to initialize the object. 3873 Res := Bounds_Acc_To_Fat_Pointer (Ptr, A_Type); 3874 Chap4.Init_Object (Res, D_Type); 3875 3876 return New_Obj_Value (Ptr); 3877 end; 3878 when Type_Mode_Acc => 3879 Res := Dp2M (Create_Temp (D_Info.Ortho_Ptr_Type (Mode_Value)), 3880 D_Info, Mode_Value); 3881 Bounds := Mnode_Null; 3882 Chap3.Translate_Object_Allocation 3883 (Res, Alloc_Heap, D_Type, Bounds); 3884 Chap4.Init_Object (Res, D_Type); 3885 return New_Convert_Ov 3886 (M2Addr (Res), A_Info.Ortho_Type (Mode_Value)); 3887 when others => 3888 raise Internal_Error; 3889 end case; 3890 end Translate_Allocator_By_Subtype; 3891 3892 function Translate_Fat_Array_Type_Conversion 3893 (Expr : O_Enode; Expr_Type : Iir; Res_Type : Iir; Loc : Iir) 3894 return O_Enode; 3895 3896 function Translate_Array_Subtype_Conversion 3897 (Expr : O_Enode; Expr_Type : Iir; Res_Type : Iir; Loc : Iir) 3898 return O_Enode 3899 is 3900 Res_Info : constant Type_Info_Acc := Get_Info (Res_Type); 3901 Expr_Info : constant Type_Info_Acc := Get_Info (Expr_Type); 3902 E : Mnode; 3903 begin 3904 E := Stabilize (E2M (Expr, Expr_Info, Mode_Value)); 3905 case Res_Info.Type_Mode is 3906 when Type_Mode_Bounded_Arrays => 3907 Chap3.Check_Composite_Match 3908 (Res_Type, T2M (Res_Type, Mode_Value), 3909 Expr_Type, E, 3910 Loc); 3911 return New_Convert_Ov 3912 (M2Addr (Chap3.Get_Composite_Base (E)), 3913 Res_Info.Ortho_Ptr_Type (Mode_Value)); 3914 when Type_Mode_Unbounded_Array => 3915 declare 3916 Res : Mnode; 3917 begin 3918 Res := Create_Temp (Res_Info); 3919 Copy_Fat_Pointer (Res, E); 3920 Chap3.Check_Composite_Match (Res_Type, Res, Expr_Type, E, Loc); 3921 return M2Addr (Res); 3922 end; 3923 when others => 3924 Error_Kind ("translate_array_subtype_conversion", Res_Type); 3925 end case; 3926 end Translate_Array_Subtype_Conversion; 3927 3928 function Translate_Type_Conversion 3929 (Expr : O_Enode; Expr_Type : Iir; Res_Type : Iir; Loc : Iir) 3930 return O_Enode 3931 is 3932 Res_Info : constant Type_Info_Acc := Get_Info (Res_Type); 3933 Res : O_Enode; 3934 begin 3935 case Get_Kind (Res_Type) is 3936 when Iir_Kinds_Scalar_Type_And_Subtype_Definition => 3937 Res := New_Convert_Ov (Expr, Res_Info.Ortho_Type (Mode_Value)); 3938 if Chap3.Need_Range_Check (Null_Iir, Res_Type) then 3939 Res := Chap3.Insert_Scalar_Check 3940 (Res, Null_Iir, Res_Type, Loc); 3941 end if; 3942 return Res; 3943 when Iir_Kinds_Array_Type_Definition => 3944 if Get_Constraint_State (Res_Type) = Fully_Constrained then 3945 return Translate_Array_Subtype_Conversion 3946 (Expr, Expr_Type, Res_Type, Loc); 3947 else 3948 return Translate_Fat_Array_Type_Conversion 3949 (Expr, Expr_Type, Res_Type, Loc); 3950 end if; 3951 when Iir_Kind_Record_Type_Definition 3952 | Iir_Kind_Record_Subtype_Definition => 3953 return Expr; 3954 when others => 3955 Error_Kind ("translate_type_conversion", Res_Type); 3956 end case; 3957 end Translate_Type_Conversion; 3958 3959 procedure Translate_Type_Conversion_Bounds 3960 (Res : Mnode; Src : Mnode; Res_Type : Iir; Src_Type : Iir; Loc : Iir) 3961 is 3962 Res_Indexes : constant Iir_Flist := Get_Index_Subtype_List (Res_Type); 3963 Src_Indexes : constant Iir_Flist := Get_Index_Subtype_List (Src_Type); 3964 Res_Base_Type : constant Iir := Get_Base_Type (Res_Type); 3965 Src_Base_Type : constant Iir := Get_Base_Type (Src_Type); 3966 Res_Base_Indexes : constant Iir_Flist := 3967 Get_Index_Subtype_List (Res_Base_Type); 3968 Src_Base_Indexes : constant Iir_Flist := 3969 Get_Index_Subtype_List (Src_Base_Type); 3970 3971 R_El : Iir; 3972 S_El : Iir; 3973 begin 3974 -- Convert bounds. 3975 for I in Flist_First .. Flist_Last (Src_Indexes) loop 3976 R_El := Get_Index_Type (Res_Indexes, I); 3977 S_El := Get_Index_Type (Src_Indexes, I); 3978 declare 3979 Rb_Ptr : Mnode; 3980 Sb_Ptr : Mnode; 3981 Ee : O_Enode; 3982 Same_Index_Type : constant Boolean := 3983 (Get_Index_Type (Res_Base_Indexes, I) 3984 = Get_Index_Type (Src_Base_Indexes, I)); 3985 begin 3986 Open_Temp; 3987 Rb_Ptr := Stabilize (Chap3.Bounds_To_Range (Res, Res_Type, I + 1)); 3988 Sb_Ptr := Stabilize (Chap3.Bounds_To_Range (Src, Src_Type, I + 1)); 3989 -- Convert left and right (unless they have the same type - 3990 -- this is an optimization but also this deals with null 3991 -- array in common cases). 3992 Ee := M2E (Chap3.Range_To_Left (Sb_Ptr)); 3993 if not Same_Index_Type then 3994 Ee := Translate_Type_Conversion (Ee, S_El, R_El, Loc); 3995 end if; 3996 New_Assign_Stmt (M2Lv (Chap3.Range_To_Left (Rb_Ptr)), Ee); 3997 Ee := M2E (Chap3.Range_To_Right (Sb_Ptr)); 3998 if not Same_Index_Type then 3999 Ee := Translate_Type_Conversion (Ee, S_El, R_El, Loc); 4000 end if; 4001 New_Assign_Stmt (M2Lv (Chap3.Range_To_Right (Rb_Ptr)), Ee); 4002 -- Copy Dir and Length. 4003 New_Assign_Stmt (M2Lv (Chap3.Range_To_Dir (Rb_Ptr)), 4004 M2E (Chap3.Range_To_Dir (Sb_Ptr))); 4005 New_Assign_Stmt (M2Lv (Chap3.Range_To_Length (Rb_Ptr)), 4006 M2E (Chap3.Range_To_Length (Sb_Ptr))); 4007 Close_Temp; 4008 end; 4009 end loop; 4010 end Translate_Type_Conversion_Bounds; 4011 4012 function Translate_Fat_Array_Type_Conversion 4013 (Expr : O_Enode; Expr_Type : Iir; Res_Type : Iir; Loc : Iir) 4014 return O_Enode 4015 is 4016 Res_Info : constant Type_Info_Acc := Get_Info (Res_Type); 4017 Expr_Info : constant Type_Info_Acc := Get_Info (Expr_Type); 4018 4019 Res : Mnode; 4020 E : Mnode; 4021 Bounds : O_Dnode; 4022 begin 4023 Res := Create_Temp (Res_Info, Mode_Value); 4024 Bounds := Create_Temp (Res_Info.B.Bounds_Type); 4025 4026 Open_Temp; 4027 E := Stabilize (E2M (Expr, Expr_Info, Mode_Value)); 4028 4029 -- Set base. 4030 New_Assign_Stmt 4031 (M2Lp (Chap3.Get_Composite_Base (Res)), 4032 New_Convert_Ov (M2Addr (Chap3.Get_Composite_Base (E)), 4033 Res_Info.B.Base_Ptr_Type (Mode_Value))); 4034 -- Set bounds. 4035 New_Assign_Stmt 4036 (M2Lp (Chap3.Get_Composite_Bounds (Res)), 4037 New_Address (New_Obj (Bounds), Res_Info.B.Bounds_Ptr_Type)); 4038 4039 -- Convert bounds. 4040 Translate_Type_Conversion_Bounds 4041 (Dv2M (Bounds, Res_Info, Mode_Value, 4042 Res_Info.B.Bounds_Type, Res_Info.B.Bounds_Ptr_Type), 4043 Stabilize (Chap3.Get_Composite_Bounds (E)), 4044 Res_Type, Expr_Type, Loc); 4045 4046 Close_Temp; 4047 return M2E (Res); 4048 end Translate_Fat_Array_Type_Conversion; 4049 4050 function Sig2val_Prepare_Composite 4051 (Targ : Mnode; Targ_Type : Iir; Data : Mnode) return Mnode 4052 is 4053 pragma Unreferenced (Targ, Targ_Type); 4054 begin 4055 if Get_Type_Info (Data).Type_Mode in Type_Mode_Unbounded then 4056 return Stabilize (Chap3.Get_Composite_Base (Data)); 4057 else 4058 return Stabilize (Data); 4059 end if; 4060 end Sig2val_Prepare_Composite; 4061 4062 function Sig2val_Update_Data_Array 4063 (Val : Mnode; Targ_Type : Iir; Index : O_Dnode) return Mnode is 4064 begin 4065 return Chap3.Index_Base (Val, Targ_Type, New_Obj_Value (Index)); 4066 end Sig2val_Update_Data_Array; 4067 4068 function Sig2val_Update_Data_Record 4069 (Val : Mnode; Targ_Type : Iir; El : Iir_Element_Declaration) return Mnode 4070 is 4071 pragma Unreferenced (Targ_Type); 4072 begin 4073 return Chap6.Translate_Selected_Element (Val, El); 4074 end Sig2val_Update_Data_Record; 4075 4076 procedure Translate_Signal_Assign_Driving_Non_Composite 4077 (Targ : Mnode; Targ_Type : Iir; Data: Mnode) is 4078 begin 4079 New_Assign_Stmt 4080 (Chap14.Get_Signal_Value_Field (M2E (Targ), Targ_Type, 4081 Ghdl_Signal_Driving_Value_Field), 4082 M2E (Data)); 4083 end Translate_Signal_Assign_Driving_Non_Composite; 4084 4085 procedure Translate_Signal_Assign_Driving is new Foreach_Non_Composite 4086 (Data_Type => Mnode, 4087 Composite_Data_Type => Mnode, 4088 Do_Non_Composite => Translate_Signal_Assign_Driving_Non_Composite, 4089 Prepare_Data_Array => Sig2val_Prepare_Composite, 4090 Update_Data_Array => Sig2val_Update_Data_Array, 4091 Prepare_Data_Record => Sig2val_Prepare_Composite, 4092 Update_Data_Record => Sig2val_Update_Data_Record); 4093 4094 function Allocate_Value_From_Signal (Sig : Mnode; Sig_Type : Iir) 4095 return Mnode 4096 is 4097 Tinfo : constant Type_Info_Acc := Get_Info (Sig_Type); 4098 Res : Mnode; 4099 begin 4100 if Tinfo.Type_Mode in Type_Mode_Unbounded then 4101 Res := Create_Temp (Tinfo); 4102 4103 -- Copy bounds. 4104 New_Assign_Stmt 4105 (M2Lp (Chap3.Get_Composite_Bounds (Res)), 4106 M2Addr (Chap3.Get_Composite_Bounds (Sig))); 4107 4108 -- Allocate base. 4109 Chap3.Allocate_Unbounded_Composite_Base (Alloc_Stack, Res, Sig_Type); 4110 elsif Is_Complex_Type (Tinfo) then 4111 Res := Create_Temp (Tinfo); 4112 Chap4.Allocate_Complex_Object (Sig_Type, Alloc_Stack, Res); 4113 else 4114 Res := Create_Temp (Tinfo); 4115 end if; 4116 4117 return Res; 4118 end Allocate_Value_From_Signal; 4119 4120 function Translate_Signal_Value (Sig : Mnode; Sig_Type : Iir) return Mnode 4121 is 4122 procedure Translate_Signal_Non_Composite 4123 (Targ : Mnode; 4124 Targ_Type : Iir; 4125 Data : Mnode) is 4126 begin 4127 New_Assign_Stmt (M2Lv (Targ), 4128 Read_Value (M2E (Data), Targ_Type)); 4129 end Translate_Signal_Non_Composite; 4130 4131 procedure Translate_Signal_Target is new Foreach_Non_Composite 4132 (Data_Type => Mnode, 4133 Composite_Data_Type => Mnode, 4134 Do_Non_Composite => Translate_Signal_Non_Composite, 4135 Prepare_Data_Array => Sig2val_Prepare_Composite, 4136 Update_Data_Array => Sig2val_Update_Data_Array, 4137 Prepare_Data_Record => Sig2val_Prepare_Composite, 4138 Update_Data_Record => Sig2val_Update_Data_Record); 4139 4140 Tinfo : constant Type_Info_Acc := Get_Info (Sig_Type); 4141 Sig2 : Mnode; 4142 Res : Mnode; 4143 begin 4144 if Tinfo.Type_Mode in Type_Mode_Scalar then 4145 return E2M (Read_Value (M2E (Sig), Sig_Type), Tinfo, Mode_Value); 4146 else 4147 Sig2 := Stabilize (Sig); 4148 pragma Unreferenced (Sig); 4149 4150 Res := Allocate_Value_From_Signal (Sig2, Sig_Type); 4151 4152 Open_Temp; 4153 Translate_Signal_Target (Res, Sig_Type, Sig2); 4154 Close_Temp; 4155 4156 return Res; 4157 end if; 4158 end Translate_Signal_Value; 4159 4160 function Read_Signal_Driving_Value (Sig : O_Enode; Sig_Type : Iir) 4161 return O_Enode is 4162 begin 4163 return New_Value (Chap14.Get_Signal_Value_Field 4164 (Sig, Sig_Type, Ghdl_Signal_Driving_Value_Field)); 4165 end Read_Signal_Driving_Value; 4166 4167 function Translate_Signal_Driving_Value_1 is new Translate_Signal_Value 4168 (Read_Value => Read_Signal_Driving_Value); 4169 4170 function Translate_Signal_Driving_Value 4171 (Sig : Mnode; Sig_Type : Iir) return Mnode 4172 renames Translate_Signal_Driving_Value_1; 4173 4174 procedure Set_Driving_Value 4175 (Sig : Mnode; Sig_Type : Iir; Val : Mnode) 4176 renames Translate_Signal_Assign_Driving; 4177 4178 function Translate_Overflow_Literal (Expr : Iir) return O_Enode 4179 is 4180 Expr_Type : constant Iir := Get_Type (Expr); 4181 Tinfo : constant Type_Info_Acc := Get_Info (Expr_Type); 4182 Otype : constant O_Tnode := Tinfo.Ortho_Type (Mode_Value); 4183 L : O_Dnode; 4184 begin 4185 -- Generate the error message 4186 Chap6.Gen_Bound_Error (Expr); 4187 4188 -- Create a dummy value, for type checking. But never 4189 -- executed. 4190 L := Create_Temp (Otype); 4191 if Tinfo.Type_Mode in Type_Mode_Fat then 4192 -- For fat pointers or arrays. 4193 return New_Address (New_Obj (L), 4194 Tinfo.Ortho_Ptr_Type (Mode_Value)); 4195 else 4196 return New_Obj_Value (L); 4197 end if; 4198 end Translate_Overflow_Literal; 4199 4200 function Translate_Aggregate_Expression (Expr : Iir; Rtype : Iir) 4201 return O_Enode 4202 is 4203 Expr_Type : constant Iir := Get_Type (Expr); 4204 Aggr_Type : Iir; 4205 Tinfo : Type_Info_Acc; 4206 Bounds : Mnode; 4207 Mres : Mnode; 4208 Res : O_Enode; 4209 begin 4210 -- Extract the type of the aggregate. Use the type of the 4211 -- context if it is fully constrained. 4212 Aggr_Type := Expr_Type; 4213 if Rtype /= Null_Iir 4214 and then Is_Fully_Constrained_Type (Rtype) 4215 then 4216 Aggr_Type := Rtype; 4217 end if; 4218 4219 if Get_Constraint_State (Aggr_Type) /= Fully_Constrained then 4220 Tinfo := Get_Info (Aggr_Type); 4221 if Tinfo = null then 4222 -- AGGR_TYPE may be a subtype that has not been 4223 -- translated. Use the base type in that case. 4224 Aggr_Type := Get_Base_Type (Aggr_Type); 4225 Tinfo := Get_Info (Aggr_Type); 4226 end if; 4227 4228 Mres := Create_Temp (Tinfo); 4229 Bounds := Create_Temp_Bounds (Tinfo); 4230 New_Assign_Stmt (M2Lp (Chap3.Get_Composite_Bounds (Mres)), 4231 M2Addr (Bounds)); 4232 -- Build bounds from aggregate. 4233 Chap7.Translate_Aggregate_Bounds (Bounds, Expr); 4234 Chap3.Allocate_Unbounded_Composite_Base 4235 (Alloc_Stack, Mres, Aggr_Type); 4236 else 4237 Chap3.Create_Composite_Subtype (Aggr_Type); 4238 4239 -- FIXME: this may be not necessary 4240 Tinfo := Get_Info (Aggr_Type); 4241 4242 -- The result area has to be created 4243 if Is_Complex_Type (Tinfo) then 4244 Mres := Create_Temp (Tinfo); 4245 Chap4.Allocate_Complex_Object (Aggr_Type, Alloc_Stack, Mres); 4246 else 4247 -- if thin array/record: 4248 -- create result 4249 Mres := Create_Temp (Tinfo); 4250 end if; 4251 end if; 4252 4253 Translate_Aggregate (Mres, Aggr_Type, Expr); 4254 Res := M2E (Mres); 4255 4256 if Rtype /= Null_Iir and then Aggr_Type /= Rtype then 4257 Res := Translate_Implicit_Conv 4258 (Res, Aggr_Type, Rtype, Mode_Value, Expr); 4259 end if; 4260 return Res; 4261 end Translate_Aggregate_Expression; 4262 4263 function Translate_Expression (Expr : Iir; Rtype : Iir := Null_Iir) 4264 return Mnode 4265 is 4266 Res_Type : Iir; 4267 Res : O_Enode; 4268 begin 4269 if Rtype = Null_Iir then 4270 Res_Type := Get_Type (Expr); 4271 else 4272 Res_Type := Rtype; 4273 end if; 4274 Res := Translate_Expression (Expr, Res_Type); 4275 return E2M (Res, Get_Info (Res_Type), Mode_Value); 4276 end Translate_Expression; 4277 4278 function Translate_Expression (Expr : Iir; Rtype : Iir := Null_Iir) 4279 return O_Enode 4280 is 4281 Imp : Iir; 4282 Expr_Type : Iir; 4283 Res_Type : Iir; 4284 Res : O_Enode; 4285 begin 4286 Expr_Type := Get_Type (Expr); 4287 if Rtype = Null_Iir then 4288 Res_Type := Expr_Type; 4289 else 4290 Res_Type := Rtype; 4291 end if; 4292 case Get_Kind (Expr) is 4293 when Iir_Kind_Integer_Literal 4294 | Iir_Kind_Enumeration_Literal 4295 | Iir_Kind_Floating_Point_Literal => 4296 return New_Lit (Translate_Static_Expression (Expr, Rtype)); 4297 4298 when Iir_Kind_Physical_Int_Literal 4299 | Iir_Kind_Physical_Fp_Literal 4300 | Iir_Kind_Unit_Declaration => 4301 declare 4302 Otype : constant O_Tnode := 4303 Get_Ortho_Type (Expr_Type, Mode_Value); 4304 Val : Int64; 4305 begin 4306 -- Get the value now, as it may generate a constraint_error. 4307 Val := Get_Physical_Value (Expr); 4308 return New_Lit (New_Signed_Literal (Otype, Integer_64 (Val))); 4309 exception 4310 when Constraint_Error => 4311 Warning_Msg_Elab (Warnid_Runtime_Error, Expr, 4312 "physical literal out of range"); 4313 return Translate_Overflow_Literal (Expr); 4314 end; 4315 4316 when Iir_Kind_String_Literal8 4317 | Iir_Kind_Simple_Aggregate 4318 | Iir_Kind_Simple_Name_Attribute => 4319 return Translate_Composite_Literal (Expr, Res_Type); 4320 4321 when Iir_Kind_Aggregate => 4322 if Get_Aggregate_Expand_Flag (Expr) then 4323 return Translate_Composite_Literal (Expr, Res_Type); 4324 else 4325 return Translate_Aggregate_Expression (Expr, Rtype); 4326 end if; 4327 4328 when Iir_Kind_Null_Literal => 4329 declare 4330 Tinfo : constant Type_Info_Acc := Get_Info (Expr_Type); 4331 Otype : constant O_Tnode := Tinfo.Ortho_Type (Mode_Value); 4332 begin 4333 return New_Lit (New_Null_Access (Otype)); 4334 end; 4335 4336 when Iir_Kind_Overflow_Literal => 4337 return Translate_Overflow_Literal (Expr); 4338 4339 when Iir_Kind_Parenthesis_Expression => 4340 return Translate_Expression (Get_Expression (Expr), Rtype); 4341 4342 when Iir_Kind_Allocator_By_Expression => 4343 return Translate_Allocator_By_Expression (Expr); 4344 when Iir_Kind_Allocator_By_Subtype => 4345 return Translate_Allocator_By_Subtype (Expr); 4346 4347 when Iir_Kind_Qualified_Expression => 4348 -- FIXME: check type. 4349 Res := Translate_Expression (Get_Expression (Expr), Expr_Type); 4350 4351 when Iir_Kind_Constant_Declaration 4352 | Iir_Kind_Variable_Declaration 4353 | Iir_Kind_Signal_Declaration 4354 | Iir_Kind_File_Declaration 4355 | Iir_Kind_Object_Alias_Declaration 4356 | Iir_Kind_Interface_Constant_Declaration 4357 | Iir_Kind_Interface_Variable_Declaration 4358 | Iir_Kind_Interface_Signal_Declaration 4359 | Iir_Kind_Interface_File_Declaration 4360 | Iir_Kind_Indexed_Name 4361 | Iir_Kind_Slice_Name 4362 | Iir_Kind_Selected_Element 4363 | Iir_Kind_Dereference 4364 | Iir_Kind_Implicit_Dereference 4365 | Iir_Kind_Stable_Attribute 4366 | Iir_Kind_Quiet_Attribute 4367 | Iir_Kind_Delayed_Attribute 4368 | Iir_Kind_Transaction_Attribute 4369 | Iir_Kind_Guard_Signal_Declaration 4370 | Iir_Kind_Anonymous_Signal_Declaration 4371 | Iir_Kind_Attribute_Value 4372 | Iir_Kind_Attribute_Name => 4373 Res := M2E (Chap6.Translate_Name (Expr, Mode_Value)); 4374 4375 when Iir_Kind_Iterator_Declaration => 4376 declare 4377 Expr_Info : Ortho_Info_Acc; 4378 begin 4379 Expr_Info := Get_Info (Expr); 4380 Res := New_Value (Get_Var (Expr_Info.Iterator_Var)); 4381 if Rtype /= Null_Iir then 4382 Res := New_Convert_Ov 4383 (Res, Get_Ortho_Type (Rtype, Mode_Value)); 4384 end if; 4385 return Res; 4386 end; 4387 4388 when Iir_Kinds_Dyadic_Operator => 4389 Imp := Get_Implementation (Expr); 4390 if Is_Implicit_Subprogram (Imp) then 4391 return Translate_Predefined_Operator 4392 (Expr, Get_Left (Expr), Get_Right (Expr), Res_Type); 4393 else 4394 return Translate_Operator_Function_Call 4395 (Expr, Get_Left (Expr), Get_Right (Expr), Res_Type); 4396 end if; 4397 when Iir_Kinds_Monadic_Operator => 4398 Imp := Get_Implementation (Expr); 4399 if Is_Implicit_Subprogram (Imp) then 4400 return Translate_Predefined_Operator 4401 (Expr, Get_Operand (Expr), Null_Iir, Res_Type); 4402 else 4403 return Translate_Operator_Function_Call 4404 (Expr, Get_Operand (Expr), Null_Iir, Res_Type); 4405 end if; 4406 when Iir_Kind_Function_Call => 4407 Imp := Get_Implementation (Expr); 4408 declare 4409 Assoc_Chain : Iir; 4410 begin 4411 if Is_Implicit_Subprogram (Imp) then 4412 declare 4413 Left, Right : Iir; 4414 begin 4415 Assoc_Chain := Get_Parameter_Association_Chain (Expr); 4416 if Assoc_Chain = Null_Iir then 4417 Left := Null_Iir; 4418 Right := Null_Iir; 4419 else 4420 Left := Get_Actual (Assoc_Chain); 4421 Assoc_Chain := Get_Chain (Assoc_Chain); 4422 if Assoc_Chain = Null_Iir then 4423 Right := Null_Iir; 4424 else 4425 Right := Get_Actual (Assoc_Chain); 4426 end if; 4427 end if; 4428 return Translate_Predefined_Operator 4429 (Expr, Left, Right, Res_Type); 4430 end; 4431 else 4432 Vhdl.Canon.Canon_Subprogram_Call (Expr); 4433 Trans.Update_Node_Infos; 4434 Assoc_Chain := Get_Parameter_Association_Chain (Expr); 4435 Res := Chap8.Translate_Subprogram_Call 4436 (Expr, Assoc_Chain, Get_Method_Object (Expr)); 4437 Expr_Type := Get_Return_Type (Imp); 4438 end if; 4439 end; 4440 4441 when Iir_Kind_Type_Conversion => 4442 declare 4443 Conv_Expr : constant Iir := Get_Expression (Expr); 4444 begin 4445 Res := Translate_Type_Conversion 4446 (Translate_Expression (Conv_Expr), Get_Type (Conv_Expr), 4447 Expr_Type, Expr); 4448 end; 4449 4450 when Iir_Kind_Length_Array_Attribute => 4451 return Chap14.Translate_Length_Array_Attribute 4452 (Expr, Res_Type); 4453 when Iir_Kind_Low_Array_Attribute => 4454 return Chap14.Translate_Low_Array_Attribute (Expr); 4455 when Iir_Kind_High_Array_Attribute => 4456 return Chap14.Translate_High_Array_Attribute (Expr); 4457 when Iir_Kind_Left_Array_Attribute => 4458 return Chap14.Translate_Left_Array_Attribute (Expr); 4459 when Iir_Kind_Right_Array_Attribute => 4460 return Chap14.Translate_Right_Array_Attribute (Expr); 4461 when Iir_Kind_Ascending_Array_Attribute => 4462 return Chap14.Translate_Ascending_Array_Attribute (Expr); 4463 4464 when Iir_Kind_Val_Attribute => 4465 return Chap14.Translate_Val_Attribute (Expr); 4466 when Iir_Kind_Pos_Attribute => 4467 return Chap14.Translate_Pos_Attribute (Expr, Res_Type); 4468 4469 when Iir_Kind_Succ_Attribute 4470 | Iir_Kind_Pred_Attribute 4471 | Iir_Kind_Leftof_Attribute 4472 | Iir_Kind_Rightof_Attribute => 4473 return Chap14.Translate_Succ_Pred_Attribute (Expr); 4474 4475 when Iir_Kind_Image_Attribute => 4476 Res := Chap14.Translate_Image_Attribute (Expr); 4477 4478 when Iir_Kind_Value_Attribute => 4479 return Chap14.Translate_Value_Attribute (Expr); 4480 4481 when Iir_Kind_Event_Attribute => 4482 return Chap14.Translate_Event_Attribute (Expr); 4483 when Iir_Kind_Active_Attribute => 4484 return Chap14.Translate_Active_Attribute (Expr); 4485 when Iir_Kind_Last_Value_Attribute => 4486 Res := Chap14.Translate_Last_Value_Attribute (Expr); 4487 4488 when Iir_Kind_High_Type_Attribute => 4489 return Chap14.Translate_High_Low_Type_Attribute 4490 (Get_Type (Expr), True); 4491 when Iir_Kind_Low_Type_Attribute => 4492 return Chap14.Translate_High_Low_Type_Attribute 4493 (Get_Type (Expr), False); 4494 when Iir_Kind_Left_Type_Attribute => 4495 return M2E 4496 (Chap3.Range_To_Left 4497 (Lv2M (Translate_Range (Get_Prefix (Expr), Expr_Type), 4498 Get_Info (Get_Base_Type (Expr_Type)), Mode_Value))); 4499 when Iir_Kind_Right_Type_Attribute => 4500 return M2E 4501 (Chap3.Range_To_Right 4502 (Lv2M (Translate_Range (Get_Prefix (Expr), Expr_Type), 4503 Get_Info (Get_Base_Type (Expr_Type)), Mode_Value))); 4504 4505 when Iir_Kind_Last_Event_Attribute => 4506 return Chap14.Translate_Last_Time_Attribute 4507 (Get_Prefix (Expr), Ghdl_Signal_Last_Event_Field); 4508 when Iir_Kind_Last_Active_Attribute => 4509 return Chap14.Translate_Last_Time_Attribute 4510 (Get_Prefix (Expr), Ghdl_Signal_Last_Active_Field); 4511 4512 when Iir_Kind_Driving_Value_Attribute => 4513 Res := Chap14.Translate_Driving_Value_Attribute (Expr); 4514 when Iir_Kind_Driving_Attribute => 4515 Res := Chap14.Translate_Driving_Attribute (Expr); 4516 4517 when Iir_Kind_Path_Name_Attribute 4518 | Iir_Kind_Instance_Name_Attribute => 4519 Res := Chap14.Translate_Path_Instance_Name_Attribute (Expr); 4520 4521 when Iir_Kind_Simple_Name 4522 | Iir_Kind_Character_Literal 4523 | Iir_Kind_Selected_Name => 4524 return Translate_Expression (Get_Named_Entity (Expr), Rtype); 4525 4526 when Iir_Kind_Psl_Endpoint_Declaration => 4527 declare 4528 Info : constant Psl_Info_Acc := Get_Info (Expr); 4529 begin 4530 return New_Value (Get_Var (Info.Psl_Count_Var)); 4531 end; 4532 4533 when others => 4534 Error_Kind ("translate_expression", Expr); 4535 end case; 4536 4537 -- Quick test to avoid useless calls. 4538 if Expr_Type /= Res_Type then 4539 Res := Translate_Implicit_Conv 4540 (Res, Expr_Type, Res_Type, Mode_Value, Expr); 4541 end if; 4542 4543 return Res; 4544 end Translate_Expression; 4545 4546 -- Check if RNG is of the form: 4547 -- 1 to T'length 4548 -- or T'Length downto 1 4549 -- or 0 to T'length - 1 4550 -- or T'Length - 1 downto 0 4551 -- In either of these cases, return T'Length 4552 function Is_Length_Range_Expression (Rng : Iir_Range_Expression) return Iir 4553 is 4554 -- Pattern of a bound. 4555 type Length_Pattern is 4556 ( 4557 Pat_Unknown, 4558 Pat_Length, 4559 Pat_Length_1, -- Length - 1 4560 Pat_1, 4561 Pat_0 4562 ); 4563 Length_Attr : Iir := Null_Iir; 4564 4565 -- Classify the bound. 4566 -- Set LENGTH_ATTR is the pattern is Pat_Length. 4567 function Get_Length_Pattern (Expr : Iir; Recurse : Boolean) 4568 return Length_Pattern 4569 is 4570 begin 4571 case Get_Kind (Expr) is 4572 when Iir_Kind_Length_Array_Attribute => 4573 Length_Attr := Expr; 4574 return Pat_Length; 4575 when Iir_Kind_Integer_Literal => 4576 case Get_Value (Expr) is 4577 when 0 => 4578 return Pat_0; 4579 when 1 => 4580 return Pat_1; 4581 when others => 4582 return Pat_Unknown; 4583 end case; 4584 when Iir_Kind_Substraction_Operator => 4585 if not Recurse then 4586 return Pat_Unknown; 4587 end if; 4588 if Get_Length_Pattern (Get_Left (Expr), False) = Pat_Length 4589 and then 4590 Get_Length_Pattern (Get_Right (Expr), False) = Pat_1 4591 then 4592 return Pat_Length_1; 4593 else 4594 return Pat_Unknown; 4595 end if; 4596 when others => 4597 return Pat_Unknown; 4598 end case; 4599 end Get_Length_Pattern; 4600 Left_Pat, Right_Pat : Length_Pattern; 4601 begin 4602 Left_Pat := Get_Length_Pattern (Get_Left_Limit (Rng), True); 4603 if Left_Pat = Pat_Unknown then 4604 return Null_Iir; 4605 end if; 4606 Right_Pat := Get_Length_Pattern (Get_Right_Limit (Rng), True); 4607 if Right_Pat = Pat_Unknown then 4608 return Null_Iir; 4609 end if; 4610 case Get_Direction (Rng) is 4611 when Dir_To => 4612 if (Left_Pat = Pat_1 and Right_Pat = Pat_Length) 4613 or else (Left_Pat = Pat_0 and Right_Pat = Pat_Length_1) 4614 then 4615 return Length_Attr; 4616 end if; 4617 when Dir_Downto => 4618 if (Left_Pat = Pat_Length and Right_Pat = Pat_1) 4619 or else (Left_Pat = Pat_Length_1 and Right_Pat = Pat_0) 4620 then 4621 return Length_Attr; 4622 end if; 4623 end case; 4624 return Null_Iir; 4625 end Is_Length_Range_Expression; 4626 4627 procedure Translate_Range_Expression 4628 (Res : Mnode; Expr : Iir; Range_Type : Iir) 4629 is 4630 T_Info : constant Type_Info_Acc := Get_Info (Range_Type); 4631 Length_Attr : Iir; 4632 Res1 : Mnode; 4633 begin 4634 Open_Temp; 4635 Res1 := Stabilize (Res); 4636 New_Assign_Stmt 4637 (M2Lv (Chap3.Range_To_Left (Res1)), 4638 Chap7.Translate_Range_Expression_Left (Expr, Range_Type)); 4639 New_Assign_Stmt 4640 (M2Lv (Chap3.Range_To_Right (Res1)), 4641 Chap7.Translate_Range_Expression_Right (Expr, Range_Type)); 4642 New_Assign_Stmt 4643 (M2Lv (Chap3.Range_To_Dir (Res1)), 4644 New_Lit (Chap7.Translate_Static_Range_Dir (Expr))); 4645 if T_Info.B.Range_Length /= O_Fnode_Null then 4646 if Get_Expr_Staticness (Expr) = Locally then 4647 New_Assign_Stmt 4648 (M2Lv (Chap3.Range_To_Length (Res1)), 4649 New_Lit (Translate_Static_Range_Length (Expr))); 4650 else 4651 Length_Attr := Is_Length_Range_Expression (Expr); 4652 if Length_Attr = Null_Iir then 4653 Open_Temp; 4654 New_Assign_Stmt 4655 (M2Lv (Chap3.Range_To_Length (Res1)), 4656 Compute_Range_Length 4657 (M2E (Chap3.Range_To_Left (Res1)), 4658 M2E (Chap3.Range_To_Right (Res1)), 4659 Get_Direction (Expr))); 4660 Close_Temp; 4661 else 4662 New_Assign_Stmt 4663 (M2Lv (Chap3.Range_To_Length (Res1)), 4664 Chap14.Translate_Length_Array_Attribute 4665 (Length_Attr, Null_Iir)); 4666 end if; 4667 end if; 4668 end if; 4669 Close_Temp; 4670 end Translate_Range_Expression; 4671 4672 -- Reverse range ARANGE. 4673 procedure Translate_Reverse_Range 4674 (Res : Mnode; Arange : O_Lnode; Range_Type : Iir) 4675 is 4676 Rinfo : constant Type_Info_Acc := Get_Info (Get_Base_Type (Range_Type)); 4677 Res1 : Mnode; 4678 Arange1 : Mnode; 4679 If_Blk : O_If_Block; 4680 begin 4681 Open_Temp; 4682 Arange1 := Stabilize (Lv2M (Arange, Rinfo, Mode_Value, 4683 Rinfo.B.Range_Type, Rinfo.B.Range_Ptr_Type)); 4684 Res1 := Stabilize (Res); 4685 New_Assign_Stmt (M2Lv (Chap3.Range_To_Left (Res1)), 4686 M2E (Chap3.Range_To_Right (Arange1))); 4687 New_Assign_Stmt (M2Lv (Chap3.Range_To_Right (Res1)), 4688 M2E (Chap3.Range_To_Left (Arange1))); 4689 New_Assign_Stmt (M2Lv (Chap3.Range_To_Length (Res1)), 4690 M2E (Chap3.Range_To_Length (Arange1))); 4691 Start_If_Stmt 4692 (If_Blk, New_Compare_Op (ON_Eq, 4693 M2E (Chap3.Range_To_Dir (Arange1)), 4694 New_Lit (Ghdl_Dir_To_Node), 4695 Ghdl_Bool_Type)); 4696 New_Assign_Stmt (M2Lv (Chap3.Range_To_Dir (Res1)), 4697 New_Lit (Ghdl_Dir_Downto_Node)); 4698 New_Else_Stmt (If_Blk); 4699 New_Assign_Stmt (M2Lv (Chap3.Range_To_Dir (Res1)), 4700 New_Lit (Ghdl_Dir_To_Node)); 4701 Finish_If_Stmt (If_Blk); 4702 Close_Temp; 4703 end Translate_Reverse_Range; 4704 4705 procedure Copy_Range (Dest : Mnode; Src : Mnode) 4706 is 4707 Info : constant Type_Info_Acc := Get_Type_Info (Dest); 4708 Dest1 : Mnode; 4709 Src1 : Mnode; 4710 begin 4711 Open_Temp; 4712 Dest1 := Stabilize (Dest); 4713 Src1 := Stabilize (Src); 4714 New_Assign_Stmt (M2Lv (Chap3.Range_To_Left (Dest1)), 4715 M2E (Chap3.Range_To_Left (Src1))); 4716 New_Assign_Stmt (M2Lv (Chap3.Range_To_Right (Dest1)), 4717 M2E (Chap3.Range_To_Right (Src1))); 4718 New_Assign_Stmt (M2Lv (Chap3.Range_To_Dir (Dest1)), 4719 M2E (Chap3.Range_To_Dir (Src1))); 4720 if Info.B.Range_Length /= O_Fnode_Null then 4721 -- Floating point types have no length. 4722 New_Assign_Stmt (M2Lv (Chap3.Range_To_Length (Dest1)), 4723 M2E (Chap3.Range_To_Length (Src1))); 4724 end if; 4725 Close_Temp; 4726 end Copy_Range; 4727 4728 procedure Translate_Range (Res : Mnode; Arange : Iir; Range_Type : Iir) 4729 is 4730 Rinfo : constant Type_Info_Acc := Get_Info (Get_Base_Type (Range_Type)); 4731 begin 4732 case Get_Kind (Arange) is 4733 when Iir_Kind_Range_Array_Attribute => 4734 declare 4735 Ptr : O_Dnode; 4736 begin 4737 Open_Temp; 4738 Ptr := Create_Temp_Ptr 4739 (Rinfo.B.Range_Ptr_Type, 4740 Chap14.Translate_Range_Array_Attribute (Arange)); 4741 Copy_Range (Res, 4742 Dp2M (Ptr, Rinfo, Mode_Value, 4743 Rinfo.B.Range_Type, Rinfo.B.Range_Ptr_Type)); 4744 Close_Temp; 4745 end; 4746 when Iir_Kind_Reverse_Range_Array_Attribute => 4747 Translate_Reverse_Range 4748 (Res, Chap14.Translate_Range_Array_Attribute (Arange), 4749 Range_Type); 4750 when Iir_Kind_Range_Expression => 4751 Translate_Range_Expression (Res, Arange, Range_Type); 4752 when others => 4753 Error_Kind ("translate_range_ptr", Arange); 4754 end case; 4755 end Translate_Range; 4756 4757 procedure Translate_Discrete_Range (Res : Mnode; Arange : Iir) is 4758 begin 4759 case Get_Kind (Arange) is 4760 when Iir_Kind_Integer_Subtype_Definition 4761 | Iir_Kind_Enumeration_Subtype_Definition => 4762 if not Is_Anonymous_Type_Definition (Arange) then 4763 declare 4764 Rinfo : constant Type_Info_Acc := Get_Info (Arange); 4765 begin 4766 Copy_Range (Res, Lv2M (Get_Var (Rinfo.S.Range_Var), 4767 Rinfo, Mode_Value, 4768 Rinfo.B.Range_Type, 4769 Rinfo.B.Range_Ptr_Type)); 4770 end; 4771 else 4772 Translate_Range (Res, 4773 Get_Range_Constraint (Arange), 4774 Get_Base_Type (Arange)); 4775 end if; 4776 when Iir_Kind_Range_Array_Attribute 4777 | Iir_Kind_Reverse_Range_Array_Attribute 4778 | Iir_Kind_Range_Expression => 4779 Translate_Range (Res, Arange, Get_Type (Arange)); 4780 when others => 4781 Error_Kind ("translate_discrete_range", Arange); 4782 end case; 4783 end Translate_Discrete_Range; 4784 4785 function Translate_Range (Arange : Iir; Range_Type : Iir) return O_Lnode is 4786 begin 4787 case Get_Kind (Arange) is 4788 when Iir_Kinds_Denoting_Name => 4789 return Translate_Range (Get_Named_Entity (Arange), Range_Type); 4790 when Iir_Kind_Subtype_Attribute 4791 | Iir_Kind_Subtype_Declaration => 4792 return Translate_Range (Get_Type (Arange), Range_Type); 4793 when Iir_Kinds_Scalar_Subtype_Definition 4794 | Iir_Kind_Enumeration_Type_Definition => 4795 -- Must be a scalar subtype. Range of types is static. 4796 return Get_Var (Get_Info (Arange).S.Range_Var); 4797 when Iir_Kind_Range_Array_Attribute => 4798 return Chap14.Translate_Range_Array_Attribute (Arange); 4799 when Iir_Kind_Reverse_Range_Array_Attribute => 4800 declare 4801 Rinfo : constant Type_Info_Acc := Get_Info (Range_Type); 4802 Res : O_Dnode; 4803 begin 4804 Res := Create_Temp (Rinfo.B.Range_Type); 4805 Translate_Reverse_Range 4806 (Dv2M (Res, Rinfo, Mode_Value), 4807 Chap14.Translate_Range_Array_Attribute (Arange), 4808 Range_Type); 4809 return New_Obj (Res); 4810 end; 4811 when Iir_Kind_Range_Expression => 4812 declare 4813 Rinfo : constant Type_Info_Acc := Get_Info (Range_Type); 4814 Res : O_Dnode; 4815 begin 4816 Res := Create_Temp (Rinfo.B.Range_Type); 4817 Translate_Range_Expression 4818 (Dv2M (Res, Rinfo, Mode_Value, 4819 Rinfo.B.Range_Type, Rinfo.B.Range_Ptr_Type), 4820 Arange, Range_Type); 4821 return New_Obj (Res); 4822 end; 4823 when others => 4824 Error_Kind ("translate_range", Arange); 4825 end case; 4826 end Translate_Range; 4827 4828 function Translate_Static_Range (Arange : Iir; Range_Type : Iir) 4829 return O_Cnode 4830 is 4831 Constr : O_Record_Aggr_List; 4832 Res : O_Cnode; 4833 T_Info : constant Type_Info_Acc := Get_Info (Range_Type); 4834 begin 4835 Start_Record_Aggr (Constr, T_Info.B.Range_Type); 4836 New_Record_Aggr_El 4837 (Constr, Chap7.Translate_Static_Range_Left (Arange, Range_Type)); 4838 New_Record_Aggr_El 4839 (Constr, Chap7.Translate_Static_Range_Right (Arange, Range_Type)); 4840 New_Record_Aggr_El 4841 (Constr, Chap7.Translate_Static_Range_Dir (Arange)); 4842 if T_Info.B.Range_Length /= O_Fnode_Null then 4843 New_Record_Aggr_El 4844 (Constr, Chap7.Translate_Static_Range_Length (Arange)); 4845 end if; 4846 Finish_Record_Aggr (Constr, Res); 4847 return Res; 4848 end Translate_Static_Range; 4849 4850 procedure Translate_Predefined_Array_Compare_Spec (Subprg : Iir) 4851 is 4852 Arr_Type : constant Iir_Array_Type_Definition := 4853 Get_Type (Get_Interface_Declaration_Chain (Subprg)); 4854 Tinfo : constant Type_Info_Acc := Get_Info (Arr_Type); 4855 Id : constant Name_Id := 4856 Get_Identifier (Get_Type_Declarator (Arr_Type)); 4857 Arr_Ptr_Type : constant O_Tnode := Tinfo.Ortho_Ptr_Type (Mode_Value); 4858 4859 F_Info : Operator_Info_Acc; 4860 Interface_List : O_Inter_List; 4861 begin 4862 F_Info := Add_Info (Subprg, Kind_Operator); 4863 4864 -- Create function. 4865 Start_Function_Decl (Interface_List, Create_Identifier (Id, "_CMP"), 4866 Global_Storage, Ghdl_Compare_Type); 4867 New_Interface_Decl (Interface_List, F_Info.Operator_Left, 4868 Wki_Left, Arr_Ptr_Type); 4869 New_Interface_Decl (Interface_List, F_Info.Operator_Right, 4870 Wki_Right, Arr_Ptr_Type); 4871 Finish_Subprogram_Decl (Interface_List, F_Info.Operator_Node); 4872 end Translate_Predefined_Array_Compare_Spec; 4873 4874 procedure Translate_Predefined_Array_Compare_Body (Subprg : Iir) 4875 is 4876 procedure Gen_Compare (L, R : O_Dnode) 4877 is 4878 If_Blk1, If_Blk2 : O_If_Block; 4879 begin 4880 Start_If_Stmt 4881 (If_Blk1, 4882 New_Compare_Op (ON_Neq, New_Obj_Value (L), New_Obj_Value (R), 4883 Ghdl_Bool_Type)); 4884 Start_If_Stmt 4885 (If_Blk2, 4886 New_Compare_Op (ON_Gt, New_Obj_Value (L), New_Obj_Value (R), 4887 Ghdl_Bool_Type)); 4888 New_Return_Stmt (New_Lit (Ghdl_Compare_Gt)); 4889 New_Else_Stmt (If_Blk2); 4890 New_Return_Stmt (New_Lit (Ghdl_Compare_Lt)); 4891 Finish_If_Stmt (If_Blk2); 4892 Finish_If_Stmt (If_Blk1); 4893 end Gen_Compare; 4894 4895 Arr_Type : constant Iir_Array_Type_Definition := 4896 Get_Type (Get_Interface_Declaration_Chain (Subprg)); 4897 Tinfo : constant Type_Info_Acc := Get_Info (Arr_Type); 4898 F_Info : constant Operator_Info_Acc := Get_Info (Subprg); 4899 4900 If_Blk : O_If_Block; 4901 Var_L_Len, Var_R_Len : O_Dnode; 4902 Var_L_El, Var_R_El : O_Dnode; 4903 Var_I, Var_Len : O_Dnode; 4904 Label : O_Snode; 4905 El_Otype : O_Tnode; 4906 begin 4907 if Global_Storage = O_Storage_External then 4908 return; 4909 end if; 4910 4911 El_Otype := Get_Ortho_Type 4912 (Get_Element_Subtype (Arr_Type), Mode_Value); 4913 Start_Subprogram_Body (F_Info.Operator_Node); 4914 -- Compute length of L and R. 4915 New_Var_Decl (Var_L_Len, Wki_L_Len, 4916 O_Storage_Local, Ghdl_Index_Type); 4917 New_Var_Decl (Var_R_Len, Wki_R_Len, 4918 O_Storage_Local, Ghdl_Index_Type); 4919 New_Var_Decl (Var_Len, Wki_Length, O_Storage_Local, Ghdl_Index_Type); 4920 New_Var_Decl (Var_I, Wki_I, O_Storage_Local, Ghdl_Index_Type); 4921 New_Assign_Stmt (New_Obj (Var_L_Len), 4922 Chap6.Get_Array_Bound_Length 4923 (Dp2M (F_Info.Operator_Left, Tinfo, Mode_Value), 4924 Arr_Type, 1)); 4925 New_Assign_Stmt (New_Obj (Var_R_Len), 4926 Chap6.Get_Array_Bound_Length 4927 (Dp2M (F_Info.Operator_Right, Tinfo, Mode_Value), 4928 Arr_Type, 1)); 4929 -- Find the minimum length. 4930 Start_If_Stmt (If_Blk, 4931 New_Compare_Op (ON_Ge, 4932 New_Obj_Value (Var_L_Len), 4933 New_Obj_Value (Var_R_Len), 4934 Ghdl_Bool_Type)); 4935 New_Assign_Stmt (New_Obj (Var_Len), New_Obj_Value (Var_R_Len)); 4936 New_Else_Stmt (If_Blk); 4937 New_Assign_Stmt (New_Obj (Var_Len), New_Obj_Value (Var_L_Len)); 4938 Finish_If_Stmt (If_Blk); 4939 4940 -- for each element, compare elements; if not equal return the 4941 -- comparaison result. 4942 Init_Var (Var_I); 4943 Start_Loop_Stmt (Label); 4944 Start_If_Stmt (If_Blk, New_Compare_Op (ON_Ge, 4945 New_Obj_Value (Var_I), 4946 New_Obj_Value (Var_Len), 4947 Ghdl_Bool_Type)); 4948 -- Compare the length and return the result. 4949 Gen_Compare (Var_L_Len, Var_R_Len); 4950 New_Return_Stmt (New_Lit (Ghdl_Compare_Eq)); 4951 Finish_If_Stmt (If_Blk); 4952 Start_Declare_Stmt; 4953 New_Var_Decl (Var_L_El, Get_Identifier ("l_el"), O_Storage_Local, 4954 El_Otype); 4955 New_Var_Decl (Var_R_El, Get_Identifier ("r_el"), O_Storage_Local, 4956 El_Otype); 4957 New_Assign_Stmt 4958 (New_Obj (Var_L_El), 4959 M2E (Chap3.Index_Base 4960 (Chap3.Get_Composite_Base 4961 (Dp2M (F_Info.Operator_Left, Tinfo, Mode_Value)), 4962 Arr_Type, 4963 New_Obj_Value (Var_I)))); 4964 New_Assign_Stmt 4965 (New_Obj (Var_R_El), 4966 M2E (Chap3.Index_Base 4967 (Chap3.Get_Composite_Base 4968 (Dp2M (F_Info.Operator_Right, Tinfo, Mode_Value)), 4969 Arr_Type, 4970 New_Obj_Value (Var_I)))); 4971 Gen_Compare (Var_L_El, Var_R_El); 4972 Finish_Declare_Stmt; 4973 Inc_Var (Var_I); 4974 Finish_Loop_Stmt (Label); 4975 Finish_Subprogram_Body; 4976 end Translate_Predefined_Array_Compare_Body; 4977 4978 -- Find the declaration of the predefined function IMP in type 4979 -- definition BASE_TYPE. 4980 function Find_Predefined_Function 4981 (Base_Type : Iir; Imp : Iir_Predefined_Functions) return Iir 4982 is 4983 El : Iir; 4984 begin 4985 El := Get_Chain (Get_Type_Declarator (Base_Type)); 4986 while El /= Null_Iir loop 4987 pragma Assert (Is_Implicit_Subprogram (El)); 4988 if Get_Implicit_Definition (El) = Imp then 4989 return El; 4990 else 4991 El := Get_Chain (El); 4992 end if; 4993 end loop; 4994 raise Internal_Error; 4995 end Find_Predefined_Function; 4996 4997 function Translate_Equality (L, R : Mnode; Etype : Iir) return O_Enode 4998 is 4999 Tinfo : Type_Info_Acc; 5000 Eq : Iir_Predefined_Functions; 5001 begin 5002 Tinfo := Get_Type_Info (L); 5003 case Tinfo.Type_Mode is 5004 when Type_Mode_Scalar 5005 | Type_Mode_Bounds_Acc 5006 | Type_Mode_Acc => 5007 -- Direct comparison. 5008 return New_Compare_Op (ON_Eq, M2E (L), M2E (R), 5009 Ghdl_Bool_Type); 5010 5011 when Type_Mode_Arrays => 5012 Eq := Iir_Predefined_Array_Equality; 5013 5014 when Type_Mode_Records => 5015 Eq := Iir_Predefined_Record_Equality; 5016 5017 when Type_Mode_Unknown 5018 | Type_Mode_File 5019 | Type_Mode_Protected => 5020 raise Internal_Error; 5021 end case; 5022 5023 -- Common code for arrays and records: use the equality function 5024 -- defined for the base type. 5025 declare 5026 Base_Type : constant Iir := Get_Base_Type (Etype); 5027 Lc, Rc : O_Enode; 5028 Func : Iir; 5029 begin 5030 Func := Find_Predefined_Function (Base_Type, Eq); 5031 -- Note: no location is passed as the conversion goes to the base 5032 -- type (which is always OK). 5033 -- If the location is used, compilation will fail. 5034 Lc := Translate_Implicit_Conv 5035 (M2E (L), Etype, Base_Type, Mode_Value, Null_Iir); 5036 Rc := Translate_Implicit_Conv 5037 (M2E (R), Etype, Base_Type, Mode_Value, Null_Iir); 5038 return Translate_Predefined_Lib_Operator (Lc, Rc, Func); 5039 end; 5040 end Translate_Equality; 5041 5042 procedure Translate_Predefined_Array_Equality_Spec (Subprg : Iir) 5043 is 5044 Arr_Type : constant Iir_Array_Type_Definition := 5045 Get_Type (Get_Interface_Declaration_Chain (Subprg)); 5046 Info : constant Type_Info_Acc := Get_Info (Arr_Type); 5047 Id : constant Name_Id := 5048 Get_Identifier (Get_Type_Declarator (Arr_Type)); 5049 Arr_Ptr_Type : constant O_Tnode := Info.Ortho_Ptr_Type (Mode_Value); 5050 F_Info : Operator_Info_Acc; 5051 Interface_List : O_Inter_List; 5052 begin 5053 F_Info := Add_Info (Subprg, Kind_Operator); 5054 5055 -- Create function. 5056 Start_Function_Decl (Interface_List, Create_Identifier (Id, "_EQ"), 5057 Global_Storage, Std_Boolean_Type_Node); 5058 Create_Operator_Instance (Interface_List, F_Info); 5059 New_Interface_Decl (Interface_List, F_Info.Operator_Left, 5060 Wki_Left, Arr_Ptr_Type); 5061 New_Interface_Decl (Interface_List, F_Info.Operator_Right, 5062 Wki_Right, Arr_Ptr_Type); 5063 Finish_Subprogram_Decl (Interface_List, F_Info.Operator_Node); 5064 end Translate_Predefined_Array_Equality_Spec; 5065 5066 procedure Translate_Predefined_Array_Equality_Body (Subprg : Iir) 5067 is 5068 Arr_Type : constant Iir_Array_Type_Definition := 5069 Get_Type (Get_Interface_Declaration_Chain (Subprg)); 5070 El_Type : constant Iir := Get_Element_Subtype (Arr_Type); 5071 Info : constant Type_Info_Acc := Get_Info (Arr_Type); 5072 F_Info : constant Operator_Info_Acc := Get_Info (Subprg); 5073 L, R : Mnode; 5074 Indexes : constant Iir_Flist := Get_Index_Subtype_List (Arr_Type); 5075 Nbr_Indexes : constant Natural := Get_Nbr_Elements (Indexes); 5076 If_Blk : O_If_Block; 5077 Var_I : O_Dnode; 5078 Var_Len : O_Dnode; 5079 Label : O_Snode; 5080 Base_Le, Base_Re : Mnode; 5081 Var_L, Var_R : Mnode; 5082 begin 5083 if Global_Storage = O_Storage_External then 5084 return; 5085 end if; 5086 5087 L := Dp2M (F_Info.Operator_Left, Info, Mode_Value); 5088 R := Dp2M (F_Info.Operator_Right, Info, Mode_Value); 5089 5090 Start_Subprogram_Body (F_Info.Operator_Node); 5091 Start_Operator_Instance_Use (F_Info); 5092 -- for each dimension: if length mismatch: return false 5093 for I in 1 .. Nbr_Indexes loop 5094 Start_If_Stmt 5095 (If_Blk, 5096 New_Compare_Op 5097 (ON_Neq, 5098 M2E (Chap3.Range_To_Length 5099 (Chap3.Get_Array_Range (L, Arr_Type, I))), 5100 M2E (Chap3.Range_To_Length 5101 (Chap3.Get_Array_Range (R, Arr_Type, I))), 5102 Std_Boolean_Type_Node)); 5103 New_Return_Stmt (New_Lit (Std_Boolean_False_Node)); 5104 Finish_If_Stmt (If_Blk); 5105 end loop; 5106 5107 -- For each element: if element is not equal, return false. 5108 New_Var_Decl (Var_I, Wki_I, O_Storage_Local, Ghdl_Index_Type); 5109 New_Var_Decl (Var_Len, Wki_Length, O_Storage_Local, Ghdl_Index_Type); 5110 Open_Temp; 5111 New_Assign_Stmt (New_Obj (Var_Len), 5112 Chap3.Get_Array_Length (L, Arr_Type)); 5113 Close_Temp; 5114 Open_Temp; 5115 Var_L := Chap3.Create_Maybe_Fat_Array_Element (L, Arr_Type); 5116 Var_R := Chap3.Create_Maybe_Fat_Array_Element (R, Arr_Type); 5117 Init_Var (Var_I); 5118 Start_Loop_Stmt (Label); 5119 -- If the end of the array is reached, return TRUE. 5120 Start_If_Stmt (If_Blk, 5121 New_Compare_Op (ON_Ge, 5122 New_Obj_Value (Var_I), 5123 New_Obj_Value (Var_Len), 5124 Ghdl_Bool_Type)); 5125 New_Return_Stmt (New_Lit (Std_Boolean_True_Node)); 5126 Finish_If_Stmt (If_Blk); 5127 Open_Temp; 5128 Base_Le := Chap3.Index_Array (L, Arr_Type, New_Obj_Value (Var_I)); 5129 Base_Le := Chap3.Assign_Maybe_Fat_Array_Element (Var_L, Base_Le); 5130 Base_Re := Chap3.Index_Array (R, Arr_Type, New_Obj_Value (Var_I)); 5131 Base_Re := Chap3.Assign_Maybe_Fat_Array_Element (Var_R, Base_Re); 5132 Start_If_Stmt 5133 (If_Blk, 5134 New_Monadic_Op (ON_Not, 5135 Translate_Equality (Base_Le, Base_Re, El_Type))); 5136 New_Return_Stmt (New_Lit (Std_Boolean_False_Node)); 5137 Finish_If_Stmt (If_Blk); 5138 Close_Temp; 5139 Inc_Var (Var_I); 5140 Finish_Loop_Stmt (Label); 5141 Close_Temp; 5142 Finish_Operator_Instance_Use (F_Info); 5143 Finish_Subprogram_Body; 5144 end Translate_Predefined_Array_Equality_Body; 5145 5146 procedure Translate_Predefined_Record_Equality_Spec (Subprg : Iir) 5147 is 5148 Rec_Type : constant Iir_Record_Type_Definition := 5149 Get_Type (Get_Interface_Declaration_Chain (Subprg)); 5150 Tinfo : constant Type_Info_Acc := Get_Info (Rec_Type); 5151 Id : constant Name_Id := 5152 Get_Identifier (Get_Type_Declarator (Rec_Type)); 5153 Rec_Ptr_Type : constant O_Tnode := Tinfo.Ortho_Ptr_Type (Mode_Value); 5154 F_Info : Operator_Info_Acc; 5155 Interface_List : O_Inter_List; 5156 begin 5157 F_Info := Add_Info (Subprg, Kind_Operator); 5158 5159 Start_Function_Decl (Interface_List, Create_Identifier (Id, "_EQ"), 5160 Global_Storage, Std_Boolean_Type_Node); 5161 Create_Operator_Instance (Interface_List, F_Info); 5162 New_Interface_Decl (Interface_List, F_Info.Operator_Left, 5163 Wki_Left, Rec_Ptr_Type); 5164 New_Interface_Decl (Interface_List, F_Info.Operator_Right, 5165 Wki_Right, Rec_Ptr_Type); 5166 Finish_Subprogram_Decl (Interface_List, F_Info.Operator_Node); 5167 end Translate_Predefined_Record_Equality_Spec; 5168 5169 procedure Translate_Predefined_Record_Equality_Body (Subprg : Iir) 5170 is 5171 Rec_Type : constant Iir_Record_Type_Definition := 5172 Get_Type (Get_Interface_Declaration_Chain (Subprg)); 5173 Tinfo : constant Type_Info_Acc := Get_Info (Rec_Type); 5174 F_Info : constant Operator_Info_Acc := Get_Info (Subprg); 5175 L, R : Mnode; 5176 If_Blk : O_If_Block; 5177 Le, Re : Mnode; 5178 5179 El_List : Iir_Flist; 5180 El : Iir_Element_Declaration; 5181 begin 5182 if Global_Storage = O_Storage_External then 5183 return; 5184 end if; 5185 5186 Start_Subprogram_Body (F_Info.Operator_Node); 5187 Start_Operator_Instance_Use (F_Info); 5188 5189 L := Dp2M (F_Info.Operator_Left, Tinfo, Mode_Value); 5190 R := Dp2M (F_Info.Operator_Right, Tinfo, Mode_Value); 5191 5192 -- Compare each element. 5193 El_List := Get_Elements_Declaration_List (Rec_Type); 5194 for I in Flist_First .. Flist_Last (El_List) loop 5195 El := Get_Nth_Element (El_List, I); 5196 Open_Temp; 5197 Le := Chap6.Translate_Selected_Element (L, El); 5198 Re := Chap6.Translate_Selected_Element (R, El); 5199 5200 Start_If_Stmt 5201 (If_Blk, 5202 New_Monadic_Op (ON_Not, 5203 Translate_Equality (Le, Re, Get_Type (El)))); 5204 New_Return_Stmt (New_Lit (Std_Boolean_False_Node)); 5205 Finish_If_Stmt (If_Blk); 5206 Close_Temp; 5207 end loop; 5208 New_Return_Stmt (New_Lit (Std_Boolean_True_Node)); 5209 Finish_Operator_Instance_Use (F_Info); 5210 Finish_Subprogram_Body; 5211 end Translate_Predefined_Record_Equality_Body; 5212 5213 procedure Translate_Predefined_Array_Logical_Spec (Subprg : Iir) 5214 is 5215 Arr_Type : constant Iir_Array_Type_Definition := 5216 Get_Type (Get_Interface_Declaration_Chain (Subprg)); 5217 -- Info for the array type. 5218 Tinfo : constant Type_Info_Acc := Get_Info (Arr_Type); 5219 -- Identifier of the type. 5220 Id : constant Name_Id := 5221 Get_Identifier (Get_Type_Declarator (Arr_Type)); 5222 Arr_Ptr_Type : constant O_Tnode := 5223 Tinfo.Ortho_Ptr_Type (Mode_Value); 5224 F_Info : Operator_Info_Acc; 5225 Interface_List : O_Inter_List; 5226 Name : O_Ident; 5227 Is_Monadic : Boolean; 5228 begin 5229 F_Info := Add_Info (Subprg, Kind_Operator); 5230 --Chap2.Clear_Instance_Data (F_Info.Subprg_Instance); 5231 F_Info.Operator_Stack2 := True; 5232 5233 Is_Monadic := False; 5234 case Iir_Predefined_TF_Array_Functions 5235 (Get_Implicit_Definition (Subprg)) is 5236 when Iir_Predefined_TF_Array_And => 5237 Name := Create_Identifier (Id, "_AND"); 5238 when Iir_Predefined_TF_Array_Or => 5239 Name := Create_Identifier (Id, "_OR"); 5240 when Iir_Predefined_TF_Array_Nand => 5241 Name := Create_Identifier (Id, "_NAND"); 5242 when Iir_Predefined_TF_Array_Nor => 5243 Name := Create_Identifier (Id, "_NOR"); 5244 when Iir_Predefined_TF_Array_Xor => 5245 Name := Create_Identifier (Id, "_XOR"); 5246 when Iir_Predefined_TF_Array_Xnor => 5247 Name := Create_Identifier (Id, "_XNOR"); 5248 when Iir_Predefined_TF_Array_Not => 5249 Name := Create_Identifier (Id, "_NOT"); 5250 Is_Monadic := True; 5251 end case; 5252 5253 -- Create function. 5254 Start_Procedure_Decl (Interface_List, Name, Global_Storage); 5255 -- Note: contrary to user function which returns composite value 5256 -- via a result record, a concatenation returns its value without 5257 -- the use of the record. 5258 New_Interface_Decl (Interface_List, F_Info.Operator_Res, 5259 Wki_Res, Arr_Ptr_Type); 5260 New_Interface_Decl (Interface_List, F_Info.Operator_Left, 5261 Wki_Left, Arr_Ptr_Type); 5262 if not Is_Monadic then 5263 New_Interface_Decl (Interface_List, F_Info.Operator_Right, 5264 Wki_Right, Arr_Ptr_Type); 5265 end if; 5266 Finish_Subprogram_Decl (Interface_List, F_Info.Operator_Node); 5267 end Translate_Predefined_Array_Logical_Spec; 5268 5269 procedure Translate_Predefined_Array_Logical_Body (Subprg : Iir) 5270 is 5271 Arr_Type : constant Iir_Array_Type_Definition := 5272 Get_Type (Get_Interface_Declaration_Chain (Subprg)); 5273 -- Info for the array type. 5274 Tinfo : constant Type_Info_Acc := Get_Info (Arr_Type); 5275 F_Info : constant Operator_Info_Acc := Get_Info (Subprg); 5276 Res : Mnode; 5277 Var_Length, Var_I : O_Dnode; 5278 Var_Base : O_Dnode; 5279 Var_L_Base : O_Dnode; 5280 Var_R_Base : O_Dnode; 5281 If_Blk : O_If_Block; 5282 Label : O_Snode; 5283 Is_Monadic : Boolean; 5284 El, L_El : O_Enode; 5285 Op : ON_Op_Kind; 5286 Do_Invert : Boolean; 5287 begin 5288 if Global_Storage = O_Storage_External then 5289 return; 5290 end if; 5291 5292 Is_Monadic := False; 5293 case Iir_Predefined_TF_Array_Functions 5294 (Get_Implicit_Definition (Subprg)) is 5295 when Iir_Predefined_TF_Array_And => 5296 Op := ON_And; 5297 Do_Invert := False; 5298 when Iir_Predefined_TF_Array_Or => 5299 Op := ON_Or; 5300 Do_Invert := False; 5301 when Iir_Predefined_TF_Array_Nand => 5302 Op := ON_And; 5303 Do_Invert := True; 5304 when Iir_Predefined_TF_Array_Nor => 5305 Op := ON_Or; 5306 Do_Invert := True; 5307 when Iir_Predefined_TF_Array_Xor => 5308 Op := ON_Xor; 5309 Do_Invert := False; 5310 when Iir_Predefined_TF_Array_Xnor => 5311 Op := ON_Xor; 5312 Do_Invert := True; 5313 when Iir_Predefined_TF_Array_Not => 5314 Is_Monadic := True; 5315 Op := ON_Not; 5316 Do_Invert := False; 5317 end case; 5318 5319 Start_Subprogram_Body (F_Info.Operator_Node); 5320 New_Var_Decl (Var_Length, Wki_Length, O_Storage_Local, 5321 Ghdl_Index_Type); 5322 New_Var_Decl (Var_I, Wki_I, O_Storage_Local, Ghdl_Index_Type); 5323 New_Var_Decl (Var_Base, Get_Identifier ("base"), O_Storage_Local, 5324 Tinfo.B.Base_Ptr_Type (Mode_Value)); 5325 New_Var_Decl (Var_L_Base, Get_Identifier ("l_base"), O_Storage_Local, 5326 Tinfo.B.Base_Ptr_Type (Mode_Value)); 5327 if not Is_Monadic then 5328 New_Var_Decl 5329 (Var_R_Base, Get_Identifier ("r_base"), O_Storage_Local, 5330 Tinfo.B.Base_Ptr_Type (Mode_Value)); 5331 end if; 5332 Open_Temp; 5333 -- Get length of LEFT. 5334 New_Assign_Stmt 5335 (New_Obj (Var_Length), 5336 Chap6.Get_Array_Bound_Length 5337 (Dp2M (F_Info.Operator_Left, Tinfo, Mode_Value), Arr_Type, 1)); 5338 -- If dyadic, check RIGHT has the same length. 5339 if not Is_Monadic then 5340 Chap6.Check_Bound_Error 5341 (New_Compare_Op 5342 (ON_Neq, 5343 New_Obj_Value (Var_Length), 5344 Chap6.Get_Array_Bound_Length 5345 (Dp2M (F_Info.Operator_Right, Tinfo, Mode_Value), 5346 Arr_Type, 1), 5347 Ghdl_Bool_Type), 5348 Subprg); 5349 end if; 5350 5351 -- Create the result from LEFT bound. 5352 Res := Dp2M (F_Info.Operator_Res, Tinfo, Mode_Value); 5353 Chap3.Translate_Object_Allocation 5354 (Res, Alloc_Return, Arr_Type, 5355 Chap3.Get_Composite_Bounds 5356 (Dp2M (F_Info.Operator_Left, Tinfo, Mode_Value))); 5357 New_Assign_Stmt 5358 (New_Obj (Var_Base), M2Addr (Chap3.Get_Composite_Base (Res))); 5359 New_Assign_Stmt 5360 (New_Obj (Var_L_Base), 5361 M2Addr (Chap3.Get_Composite_Base 5362 (Dp2M (F_Info.Operator_Left, Tinfo, Mode_Value)))); 5363 if not Is_Monadic then 5364 New_Assign_Stmt 5365 (New_Obj (Var_R_Base), 5366 M2Addr (Chap3.Get_Composite_Base 5367 (Dp2M (F_Info.Operator_Right, Tinfo, Mode_Value)))); 5368 end if; 5369 5370 -- Do the logical operation on each element. 5371 Init_Var (Var_I); 5372 Start_Loop_Stmt (Label); 5373 Start_If_Stmt (If_Blk, 5374 New_Compare_Op (ON_Ge, 5375 New_Obj_Value (Var_I), 5376 New_Obj_Value (Var_Length), 5377 Ghdl_Bool_Type)); 5378 New_Return_Stmt; 5379 Finish_If_Stmt (If_Blk); 5380 L_El := New_Value (New_Indexed_Element 5381 (New_Acc_Value (New_Obj (Var_L_Base)), 5382 New_Obj_Value (Var_I))); 5383 if Is_Monadic then 5384 El := New_Monadic_Op (Op, L_El); 5385 else 5386 El := New_Dyadic_Op 5387 (Op, L_El, 5388 New_Value (New_Indexed_Element 5389 (New_Acc_Value (New_Obj (Var_R_Base)), 5390 New_Obj_Value (Var_I)))); 5391 end if; 5392 if Do_Invert then 5393 El := New_Monadic_Op (ON_Not, El); 5394 end if; 5395 5396 New_Assign_Stmt (New_Indexed_Element 5397 (New_Acc_Value (New_Obj (Var_Base)), 5398 New_Obj_Value (Var_I)), 5399 El); 5400 Inc_Var (Var_I); 5401 Finish_Loop_Stmt (Label); 5402 Close_Temp; 5403 Finish_Subprogram_Body; 5404 end Translate_Predefined_Array_Logical_Body; 5405 5406 procedure Translate_Predefined_Array_Shift_Spec (Subprg : Iir) 5407 is 5408 Inter : constant Iir := Get_Interface_Declaration_Chain (Subprg); 5409 Int_Info : constant Type_Info_Acc := 5410 Get_Info (Get_Type (Get_Chain (Inter))); 5411 Int_Type : constant O_Tnode := Int_Info.Ortho_Type (Mode_Value); 5412 5413 -- Info for the array type. 5414 Arr_Type : constant Iir_Array_Type_Definition := Get_Type (Inter); 5415 Tinfo : constant Type_Info_Acc := Get_Info (Arr_Type); 5416 Arr_Ptr_Type : constant O_Tnode := Tinfo.Ortho_Ptr_Type (Mode_Value); 5417 5418 Id : constant Name_Id := Get_Identifier (Get_Type_Declarator (Arr_Type)); 5419 5420 F_Info : Operator_Info_Acc; 5421 Interface_List : O_Inter_List; 5422 Name : O_Ident; 5423 begin 5424 F_Info := Add_Info (Subprg, Kind_Operator); 5425 --Chap2.Clear_Instance_Data (F_Info.Subprg_Instance); 5426 F_Info.Operator_Stack2 := True; 5427 5428 case Iir_Predefined_Shift_Functions (Get_Implicit_Definition (Subprg)) is 5429 when Iir_Predefined_Array_Sll 5430 | Iir_Predefined_Array_Srl => 5431 -- Shift logical. 5432 Name := Create_Identifier (Id, "_SHL"); 5433 when Iir_Predefined_Array_Sla 5434 | Iir_Predefined_Array_Sra => 5435 -- Shift arithmetic. 5436 Name := Create_Identifier (Id, "_SHA"); 5437 when Iir_Predefined_Array_Rol 5438 | Iir_Predefined_Array_Ror => 5439 -- Rotation 5440 Name := Create_Identifier (Id, "_ROT"); 5441 end case; 5442 5443 -- Create function. 5444 Start_Procedure_Decl (Interface_List, Name, Global_Storage); 5445 -- Note: contrary to user function which returns composite value 5446 -- via a result record, a shift returns its value without 5447 -- the use of the record. 5448 New_Interface_Decl (Interface_List, F_Info.Operator_Res, 5449 Wki_Res, Arr_Ptr_Type); 5450 New_Interface_Decl (Interface_List, F_Info.Operator_Left, 5451 Wki_Left, Arr_Ptr_Type); 5452 New_Interface_Decl (Interface_List, F_Info.Operator_Right, 5453 Wki_Right, Int_Type); 5454 Finish_Subprogram_Decl (Interface_List, F_Info.Operator_Node); 5455 end Translate_Predefined_Array_Shift_Spec; 5456 5457 procedure Translate_Predefined_Array_Shift_Body (Subprg : Iir) 5458 is 5459 Inter : constant Iir := Get_Interface_Declaration_Chain (Subprg); 5460 Int_Info : constant Type_Info_Acc := 5461 Get_Info (Get_Type (Get_Chain (Inter))); 5462 Int_Type : constant O_Tnode := Int_Info.Ortho_Type (Mode_Value); 5463 5464 -- Info for the array type. 5465 Arr_Type : constant Iir_Array_Type_Definition := Get_Type (Inter); 5466 Tinfo : constant Type_Info_Acc := Get_Info (Arr_Type); 5467 5468 F_Info : constant Operator_Info_Acc := Get_Info (Subprg); 5469 5470 type Shift_Kind is (Sh_Logical, Sh_Arith, Rotation); 5471 Shift : Shift_Kind; 5472 5473 -- Body; 5474 Var_Length, Var_I, Var_I1 : O_Dnode; 5475 Var_Res_Base, Var_L_Base : O_Dnode; 5476 Var_Rl : O_Dnode; 5477 Var_E : O_Dnode; 5478 L : Mnode; 5479 If_Blk, If_Blk1 : O_If_Block; 5480 Label : O_Snode; 5481 Res : Mnode; 5482 5483 procedure Do_Shift (To_Right : Boolean) 5484 is 5485 Tmp : O_Enode; 5486 begin 5487 -- LEFT: 5488 -- * I := 0; 5489 if not To_Right then 5490 Init_Var (Var_I); 5491 end if; 5492 5493 -- * If R < LENGTH then 5494 Start_If_Stmt (If_Blk1, 5495 New_Compare_Op (ON_Lt, 5496 New_Obj_Value (Var_Rl), 5497 New_Obj_Value (Var_Length), 5498 Ghdl_Bool_Type)); 5499 -- Shift the elements (that remains in the result). 5500 -- RIGHT: 5501 -- * for I = R to LENGTH - 1 loop 5502 -- * RES[I] := L[I - R] 5503 -- LEFT: 5504 -- * for I = 0 to LENGTH - R loop 5505 -- * RES[I] := L[R + I] 5506 if To_Right then 5507 New_Assign_Stmt (New_Obj (Var_I), New_Obj_Value (Var_Rl)); 5508 Init_Var (Var_I1); 5509 else 5510 New_Assign_Stmt (New_Obj (Var_I1), New_Obj_Value (Var_Rl)); 5511 end if; 5512 Start_Loop_Stmt (Label); 5513 if To_Right then 5514 Tmp := New_Obj_Value (Var_I); 5515 else 5516 Tmp := New_Obj_Value (Var_I1); 5517 end if; 5518 Gen_Exit_When (Label, New_Compare_Op (ON_Ge, 5519 Tmp, 5520 New_Obj_Value (Var_Length), 5521 Ghdl_Bool_Type)); 5522 New_Assign_Stmt 5523 (New_Indexed_Acc_Value (New_Obj (Var_Res_Base), 5524 New_Obj_Value (Var_I)), 5525 New_Value 5526 (New_Indexed_Acc_Value (New_Obj (Var_L_Base), 5527 New_Obj_Value (Var_I1)))); 5528 Inc_Var (Var_I); 5529 Inc_Var (Var_I1); 5530 Finish_Loop_Stmt (Label); 5531 -- RIGHT: 5532 -- * else 5533 -- * R := LENGTH; 5534 if To_Right then 5535 New_Else_Stmt (If_Blk1); 5536 New_Assign_Stmt (New_Obj (Var_Rl), New_Obj_Value (Var_Length)); 5537 end if; 5538 Finish_If_Stmt (If_Blk1); 5539 5540 -- Pad the result. 5541 -- RIGHT: 5542 -- * For I = 0 to R - 1 5543 -- * RES[I] := 0/L[0/LENGTH-1] 5544 -- LEFT: 5545 -- * For I = LENGTH - R to LENGTH - 1 5546 -- * RES[I] := 0/L[0/LENGTH-1] 5547 if To_Right then 5548 Init_Var (Var_I); 5549 else 5550 -- I is yet correctly set. 5551 null; 5552 end if; 5553 if Shift = Sh_Arith then 5554 if To_Right then 5555 Tmp := New_Lit (Ghdl_Index_0); 5556 else 5557 Tmp := New_Dyadic_Op 5558 (ON_Sub_Ov, 5559 New_Obj_Value (Var_Length), 5560 New_Lit (Ghdl_Index_1)); 5561 end if; 5562 New_Assign_Stmt 5563 (New_Obj (Var_E), 5564 New_Value (New_Indexed_Acc_Value (New_Obj (Var_L_Base), 5565 Tmp))); 5566 end if; 5567 Start_Loop_Stmt (Label); 5568 if To_Right then 5569 Tmp := New_Obj_Value (Var_Rl); 5570 else 5571 Tmp := New_Obj_Value (Var_Length); 5572 end if; 5573 Gen_Exit_When (Label, New_Compare_Op (ON_Ge, 5574 New_Obj_Value (Var_I), 5575 Tmp, 5576 Ghdl_Bool_Type)); 5577 case Shift is 5578 when Sh_Logical => 5579 declare 5580 Enum_List : constant Iir_Flist := 5581 Get_Enumeration_Literal_List 5582 (Get_Base_Type (Get_Element_Subtype (Arr_Type))); 5583 begin 5584 Tmp := New_Lit 5585 (Get_Ortho_Literal (Get_Nth_Element (Enum_List, 0))); 5586 end; 5587 when Sh_Arith => 5588 Tmp := New_Obj_Value (Var_E); 5589 when Rotation => 5590 raise Internal_Error; 5591 end case; 5592 5593 New_Assign_Stmt 5594 (New_Indexed_Acc_Value (New_Obj (Var_Res_Base), 5595 New_Obj_Value (Var_I)), Tmp); 5596 Inc_Var (Var_I); 5597 Finish_Loop_Stmt (Label); 5598 end Do_Shift; 5599 begin 5600 if Global_Storage = O_Storage_External then 5601 return; 5602 end if; 5603 5604 case Iir_Predefined_Shift_Functions (Get_Implicit_Definition (Subprg)) is 5605 when Iir_Predefined_Array_Sll 5606 | Iir_Predefined_Array_Srl => 5607 -- Shift logical. 5608 Shift := Sh_Logical; 5609 when Iir_Predefined_Array_Sla 5610 | Iir_Predefined_Array_Sra => 5611 -- Shift arithmetic. 5612 Shift := Sh_Arith; 5613 when Iir_Predefined_Array_Rol 5614 | Iir_Predefined_Array_Ror => 5615 -- Rotation 5616 Shift := Rotation; 5617 end case; 5618 5619 -- Body 5620 Start_Subprogram_Body (F_Info.Operator_Node); 5621 New_Var_Decl (Var_Length, Wki_Length, O_Storage_Local, 5622 Ghdl_Index_Type); 5623 if Shift /= Rotation then 5624 New_Var_Decl (Var_Rl, Get_Identifier ("rl"), O_Storage_Local, 5625 Ghdl_Index_Type); 5626 end if; 5627 New_Var_Decl (Var_I, Wki_I, O_Storage_Local, Ghdl_Index_Type); 5628 New_Var_Decl (Var_I1, Get_Identifier ("I1"), O_Storage_Local, 5629 Ghdl_Index_Type); 5630 New_Var_Decl (Var_Res_Base, Get_Identifier ("res_base"), 5631 O_Storage_Local, Tinfo.B.Base_Ptr_Type (Mode_Value)); 5632 New_Var_Decl (Var_L_Base, Get_Identifier ("l_base"), 5633 O_Storage_Local, Tinfo.B.Base_Ptr_Type (Mode_Value)); 5634 if Shift = Sh_Arith then 5635 New_Var_Decl (Var_E, Get_Identifier ("E"), O_Storage_Local, 5636 Get_Info (Get_Element_Subtype (Arr_Type)). 5637 Ortho_Type (Mode_Value)); 5638 end if; 5639 Res := Dp2M (F_Info.Operator_Res, Tinfo, Mode_Value); 5640 L := Dp2M (F_Info.Operator_Left, Tinfo, Mode_Value); 5641 5642 -- LRM93 7.2.3 5643 -- The index subtypes of the return values of all shift operators is 5644 -- the same as the index subtype of their left arguments. 5645 New_Assign_Stmt 5646 (M2Lp (Chap3.Get_Composite_Bounds (Res)), 5647 M2Addr (Chap3.Get_Composite_Bounds (L))); 5648 5649 -- Get length of LEFT. 5650 New_Assign_Stmt (New_Obj (Var_Length), 5651 Chap3.Get_Array_Length (L, Arr_Type)); 5652 5653 -- LRM93 7.2.3 [6 times] 5654 -- That is, if R is 0 or L is a null array, the return value is L. 5655 Start_If_Stmt 5656 (If_Blk, 5657 New_Dyadic_Op 5658 (ON_Or, 5659 New_Compare_Op (ON_Eq, 5660 New_Obj_Value (F_Info.Operator_Right), 5661 New_Lit (New_Signed_Literal (Int_Type, 0)), 5662 Ghdl_Bool_Type), 5663 New_Compare_Op (ON_Eq, 5664 New_Obj_Value (Var_Length), 5665 New_Lit (Ghdl_Index_0), 5666 Ghdl_Bool_Type))); 5667 New_Assign_Stmt 5668 (M2Lp (Chap3.Get_Composite_Base (Res)), 5669 M2Addr (Chap3.Get_Composite_Base (L))); 5670 New_Return_Stmt; 5671 Finish_If_Stmt (If_Blk); 5672 5673 -- Allocate base. 5674 New_Assign_Stmt 5675 (New_Obj (Var_Res_Base), 5676 Gen_Alloc (Alloc_Return, New_Obj_Value (Var_Length), 5677 Tinfo.B.Base_Ptr_Type (Mode_Value))); 5678 New_Assign_Stmt (M2Lp (Chap3.Get_Composite_Base (Res)), 5679 New_Obj_Value (Var_Res_Base)); 5680 5681 New_Assign_Stmt (New_Obj (Var_L_Base), 5682 M2Addr (Chap3.Get_Composite_Base (L))); 5683 5684 Start_If_Stmt (If_Blk, 5685 New_Compare_Op (ON_Gt, 5686 New_Obj_Value (F_Info.Operator_Right), 5687 New_Lit (New_Signed_Literal (Int_Type, 5688 0)), 5689 Ghdl_Bool_Type)); 5690 -- R > 0. 5691 -- Ie, to the right 5692 case Shift is 5693 when Rotation => 5694 -- * I1 := LENGTH - (R mod LENGTH) 5695 New_Assign_Stmt 5696 (New_Obj (Var_I1), 5697 New_Dyadic_Op 5698 (ON_Sub_Ov, 5699 New_Obj_Value (Var_Length), 5700 New_Dyadic_Op 5701 (ON_Mod_Ov, 5702 New_Convert_Ov (New_Obj_Value (F_Info.Operator_Right), 5703 Ghdl_Index_Type), 5704 New_Obj_Value (Var_Length)))); 5705 5706 when Sh_Logical 5707 | Sh_Arith => 5708 -- Real SRL or SRA. 5709 New_Assign_Stmt 5710 (New_Obj (Var_Rl), 5711 New_Convert_Ov (New_Obj_Value (F_Info.Operator_Right), 5712 Ghdl_Index_Type)); 5713 5714 Do_Shift (True); 5715 end case; 5716 5717 New_Else_Stmt (If_Blk); 5718 5719 -- R < 0, to the left. 5720 case Shift is 5721 when Rotation => 5722 -- * I1 := (-R) mod LENGTH 5723 New_Assign_Stmt 5724 (New_Obj (Var_I1), 5725 New_Dyadic_Op (ON_Mod_Ov, 5726 New_Convert_Ov 5727 (New_Monadic_Op 5728 (ON_Neg_Ov, 5729 New_Obj_Value (F_Info.Operator_Right)), 5730 Ghdl_Index_Type), 5731 New_Obj_Value (Var_Length))); 5732 when Sh_Logical 5733 | Sh_Arith => 5734 -- Real SLL or SLA. 5735 New_Assign_Stmt 5736 (New_Obj (Var_Rl), 5737 New_Convert_Ov (New_Monadic_Op 5738 (ON_Neg_Ov, 5739 New_Obj_Value (F_Info.Operator_Right)), 5740 Ghdl_Index_Type)); 5741 5742 Do_Shift (False); 5743 end case; 5744 Finish_If_Stmt (If_Blk); 5745 5746 if Shift = Rotation then 5747 -- * If I1 = LENGTH then 5748 -- * I1 := 0 5749 Start_If_Stmt (If_Blk, New_Compare_Op (ON_Ge, 5750 New_Obj_Value (Var_I1), 5751 New_Obj_Value (Var_Length), 5752 Ghdl_Bool_Type)); 5753 Init_Var (Var_I1); 5754 Finish_If_Stmt (If_Blk); 5755 5756 -- * for I = 0 to LENGTH - 1 loop 5757 -- * RES[I] := L[I1]; 5758 Init_Var (Var_I); 5759 Start_Loop_Stmt (Label); 5760 Gen_Exit_When (Label, New_Compare_Op (ON_Ge, 5761 New_Obj_Value (Var_I), 5762 New_Obj_Value (Var_Length), 5763 Ghdl_Bool_Type)); 5764 New_Assign_Stmt 5765 (New_Indexed_Acc_Value (New_Obj (Var_Res_Base), 5766 New_Obj_Value (Var_I)), 5767 New_Value 5768 (New_Indexed_Acc_Value (New_Obj (Var_L_Base), 5769 New_Obj_Value (Var_I1)))); 5770 Inc_Var (Var_I); 5771 -- * I1 := I1 + 1 5772 Inc_Var (Var_I1); 5773 -- * If I1 = LENGTH then 5774 -- * I1 := 0 5775 Start_If_Stmt (If_Blk, New_Compare_Op (ON_Ge, 5776 New_Obj_Value (Var_I1), 5777 New_Obj_Value (Var_Length), 5778 Ghdl_Bool_Type)); 5779 Init_Var (Var_I1); 5780 Finish_If_Stmt (If_Blk); 5781 Finish_Loop_Stmt (Label); 5782 end if; 5783 Finish_Subprogram_Body; 5784 end Translate_Predefined_Array_Shift_Body; 5785 5786 procedure Translate_File_Subprogram_Spec (Subprg : Iir; File_Type : Iir) 5787 is 5788 Etype : constant Iir := Get_Type (Get_File_Type_Mark (File_Type)); 5789 Tinfo : constant Type_Info_Acc := Get_Info (Etype); 5790 Kind : Iir_Predefined_Functions; 5791 F_Info : Operator_Info_Acc; 5792 Name : O_Ident; 5793 Inter_List : O_Inter_List; 5794 Id : Name_Id; 5795 begin 5796 if Tinfo.Type_Mode in Type_Mode_Scalar then 5797 -- Intrinsic. 5798 return; 5799 end if; 5800 5801 F_Info := Add_Info (Subprg, Kind_Operator); 5802 --Chap2.Clear_Instance_Data (F_Info.Subprg_Instance); 5803 F_Info.Operator_Stack2 := False; 5804 5805 Id := Get_Identifier (Get_Type_Declarator (File_Type)); 5806 Kind := Get_Implicit_Definition (Subprg); 5807 case Kind is 5808 when Iir_Predefined_Write => 5809 Name := Create_Identifier (Id, "_WRITE"); 5810 when Iir_Predefined_Read 5811 | Iir_Predefined_Read_Length => 5812 Name := Create_Identifier (Id, "_READ"); 5813 when others => 5814 raise Internal_Error; 5815 end case; 5816 5817 -- Create function. 5818 if Kind = Iir_Predefined_Read_Length then 5819 Start_Function_Decl 5820 (Inter_List, Name, Global_Storage, Std_Integer_Otype); 5821 else 5822 Start_Procedure_Decl (Inter_List, Name, Global_Storage); 5823 end if; 5824 Create_Operator_Instance (Inter_List, F_Info); 5825 5826 New_Interface_Decl (Inter_List, F_Info.Operator_Left, 5827 Get_Identifier ("FILE"), Ghdl_File_Index_Type); 5828 New_Interface_Decl (Inter_List, F_Info.Operator_Right, 5829 Wki_Val, Tinfo.Ortho_Ptr_Type (Mode_Value)); 5830 Finish_Subprogram_Decl (Inter_List, F_Info.Operator_Node); 5831 end Translate_File_Subprogram_Spec; 5832 5833 procedure Translate_File_Subprogram_Body (Subprg : Iir; File_Type : Iir) 5834 is 5835 Etype : constant Iir := Get_Type (Get_File_Type_Mark (File_Type)); 5836 Tinfo : constant Type_Info_Acc := Get_Info (Etype); 5837 F_Info : constant Operator_Info_Acc := Get_Info (Subprg); 5838 Kind : constant Iir_Predefined_Functions 5839 := Get_Implicit_Definition (Subprg); 5840 5841 procedure Translate_Rw (Val : Mnode; Val_Type : Iir; Proc : O_Dnode); 5842 5843 procedure Translate_Rw_Array 5844 (Val : Mnode; Val_Type : Iir; Var_Max : O_Dnode; Proc : O_Dnode) 5845 is 5846 Var_It : O_Dnode; 5847 Label : O_Snode; 5848 begin 5849 Var_It := Create_Temp (Ghdl_Index_Type); 5850 Init_Var (Var_It); 5851 Start_Loop_Stmt (Label); 5852 Gen_Exit_When 5853 (Label, 5854 New_Compare_Op (ON_Eq, 5855 New_Obj_Value (Var_It), 5856 New_Obj_Value (Var_Max), 5857 Ghdl_Bool_Type)); 5858 Translate_Rw 5859 (Chap3.Index_Base (Val, Val_Type, New_Obj_Value (Var_It)), 5860 Get_Element_Subtype (Val_Type), Proc); 5861 Inc_Var (Var_It); 5862 Finish_Loop_Stmt (Label); 5863 end Translate_Rw_Array; 5864 5865 procedure Translate_Rw (Val : Mnode; Val_Type : Iir; Proc : O_Dnode) 5866 is 5867 Val_Info : Type_Info_Acc; 5868 Assocs : O_Assoc_List; 5869 begin 5870 Val_Info := Get_Type_Info (Val); 5871 case Val_Info.Type_Mode is 5872 when Type_Mode_Scalar => 5873 Start_Association (Assocs, Proc); 5874 -- compute file parameter (get an index) 5875 New_Association (Assocs, New_Obj_Value (F_Info.Operator_Left)); 5876 -- compute the value. 5877 New_Association 5878 (Assocs, New_Convert_Ov (M2Addr (Val), Ghdl_Ptr_Type)); 5879 -- length. 5880 New_Association 5881 (Assocs, 5882 New_Lit (New_Sizeof (Val_Info.Ortho_Type (Mode_Value), 5883 Ghdl_Index_Type))); 5884 -- call a predefined procedure 5885 New_Procedure_Call (Assocs); 5886 when Type_Mode_Bounded_Records => 5887 declare 5888 El_List : constant Iir_Flist := 5889 Get_Elements_Declaration_List (Get_Base_Type (Val_Type)); 5890 El : Iir; 5891 Val1 : Mnode; 5892 begin 5893 Open_Temp; 5894 Val1 := Stabilize (Val); 5895 for I in Flist_First .. Flist_Last (El_List) loop 5896 El := Get_Nth_Element (El_List, I); 5897 Translate_Rw 5898 (Chap6.Translate_Selected_Element (Val1, El), 5899 Get_Type (El), Proc); 5900 end loop; 5901 Close_Temp; 5902 end; 5903 when Type_Mode_Bounded_Arrays => 5904 declare 5905 Var_Max : O_Dnode; 5906 begin 5907 Open_Temp; 5908 Var_Max := Create_Temp (Ghdl_Index_Type); 5909 New_Assign_Stmt 5910 (New_Obj (Var_Max), 5911 Chap3.Get_Array_Type_Length (Val_Type)); 5912 Translate_Rw_Array (Val, Val_Type, Var_Max, Proc); 5913 Close_Temp; 5914 end; 5915 when Type_Mode_Unknown 5916 | Type_Mode_File 5917 | Type_Mode_Acc 5918 | Type_Mode_Bounds_Acc 5919 | Type_Mode_Unbounded_Array 5920 | Type_Mode_Unbounded_Record 5921 | Type_Mode_Protected => 5922 raise Internal_Error; 5923 end case; 5924 end Translate_Rw; 5925 5926 procedure Translate_Rw_Length (Var_Length : O_Dnode; Proc : O_Dnode) 5927 is 5928 Assocs : O_Assoc_List; 5929 begin 5930 Start_Association (Assocs, Proc); 5931 New_Association (Assocs, New_Obj_Value (F_Info.Operator_Left)); 5932 New_Association 5933 (Assocs, New_Unchecked_Address (New_Obj (Var_Length), 5934 Ghdl_Ptr_Type)); 5935 New_Association 5936 (Assocs, 5937 New_Lit (New_Sizeof (Ghdl_Index_Type, Ghdl_Index_Type))); 5938 New_Procedure_Call (Assocs); 5939 end Translate_Rw_Length; 5940 5941 Var : Mnode; 5942 begin 5943 if F_Info = null then 5944 return; 5945 end if; 5946 5947 if Global_Storage = O_Storage_External then 5948 return; 5949 end if; 5950 5951 Start_Subprogram_Body (F_Info.Operator_Node); 5952 Start_Operator_Instance_Use (F_Info); 5953 Push_Local_Factory; 5954 5955 Var := Dp2M (F_Info.Operator_Right, Tinfo, Mode_Value); 5956 5957 case Kind is 5958 when Iir_Predefined_Write => 5959 if Tinfo.Type_Mode = Type_Mode_Fat_Array then 5960 declare 5961 Var_Max : O_Dnode; 5962 begin 5963 Open_Temp; 5964 Var_Max := Create_Temp_Init 5965 (Ghdl_Index_Type, 5966 Chap3.Get_Array_Length (Var, Etype)); 5967 Translate_Rw_Length (Var_Max, Ghdl_Write_Scalar); 5968 Translate_Rw_Array (Chap3.Get_Composite_Base (Var), Etype, 5969 Var_Max, Ghdl_Write_Scalar); 5970 Close_Temp; 5971 end; 5972 else 5973 Translate_Rw (Var, Etype, Ghdl_Write_Scalar); 5974 end if; 5975 when Iir_Predefined_Read => 5976 Translate_Rw (Var, Etype, Ghdl_Read_Scalar); 5977 5978 when Iir_Predefined_Read_Length => 5979 declare 5980 El_Type : constant Iir := Get_Element_Subtype (Etype); 5981 El_Tinfo : constant Type_Info_Acc := Get_Info (El_Type); 5982 Var_Len : O_Dnode; 5983 Var_Max : O_Dnode; 5984 Var_It : O_Dnode; 5985 Label : O_Snode; 5986 If_Blk : O_If_Block; 5987 Targ : O_Dnode; 5988 Dummy : Mnode; 5989 begin 5990 Open_Temp; 5991 Var_Max := Create_Temp (Ghdl_Index_Type); 5992 New_Assign_Stmt (New_Obj (Var_Max), 5993 Chap3.Get_Array_Length (Var, Etype)); 5994 -- TODO: complex element type. 5995 pragma Assert (Is_Static_Type (El_Tinfo)); 5996 Dummy := Create_Temp (El_Tinfo); 5997 Targ := Create_Temp (El_Tinfo.Ortho_Ptr_Type (Mode_Value)); 5998 5999 -- Read length. 6000 Var_Len := Create_Temp (Ghdl_Index_Type); 6001 Translate_Rw_Length (Var_Len, Ghdl_Read_Scalar); 6002 6003 -- LRM08 5.5.2 File Operations 6004 -- If the object associated with formal parameter VALUE is 6005 -- shorter than this length, then only that portion of the 6006 -- array value read by the operation that can be contained in 6007 -- the object is returned by the READ operation, and the rest 6008 -- of the value is lost. If the object associated with formal 6009 -- parameter VALUE is longer than this length, then the entire 6010 -- value is returned and remaining elements of the object are 6011 -- unaffected. 6012 6013 -- Iterate on length. 6014 Var_It := Create_Temp (Ghdl_Index_Type); 6015 Init_Var (Var_It); 6016 Start_Loop_Stmt (Label); 6017 Gen_Exit_When 6018 (Label, 6019 New_Compare_Op (ON_Eq, 6020 New_Obj_Value (Var_It), 6021 New_Obj_Value (Var_Len), 6022 Ghdl_Bool_Type)); 6023 Start_If_Stmt 6024 (If_Blk, New_Compare_Op (ON_Gt, 6025 New_Obj_Value (Var_It), 6026 New_Obj_Value (Var_Max), 6027 Ghdl_Bool_Type)); 6028 New_Assign_Stmt (New_Obj (Targ), M2Addr (Dummy)); 6029 New_Else_Stmt (If_Blk); 6030 New_Assign_Stmt 6031 (New_Obj (Targ), 6032 M2Addr (Chap3.Index_Base (Chap3.Get_Composite_Base (Var), 6033 Etype, 6034 New_Obj_Value (Var_It)))); 6035 Finish_If_Stmt (If_Blk); 6036 6037 Translate_Rw (Dp2M (Targ, El_Tinfo, Mode_Value), 6038 El_Type, Ghdl_Read_Scalar); 6039 Inc_Var (Var_It); 6040 Finish_Loop_Stmt (Label); 6041 6042 -- Return the length (the minimum of len, max) 6043 Start_If_Stmt 6044 (If_Blk, New_Compare_Op (ON_Gt, 6045 New_Obj_Value (Var_Len), 6046 New_Obj_Value (Var_Max), 6047 Ghdl_Bool_Type)); 6048 New_Assign_Stmt (New_Obj (Var_It), New_Obj_Value (Var_Max)); 6049 New_Else_Stmt (If_Blk); 6050 New_Assign_Stmt (New_Obj (Var_It), New_Obj_Value (Var_Len)); 6051 Finish_If_Stmt (If_Blk); 6052 New_Return_Stmt (New_Convert_Ov (New_Obj_Value (Var_It), 6053 Std_Integer_Otype)); 6054 6055 Close_Temp; 6056 end; 6057 when others => 6058 raise Internal_Error; 6059 end case; 6060 Finish_Operator_Instance_Use (F_Info); 6061 Pop_Local_Factory; 6062 Finish_Subprogram_Body; 6063 end Translate_File_Subprogram_Body; 6064 6065 procedure Init_Implicit_Subprogram_Infos 6066 (Infos : out Implicit_Subprogram_Infos) is 6067 begin 6068 -- Be independant of declaration order since the same subprogram 6069 -- may be used for several implicit operators (eg. array comparaison) 6070 Infos.Arr_Eq_Info := null; 6071 Infos.Arr_Cmp_Info := null; 6072 Infos.Rec_Eq_Info := null; 6073 Infos.Arr_Shl_Info := null; 6074 Infos.Arr_Sha_Info := null; 6075 Infos.Arr_Rot_Info := null; 6076 end Init_Implicit_Subprogram_Infos; 6077 6078 procedure Translate_Implicit_Subprogram_Spec 6079 (Subprg : Iir; Infos : in out Implicit_Subprogram_Infos) 6080 is 6081 Kind : constant Iir_Predefined_Functions := 6082 Get_Implicit_Definition (Subprg); 6083 begin 6084 case Get_Implicit_Definition (Subprg) is 6085 when Iir_Predefined_Error 6086 | Iir_Predefined_Explicit => 6087 raise Internal_Error; 6088 when Iir_Predefined_Boolean_And 6089 | Iir_Predefined_Boolean_Or 6090 | Iir_Predefined_Boolean_Xor 6091 | Iir_Predefined_Boolean_Not 6092 | Iir_Predefined_Enum_Equality 6093 | Iir_Predefined_Enum_Inequality 6094 | Iir_Predefined_Enum_Less 6095 | Iir_Predefined_Enum_Less_Equal 6096 | Iir_Predefined_Enum_Greater 6097 | Iir_Predefined_Enum_Greater_Equal 6098 | Iir_Predefined_Bit_And 6099 | Iir_Predefined_Bit_Or 6100 | Iir_Predefined_Bit_Xor 6101 | Iir_Predefined_Bit_Not 6102 | Iir_Predefined_Integer_Equality 6103 | Iir_Predefined_Integer_Inequality 6104 | Iir_Predefined_Integer_Less 6105 | Iir_Predefined_Integer_Less_Equal 6106 | Iir_Predefined_Integer_Greater 6107 | Iir_Predefined_Integer_Greater_Equal 6108 | Iir_Predefined_Integer_Negation 6109 | Iir_Predefined_Integer_Absolute 6110 | Iir_Predefined_Integer_Plus 6111 | Iir_Predefined_Integer_Minus 6112 | Iir_Predefined_Integer_Mul 6113 | Iir_Predefined_Integer_Div 6114 | Iir_Predefined_Integer_Mod 6115 | Iir_Predefined_Integer_Rem 6116 | Iir_Predefined_Floating_Equality 6117 | Iir_Predefined_Floating_Inequality 6118 | Iir_Predefined_Floating_Less 6119 | Iir_Predefined_Floating_Less_Equal 6120 | Iir_Predefined_Floating_Greater 6121 | Iir_Predefined_Floating_Greater_Equal 6122 | Iir_Predefined_Floating_Negation 6123 | Iir_Predefined_Floating_Absolute 6124 | Iir_Predefined_Floating_Plus 6125 | Iir_Predefined_Floating_Minus 6126 | Iir_Predefined_Floating_Mul 6127 | Iir_Predefined_Floating_Div 6128 | Iir_Predefined_Physical_Equality 6129 | Iir_Predefined_Physical_Inequality 6130 | Iir_Predefined_Physical_Less 6131 | Iir_Predefined_Physical_Less_Equal 6132 | Iir_Predefined_Physical_Greater 6133 | Iir_Predefined_Physical_Greater_Equal 6134 | Iir_Predefined_Physical_Negation 6135 | Iir_Predefined_Physical_Absolute 6136 | Iir_Predefined_Physical_Plus 6137 | Iir_Predefined_Physical_Minus => 6138 pragma Assert (Predefined_To_Onop (Kind) /= ON_Nil); 6139 return; 6140 6141 when Iir_Predefined_Boolean_Nand 6142 | Iir_Predefined_Boolean_Nor 6143 | Iir_Predefined_Boolean_Xnor 6144 | Iir_Predefined_Bit_Nand 6145 | Iir_Predefined_Bit_Nor 6146 | Iir_Predefined_Bit_Xnor 6147 | Iir_Predefined_Bit_Match_Equality 6148 | Iir_Predefined_Bit_Match_Inequality 6149 | Iir_Predefined_Bit_Match_Less 6150 | Iir_Predefined_Bit_Match_Less_Equal 6151 | Iir_Predefined_Bit_Match_Greater 6152 | Iir_Predefined_Bit_Match_Greater_Equal 6153 | Iir_Predefined_Bit_Condition 6154 | Iir_Predefined_Boolean_Rising_Edge 6155 | Iir_Predefined_Boolean_Falling_Edge 6156 | Iir_Predefined_Bit_Rising_Edge 6157 | Iir_Predefined_Bit_Falling_Edge => 6158 -- Intrinsic. 6159 null; 6160 6161 when Iir_Predefined_Enum_Minimum 6162 | Iir_Predefined_Enum_Maximum 6163 | Iir_Predefined_Enum_To_String => 6164 -- Intrinsic. 6165 null; 6166 6167 when Iir_Predefined_Integer_Identity 6168 | Iir_Predefined_Integer_Exp 6169 | Iir_Predefined_Integer_Minimum 6170 | Iir_Predefined_Integer_Maximum 6171 | Iir_Predefined_Integer_To_String => 6172 -- Intrinsic. 6173 null; 6174 when Iir_Predefined_Universal_R_I_Mul 6175 | Iir_Predefined_Universal_I_R_Mul 6176 | Iir_Predefined_Universal_R_I_Div => 6177 -- Intrinsic 6178 null; 6179 6180 when Iir_Predefined_Physical_Identity 6181 | Iir_Predefined_Physical_Minimum 6182 | Iir_Predefined_Physical_Maximum 6183 | Iir_Predefined_Physical_To_String 6184 | Iir_Predefined_Time_To_String_Unit => 6185 null; 6186 6187 when Iir_Predefined_Physical_Integer_Mul 6188 | Iir_Predefined_Physical_Integer_Div 6189 | Iir_Predefined_Integer_Physical_Mul 6190 | Iir_Predefined_Physical_Real_Mul 6191 | Iir_Predefined_Physical_Real_Div 6192 | Iir_Predefined_Real_Physical_Mul 6193 | Iir_Predefined_Physical_Physical_Div => 6194 null; 6195 6196 when Iir_Predefined_Floating_Exp 6197 | Iir_Predefined_Floating_Identity 6198 | Iir_Predefined_Floating_Minimum 6199 | Iir_Predefined_Floating_Maximum 6200 | Iir_Predefined_Floating_To_String 6201 | Iir_Predefined_Real_To_String_Digits 6202 | Iir_Predefined_Real_To_String_Format => 6203 null; 6204 6205 when Iir_Predefined_Record_Equality 6206 | Iir_Predefined_Record_Inequality => 6207 if Infos.Rec_Eq_Info = null then 6208 Translate_Predefined_Record_Equality_Spec (Subprg); 6209 Infos.Rec_Eq_Info := Get_Info (Subprg); 6210 else 6211 Set_Info (Subprg, Infos.Rec_Eq_Info); 6212 end if; 6213 6214 when Iir_Predefined_Array_Equality 6215 | Iir_Predefined_Array_Inequality 6216 | Iir_Predefined_Bit_Array_Match_Equality 6217 | Iir_Predefined_Bit_Array_Match_Inequality => 6218 if Infos.Arr_Eq_Info = null then 6219 Translate_Predefined_Array_Equality_Spec (Subprg); 6220 Infos.Arr_Eq_Info := Get_Info (Subprg); 6221 else 6222 Set_Info (Subprg, Infos.Arr_Eq_Info); 6223 end if; 6224 6225 when Iir_Predefined_Array_Greater 6226 | Iir_Predefined_Array_Greater_Equal 6227 | Iir_Predefined_Array_Less 6228 | Iir_Predefined_Array_Less_Equal 6229 | Iir_Predefined_Array_Minimum 6230 | Iir_Predefined_Array_Maximum => 6231 if Infos.Arr_Cmp_Info = null then 6232 Translate_Predefined_Array_Compare_Spec (Subprg); 6233 Infos.Arr_Cmp_Info := Get_Info (Subprg); 6234 else 6235 Set_Info (Subprg, Infos.Arr_Cmp_Info); 6236 end if; 6237 6238 when Iir_Predefined_Array_Array_Concat 6239 | Iir_Predefined_Array_Element_Concat 6240 | Iir_Predefined_Element_Array_Concat 6241 | Iir_Predefined_Element_Element_Concat => 6242 null; 6243 6244 when Iir_Predefined_Vector_Minimum 6245 | Iir_Predefined_Vector_Maximum => 6246 null; 6247 6248 when Iir_Predefined_TF_Array_And 6249 | Iir_Predefined_TF_Array_Or 6250 | Iir_Predefined_TF_Array_Nand 6251 | Iir_Predefined_TF_Array_Nor 6252 | Iir_Predefined_TF_Array_Xor 6253 | Iir_Predefined_TF_Array_Xnor 6254 | Iir_Predefined_TF_Array_Not => 6255 Translate_Predefined_Array_Logical_Spec (Subprg); 6256 6257 when Iir_Predefined_TF_Reduction_And 6258 | Iir_Predefined_TF_Reduction_Or 6259 | Iir_Predefined_TF_Reduction_Nand 6260 | Iir_Predefined_TF_Reduction_Nor 6261 | Iir_Predefined_TF_Reduction_Xor 6262 | Iir_Predefined_TF_Reduction_Xnor 6263 | Iir_Predefined_TF_Reduction_Not 6264 | Iir_Predefined_TF_Array_Element_And 6265 | Iir_Predefined_TF_Element_Array_And 6266 | Iir_Predefined_TF_Array_Element_Or 6267 | Iir_Predefined_TF_Element_Array_Or 6268 | Iir_Predefined_TF_Array_Element_Nand 6269 | Iir_Predefined_TF_Element_Array_Nand 6270 | Iir_Predefined_TF_Array_Element_Nor 6271 | Iir_Predefined_TF_Element_Array_Nor 6272 | Iir_Predefined_TF_Array_Element_Xor 6273 | Iir_Predefined_TF_Element_Array_Xor 6274 | Iir_Predefined_TF_Array_Element_Xnor 6275 | Iir_Predefined_TF_Element_Array_Xnor => 6276 null; 6277 6278 when Iir_Predefined_Array_Sll 6279 | Iir_Predefined_Array_Srl => 6280 if Infos.Arr_Shl_Info = null then 6281 Translate_Predefined_Array_Shift_Spec (Subprg); 6282 Infos.Arr_Shl_Info := Get_Info (Subprg); 6283 else 6284 Set_Info (Subprg, Infos.Arr_Shl_Info); 6285 end if; 6286 6287 when Iir_Predefined_Array_Sla 6288 | Iir_Predefined_Array_Sra => 6289 if Infos.Arr_Sha_Info = null then 6290 Translate_Predefined_Array_Shift_Spec (Subprg); 6291 Infos.Arr_Sha_Info := Get_Info (Subprg); 6292 else 6293 Set_Info (Subprg, Infos.Arr_Sha_Info); 6294 end if; 6295 6296 when Iir_Predefined_Array_Rol 6297 | Iir_Predefined_Array_Ror => 6298 if Infos.Arr_Rot_Info = null then 6299 Translate_Predefined_Array_Shift_Spec (Subprg); 6300 Infos.Arr_Rot_Info := Get_Info (Subprg); 6301 else 6302 Set_Info (Subprg, Infos.Arr_Rot_Info); 6303 end if; 6304 6305 when Iir_Predefined_Access_Equality 6306 | Iir_Predefined_Access_Inequality => 6307 -- Intrinsic. 6308 null; 6309 when Iir_Predefined_Deallocate => 6310 -- Intrinsic. 6311 null; 6312 6313 when Iir_Predefined_File_Open 6314 | Iir_Predefined_File_Open_Status 6315 | Iir_Predefined_File_Close 6316 | Iir_Predefined_Flush 6317 | Iir_Predefined_Endfile => 6318 -- All of them have predefined definitions. 6319 null; 6320 6321 when Iir_Predefined_Write 6322 | Iir_Predefined_Read_Length 6323 | Iir_Predefined_Read => 6324 declare 6325 Param : constant Iir := 6326 Get_Interface_Declaration_Chain (Subprg); 6327 File_Type : constant Iir := Get_Type (Param); 6328 begin 6329 if not Get_Text_File_Flag (File_Type) then 6330 Translate_File_Subprogram_Spec (Subprg, File_Type); 6331 end if; 6332 end; 6333 6334 when Iir_Predefined_Array_Char_To_String 6335 | Iir_Predefined_Bit_Vector_To_Ostring 6336 | Iir_Predefined_Bit_Vector_To_Hstring 6337 | Iir_Predefined_Std_Ulogic_Match_Equality 6338 | Iir_Predefined_Std_Ulogic_Match_Inequality 6339 | Iir_Predefined_Std_Ulogic_Match_Less 6340 | Iir_Predefined_Std_Ulogic_Match_Less_Equal 6341 | Iir_Predefined_Std_Ulogic_Match_Greater 6342 | Iir_Predefined_Std_Ulogic_Match_Greater_Equal 6343 | Iir_Predefined_Std_Ulogic_Array_Match_Equality 6344 | Iir_Predefined_Std_Ulogic_Array_Match_Inequality => 6345 null; 6346 6347 when Iir_Predefined_Now_Function 6348 | Iir_Predefined_Real_Now_Function 6349 | Iir_Predefined_Frequency_Function => 6350 null; 6351 6352 -- when others => 6353 -- Error_Kind ("translate_implicit_subprogram (" 6354 -- & Iir_Predefined_Functions'Image (Kind) & ")", 6355 -- Subprg); 6356 end case; 6357 end Translate_Implicit_Subprogram_Spec; 6358 6359 procedure Translate_Implicit_Subprogram_Body (Subprg : Iir) 6360 is 6361 Info : constant Operator_Info_Acc := Get_Info (Subprg); 6362 begin 6363 if Info = null or else Info.Operator_Body then 6364 return; 6365 end if; 6366 6367 -- Translate only once. 6368 Info.Operator_Body := True; 6369 6370 case Get_Implicit_Definition (Subprg) is 6371 when Iir_Predefined_Record_Equality 6372 | Iir_Predefined_Record_Inequality => 6373 Translate_Predefined_Record_Equality_Body (Subprg); 6374 6375 when Iir_Predefined_Array_Equality 6376 | Iir_Predefined_Array_Inequality 6377 | Iir_Predefined_Bit_Array_Match_Equality 6378 | Iir_Predefined_Bit_Array_Match_Inequality => 6379 Translate_Predefined_Array_Equality_Body (Subprg); 6380 6381 when Iir_Predefined_Array_Greater 6382 | Iir_Predefined_Array_Greater_Equal 6383 | Iir_Predefined_Array_Less 6384 | Iir_Predefined_Array_Less_Equal 6385 | Iir_Predefined_Array_Minimum 6386 | Iir_Predefined_Array_Maximum => 6387 Translate_Predefined_Array_Compare_Body (Subprg); 6388 6389 when Iir_Predefined_TF_Array_And 6390 | Iir_Predefined_TF_Array_Or 6391 | Iir_Predefined_TF_Array_Nand 6392 | Iir_Predefined_TF_Array_Nor 6393 | Iir_Predefined_TF_Array_Xor 6394 | Iir_Predefined_TF_Array_Xnor 6395 | Iir_Predefined_TF_Array_Not => 6396 Translate_Predefined_Array_Logical_Body (Subprg); 6397 6398 when Iir_Predefined_Array_Sll 6399 | Iir_Predefined_Array_Srl 6400 | Iir_Predefined_Array_Sla 6401 | Iir_Predefined_Array_Sra 6402 | Iir_Predefined_Array_Rol 6403 | Iir_Predefined_Array_Ror => 6404 Translate_Predefined_Array_Shift_Body (Subprg); 6405 6406 when Iir_Predefined_Write 6407 | Iir_Predefined_Read_Length 6408 | Iir_Predefined_Read => 6409 declare 6410 Param : constant Iir := 6411 Get_Interface_Declaration_Chain (Subprg); 6412 File_Type : constant Iir := Get_Type (Param); 6413 begin 6414 if not Get_Text_File_Flag (File_Type) then 6415 Translate_File_Subprogram_Body (Subprg, File_Type); 6416 end if; 6417 end; 6418 6419 when others => 6420 raise Internal_Error; 6421 end case; 6422 end Translate_Implicit_Subprogram_Body; 6423end Trans.Chap7; 6424