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 Name_Table; 18with Vhdl.Errors; use Vhdl.Errors; 19with Vhdl.Utils; use Vhdl.Utils; 20with Vhdl.Evaluation; use Vhdl.Evaluation; 21with Trans.Chap2; 22with Trans.Chap4; 23with Trans.Chap6; 24with Trans.Chap7; 25with Trans.Chap14; 26with Trans_Decls; use Trans_Decls; 27with Trans.Helpers2; use Trans.Helpers2; 28 29package body Trans.Chap3 is 30 use Trans.Helpers; 31 32 function Create_Static_Type_Definition_Type_Range (Def : Iir) 33 return O_Cnode; 34 procedure Elab_Scalar_Type_Range (Def : Iir; Target : O_Lnode); 35 36 -- For scalar subtypes: creates info from the base type. 37 procedure Create_Subtype_Info_From_Type (Def : Iir; 38 Base : Iir; 39 Subtype_Info : Type_Info_Acc); 40 41 function Get_Composite_Type_Layout (Info : Type_Info_Acc) return Mnode 42 is 43 Res : O_Lnode; 44 begin 45 if Info.S.Subtype_Owner /= null then 46 pragma Assert (Info.S.Composite_Layout = Null_Var); 47 Res := M2Lv (Get_Composite_Type_Layout (Info.S.Subtype_Owner)); 48 if Info.S.Owner_Field = null then 49 -- From an array. 50 Res := New_Selected_Element 51 (Res, Info.S.Subtype_Owner.B.Layout_Bounds); 52 Res := New_Selected_Element 53 (Res, Info.S.Subtype_Owner.B.Bounds_El); 54 else 55 -- From a record 56 Res := New_Selected_Element 57 (Res, Info.S.Owner_Field.Field_Bound); 58 end if; 59 else 60 pragma Assert (Info.S.Composite_Layout /= Null_Var); 61 Res := Get_Var (Info.S.Composite_Layout); 62 end if; 63 return Lv2M (Res, 64 Info, Mode_Value, 65 Info.B.Layout_Type, 66 Info.B.Layout_Ptr_Type); 67 end Get_Composite_Type_Layout; 68 69 function Get_Composite_Type_Layout_Alloc (Info : Type_Info_Acc) 70 return Allocation_Kind is 71 begin 72 if Info.S.Subtype_Owner /= null then 73 return Get_Composite_Type_Layout_Alloc (Info.S.Subtype_Owner); 74 else 75 return Get_Alloc_Kind_For_Var (Info.S.Composite_Layout); 76 end if; 77 end Get_Composite_Type_Layout_Alloc; 78 79 function Layout_To_Bounds (B : Mnode) return Mnode 80 is 81 Info : constant Type_Info_Acc := Get_Type_Info (B); 82 begin 83 case Info.Type_Mode is 84 when Type_Mode_Arrays => 85 return Lv2M (New_Selected_Element (M2Lv (B), Info.B.Layout_Bounds), 86 Info, Mode_Value, 87 Info.B.Bounds_Type, Info.B.Bounds_Ptr_Type); 88 when Type_Mode_Records => 89 return B; 90 when others => 91 raise Internal_Error; 92 end case; 93 end Layout_To_Bounds; 94 95 function Layout_To_Sizes (B : Mnode) return O_Lnode 96 is 97 Info : constant Type_Info_Acc := Get_Type_Info (B); 98 begin 99 return New_Selected_Element (M2Lv (B), Info.B.Layout_Size); 100 end Layout_To_Sizes; 101 102 function Layout_To_Sizes (B : Mnode) return Mnode is 103 begin 104 return Lv2M (Layout_To_Sizes (B), Get_Type_Info (B), Mode_Value, 105 Ghdl_Sizes_Type, Ghdl_Sizes_Ptr); 106 end Layout_To_Sizes; 107 108 function Sizes_To_Size (Sizes : O_Lnode; Kind : Object_Kind_Type) 109 return O_Lnode 110 is 111 Field : O_Fnode; 112 begin 113 case Kind is 114 when Mode_Value => 115 Field := Ghdl_Sizes_Val; 116 when Mode_Signal => 117 Field := Ghdl_Sizes_Sig; 118 end case; 119 return New_Selected_Element (Sizes, Field); 120 end Sizes_To_Size; 121 122 function Layout_To_Size (Layout : Mnode; Kind : Object_Kind_Type) 123 return O_Lnode is 124 begin 125 return Sizes_To_Size (M2Lv (Layout_To_Sizes (Layout)), Kind); 126 end Layout_To_Size; 127 128 function Record_Layout_To_Element_Layout (B : Mnode; El : Iir) return Mnode 129 is 130 El_Type : constant Iir := Get_Type (El); 131 El_Info : constant Field_Info_Acc := Get_Info (El); 132 El_Tinfo : constant Type_Info_Acc := Get_Info (El_Type); 133 begin 134 return Lv2M (New_Selected_Element (M2Lv (B), 135 El_Info.Field_Bound), 136 El_Tinfo, Mode_Value, 137 El_Tinfo.B.Layout_Type, El_Tinfo.B.Layout_Ptr_Type); 138 end Record_Layout_To_Element_Layout; 139 140 function Record_Layout_To_Element_Offset 141 (B : Mnode; El : Iir; Kind : Object_Kind_Type) return O_Lnode 142 is 143 El_Info : constant Field_Info_Acc := Get_Info (El); 144 begin 145 return New_Selected_Element (M2Lv (B), El_Info.Field_Node (Kind)); 146 end Record_Layout_To_Element_Offset; 147 148 function Array_Bounds_To_Element_Layout (B : Mnode; Arr_Type : Iir) 149 return Mnode 150 is 151 Arr_Tinfo : constant Type_Info_Acc := Get_Info (Arr_Type); 152 El_Type : constant Iir := Get_Element_Subtype (Arr_Type); 153 El_Tinfo : constant Type_Info_Acc := Get_Info (El_Type); 154 begin 155 return Lv2M (New_Selected_Element (M2Lv (B), Arr_Tinfo.B.Bounds_El), 156 El_Tinfo, Mode_Value, 157 El_Tinfo.B.Layout_Type, El_Tinfo.B.Layout_Ptr_Type); 158 end Array_Bounds_To_Element_Layout; 159 160 function Array_Layout_To_Element_Layout (B : Mnode; Arr_Type : Iir) 161 return Mnode is 162 begin 163 return Array_Bounds_To_Element_Layout (Layout_To_Bounds (B), Arr_Type); 164 end Array_Layout_To_Element_Layout; 165 166 procedure Declare_Value_Type (Info : Type_Info_Acc) is 167 begin 168 New_Type_Decl (Create_Identifier, Info.Ortho_Type (Mode_Value)); 169 end Declare_Value_Type; 170 171 procedure Declare_Signal_Type (Info : Type_Info_Acc) is 172 begin 173 if Info.Ortho_Type (Mode_Signal) /= O_Tnode_Null then 174 New_Type_Decl (Create_Identifier ("SIG"), 175 Info.Ortho_Type (Mode_Signal)); 176 end if; 177 end Declare_Signal_Type; 178 179 procedure Declare_Value_Ptr_Type (Info : Type_Info_Acc) is 180 begin 181 Info.Ortho_Ptr_Type (Mode_Value) := 182 New_Access_Type (Info.Ortho_Type (Mode_Value)); 183 New_Type_Decl (Create_Identifier ("PTR"), 184 Info.Ortho_Ptr_Type (Mode_Value)); 185 end Declare_Value_Ptr_Type; 186 187 procedure Declare_Signal_Ptr_Type (Info : Type_Info_Acc) is 188 begin 189 if Info.Ortho_Type (Mode_Signal) /= O_Tnode_Null then 190 Info.Ortho_Ptr_Type (Mode_Signal) := 191 New_Access_Type (Info.Ortho_Type (Mode_Signal)); 192 New_Type_Decl (Create_Identifier ("SIGPTR"), 193 Info.Ortho_Ptr_Type (Mode_Signal)); 194 else 195 Info.Ortho_Ptr_Type (Mode_Signal) := O_Tnode_Null; 196 end if; 197 end Declare_Signal_Ptr_Type; 198 199 -- Finish a type definition: declare the type, define and declare a 200 -- pointer to the type. 201 procedure Finish_Type_Definition 202 (Info : Type_Info_Acc; Completion : Boolean := False) is 203 begin 204 -- Declare the type. 205 if not Completion then 206 Declare_Value_Type (Info); 207 end if; 208 209 -- Create an access to the type and declare it. 210 Declare_Value_Ptr_Type (Info); 211 212 -- Signal type. 213 if Info.Type_Mode in Type_Mode_Scalar then 214 Info.Ortho_Type (Mode_Signal) := Ghdl_Signal_Ptr; 215 Info.Ortho_Ptr_Type (Mode_Signal) := O_Tnode_Null; 216 else 217 Declare_Signal_Type (Info); 218 Declare_Signal_Ptr_Type (Info); 219 end if; 220 end Finish_Type_Definition; 221 222 -- A builder set internal fields of object pointed by BASE_PTR, using 223 -- memory from BASE_PTR and returns a pointer to the next memory byte 224 -- to be used. 225 procedure Create_Builder_Subprogram_Decl (Info : Type_Info_Acc; 226 Name : Name_Id; 227 Kind : Object_Kind_Type) 228 is 229 Interface_List : O_Inter_List; 230 Ident : O_Ident; 231 begin 232 case Kind is 233 when Mode_Value => 234 Ident := Create_Identifier (Name, "_BUILDER"); 235 when Mode_Signal => 236 Ident := Create_Identifier (Name, "_SIGBUILDER"); 237 end case; 238 -- FIXME: return the same type as its first parameter ??? 239 Start_Procedure_Decl (Interface_List, Ident, Global_Storage); 240 Subprgs.Add_Subprg_Instance_Interfaces 241 (Interface_List, Info.B.Builder (Kind).Builder_Instance); 242 New_Interface_Decl 243 (Interface_List, Info.B.Builder (Kind).Builder_Layout_Param, 244 Get_Identifier ("layout_ptr"), Info.B.Layout_Ptr_Type); 245 Finish_Subprogram_Decl 246 (Interface_List, Info.B.Builder (Kind).Builder_Proc); 247 end Create_Builder_Subprogram_Decl; 248 249 procedure Gen_Call_Type_Builder 250 (Layout : Mnode; Var_Type : Iir; Kind : Object_Kind_Type) 251 is 252 Binfo : constant Type_Info_Acc := Get_Info (Get_Base_Type (Var_Type)); 253 Assoc : O_Assoc_List; 254 begin 255 Start_Association (Assoc, Binfo.B.Builder (Kind).Builder_Proc); 256 Subprgs.Add_Subprg_Instance_Assoc 257 (Assoc, Binfo.B.Builder (Kind).Builder_Instance); 258 New_Association (Assoc, M2Addr (Layout)); 259 New_Procedure_Call (Assoc); 260 end Gen_Call_Type_Builder; 261 262 ------------------ 263 -- Enumeration -- 264 ------------------ 265 266 procedure Set_Ortho_Literal (Target : Iir; Expr : O_Cnode) 267 is 268 Info : Ortho_Info_Acc; 269 begin 270 Info := Add_Info (Target, Kind_Enum_Lit); 271 Info.Lit_Node := Expr; 272 end Set_Ortho_Literal; 273 274 function Translate_Enumeration_Literal (Lit : Iir_Enumeration_Literal) 275 return O_Ident 276 is 277 El_Str : String (1 .. 4); 278 Id : Name_Id; 279 N : Integer; 280 C : Character; 281 begin 282 Id := Get_Identifier (Lit); 283 if Name_Table.Is_Character (Id) then 284 C := Name_Table.Get_Character (Id); 285 El_Str (1) := 'C'; 286 case C is 287 when 'A' .. 'Z' 288 | 'a' .. 'z' 289 | '0' .. '9' => 290 El_Str (2) := '_'; 291 El_Str (3) := C; 292 when others => 293 N := Character'Pos (Name_Table.Get_Character (Id)); 294 El_Str (2) := N2hex (N / 16); 295 El_Str (3) := N2hex (N mod 16); 296 end case; 297 return Get_Identifier (El_Str (1 .. 3)); 298 else 299 return Create_Identifier_Without_Prefix (Lit); 300 end if; 301 end Translate_Enumeration_Literal; 302 303 procedure Translate_Enumeration_Type 304 (Def : Iir_Enumeration_Type_Definition) 305 is 306 El_List : constant Iir_Flist := Get_Enumeration_Literal_List (Def); 307 Nbr : constant Natural := Get_Nbr_Elements (El_List); 308 Info : constant Type_Info_Acc := Get_Info (Def); 309 El : Iir_Enumeration_Literal; 310 Constr : O_Enum_List; 311 Lit_Name : O_Ident; 312 Val : O_Cnode; 313 Size : Natural; 314 begin 315 if Nbr <= 256 then 316 Size := 8; 317 else 318 Size := 32; 319 end if; 320 Start_Enum_Type (Constr, Size); 321 for I in Flist_First .. Flist_Last (El_List) loop 322 El := Get_Nth_Element (El_List, I); 323 324 Lit_Name := Translate_Enumeration_Literal (El); 325 New_Enum_Literal (Constr, Lit_Name, Val); 326 Set_Ortho_Literal (El, Val); 327 end loop; 328 Finish_Enum_Type (Constr, Info.Ortho_Type (Mode_Value)); 329 if Nbr <= 256 then 330 Info.Type_Mode := Type_Mode_E8; 331 Info.B.Align := Align_8; 332 else 333 Info.Type_Mode := Type_Mode_E32; 334 Info.B.Align := Align_32; 335 end if; 336 -- Enumerations are always in their range. 337 Info.S.Nocheck_Low := True; 338 Info.S.Nocheck_Hi := True; 339 Finish_Type_Definition (Info); 340 end Translate_Enumeration_Type; 341 342 procedure Translate_Bool_Type (Def : Iir_Enumeration_Type_Definition) 343 is 344 Info : constant Type_Info_Acc := Get_Info (Def); 345 El_List : constant Iir_Flist := Get_Enumeration_Literal_List (Def); 346 pragma Assert (Get_Nbr_Elements (El_List) = 2); 347 348 False_Lit : constant Iir := Get_Nth_Element (El_List, 0); 349 True_Lit : constant Iir := Get_Nth_Element (El_List, 1); 350 351 False_Node, True_Node : O_Cnode; 352 begin 353 New_Boolean_Type 354 (Info.Ortho_Type (Mode_Value), 355 Translate_Enumeration_Literal (False_Lit), False_Node, 356 Translate_Enumeration_Literal (True_Lit), True_Node); 357 Info.Type_Mode := Type_Mode_B1; 358 Set_Ortho_Literal (False_Lit, False_Node); 359 Set_Ortho_Literal (True_Lit, True_Node); 360 Info.S.Nocheck_Low := True; 361 Info.S.Nocheck_Hi := True; 362 Info.B.Align := Align_8; 363 Finish_Type_Definition (Info); 364 end Translate_Bool_Type; 365 366 --------------- 367 -- Integer -- 368 --------------- 369 370 procedure Translate_Integer_Type (Def : Iir_Integer_Type_Definition) 371 is 372 Info : constant Type_Info_Acc := Get_Info (Def); 373 begin 374 case Get_Scalar_Size (Def) is 375 when Scalar_32 => 376 Info.Ortho_Type (Mode_Value) := New_Signed_Type (32); 377 Info.Type_Mode := Type_Mode_I32; 378 Info.B.Align := Align_32; 379 when Scalar_64 => 380 Info.Ortho_Type (Mode_Value) := New_Signed_Type (64); 381 Info.Type_Mode := Type_Mode_I64; 382 Info.B.Align := Align_64; 383 when others => 384 raise Internal_Error; 385 end case; 386 -- Integers are always in their ranges. 387 Info.S.Nocheck_Low := True; 388 Info.S.Nocheck_Hi := True; 389 390 Finish_Type_Definition (Info); 391 end Translate_Integer_Type; 392 393 ---------------------- 394 -- Floating types -- 395 ---------------------- 396 397 procedure Translate_Floating_Type (Def : Iir_Floating_Type_Definition) 398 is 399 Info : constant Type_Info_Acc := Get_Info (Def); 400 begin 401 -- FIXME: should check precision 402 Info.Type_Mode := Type_Mode_F64; 403 Info.B.Align := Align_64; 404 Info.Ortho_Type (Mode_Value) := New_Float_Type; 405 -- Reals are always in their ranges. 406 Info.S.Nocheck_Low := True; 407 Info.S.Nocheck_Hi := True; 408 409 Finish_Type_Definition (Info); 410 end Translate_Floating_Type; 411 412 ---------------- 413 -- Physical -- 414 ---------------- 415 416 procedure Translate_Physical_Type (Def : Iir_Physical_Type_Definition) 417 is 418 Info : constant Type_Info_Acc := Get_Info (Def); 419 begin 420 case Get_Scalar_Size (Def) is 421 when Scalar_32 => 422 Info.Ortho_Type (Mode_Value) := New_Signed_Type (32); 423 Info.Type_Mode := Type_Mode_P32; 424 Info.B.Align := Align_32; 425 when Scalar_64 => 426 Info.Ortho_Type (Mode_Value) := New_Signed_Type (64); 427 Info.Type_Mode := Type_Mode_P64; 428 Info.B.Align := Align_64; 429 when others => 430 raise Internal_Error; 431 end case; 432 -- Physical types are always in their ranges. 433 Info.S.Nocheck_Low := True; 434 Info.S.Nocheck_Hi := True; 435 436 Finish_Type_Definition (Info); 437 end Translate_Physical_Type; 438 439 procedure Translate_Physical_Units (Def : Iir_Physical_Type_Definition) 440 is 441 Phy_Type : constant O_Tnode := Get_Ortho_Type (Def, Mode_Value); 442 Unit : Iir; 443 Info : Object_Info_Acc; 444 begin 445 Unit := Get_Unit_Chain (Def); 446 while Unit /= Null_Iir loop 447 Info := Add_Info (Unit, Kind_Object); 448 Info.Object_Var := 449 Create_Var (Create_Var_Identifier (Unit), Phy_Type); 450 Unit := Get_Chain (Unit); 451 end loop; 452 end Translate_Physical_Units; 453 454 ------------ 455 -- File -- 456 ------------ 457 458 procedure Translate_File_Type (Def : Iir_File_Type_Definition) 459 is 460 Info : Type_Info_Acc; 461 begin 462 Info := Get_Info (Def); 463 Info.Ortho_Type (Mode_Value) := Ghdl_File_Index_Type; 464 Info.Ortho_Ptr_Type (Mode_Value) := Ghdl_File_Index_Ptr_Type; 465 Info.Type_Mode := Type_Mode_File; 466 Info.B.Align := Align_32; 467 end Translate_File_Type; 468 469 procedure Create_File_Type_Var (Def : Iir_File_Type_Definition) 470 is 471 Type_Name : constant Iir := Get_Type (Get_File_Type_Mark (Def)); 472 Info : Type_Info_Acc; 473 begin 474 if Get_Kind (Type_Name) in Iir_Kinds_Scalar_Type_And_Subtype_Definition 475 then 476 return; 477 end if; 478 declare 479 Len : constant Natural := Get_File_Signature_Length (Type_Name); 480 Sig : String (1 .. Len + 2); 481 Off : Natural := Sig'First; 482 begin 483 Get_File_Signature (Type_Name, Sig, Off); 484 Sig (Len + 1) := '.'; 485 Sig (Len + 2) := Character'Val (10); 486 Info := Get_Info (Def); 487 Info.B.File_Signature := Create_String 488 (Sig, Create_Identifier ("FILESIG"), Global_Storage); 489 end; 490 end Create_File_Type_Var; 491 492 ----------------------- 493 -- Unbounded types -- 494 ----------------------- 495 496 function Type_To_Last_Object_Kind (Def : Iir) return Object_Kind_Type is 497 begin 498 if Get_Has_Signal_Flag (Def) then 499 return Mode_Signal; 500 else 501 return Mode_Value; 502 end if; 503 end Type_To_Last_Object_Kind; 504 505 procedure Create_Unbounded_Type_Fat_Pointer (Info : Type_Info_Acc) 506 is 507 Constr : O_Element_List; 508 Bounds_Type : O_Tnode; 509 begin 510 for Kind in Object_Kind_Type loop 511 exit when Info.B.Base_Type (Kind) = O_Tnode_Null; 512 513 Start_Record_Type (Constr); 514 New_Record_Field 515 (Constr, Info.B.Base_Field (Kind), Wki_Base, 516 Info.B.Base_Ptr_Type (Kind)); 517 case Info.Type_Mode is 518 when Type_Mode_Unbounded_Array => 519 Bounds_Type := Info.B.Bounds_Ptr_Type; 520 when Type_Mode_Unbounded_Record => 521 Bounds_Type := Info.B.Layout_Ptr_Type; 522 when others => 523 raise Internal_Error; 524 end case; 525 New_Record_Field 526 (Constr, Info.B.Bounds_Field (Kind), Wki_Bounds, 527 Bounds_Type); 528 Finish_Record_Type (Constr, Info.Ortho_Type (Kind)); 529 end loop; 530 end Create_Unbounded_Type_Fat_Pointer; 531 532 procedure Finish_Unbounded_Type_Base (Info : Type_Info_Acc) 533 is 534 Id, Idptr : O_Ident; 535 begin 536 for Kind in Object_Kind_Type loop 537 exit when Info.B.Base_Type (Kind) = O_Tnode_Null; 538 539 case Kind is 540 when Mode_Value => 541 -- For the values. 542 Id := Create_Identifier ("BASE"); 543 Idptr := Create_Identifier ("BASEP"); 544 when Mode_Signal => 545 -- For the signals 546 Id := Create_Identifier ("SIGBASE"); 547 Idptr := Create_Identifier ("SIGBASEP"); 548 end case; 549 New_Type_Decl (Id, Info.B.Base_Type (Kind)); 550 Info.B.Base_Ptr_Type (Kind) := 551 New_Access_Type (Info.B.Base_Type (Kind)); 552 New_Type_Decl (Idptr, Info.B.Base_Ptr_Type (Kind)); 553 end loop; 554 end Finish_Unbounded_Type_Base; 555 556 -- Create the dope vector type declaration and access type. 557 procedure Finish_Unbounded_Type_Bounds (Info : Type_Info_Acc) is 558 begin 559 New_Type_Decl (Create_Identifier ("BOUND"), Info.B.Bounds_Type); 560 Info.B.Bounds_Ptr_Type := New_Access_Type (Info.B.Bounds_Type); 561 New_Type_Decl (Create_Identifier ("BOUNDP"), Info.B.Bounds_Ptr_Type); 562 end Finish_Unbounded_Type_Bounds; 563 564 function Create_Static_Composite_Subtype_Sizes (Def : Iir) return O_Cnode 565 is 566 Info : constant Type_Info_Acc := Get_Info (Def); 567 Sz_List : O_Record_Aggr_List; 568 Sz : O_Cnode; 569 Sz_Res : O_Cnode; 570 begin 571 Start_Record_Aggr (Sz_List, Ghdl_Sizes_Type); 572 New_Record_Aggr_El 573 (Sz_List, New_Sizeof (Info.Ortho_Type (Mode_Value), Ghdl_Index_Type)); 574 if Get_Has_Signal_Flag (Def) then 575 Sz := New_Sizeof (Info.Ortho_Type (Mode_Signal), Ghdl_Index_Type); 576 else 577 Sz := Ghdl_Index_0; 578 end if; 579 New_Record_Aggr_El (Sz_List, Sz); 580 Finish_Record_Aggr (Sz_List, Sz_Res); 581 return Sz_Res; 582 end Create_Static_Composite_Subtype_Sizes; 583 584 function Create_Static_Array_Subtype_Bounds (Def : Iir) return O_Cnode 585 is 586 Base_Type : constant Iir := Get_Base_Type (Def); 587 Binfo : constant Type_Info_Acc := Get_Info (Base_Type); 588 Indexes_List : constant Iir_Flist := Get_Index_Subtype_List (Def); 589 Index : Iir; 590 El_Type : Iir; 591 List : O_Record_Aggr_List; 592 Res : O_Cnode; 593 begin 594 Start_Record_Aggr (List, Binfo.B.Bounds_Type); 595 596 for I in Flist_First .. Flist_Last (Indexes_List) loop 597 Index := Get_Index_Type (Indexes_List, I); 598 New_Record_Aggr_El 599 (List, Create_Static_Type_Definition_Type_Range (Index)); 600 end loop; 601 602 if Binfo.B.Bounds_El /= O_Fnode_Null then 603 -- For arrays of unbounded type. 604 El_Type := Get_Element_Subtype (Def); 605 New_Record_Aggr_El 606 (List, Create_Static_Composite_Subtype_Layout (El_Type)); 607 end if; 608 609 Finish_Record_Aggr (List, Res); 610 return Res; 611 end Create_Static_Array_Subtype_Bounds; 612 613 function Create_Static_Record_Subtype_Bounds (Def : Iir) return O_Cnode 614 is 615 Base_Type : constant Iir := Get_Base_Type (Def); 616 Binfo : constant Type_Info_Acc := Get_Info (Base_Type); 617 El_List : constant Iir_Flist := Get_Elements_Declaration_List (Def); 618 El_Blist : constant Iir_Flist := 619 Get_Elements_Declaration_List (Base_Type); 620 Info : constant Type_Info_Acc := Get_Info (Def); 621 List : O_Record_Aggr_List; 622 Res : O_Cnode; 623 El : Iir; 624 El_Type : Iir; 625 Bel : Iir; 626 Bel_Info : Field_Info_Acc; 627 Off : O_Cnode; 628 begin 629 Start_Record_Aggr (List, Binfo.B.Bounds_Type); 630 631 New_Record_Aggr_El (List, Create_Static_Composite_Subtype_Sizes (Def)); 632 633 for I in Flist_First .. Flist_Last (El_Blist) loop 634 Bel := Get_Nth_Element (El_Blist, I); 635 Bel_Info := Get_Info (Bel); 636 if Bel_Info.Field_Bound /= O_Fnode_Null then 637 for Kind in Mode_Value .. Type_To_Last_Object_Kind (Base_Type) 638 loop 639 if Info.Ortho_Type (Kind) /= O_Tnode_Null then 640 Off := New_Offsetof 641 (Info.Ortho_Type (Kind), 642 Info.S.Rec_Fields (Iir_Index32 (I)).Fields (Kind), 643 Ghdl_Index_Type); 644 else 645 Off := Ghdl_Index_0; 646 end if; 647 New_Record_Aggr_El (List, Off); 648 end loop; 649 El := Get_Nth_Element (El_List, I); 650 El_Type := Get_Type (El); 651 New_Record_Aggr_El 652 (List, Create_Static_Composite_Subtype_Layout (El_Type)); 653 end if; 654 end loop; 655 656 Finish_Record_Aggr (List, Res); 657 return Res; 658 end Create_Static_Record_Subtype_Bounds; 659 660 function Create_Static_Composite_Subtype_Layout (Def : Iir) return O_Cnode 661 is 662 Info : constant Type_Info_Acc := Get_Info (Def); 663 begin 664 case Info.Type_Mode is 665 when Type_Mode_Static_Record 666 | Type_Mode_Complex_Record => 667 return Create_Static_Record_Subtype_Bounds (Def); 668 when Type_Mode_Static_Array 669 | Type_Mode_Complex_Array => 670 declare 671 List : O_Record_Aggr_List; 672 Res : O_Cnode; 673 begin 674 Start_Record_Aggr (List, Info.B.Layout_Type); 675 New_Record_Aggr_El 676 (List, Create_Static_Composite_Subtype_Sizes (Def)); 677 New_Record_Aggr_El 678 (List, Create_Static_Array_Subtype_Bounds (Def)); 679 Finish_Record_Aggr (List, Res); 680 return Res; 681 end; 682 when others => 683 raise Internal_Error; 684 end case; 685 end Create_Static_Composite_Subtype_Layout; 686 687 procedure Elab_Composite_Subtype_Layout (Def : Iir; Target : Mnode) 688 is 689 Tinfo : constant Type_Info_Acc := Get_Info (Def); 690 begin 691 Open_Temp; 692 693 case Get_Kind (Def) is 694 when Iir_Kind_Array_Type_Definition 695 | Iir_Kind_Record_Type_Definition => 696 -- Fully unconstrained, no layout to fill. 697 null; 698 699 when Iir_Kind_Array_Subtype_Definition => 700 declare 701 Parent_Type : constant Iir := Get_Parent_Type (Def); 702 Parent_Tinfo : constant Type_Info_Acc := Get_Info (Parent_Type); 703 New_Indexes : constant Boolean := 704 not Get_Index_Constraint_Flag (Parent_Type); 705 Indexes_List : constant Iir_Flist := 706 Get_Index_Subtype_List (Def); 707 El_Type : Iir; 708 El_Tinfo : Type_Info_Acc; 709 Targ : Mnode; 710 Rng : Mnode; 711 Index : Iir; 712 begin 713 Targ := Layout_To_Bounds (Target); 714 715 -- Indexes. 716 -- Set only if the array subtype has indexes constraints. 717 if Get_Index_Constraint_Flag (Def) then 718 if Tinfo.B.Bounds_El /= O_Fnode_Null 719 or else Get_Nbr_Elements (Indexes_List) > 1 720 then 721 Targ := Stabilize (Targ); 722 end if; 723 for I in Flist_First .. Flist_Last (Indexes_List) loop 724 Index := Get_Index_Type (Indexes_List, I); 725 Open_Temp; 726 Rng := Bounds_To_Range (Targ, Def, I + 1); 727 if New_Indexes then 728 Chap7.Translate_Discrete_Range (Rng, Index); 729 else 730 Gen_Memcpy 731 (M2Addr (Rng), 732 M2Addr 733 (Bounds_To_Range 734 (Layout_To_Bounds 735 (Get_Composite_Type_Layout (Parent_Tinfo)), 736 Parent_Type, I + 1)), 737 New_Lit (New_Sizeof (Rng.M1.Vtype, 738 Ghdl_Index_Type))); 739 end if; 740 Close_Temp; 741 end loop; 742 end if; 743 744 -- Element. 745 if Tinfo.B.Bounds_El /= O_Fnode_Null then 746 El_Type := Get_Element_Subtype (Def); 747 El_Tinfo := Get_Info (El_Type); 748 if Get_Constraint_State (El_Type) = Unconstrained then 749 -- Fully unconstrained, so there is no layout variable 750 -- for it. 751 null; 752 elsif Get_Array_Element_Constraint (Def) = Null_Iir then 753 -- No new constraints. 754 Gen_Memcpy 755 (M2Addr (Array_Bounds_To_Element_Layout (Targ, Def)), 756 M2Addr (Get_Composite_Type_Layout (El_Tinfo)), 757 New_Lit (New_Sizeof (El_Tinfo.B.Layout_Type, 758 Ghdl_Index_Type))); 759 else 760 -- New constraints. 761 Elab_Composite_Subtype_Layout 762 (El_Type, Array_Bounds_To_Element_Layout (Targ, Def)); 763 end if; 764 end if; 765 end; 766 767 when Iir_Kind_Record_Subtype_Definition => 768 declare 769 El_List : constant Iir_Flist := 770 Get_Elements_Declaration_List (Def); 771 Base_El_List : constant Iir_Flist := 772 Get_Elements_Declaration_List (Get_Base_Type (Def)); 773 Targ : Mnode; 774 El : Iir; 775 Base_El : Iir; 776 El_Type : Iir; 777 begin 778 Targ := Stabilize (Target); 779 for I in Flist_First .. Flist_Last (El_List) loop 780 El := Get_Nth_Element (El_List, I); 781 Base_El := Get_Nth_Element (Base_El_List, I); 782 if Is_Unbounded_Type (Get_Info (Get_Type (Base_El))) then 783 -- FIXME: copy if not new. 784 El_Type := Get_Type (El); 785 Elab_Composite_Subtype_Layout 786 (El_Type, 787 Record_Layout_To_Element_Layout (Targ, El)); 788 end if; 789 end loop; 790 end; 791 792 when others => 793 Error_Kind ("elab_composite_subtype_layout", Def); 794 end case; 795 796 Close_Temp; 797 end Elab_Composite_Subtype_Layout; 798 799 -- Compute sizes for DEF (settings the size fields of layout variable 800 -- TARGET) for all the new constraints. 801 procedure Elab_Composite_Subtype_Size (Def : Iir; Target : Mnode) 802 is 803 Info : constant Type_Info_Acc := Get_Info (Def); 804 T : Mnode; 805 begin 806 case Type_Mode_Composite (Info.Type_Mode) is 807 when Type_Mode_Static_Record 808 | Type_Mode_Static_Array => 809 -- Precomputed. 810 null; 811 when Type_Mode_Complex_Record 812 | Type_Mode_Complex_Array => 813 Open_Temp; 814 T := Stabilize (Target); 815 Gen_Call_Type_Builder (T, Def, Mode_Value); 816 if Get_Has_Signal_Flag (Def) then 817 Gen_Call_Type_Builder (T, Def, Mode_Signal); 818 end if; 819 Close_Temp; 820 when Type_Mode_Unbounded_Record => 821 declare 822 El : Iir; 823 El_Type : Iir; 824 begin 825 El := Get_Owned_Elements_Chain (Def); 826 if El = Null_Iir then 827 -- No new constraints. 828 return; 829 end if; 830 Open_Temp; 831 T := Stabilize (Target); 832 while El /= Null_Iir loop 833 El_Type := Get_Type (El); 834 Elab_Composite_Subtype_Size 835 (El_Type, 836 Record_Layout_To_Element_Layout (T, El)); 837 El := Get_Chain (El); 838 end loop; 839 Close_Temp; 840 end; 841 when Type_Mode_Unbounded_Array => 842 if Get_Array_Element_Constraint (Def) = Null_Iir then 843 -- Element is defined by the subtype. 844 return; 845 end if; 846 Elab_Composite_Subtype_Size 847 (Get_Element_Subtype (Def), 848 Array_Bounds_To_Element_Layout (Layout_To_Bounds (Target), 849 Def)); 850 when Type_Mode_Protected => 851 -- Not expected. 852 raise Internal_Error; 853 end case; 854 end Elab_Composite_Subtype_Size; 855 856 procedure Elab_Composite_Subtype_Layout (Def : Iir) 857 is 858 Info : constant Type_Info_Acc := Get_Info (Def); 859 begin 860 if Is_Static_Type (Info) then 861 -- Created as a constant. 862 return; 863 end if; 864 865 -- Fill ranges and length. 866 Elab_Composite_Subtype_Layout (Def, Get_Composite_Type_Layout (Info)); 867 868 -- Compute sizes for this subtype. 869 Elab_Composite_Subtype_Size (Def, Get_Composite_Type_Layout (Info)); 870 end Elab_Composite_Subtype_Layout; 871 872 -- Create a variable containing the layout for composite subtype DEF. 873 procedure Create_Composite_Subtype_Layout_Var 874 (Def : Iir; Elab_Now : Boolean) 875 is 876 Info : constant Type_Info_Acc := Get_Info (Def); 877 Val : O_Cnode; 878 begin 879 if Info.S.Composite_Layout /= Null_Var 880 or else Info.S.Subtype_Owner /= null 881 then 882 -- Already created. 883 return; 884 end if; 885 886 if Info.Type_Mode = Type_Mode_Static_Array 887 or Info.Type_Mode = Type_Mode_Static_Record 888 then 889 if Global_Storage = O_Storage_External then 890 -- Do not create the value of the type desc, since it 891 -- is never dereferenced in a static type desc. 892 Val := O_Cnode_Null; 893 else 894 Val := Create_Static_Composite_Subtype_Layout (Def); 895 end if; 896 Info.S.Composite_Layout := Create_Global_Const 897 (Create_Identifier ("STL"), 898 Info.B.Layout_Type, Global_Storage, Val); 899 else 900 Info.S.Composite_Layout := Create_Var 901 (Create_Var_Identifier ("STL"), Info.B.Layout_Type); 902 if Elab_Now then 903 Elab_Composite_Subtype_Layout (Def); 904 end if; 905 end if; 906 end Create_Composite_Subtype_Layout_Var; 907 908 ------------- 909 -- Array -- 910 ------------- 911 912 -- Declare the bounds types for DEF. 913 procedure Translate_Array_Type_Bounds 914 (Def : Iir_Array_Type_Definition; Info : Type_Info_Acc) 915 is 916 Indexes_List : constant Iir_Flist := 917 Get_Index_Subtype_Definition_List (Def); 918 El_Type : constant Iir := Get_Element_Subtype (Def); 919 El_Info : constant Type_Info_Acc := Get_Info (El_Type); 920 Constr : O_Element_List; 921 Dim : String (1 .. 8); 922 N : Natural; 923 P : Natural; 924 Index : Iir; 925 Index_Info : Index_Info_Acc; 926 Index_Type_Mark : Iir; 927 begin 928 Start_Record_Type (Constr); 929 for I in Flist_First .. Flist_Last (Indexes_List) loop 930 Index_Type_Mark := Get_Nth_Element (Indexes_List, I); 931 Index := Get_Index_Type (Index_Type_Mark); 932 933 -- Index comes from a type mark. 934 pragma Assert (not Is_Anonymous_Type_Definition (Index)); 935 936 Index_Info := Add_Info (Index_Type_Mark, Kind_Index); 937 938 -- Build the name 939 N := I + 1; 940 P := Dim'Last; 941 loop 942 Dim (P) := Character'Val (Character'Pos ('0') + N mod 10); 943 P := P - 1; 944 N := N / 10; 945 exit when N = 0; 946 end loop; 947 P := P - 3; 948 Dim (P .. P + 3) := "dim_"; 949 950 New_Record_Field (Constr, Index_Info.Index_Field, 951 Get_Identifier (Dim (P .. Dim'Last)), 952 Get_Info (Get_Base_Type (Index)).B.Range_Type); 953 end loop; 954 955 if Is_Unbounded_Type (El_Info) then 956 -- Add layout for the element. 957 New_Record_Field 958 (Constr, Info.B.Bounds_El, 959 Get_Identifier ("el_layout"), El_Info.B.Layout_Type); 960 end if; 961 962 Finish_Record_Type (Constr, Info.B.Bounds_Type); 963 Finish_Unbounded_Type_Bounds (Info); 964 end Translate_Array_Type_Bounds; 965 966 -- Create the layout type. 967 procedure Create_Array_Type_Layout_Type (Info : Type_Info_Acc) 968 is 969 Constr : O_Element_List; 970 begin 971 Start_Record_Type (Constr); 972 New_Record_Field (Constr, Info.B.Layout_Size, 973 Get_Identifier ("size"), Ghdl_Sizes_Type); 974 New_Record_Field (Constr, Info.B.Layout_Bounds, 975 Get_Identifier ("bounds"), Info.B.Bounds_Type); 976 Finish_Record_Type (Constr, Info.B.Layout_Type); 977 978 New_Type_Decl (Create_Identifier ("LAYOUT"), Info.B.Layout_Type); 979 Info.B.Layout_Ptr_Type := New_Access_Type (Info.B.Layout_Type); 980 New_Type_Decl (Create_Identifier ("LAYOUTP"), Info.B.Layout_Ptr_Type); 981 end Create_Array_Type_Layout_Type; 982 983 -- Return the type of INFO for MODE when used as a subelement (of either 984 -- a record or an array). 985 function Get_Ortho_Type_Subelement 986 (Info : Type_Info_Acc; Mode : Object_Kind_Type) return O_Tnode is 987 begin 988 if Is_Unbounded_Type (Info) then 989 return Info.B.Base_Type (Mode); 990 else 991 return Info.Ortho_Type (Mode); 992 end if; 993 end Get_Ortho_Type_Subelement; 994 995 procedure Translate_Array_Type_Base 996 (Def : Iir_Array_Type_Definition; Info : Type_Info_Acc) 997 is 998 El_Type : constant Iir := Get_Element_Subtype (Def); 999 El_Tinfo : constant Type_Info_Acc := Get_Info (El_Type); 1000 begin 1001 Info.B.Align := El_Tinfo.B.Align; 1002 1003 for Kind in Mode_Value .. Type_To_Last_Object_Kind (Def) loop 1004 Info.B.Base_Type (Kind) := 1005 New_Array_Type (Get_Ortho_Type_Subelement (El_Tinfo, Kind), 1006 Ghdl_Index_Type); 1007 end loop; 1008 1009 -- Declare the types. 1010 Finish_Unbounded_Type_Base (Info); 1011 end Translate_Array_Type_Base; 1012 1013 procedure Translate_Array_Type (Def : Iir_Array_Type_Definition) 1014 is 1015 Info : constant Type_Info_Acc := Get_Info (Def); 1016 begin 1017 Info.Type_Mode := Type_Mode_Fat_Array; 1018 Info.B := Ortho_Info_Basetype_Array_Init; 1019 Info.S := Ortho_Info_Subtype_Array_Init; 1020 Translate_Array_Type_Base (Def, Info); 1021 Translate_Array_Type_Bounds (Def, Info); 1022 Info.Ortho_Type (Mode_Signal) := O_Tnode_Null; 1023 Create_Unbounded_Type_Fat_Pointer (Info); 1024 Finish_Type_Definition (Info, False); 1025 1026 Create_Array_Type_Layout_Type (Info); 1027 1028 Info.Type_Incomplete := False; 1029 end Translate_Array_Type; 1030 1031 -- Get the length of DEF, ie the number of elements. 1032 -- If the length is not statically defined, returns -1. 1033 function Get_Array_Subtype_Length (Def : Iir_Array_Subtype_Definition) 1034 return Int64 1035 is 1036 Indexes_List : constant Iir_Flist := Get_Index_Subtype_List (Def); 1037 Index : Iir; 1038 Idx_Len : Int64; 1039 Len : Int64; 1040 begin 1041 -- Check if the bounds of the array are locally static. 1042 Len := 1; 1043 for I in Flist_First .. Flist_Last (Indexes_List) loop 1044 Index := Get_Index_Type (Indexes_List, I); 1045 1046 if Get_Type_Staticness (Index) /= Locally then 1047 return -1; 1048 end if; 1049 Idx_Len := Eval_Discrete_Type_Length (Index); 1050 1051 -- Do not consider very large arrays as static, to avoid overflow at 1052 -- compile time. 1053 if Idx_Len >= 2**31 then 1054 return -1; 1055 end if; 1056 Len := Len * Idx_Len; 1057 if Len >= 2**31 then 1058 return -1; 1059 end if; 1060 end loop; 1061 return Len; 1062 end Get_Array_Subtype_Length; 1063 1064 procedure Translate_Bounded_Array_Subtype_Definition 1065 (Def : Iir_Array_Subtype_Definition; Parent_Type : Iir) 1066 is 1067 El_Type : constant Iir := Get_Element_Subtype (Def); 1068 El_Info : constant Type_Info_Acc := Get_Info (El_Type); 1069 1070 Info : constant Type_Info_Acc := Get_Info (Def); 1071 Pinfo : constant Type_Info_Acc := Get_Info (Parent_Type); 1072 1073 Last_Mode : constant Object_Kind_Type := Type_To_Last_Object_Kind (Def); 1074 1075 Len : Int64; 1076 begin 1077 -- Note: info of indexes subtype are not created! 1078 1079 Len := Get_Array_Subtype_Length (Def); 1080 Info.Type_Locally_Constrained := (Len >= 0); 1081 Info.B := Pinfo.B; 1082 Info.S := Ortho_Info_Subtype_Array_Init; 1083 1084 if Info.Type_Locally_Constrained 1085 and then Is_Static_Type (El_Info) 1086 then 1087 -- Element and length are static. 1088 Info.Type_Mode := Type_Mode_Static_Array; 1089 1090 -- Create a subtype. 1091 Info.Ortho_Type (Mode_Signal) := O_Tnode_Null; 1092 for K in Mode_Value .. Last_Mode loop 1093 Info.Ortho_Type (K) := New_Array_Subtype 1094 (Pinfo.B.Base_Type (K), 1095 El_Info.Ortho_Type (K), 1096 New_Index_Lit (Unsigned_64 (Len))); 1097 end loop; 1098 -- Declare the types. 1099 Declare_Value_Type (Info); 1100 Declare_Value_Ptr_Type (Info); 1101 if Last_Mode = Mode_Signal then 1102 Declare_Signal_Type (Info); 1103 Declare_Signal_Ptr_Type (Info); 1104 end if; 1105 else 1106 -- This is a complex type as the size is not known at compile 1107 -- time. 1108 Info.Type_Mode := Type_Mode_Complex_Array; 1109 1110 -- Use the base type. 1111 Info.Ortho_Type := Pinfo.B.Base_Type; 1112 Info.Ortho_Ptr_Type := Pinfo.B.Base_Ptr_Type; 1113 end if; 1114 end Translate_Bounded_Array_Subtype_Definition; 1115 1116 procedure Create_Array_Type_Builder 1117 (Def : Iir_Array_Type_Definition; Kind : Object_Kind_Type) 1118 is 1119 El_Type : constant Iir := Get_Element_Subtype (Def); 1120 El_Info : constant Type_Info_Acc := Get_Info (El_Type); 1121 Info : constant Type_Info_Acc := Get_Info (Def); 1122 Layout_Param : constant O_Dnode := 1123 Info.B.Builder (Kind).Builder_Layout_Param; 1124 Layout : Mnode; 1125 El_Size : O_Enode; 1126 Size : O_Enode; 1127 begin 1128 Start_Subprogram_Body (Info.B.Builder (Kind).Builder_Proc); 1129 Subprgs.Start_Subprg_Instance_Use 1130 (Info.B.Builder (Kind).Builder_Instance); 1131 Open_Local_Temp; 1132 1133 Layout := Dp2M (Layout_Param, Info, Kind, 1134 Info.B.Layout_Type, Info.B.Layout_Ptr_Type); 1135 1136 -- Call the builder to layout the element (only for unbounded elements) 1137 if Is_Unbounded_Type (El_Info) then 1138 Gen_Call_Type_Builder 1139 (Array_Layout_To_Element_Layout (Layout, Def), El_Type, Kind); 1140 1141 El_Size := New_Value 1142 (Layout_To_Size (Array_Layout_To_Element_Layout (Layout, Def), 1143 Kind)); 1144 else 1145 El_Size := Get_Subtype_Size (El_Type, Mnode_Null, Kind); 1146 end if; 1147 1148 -- Compute size. 1149 Size := New_Dyadic_Op 1150 (ON_Mul_Ov, 1151 El_Size, 1152 Get_Bounds_Length (Layout_To_Bounds (Layout), Def)); 1153 1154 -- Set size. 1155 New_Assign_Stmt (Layout_To_Size (Layout, Kind), Size); 1156 1157 Close_Local_Temp; 1158 1159 Subprgs.Finish_Subprg_Instance_Use 1160 (Info.B.Builder (Kind).Builder_Instance); 1161 Finish_Subprogram_Body; 1162 end Create_Array_Type_Builder; 1163 1164 procedure Translate_Array_Subtype_Definition (Def : Iir) 1165 is 1166 Parent_Type : constant Iir := Get_Parent_Type (Def); 1167 Parent_El_Type : constant Iir := Get_Element_Subtype (Parent_Type); 1168 El_Type : constant Iir := Get_Element_Subtype (Def); 1169 El_Tinfo : Type_Info_Acc; 1170 Mark : Id_Mark_Type; 1171 begin 1172 -- Handle element subtype. 1173 if Get_Array_Element_Constraint (Def) /= Null_Iir then 1174 -- Do not create vars for element subtype, but use 1175 -- the layout field of the array vars. 1176 Push_Identifier_Prefix (Mark, "ET"); 1177 Translate_Subtype_Definition (El_Type, False); 1178 Pop_Identifier_Prefix (Mark); 1179 1180 El_Tinfo := Get_Info (El_Type); 1181 if Is_Composite (El_Tinfo) then 1182 pragma Assert (El_Tinfo.S.Composite_Layout = Null_Var); 1183 El_Tinfo.S.Subtype_Owner := Get_Info (Def); 1184 end if; 1185 elsif Get_Info (El_Type) = null then 1186 -- if the element subtype is created for this subtype, be sure it 1187 -- has infos. 1188 -- FIXME: the test should be refined. There can be a new element 1189 -- subtype because a resolver has been added. 1190 Set_Info (El_Type, Get_Info (Parent_El_Type)); 1191 end if; 1192 1193 if Get_Constraint_State (Def) = Fully_Constrained then 1194 -- Index constrained. 1195 Translate_Bounded_Array_Subtype_Definition (Def, Parent_Type); 1196 else 1197 -- An unconstrained array subtype. Use same infos as base 1198 -- type. 1199 -- FIXME: what if bounds are added. 1200 declare 1201 Tinfo : constant Type_Info_Acc := Get_Info (Def); 1202 Parent_Tinfo : constant Type_Info_Acc := Get_Info (Parent_Type); 1203 begin 1204 Tinfo.all := Parent_Tinfo.all; 1205 Tinfo.S.Composite_Layout := Null_Var; 1206 Tinfo.Type_Rti := O_Dnode_Null; 1207 end; 1208 end if; 1209 end Translate_Array_Subtype_Definition; 1210 1211 -------------- 1212 -- record -- 1213 -------------- 1214 1215 -- Get the alignment mask for *ortho* type ATYPE. 1216 function Get_Alignmask (Align : Alignment_Type) return O_Enode is 1217 begin 1218 return New_Dyadic_Op (ON_Sub_Ov, 1219 New_Lit (Align_Val (Align)), 1220 New_Lit (Ghdl_Index_1)); 1221 end Get_Alignmask; 1222 1223 -- Align VALUE (of unsigned type) for type ATYPE. 1224 -- The formulae is: (V + (A - 1)) and not (A - 1), where A is the 1225 -- alignment for ATYPE in bytes. 1226 function Realign (Value : O_Enode; Align : Alignment_Type) return O_Enode is 1227 begin 1228 return New_Dyadic_Op 1229 (ON_And, 1230 New_Dyadic_Op (ON_Add_Ov, Value, Get_Alignmask (Align)), 1231 New_Monadic_Op (ON_Not, Get_Alignmask (Align))); 1232 end Realign; 1233 1234 function Realign (Value : O_Enode; Atype : Iir) return O_Enode 1235 is 1236 Tinfo : constant Type_Info_Acc := Get_Info (Atype); 1237 begin 1238 return Realign (Value, Tinfo.B.Align); 1239 end Realign; 1240 1241 procedure Translate_Record_Type (Def : Iir_Record_Type_Definition) 1242 is 1243 Info : constant Type_Info_Acc := Get_Info (Def); 1244 List : constant Iir_Flist := Get_Elements_Declaration_List (Def); 1245 Is_Unbounded : constant Boolean := 1246 Get_Constraint_State (Def) /= Fully_Constrained; 1247 El_List : O_Element_List; 1248 El : Iir_Element_Declaration; 1249 Field_Info : Ortho_Info_Acc; 1250 El_Type : Iir; 1251 El_Tinfo : Type_Info_Acc; 1252 Align : Alignment_Type; 1253 1254 -- True if a size variable will be created since the size of 1255 -- the record is not known at compile-time. 1256 Is_Complex : Boolean; 1257 1258 Mark : Id_Mark_Type; 1259 begin 1260 -- First, translate the anonymous type of the elements. 1261 Align := Align_8; 1262 for I in Flist_First .. Flist_Last (List) loop 1263 El := Get_Nth_Element (List, I); 1264 El_Type := Get_Type (El); 1265 El_Tinfo := Get_Info (El_Type); 1266 if El_Tinfo = null then 1267 Push_Identifier_Prefix (Mark, Get_Identifier (El)); 1268 Translate_Subtype_Indication (El_Type, True); 1269 Pop_Identifier_Prefix (Mark); 1270 El_Tinfo := Get_Info (El_Type); 1271 end if; 1272 Field_Info := Add_Info (El, Kind_Field); 1273 1274 pragma Assert (El_Tinfo.B.Align /= Align_Undef); 1275 Align := Alignment_Type'Max (Align, El_Tinfo.B.Align); 1276 end loop; 1277 Info.B.Align := Align; 1278 1279 -- Then create the record type. 1280 Info.S := Ortho_Info_Subtype_Record_Init; 1281 Info.Ortho_Type (Mode_Signal) := O_Tnode_Null; 1282 for Kind in Mode_Value .. Type_To_Last_Object_Kind (Def) loop 1283 Start_Record_Type (El_List); 1284 for Static in reverse Boolean loop 1285 -- First static fields, then non-static ones. 1286 for I in Flist_First .. Flist_Last (List) loop 1287 El := Get_Nth_Element (List, I); 1288 Field_Info := Get_Info (El); 1289 El_Tinfo := Get_Info (Get_Type (El)); 1290 if Is_Static_Type (El_Tinfo) = Static then 1291 New_Record_Field 1292 (El_List, Field_Info.Field_Node (Kind), 1293 Create_Identifier_Without_Prefix (El), 1294 Get_Ortho_Type_Subelement (El_Tinfo, Kind)); 1295 end if; 1296 end loop; 1297 end loop; 1298 Finish_Record_Type (El_List, Info.B.Base_Type (Kind)); 1299 end loop; 1300 1301 -- Create the bounds type 1302 Info.B.Bounds_Type := O_Tnode_Null; 1303 Start_Record_Type (El_List); 1304 New_Record_Field (El_List, Info.B.Layout_Size, 1305 Get_Identifier ("size"), Ghdl_Sizes_Type); 1306 Is_Complex := False; 1307 for I in Flist_First .. Flist_Last (List) loop 1308 declare 1309 El : constant Iir := Get_Nth_Element (List, I); 1310 Field_Info : constant Field_Info_Acc := Get_Info (El); 1311 El_Tinfo : constant Type_Info_Acc := Get_Info (Get_Type (El)); 1312 Unbounded_El : constant Boolean := Is_Unbounded_Type (El_Tinfo); 1313 Complex_El : constant Boolean := Is_Complex_Type (El_Tinfo); 1314 begin 1315 Is_Complex := Is_Complex or Complex_El; 1316 if Unbounded_El or Complex_El then 1317 -- Offset 1318 New_Record_Field 1319 (El_List, Field_Info.Field_Node (Mode_Value), 1320 Create_Identifier_Without_Prefix (El, "_OFF"), 1321 Ghdl_Index_Type); 1322 if Get_Has_Signal_Flag (Def) then 1323 New_Record_Field 1324 (El_List, Field_Info.Field_Node (Mode_Signal), 1325 Create_Identifier_Without_Prefix (El, "_SIGOFF"), 1326 Ghdl_Index_Type); 1327 end if; 1328 end if; 1329 if Unbounded_El then 1330 New_Record_Field 1331 (El_List, Field_Info.Field_Bound, 1332 Create_Identifier_Without_Prefix (El, "_BND"), 1333 El_Tinfo.B.Layout_Type); 1334 end if; 1335 end; 1336 end loop; 1337 Finish_Record_Type (El_List, Info.B.Bounds_Type); 1338 Finish_Unbounded_Type_Bounds (Info); 1339 1340 -- For records: layout == bounds. 1341 Info.B.Layout_Type := Info.B.Bounds_Type; 1342 Info.B.Layout_Ptr_Type := Info.B.Bounds_Ptr_Type; 1343 1344 if Is_Unbounded then 1345 Info.Type_Mode := Type_Mode_Unbounded_Record; 1346 Finish_Unbounded_Type_Base (Info); 1347 Create_Unbounded_Type_Fat_Pointer (Info); 1348 Finish_Type_Definition (Info); 1349 else 1350 if Is_Complex then 1351 Info.Type_Mode := Type_Mode_Complex_Record; 1352 else 1353 Info.Type_Mode := Type_Mode_Static_Record; 1354 end if; 1355 Info.Ortho_Type := Info.B.Base_Type; 1356 Finish_Type_Definition (Info); 1357 Info.B.Base_Ptr_Type := Info.Ortho_Ptr_Type; 1358 1359 Create_Composite_Subtype_Layout_Var (Def, False); 1360 end if; 1361 end Translate_Record_Type; 1362 1363 procedure Translate_Record_Subtype_Definition (Def : Iir) 1364 is 1365 Parent_Type : constant Iir := Get_Parent_Type (Def); 1366 Base_Type : constant Iir := Get_Base_Type (Parent_Type); 1367 Info : constant Type_Info_Acc := Get_Info (Def); 1368 El_List : constant Iir_Flist := Get_Elements_Declaration_List (Def); 1369 El_Blist : constant Iir_Flist := 1370 Get_Elements_Declaration_List (Base_Type); 1371 Parent_Info : constant Type_Info_Acc := Get_Info (Parent_Type); 1372 El_Tm_List : constant Iir_Flist := 1373 Get_Elements_Declaration_List (Parent_Type); 1374 El, B_El : Iir_Element_Declaration; 1375 1376 Rec : O_Element_Sublist; 1377 El_Tinfo : Type_Info_Acc; 1378 1379 Mode : Type_Mode_Type; 1380 Fields : Subtype_Fields_Array_Acc; 1381 begin 1382 -- Translate the newly constrained elements. 1383 El := Get_Owned_Elements_Chain (Def); 1384 while El /= Null_Iir loop 1385 declare 1386 El_Type : constant Iir := Get_Type (El); 1387 Pos : constant Natural := Natural (Get_Element_Position (El)); 1388 B_El : constant Iir := Get_Nth_Element (El_Tm_List, Pos); 1389 El_Info : Field_Info_Acc; 1390 Mark : Id_Mark_Type; 1391 begin 1392 -- Copy info (for the bound field). 1393 El_Info := Get_Info (B_El); 1394 Set_Info (El, El_Info); 1395 1396 if Get_Info (El_Type) = null then 1397 -- Translate the new constraint. 1398 -- Not triggered on ownership, because of aggregate where 1399 -- the subtype of a whole aggregate may be defined with bounds 1400 -- from an element which can be a string or an aggregate that 1401 -- owns the bound. 1402 Push_Identifier_Prefix (Mark, Get_Identifier (El)); 1403 Translate_Subtype_Definition (El_Type, False); 1404 Pop_Identifier_Prefix (Mark); 1405 1406 El_Tinfo := Get_Info (El_Type); 1407 if Is_Composite (El_Tinfo) then 1408 pragma Assert (El_Tinfo.S.Composite_Layout = Null_Var); 1409 El_Tinfo.S.Subtype_Owner := Info; 1410 El_Tinfo.S.Owner_Field := El_Info; 1411 end if; 1412 end if; 1413 end; 1414 El := Get_Chain (El); 1415 end loop; 1416 1417 -- Mode of the subtype. 1418 Mode := Type_Mode_Static_Record; 1419 for I in Flist_First .. Flist_Last (El_List) loop 1420 declare 1421 El : constant Iir := Get_Nth_Element (El_List, I); 1422 El_Type : constant Iir := Get_Type (El); 1423 El_Tinfo : constant Type_Info_Acc := Get_Info (El_Type); 1424 begin 1425 if Is_Unbounded_Type (El_Tinfo) then 1426 Mode := Type_Mode_Unbounded_Record; 1427 -- Cannot be 'worse' than unbounded. 1428 exit; 1429 elsif Is_Complex_Type (El_Tinfo) then 1430 Mode := Type_Mode_Complex_Record; 1431 end if; 1432 end; 1433 end loop; 1434 1435 -- By default, use the same representation as the parent type. 1436 Info.all := Parent_Info.all; 1437 -- However, it is a different subtype which has its own rti. 1438 Info.Type_Rti := O_Dnode_Null; 1439 1440 if Get_Owned_Elements_Chain (Def) = Null_Iir then 1441 -- That's considered as an alias of the type mark. Maybe only the 1442 -- resolution is different. 1443 return; 1444 end if; 1445 Info.S := Ortho_Info_Subtype_Record_Init; 1446 1447 case Type_Mode_Records (Mode) is 1448 when Type_Mode_Unbounded_Record => 1449 pragma Assert (Parent_Info.Type_Mode = Type_Mode_Unbounded_Record); 1450 -- The subtype is not completly constrained: it cannot be used to 1451 -- create objects, so wait until it is completly constrained. 1452 -- The subtype is simply an alias. 1453 -- In both cases, use the same representation as its type mark. 1454 null; 1455 1456 when Type_Mode_Complex_Record => 1457 -- At least one field is not static. 1458 -- Do not over-optimize and consider all the fields that were 1459 -- initially unbounded as complex. 1460 Info.Type_Mode := Type_Mode_Complex_Record; 1461 1462 Info.Ortho_Type := Parent_Info.B.Base_Type; 1463 Info.Ortho_Ptr_Type := Parent_Info.B.Base_Ptr_Type; 1464 1465 when Type_Mode_Static_Record => 1466 -- The subtype is static. 1467 Info.Type_Mode := Type_Mode_Static_Record; 1468 1469 -- Create the subtypes. 1470 Info.Ortho_Type (Mode_Signal) := O_Tnode_Null; 1471 Fields := new Subtype_Fields_Array 1472 (0 .. Iir_Index32 (Get_Nbr_Elements (El_Blist)) - 1); 1473 Fields.all := (others => Subtype_Fields_Null); 1474 Info.S.Rec_Fields := Fields; 1475 for Kind in Mode_Value .. Type_To_Last_Object_Kind (Def) loop 1476 Start_Record_Subtype (Parent_Info.B.Base_Type (Kind), Rec); 1477 for Static in reverse Boolean loop 1478 for I in Flist_First .. Flist_Last (El_Blist) loop 1479 B_El := Get_Nth_Element (El_Blist, I); 1480 El_Tinfo := Get_Info (Get_Type (B_El)); 1481 if Is_Static_Type (El_Tinfo) then 1482 if Static then 1483 -- First the bounded fields. 1484 New_Subrecord_Field 1485 (Rec, Fields (Iir_Index32 (I)).Fields (Kind), 1486 El_Tinfo.Ortho_Type (Kind)); 1487 Fields (Iir_Index32 (I)).Tinfo := El_Tinfo; 1488 end if; 1489 else 1490 if not Static then 1491 -- Then the bounded subtype of unbounded fields. 1492 El := Get_Nth_Element (El_List, I); 1493 El_Tinfo := Get_Info (Get_Type (El)); 1494 New_Subrecord_Field 1495 (Rec, Fields (Iir_Index32 (I)).Fields (Kind), 1496 El_Tinfo.Ortho_Type (Kind)); 1497 Fields (Iir_Index32 (I)).Tinfo := El_Tinfo; 1498 end if; 1499 end if; 1500 end loop; 1501 end loop; 1502 Finish_Record_Subtype (Rec, Info.Ortho_Type (Kind)); 1503 end loop; 1504 1505 Finish_Type_Definition (Info); 1506 end case; 1507 end Translate_Record_Subtype_Definition; 1508 1509 procedure Create_Record_Type_Builder 1510 (Def : Iir_Record_Type_Definition; Kind : Object_Kind_Type) 1511 is 1512 Info : constant Type_Info_Acc := Get_Info (Def); 1513 Layout_Param : constant O_Dnode := 1514 Info.B.Builder (Kind).Builder_Layout_Param; 1515 List : constant Iir_Flist := Get_Elements_Declaration_List (Def); 1516 1517 Layout : Mnode; 1518 Off_Var : O_Dnode; 1519 Off_Val : O_Enode; 1520 begin 1521 Start_Subprogram_Body (Info.B.Builder (Kind).Builder_Proc); 1522 Subprgs.Start_Subprg_Instance_Use 1523 (Info.B.Builder (Kind).Builder_Instance); 1524 1525 Layout := Dp2M (Layout_Param, Info, Kind, 1526 Info.B.Layout_Type, Info.B.Layout_Ptr_Type); 1527 1528 -- Declare OFF, the offset variable 1529 New_Var_Decl (Off_Var, Get_Identifier ("off"), O_Storage_Local, 1530 Ghdl_Index_Type); 1531 1532 -- Reserve memory for the record, ie: 1533 -- off = RECORD_SIZEOF (record). 1534 Off_Val := New_Lit 1535 (New_Record_Sizeof (Info.B.Base_Type (Kind), Ghdl_Index_Type)); 1536 New_Assign_Stmt (New_Obj (Off_Var), Off_Val); 1537 1538 -- Set memory for each complex element. 1539 for I in Flist_First .. Flist_Last (List) loop 1540 declare 1541 El : constant Iir := Get_Nth_Element (List, I); 1542 El_Type : constant Iir := Get_Type (El); 1543 El_Tinfo : constant Type_Info_Acc := Get_Info (El_Type); 1544 El_Complex : constant Boolean := Is_Complex_Type (El_Tinfo); 1545 El_Unbounded : constant Boolean := Is_Unbounded_Type (El_Tinfo); 1546 El_Layout : Mnode; 1547 El_Size : O_Enode; 1548 begin 1549 if El_Unbounded then 1550 -- Set layout 1551 El_Layout := Record_Layout_To_Element_Layout (Layout, El); 1552 Gen_Call_Type_Builder (El_Layout, El_Type, Kind); 1553 end if; 1554 1555 if El_Unbounded or El_Complex then 1556 -- Complex or unbounded type. Field is an offset. 1557 1558 -- Align on the innermost array element (which should be 1559 -- a record) for Mode_Value. No need to align for signals, 1560 -- as all non-composite elements are accesses. 1561 Off_Val := New_Obj_Value (Off_Var); 1562 if Kind = Mode_Value then 1563 Off_Val := Realign (Off_Val, El_Type); 1564 end if; 1565 New_Assign_Stmt (New_Obj (Off_Var), Off_Val); 1566 1567 -- Set the offset. 1568 New_Assign_Stmt 1569 (Record_Layout_To_Element_Offset (Layout, El, Kind), 1570 New_Obj_Value (Off_Var)); 1571 1572 if El_Unbounded then 1573 El_Layout := Record_Layout_To_Element_Layout (Layout, El); 1574 El_Size := New_Value 1575 (Sizes_To_Size (Layout_To_Sizes (El_Layout), Kind)); 1576 else 1577 El_Size := Get_Subtype_Size (El_Type, El_Layout, Kind); 1578 end if; 1579 1580 New_Assign_Stmt (New_Obj (Off_Var), 1581 New_Dyadic_Op (ON_Add_Ov, 1582 New_Obj_Value (Off_Var), 1583 El_Size)); 1584 end if; 1585 end; 1586 end loop; 1587 1588 -- Align the size to the object alignment. 1589 Off_Val := New_Obj_Value (Off_Var); 1590 if Kind = Mode_Value then 1591 Off_Val := Realign (Off_Val, Def); 1592 end if; 1593 1594 -- Set size. 1595 New_Assign_Stmt (Layout_To_Size (Layout, Kind), Off_Val); 1596 1597 Subprgs.Finish_Subprg_Instance_Use 1598 (Info.B.Builder (Kind).Builder_Instance); 1599 Finish_Subprogram_Body; 1600 end Create_Record_Type_Builder; 1601 1602 -------------- 1603 -- Access -- 1604 -------------- 1605 1606 -- Get the ortho designated type for access type DEF. 1607 function Get_Ortho_Designated_Type (Def : Iir_Access_Type_Definition) 1608 return O_Tnode 1609 is 1610 D_Type : constant Iir := Get_Designated_Type (Def); 1611 D_Info : constant Type_Info_Acc := Get_Info (D_Type); 1612 begin 1613 if not Is_Fully_Constrained_Type (D_Type) then 1614 return D_Info.B.Bounds_Type; 1615 else 1616 if D_Info.Type_Mode in Type_Mode_Arrays then 1617 -- The designated type cannot be a sub array inside ortho. 1618 -- FIXME: lift this restriction. 1619 return D_Info.B.Base_Type (Mode_Value); 1620 else 1621 return D_Info.Ortho_Type (Mode_Value); 1622 end if; 1623 end if; 1624 end Get_Ortho_Designated_Type; 1625 1626 procedure Translate_Access_Type (Def : Iir_Access_Type_Definition) 1627 is 1628 D_Type : constant Iir := Get_Designated_Type (Def); 1629 -- Info for designated type may not be a type info: it may be an 1630 -- incomplete type. 1631 D_Info : constant Ortho_Info_Acc := Get_Info (D_Type); 1632 Def_Info : constant Type_Info_Acc := Get_Info (Def); 1633 Dtype : O_Tnode; 1634 begin 1635 -- No access types for signals. 1636 Def_Info.Ortho_Type (Mode_Signal) := O_Tnode_Null; 1637 1638 if not Is_Fully_Constrained_Type (D_Type) then 1639 -- An access type to an unconstrained type definition is a pointer 1640 -- to bounds and base. 1641 Def_Info.Type_Mode := Type_Mode_Bounds_Acc; 1642 else 1643 -- Otherwise, it is a thin pointer. 1644 Def_Info.Type_Mode := Type_Mode_Acc; 1645 end if; 1646 Def_Info.B.Align := Align_Ptr; 1647 1648 if D_Info.Kind = Kind_Incomplete_Type then 1649 -- Incomplete access. 1650 Dtype := O_Tnode_Null; 1651 else 1652 Dtype := Get_Ortho_Designated_Type (Def); 1653 end if; 1654 1655 Def_Info.Ortho_Type (Mode_Value) := New_Access_Type (Dtype); 1656 Finish_Type_Definition (Def_Info); 1657 end Translate_Access_Type; 1658 1659 ------------------------ 1660 -- Incomplete types -- 1661 ------------------------ 1662 1663 procedure Translate_Incomplete_Type (Def : Iir) 1664 is 1665 Info : Incomplete_Type_Info_Acc; 1666 Ctype : Iir; 1667 begin 1668 if Is_Null (Get_Incomplete_Type_Ref_Chain (Def)) then 1669 -- FIXME: 1670 -- This is a work-around for dummy incomplete type (ie incomplete 1671 -- types not used before the full type declaration). 1672 return; 1673 end if; 1674 1675 -- Get the complete type definition. 1676 Ctype := Get_Complete_Type_Definition (Def); 1677 Info := Add_Info (Ctype, Kind_Incomplete_Type); 1678 Info.Incomplete_Type := Def; 1679 end Translate_Incomplete_Type; 1680 1681 procedure Translate_Complete_Type 1682 (Incomplete_Info : in out Incomplete_Type_Info_Acc) 1683 is 1684 Atype : Iir; 1685 Def_Info : Type_Info_Acc; 1686 begin 1687 Atype := Get_Incomplete_Type_Ref_Chain (Incomplete_Info.Incomplete_Type); 1688 while Is_Valid (Atype) loop 1689 -- Only access type can be completed. 1690 pragma Assert (Get_Kind (Atype) = Iir_Kind_Access_Type_Definition); 1691 1692 Def_Info := Get_Info (Atype); 1693 Finish_Access_Type (Def_Info.Ortho_Type (Mode_Value), 1694 Get_Ortho_Designated_Type (Atype)); 1695 1696 Atype := Get_Incomplete_Type_Ref_Chain (Atype); 1697 end loop; 1698 Unchecked_Deallocation (Incomplete_Info); 1699 end Translate_Complete_Type; 1700 1701 ----------------- 1702 -- protected -- 1703 ----------------- 1704 1705 procedure Translate_Protected_Type (Def : Iir_Protected_Type_Declaration) 1706 is 1707 Info : constant Type_Info_Acc := Get_Info (Def); 1708 Mark : Id_Mark_Type; 1709 begin 1710 -- The protected type is represented by an incomplete record, that 1711 -- will be completed by the protected type body. 1712 Predeclare_Scope_Type (Info.B.Prot_Scope, Create_Identifier); 1713 Info.Ortho_Type (Mode_Value) := O_Tnode_Null; 1714 1715 -- Create a pointer type to that record. 1716 Declare_Scope_Acc (Info.B.Prot_Scope, 1717 Create_Identifier ("PTR"), 1718 Info.Ortho_Ptr_Type (Mode_Value)); 1719 1720 -- A protected type cannot be used for signals. 1721 Info.Ortho_Type (Mode_Signal) := O_Tnode_Null; 1722 Info.Ortho_Ptr_Type (Mode_Signal) := O_Tnode_Null; 1723 1724 Info.Type_Mode := Type_Mode_Protected; 1725 1726 -- This is just use to set overload number on subprograms, and to 1727 -- translate interfaces. 1728 Push_Identifier_Prefix 1729 (Mark, Get_Identifier (Get_Type_Declarator (Def))); 1730 Chap4.Translate_Declaration_Chain (Def); 1731 Pop_Identifier_Prefix (Mark); 1732 end Translate_Protected_Type; 1733 1734 procedure Translate_Protected_Type_Subprograms_Spec 1735 (Def : Iir_Protected_Type_Declaration) 1736 is 1737 Info : constant Type_Info_Acc := Get_Info (Def); 1738 El : Iir; 1739 Inter_List : O_Inter_List; 1740 Mark : Id_Mark_Type; 1741 Prev_Subprg_Instance : Subprgs.Subprg_Instance_Stack; 1742 begin 1743 Push_Identifier_Prefix 1744 (Mark, Get_Identifier (Get_Type_Declarator (Def))); 1745 1746 -- Init. 1747 Start_Function_Decl 1748 (Inter_List, Create_Identifier ("INIT"), Global_Storage, 1749 Info.Ortho_Ptr_Type (Mode_Value)); 1750 Subprgs.Add_Subprg_Instance_Interfaces 1751 (Inter_List, Info.B.Prot_Init_Instance); 1752 Finish_Subprogram_Decl (Inter_List, Info.B.Prot_Init_Subprg); 1753 1754 -- Use the object as instance. 1755 Subprgs.Push_Subprg_Instance (Info.B.Prot_Scope'Unrestricted_Access, 1756 Info.Ortho_Ptr_Type (Mode_Value), 1757 Wki_Obj, 1758 Prev_Subprg_Instance); 1759 1760 -- Final. 1761 Start_Procedure_Decl 1762 (Inter_List, Create_Identifier ("FINI"), Global_Storage); 1763 Subprgs.Add_Subprg_Instance_Interfaces 1764 (Inter_List, Info.B.Prot_Final_Instance); 1765 Finish_Subprogram_Decl (Inter_List, Info.B.Prot_Final_Subprg); 1766 1767 -- Methods. 1768 El := Get_Declaration_Chain (Def); 1769 while El /= Null_Iir loop 1770 case Get_Kind (El) is 1771 when Iir_Kind_Function_Declaration 1772 | Iir_Kind_Procedure_Declaration => 1773 -- Translate only if used. 1774 if Get_Info (El) /= null then 1775 Chap2.Translate_Subprogram_Declaration (El); 1776 end if; 1777 when Iir_Kind_Attribute_Specification => 1778 null; 1779 when others => 1780 Error_Kind ("translate_protected_type_subprograms_spec", El); 1781 end case; 1782 El := Get_Chain (El); 1783 end loop; 1784 1785 Subprgs.Pop_Subprg_Instance (Wki_Obj, Prev_Subprg_Instance); 1786 1787 Pop_Identifier_Prefix (Mark); 1788 end Translate_Protected_Type_Subprograms_Spec; 1789 1790 procedure Translate_Protected_Type_Body (Bod : Iir) 1791 is 1792 Decl : constant Iir_Protected_Type_Declaration := 1793 Get_Protected_Type_Declaration (Bod); 1794 Info : constant Type_Info_Acc := Get_Info (Decl); 1795 Mark : Id_Mark_Type; 1796 begin 1797 Push_Identifier_Prefix (Mark, Get_Identifier (Bod)); 1798 1799 -- Create the object type 1800 Push_Instance_Factory (Info.B.Prot_Scope'Unrestricted_Access); 1801 -- First, the previous instance. 1802 Subprgs.Add_Subprg_Instance_Field 1803 (Info.B.Prot_Subprg_Instance_Field, Info.B.Prot_Prev_Scope); 1804 -- Then the object lock 1805 Info.B.Prot_Lock_Field := Add_Instance_Factory_Field 1806 (Get_Identifier ("LOCK"), Ghdl_Ptr_Type); 1807 1808 -- Translate declarations. 1809 Chap4.Translate_Declaration_Chain (Bod); 1810 1811 Pop_Instance_Factory (Info.B.Prot_Scope'Unrestricted_Access); 1812 1813 Pop_Identifier_Prefix (Mark); 1814 end Translate_Protected_Type_Body; 1815 1816 procedure Call_Ghdl_Protected_Procedure (Type_Def : Iir; Proc : O_Dnode) 1817 is 1818 Info : constant Type_Info_Acc := Get_Info (Type_Def); 1819 Assoc : O_Assoc_List; 1820 begin 1821 Start_Association (Assoc, Proc); 1822 New_Association 1823 (Assoc, 1824 New_Unchecked_Address 1825 (New_Selected_Element 1826 (Get_Instance_Ref (Info.B.Prot_Scope), 1827 Info.B.Prot_Lock_Field), 1828 Ghdl_Ptr_Type)); 1829 New_Procedure_Call (Assoc); 1830 end Call_Ghdl_Protected_Procedure; 1831 1832 procedure Translate_Protected_Type_Body_Subprograms_Spec (Bod : Iir) 1833 is 1834 Mark : Id_Mark_Type; 1835 Decl : constant Iir := Get_Protected_Type_Declaration (Bod); 1836 Info : constant Type_Info_Acc := Get_Info (Decl); 1837 Prev_Subprg_Instance : Subprgs.Subprg_Instance_Stack; 1838 begin 1839 Push_Identifier_Prefix (Mark, Get_Identifier (Bod)); 1840 1841 -- Subprograms of BOD. 1842 Subprgs.Push_Subprg_Instance (Info.B.Prot_Scope'Unrestricted_Access, 1843 Info.Ortho_Ptr_Type (Mode_Value), 1844 Wki_Obj, 1845 Prev_Subprg_Instance); 1846 1847 -- Environment is referenced through the object. 1848 Subprgs.Start_Prev_Subprg_Instance_Use_Via_Field 1849 (Info.B.Prot_Prev_Scope, Info.B.Prot_Subprg_Instance_Field); 1850 1851 Chap4.Translate_Declaration_Chain_Subprograms 1852 (Bod, Subprg_Translate_Spec_And_Body); 1853 1854 Subprgs.Pop_Subprg_Instance (Wki_Obj, Prev_Subprg_Instance); 1855 1856 Subprgs.Finish_Prev_Subprg_Instance_Use_Via_Field 1857 (Info.B.Prot_Prev_Scope, Info.B.Prot_Subprg_Instance_Field); 1858 1859 Pop_Identifier_Prefix (Mark); 1860 end Translate_Protected_Type_Body_Subprograms_Spec; 1861 1862 procedure Translate_Protected_Type_Body_Subprograms_Body (Bod : Iir) 1863 is 1864 Decl : constant Iir := Get_Protected_Type_Declaration (Bod); 1865 Info : constant Type_Info_Acc := Get_Info (Decl); 1866 Final : Boolean; 1867 begin 1868 pragma Assert (Global_Storage /= O_Storage_External); 1869 1870 -- Init subprogram 1871 -- Contrary to other subprograms, no object is passed to it. 1872 declare 1873 Var_Obj : O_Dnode; 1874 begin 1875 Start_Subprogram_Body (Info.B.Prot_Init_Subprg); 1876 Subprgs.Start_Subprg_Instance_Use (Info.B.Prot_Init_Instance); 1877 New_Var_Decl (Var_Obj, Wki_Obj, O_Storage_Local, 1878 Info.Ortho_Ptr_Type (Mode_Value)); 1879 1880 -- Allocate the object 1881 New_Assign_Stmt 1882 (New_Obj (Var_Obj), 1883 Gen_Alloc 1884 (Alloc_System, 1885 New_Lit (New_Sizeof (Get_Scope_Type (Info.B.Prot_Scope), 1886 Ghdl_Index_Type)), 1887 Info.Ortho_Ptr_Type (Mode_Value))); 1888 1889 Subprgs.Set_Subprg_Instance_Field 1890 (Var_Obj, Info.B.Prot_Subprg_Instance_Field, 1891 Info.B.Prot_Init_Instance); 1892 1893 Set_Scope_Via_Param_Ptr (Info.B.Prot_Scope, Var_Obj); 1894 1895 -- Create lock. 1896 Call_Ghdl_Protected_Procedure (Decl, Ghdl_Protected_Init); 1897 1898 -- Elaborate fields. 1899 Open_Temp; 1900 Chap4.Elab_Declaration_Chain (Bod, Final); 1901 Close_Temp; 1902 1903 Clear_Scope (Info.B.Prot_Scope); 1904 1905 New_Return_Stmt (New_Obj_Value (Var_Obj)); 1906 Subprgs.Finish_Subprg_Instance_Use (Info.B.Prot_Init_Instance); 1907 1908 Finish_Subprogram_Body; 1909 end; 1910 1911-- Chap4.Translate_Declaration_Chain_Subprograms 1912-- (Bod, Subprg_Translate_Only_Body); 1913 1914 -- Fini subprogram 1915 begin 1916 Start_Subprogram_Body (Info.B.Prot_Final_Subprg); 1917 Subprgs.Start_Subprg_Instance_Use (Info.B.Prot_Final_Instance); 1918 1919 -- Deallocate fields. 1920 if Final or True then 1921 Chap4.Final_Declaration_Chain (Bod, True); 1922 end if; 1923 1924 -- Destroy lock. 1925 Call_Ghdl_Protected_Procedure (Decl, Ghdl_Protected_Fini); 1926 1927 Subprgs.Finish_Subprg_Instance_Use (Info.B.Prot_Final_Instance); 1928 Finish_Subprogram_Body; 1929 end; 1930 1931 end Translate_Protected_Type_Body_Subprograms_Body; 1932 1933 --------------- 1934 -- Scalars -- 1935 --------------- 1936 1937 -- Create a type_range structure. 1938 procedure Elab_Scalar_Type_Range (Def : Iir; Target : O_Lnode) 1939 is 1940 T_Info : constant Type_Info_Acc := Get_Info (Get_Base_Type (Def)); 1941 begin 1942 Chap7.Translate_Range 1943 (Lv2M (Target, T_Info, Mode_Value, 1944 T_Info.B.Range_Type, T_Info.B.Range_Ptr_Type), 1945 Get_Range_Constraint (Def), Def); 1946 end Elab_Scalar_Type_Range; 1947 1948 function Create_Static_Scalar_Type_Range (Def : Iir) return O_Cnode is 1949 begin 1950 return Chap7.Translate_Static_Range (Get_Range_Constraint (Def), 1951 Get_Base_Type (Def)); 1952 end Create_Static_Scalar_Type_Range; 1953 1954 procedure Create_Scalar_Type_Range_Type 1955 (Def : Iir; With_Length : Boolean) 1956 is 1957 Constr : O_Element_List; 1958 Info : Ortho_Info_Acc; 1959 begin 1960 Info := Get_Info (Def); 1961 Start_Record_Type (Constr); 1962 New_Record_Field 1963 (Constr, Info.B.Range_Left, Wki_Left, 1964 Info.Ortho_Type (Mode_Value)); 1965 New_Record_Field 1966 (Constr, Info.B.Range_Right, Wki_Right, 1967 Info.Ortho_Type (Mode_Value)); 1968 New_Record_Field 1969 (Constr, Info.B.Range_Dir, Wki_Dir, Ghdl_Dir_Type_Node); 1970 if With_Length then 1971 New_Record_Field 1972 (Constr, Info.B.Range_Length, Wki_Length, Ghdl_Index_Type); 1973 else 1974 Info.B.Range_Length := O_Fnode_Null; 1975 end if; 1976 Finish_Record_Type (Constr, Info.B.Range_Type); 1977 New_Type_Decl (Create_Identifier ("TRT"), Info.B.Range_Type); 1978 Info.B.Range_Ptr_Type := New_Access_Type (Info.B.Range_Type); 1979 New_Type_Decl (Create_Identifier ("TRPTR"), 1980 Info.B.Range_Ptr_Type); 1981 end Create_Scalar_Type_Range_Type; 1982 1983 function Create_Static_Type_Definition_Type_Range (Def : Iir) 1984 return O_Cnode 1985 is 1986 begin 1987 case Get_Kind (Def) is 1988 when Iir_Kind_Enumeration_Type_Definition 1989 | Iir_Kinds_Scalar_Subtype_Definition => 1990 return Create_Static_Scalar_Type_Range (Def); 1991 1992 when Iir_Kind_Array_Subtype_Definition => 1993 return Create_Static_Array_Subtype_Bounds (Def); 1994 1995 when Iir_Kind_Array_Type_Definition => 1996 return O_Cnode_Null; 1997 1998 when others => 1999 Error_Kind ("create_static_type_definition_type_range", Def); 2000 end case; 2001 end Create_Static_Type_Definition_Type_Range; 2002 2003 procedure Elab_Type_Definition_Type_Range (Def : Iir) 2004 is 2005 Target : O_Lnode; 2006 Info : Type_Info_Acc; 2007 begin 2008 case Get_Kind (Def) is 2009 when Iir_Kind_Enumeration_Type_Definition => 2010 Info := Get_Info (Def); 2011 if not Info.S.Same_Range then 2012 Target := Get_Var (Info.S.Range_Var); 2013 Elab_Scalar_Type_Range (Def, Target); 2014 end if; 2015 2016 when Iir_Kind_Array_Type_Definition => 2017 declare 2018 Index_List : constant Iir_Flist := 2019 Get_Index_Subtype_List (Def); 2020 Index : Iir; 2021 begin 2022 for I in Flist_First .. Flist_Last (Index_List) loop 2023 Index := Get_Index_Type (Index_List, I); 2024 if Is_Anonymous_Type_Definition (Index) then 2025 Elab_Type_Definition_Type_Range (Index); 2026 end if; 2027 end loop; 2028 end; 2029 return; 2030 2031 when Iir_Kind_Record_Type_Definition => 2032 Info := Get_Info (Def); 2033 if Info.S.Composite_Layout /= Null_Var then 2034 Elab_Composite_Subtype_Layout (Def); 2035 end if; 2036 2037 when Iir_Kind_Access_Type_Definition 2038 | Iir_Kind_File_Type_Definition 2039 | Iir_Kind_Protected_Type_Declaration => 2040 return; 2041 2042 when others => 2043 Error_Kind ("elab_type_definition_type_range", Def); 2044 end case; 2045 end Elab_Type_Definition_Type_Range; 2046 2047 -- Return TRUE iff LIT is equal to the high (IS_HI=TRUE) or low 2048 -- (IS_HI=false) limit of the base type of DEF. MODE is the mode of 2049 -- DEF. 2050 function Is_Equal_Limit (Lit : Iir; 2051 Is_Hi : Boolean; 2052 Def : Iir; 2053 Mode : Type_Mode_Type) return Boolean 2054 is 2055 begin 2056 case Mode is 2057 when Type_Mode_B1 => 2058 declare 2059 V : Iir_Int32; 2060 begin 2061 V := Iir_Int32 (Eval_Pos (Lit)); 2062 if Is_Hi then 2063 return V = 1; 2064 else 2065 return V = 0; 2066 end if; 2067 end; 2068 when Type_Mode_E8 => 2069 declare 2070 V : Iir_Int32; 2071 Base_Type : Iir; 2072 begin 2073 V := Iir_Int32 (Eval_Pos (Lit)); 2074 if Is_Hi then 2075 Base_Type := Get_Base_Type (Def); 2076 return V = Iir_Int32 2077 (Get_Nbr_Elements 2078 (Get_Enumeration_Literal_List (Base_Type))) - 1; 2079 else 2080 return V = 0; 2081 end if; 2082 end; 2083 when Type_Mode_I32 => 2084 declare 2085 V : Int64; 2086 begin 2087 V := Get_Value (Lit); 2088 if Is_Hi then 2089 return V = Int64 (Iir_Int32'Last); 2090 else 2091 return V = Int64 (Iir_Int32'First); 2092 end if; 2093 end; 2094 when Type_Mode_P32 => 2095 declare 2096 V : Iir_Int32; 2097 begin 2098 V := Iir_Int32 (Get_Physical_Value (Lit)); 2099 if Is_Hi then 2100 return V = Iir_Int32'Last; 2101 else 2102 return V = Iir_Int32'First; 2103 end if; 2104 end; 2105 when Type_Mode_I64 => 2106 declare 2107 V : Int64; 2108 begin 2109 V := Get_Value (Lit); 2110 if Is_Hi then 2111 return V = Int64'Last; 2112 else 2113 return V = Int64'First; 2114 end if; 2115 end; 2116 when Type_Mode_P64 => 2117 declare 2118 V : Int64; 2119 begin 2120 V := Get_Physical_Value (Lit); 2121 if Is_Hi then 2122 return V = Int64'Last; 2123 else 2124 return V = Int64'First; 2125 end if; 2126 end; 2127 when Type_Mode_F64 => 2128 -- Don't include +/- Inf 2129 return False; 2130 when others => 2131 Error_Kind ("is_equal_limit " & Type_Mode_Type'Image (Mode), 2132 Lit); 2133 end case; 2134 end Is_Equal_Limit; 2135 2136 -- For scalar subtypes: creates info from the base type. 2137 procedure Create_Subtype_Info_From_Type (Def : Iir; 2138 Base : Iir; 2139 Subtype_Info : Type_Info_Acc) 2140 is 2141 Base_Info : constant Type_Info_Acc := Get_Info (Base); 2142 Rng : constant Iir := Get_Range_Constraint (Def); 2143 Lo, Hi : Iir; 2144 begin 2145 Subtype_Info.Ortho_Type := Base_Info.Ortho_Type; 2146 Subtype_Info.Ortho_Ptr_Type := Base_Info.Ortho_Ptr_Type; 2147 Subtype_Info.Type_Mode := Base_Info.Type_Mode; 2148 Subtype_Info.B := Base_Info.B; 2149 Subtype_Info.S := Base_Info.S; 2150 2151 -- If the range is the same as its parent (its type_mark), set 2152 -- Same_Range and return (so that no new range variable would be 2153 -- created). 2154 if Get_Kind (Base) in Iir_Kinds_Scalar_Subtype_Definition then 2155 declare 2156 Tm_Rng : constant Iir := Get_Range_Constraint (Base); 2157 begin 2158 if Tm_Rng = Rng then 2159 Subtype_Info.S.Same_Range := True; 2160 return; 2161 elsif Get_Kind (Rng) = Iir_Kind_Range_Expression 2162 and then Get_Kind (Tm_Rng) = Iir_Kind_Range_Expression 2163 and then Get_Left_Limit (Rng) = Get_Left_Limit (Tm_Rng) 2164 and then Get_Right_Limit (Rng) = Get_Right_Limit (Tm_Rng) 2165 and then Get_Direction (Rng) = Get_Direction (Tm_Rng) 2166 then 2167 Subtype_Info.S.Same_Range := True; 2168 return; 2169 end if; 2170 end; 2171 end if; 2172 2173 -- So range is not the same. 2174 Subtype_Info.S.Same_Range := False; 2175 Subtype_Info.S.Range_Var := Null_Var; 2176 2177 if Get_Expr_Staticness (Rng) /= Locally then 2178 -- Bounds are not known. 2179 -- Do the checks. 2180 Subtype_Info.S.Nocheck_Hi := False; 2181 Subtype_Info.S.Nocheck_Low := False; 2182 else 2183 -- Bounds are locally static. 2184 Get_Low_High_Limit (Rng, Lo, Hi); 2185 Subtype_Info.S.Nocheck_Hi := 2186 Is_Equal_Limit (Hi, True, Def, Base_Info.Type_Mode); 2187 Subtype_Info.S.Nocheck_Low := 2188 Is_Equal_Limit (Lo, False, Def, Base_Info.Type_Mode); 2189 end if; 2190 end Create_Subtype_Info_From_Type; 2191 2192 procedure Create_Type_Range_Var (Def : Iir) 2193 is 2194 Info : constant Type_Info_Acc := Get_Info (Def); 2195 Base_Info : Type_Info_Acc; 2196 Val : O_Cnode; 2197 Suffix : String (1 .. 3) := "xTR"; 2198 begin 2199 pragma Assert (Info.S.Range_Var = Null_Var); 2200 2201 case Get_Kind (Def) is 2202 when Iir_Kinds_Subtype_Definition => 2203 Suffix (1) := 'S'; -- "STR"; 2204 when Iir_Kind_Enumeration_Type_Definition => 2205 Suffix (1) := 'B'; -- "BTR"; 2206 when others => 2207 raise Internal_Error; 2208 end case; 2209 Base_Info := Get_Info (Get_Base_Type (Def)); 2210 case Get_Type_Staticness (Def) is 2211 when None 2212 | Globally => 2213 Info.S.Range_Var := Create_Var 2214 (Create_Var_Identifier (Suffix), Base_Info.B.Range_Type); 2215 when Locally => 2216 if Global_Storage = O_Storage_External then 2217 -- Do not create the value of the type desc, since it 2218 -- is never dereferenced in a static type desc. 2219 Val := O_Cnode_Null; 2220 else 2221 Val := Create_Static_Type_Definition_Type_Range (Def); 2222 end if; 2223 Info.S.Range_Var := Create_Global_Const 2224 (Create_Identifier (Suffix), 2225 Base_Info.B.Range_Type, Global_Storage, Val); 2226 when Unknown => 2227 raise Internal_Error; 2228 end case; 2229 end Create_Type_Range_Var; 2230 2231 2232 -- Call HANDLE_A_SUBTYPE for all type/subtypes declared with DEF 2233 -- (of course, this is a noop if DEF is not a composite type). 2234 generic 2235 with procedure Handle_A_Subtype (Atype : Iir); 2236 procedure Handle_Anonymous_Subtypes (Def : Iir); 2237 2238 procedure Handle_Anonymous_Subtypes (Def : Iir) is 2239 begin 2240 case Get_Kind (Def) is 2241 when Iir_Kind_Array_Type_Definition 2242 | Iir_Kind_Array_Subtype_Definition => 2243 declare 2244 Asub : Iir; 2245 begin 2246 Asub := Get_Element_Subtype (Def); 2247 if Is_Anonymous_Type_Definition (Asub) then 2248 Handle_A_Subtype (Asub); 2249 end if; 2250 end; 2251 when Iir_Kind_Record_Type_Definition => 2252 declare 2253 List : constant Iir_Flist := 2254 Get_Elements_Declaration_List (Def); 2255 El : Iir; 2256 Asub : Iir; 2257 begin 2258 for I in Flist_First .. Flist_Last (List) loop 2259 El := Get_Nth_Element (List, I); 2260 Asub := Get_Type (El); 2261 if Is_Anonymous_Type_Definition (Asub) then 2262 Handle_A_Subtype (Asub); 2263 end if; 2264 end loop; 2265 end; 2266 when Iir_Kind_Record_Subtype_Definition => 2267 declare 2268 List : constant Iir_Flist := 2269 Get_Elements_Declaration_List (Def); 2270 El : Iir; 2271 Asub : Iir; 2272 begin 2273 for I in Flist_First .. Flist_Last (List) loop 2274 El := Get_Nth_Element (List, I); 2275 if Get_Kind (El) = Iir_Kind_Record_Element_Constraint then 2276 Asub := Get_Type (El); 2277 if Is_Anonymous_Type_Definition (Asub) then 2278 Handle_A_Subtype (Asub); 2279 end if; 2280 end if; 2281 end loop; 2282 end; 2283 when others => 2284 null; 2285 end case; 2286 end Handle_Anonymous_Subtypes; 2287 2288 procedure Translate_Array_Element_Definition (Def : Iir) 2289 is 2290 El_Type : constant Iir := Get_Element_Subtype (Def); 2291 Mark : Id_Mark_Type; 2292 begin 2293 if Get_Info (El_Type) = null then 2294 Push_Identifier_Prefix (Mark, "ET"); 2295 Translate_Subtype_Indication (El_Type, True); 2296 Pop_Identifier_Prefix (Mark); 2297 end if; 2298 end Translate_Array_Element_Definition; 2299 2300 -- Note: boolean types are translated by translate_bool_type_definition! 2301 procedure Translate_Type_Definition (Def : Iir) 2302 is 2303 Info : Ortho_Info_Acc; 2304 Complete_Info : Incomplete_Type_Info_Acc; 2305 begin 2306 -- Handle the special case of incomplete type. 2307 if Get_Kind (Def) = Iir_Kind_Incomplete_Type_Definition then 2308 Translate_Incomplete_Type (Def); 2309 return; 2310 end if; 2311 2312 -- If the definition is already translated, return now. 2313 Info := Get_Info (Def); 2314 if Info /= null then 2315 case Info.Kind is 2316 when Kind_Type => 2317 -- The subtype was already translated. 2318 return; 2319 when Kind_Incomplete_Type => 2320 -- Type is being completed. 2321 Complete_Info := Info; 2322 Clear_Info (Def); 2323 when others => 2324 raise Internal_Error; 2325 end case; 2326 else 2327 Complete_Info := null; 2328 end if; 2329 2330 Info := Add_Info (Def, Kind_Type); 2331 2332 case Get_Kind (Def) is 2333 when Iir_Kind_Enumeration_Type_Definition => 2334 Translate_Enumeration_Type (Def); 2335 Create_Scalar_Type_Range_Type (Def, True); 2336 Create_Type_Range_Var (Def); 2337 2338 when Iir_Kind_Integer_Type_Definition => 2339 Translate_Integer_Type (Def); 2340 Create_Scalar_Type_Range_Type (Def, True); 2341 2342 when Iir_Kind_Physical_Type_Definition => 2343 Translate_Physical_Type (Def); 2344 Create_Scalar_Type_Range_Type (Def, False); 2345 if Get_Type_Staticness (Def) /= Locally then 2346 Translate_Physical_Units (Def); 2347 else 2348 Info.S.Range_Var := Null_Var; 2349 end if; 2350 2351 when Iir_Kind_Floating_Type_Definition => 2352 Translate_Floating_Type (Def); 2353 Create_Scalar_Type_Range_Type (Def, False); 2354 2355 when Iir_Kind_Array_Type_Definition => 2356 Translate_Array_Element_Definition (Def); 2357 Translate_Array_Type (Def); 2358 2359 when Iir_Kind_Record_Type_Definition => 2360 Info.B := Ortho_Info_Basetype_Record_Init; 2361 Translate_Record_Type (Def); 2362 2363 when Iir_Kind_Access_Type_Definition => 2364 declare 2365 Dtype : constant Iir := Get_Designated_Type (Def); 2366 Mark : Id_Mark_Type; 2367 begin 2368 -- Translate the subtype 2369 if Is_Anonymous_Type_Definition (Dtype) then 2370 Push_Identifier_Prefix (Mark, "AT"); 2371 Translate_Subtype_Indication (Dtype, True); 2372 Pop_Identifier_Prefix (Mark); 2373 end if; 2374 Translate_Access_Type (Def); 2375 end; 2376 2377 when Iir_Kind_File_Type_Definition => 2378 Info.B := Ortho_Info_Basetype_File_Init; 2379 Translate_File_Type (Def); 2380 Create_File_Type_Var (Def); 2381 2382 when Iir_Kind_Protected_Type_Declaration => 2383 Info.B := Ortho_Info_Basetype_Prot_Init; 2384 Translate_Protected_Type (Def); 2385 2386 when others => 2387 Error_Kind ("translate_type_definition", Def); 2388 end case; 2389 2390 if Complete_Info /= null then 2391 Translate_Complete_Type (Complete_Info); 2392 end if; 2393 end Translate_Type_Definition; 2394 2395 procedure Translate_Bool_Type_Definition (Def : Iir) 2396 is 2397 Info : Type_Info_Acc; 2398 pragma Unreferenced (Info); 2399 begin 2400 -- Not already translated. 2401 pragma Assert (Get_Info (Def) = null); 2402 2403 -- A boolean type is an enumerated type. 2404 pragma Assert (Get_Kind (Def) = Iir_Kind_Enumeration_Type_Definition); 2405 2406 Info := Add_Info (Def, Kind_Type); 2407 2408 Translate_Bool_Type (Def); 2409 2410 -- This is usually done in translate_type_definition, but boolean 2411 -- types are not handled by translate_type_definition. 2412 Create_Scalar_Type_Range_Type (Def, True); 2413 end Translate_Bool_Type_Definition; 2414 2415 procedure Translate_Subtype_Definition 2416 (Def : Iir; With_Vars : Boolean := True) 2417 is 2418 Info : Ortho_Info_Acc; 2419 Complete_Info : Incomplete_Type_Info_Acc; 2420 begin 2421 -- If the definition is already translated, return now. 2422 Info := Get_Info (Def); 2423 if Info /= null then 2424 case Info.Kind is 2425 when Kind_Type => 2426 -- The subtype was already translated. 2427 return; 2428 when Kind_Incomplete_Type => 2429 -- Type is being completed. 2430 Complete_Info := Info; 2431 Clear_Info (Def); 2432 when others => 2433 raise Internal_Error; 2434 end case; 2435 else 2436 Complete_Info := null; 2437 end if; 2438 2439 Info := Add_Info (Def, Kind_Type); 2440 2441 case Get_Kind (Def) is 2442 when Iir_Kinds_Scalar_Subtype_Definition => 2443 Create_Subtype_Info_From_Type (Def, Get_Parent_Type (Def), Info); 2444 if With_Vars and then not Info.S.Same_Range then 2445 Create_Type_Range_Var (Def); 2446 end if; 2447 2448 when Iir_Kind_Array_Subtype_Definition => 2449 Translate_Array_Subtype_Definition (Def); 2450 if With_Vars 2451-- and then Get_Index_Constraint_Flag (Def) 2452 then 2453 Create_Composite_Subtype_Layout_Var (Def, False); 2454 end if; 2455 2456 when Iir_Kind_Record_Subtype_Definition => 2457 Translate_Record_Subtype_Definition (Def); 2458 if With_Vars 2459 and then Get_Owned_Elements_Chain (Def) /= Null_Iir 2460 then 2461 Create_Composite_Subtype_Layout_Var (Def, False); 2462 end if; 2463 2464 when Iir_Kind_Access_Subtype_Definition => 2465 -- Like the access type. 2466 Free_Info (Def); 2467 Set_Info (Def, Get_Info (Get_Parent_Type (Def))); 2468 2469 when others => 2470 Error_Kind ("translate_subtype_definition", Def); 2471 end case; 2472 2473 if Complete_Info /= null then 2474 Translate_Complete_Type (Complete_Info); 2475 end if; 2476 end Translate_Subtype_Definition; 2477 2478 procedure Translate_Type_Subprograms 2479 (Decl : Iir; Kind : Subprg_Translate_Kind) 2480 is 2481 Def : constant Iir := Get_Type_Definition (Decl); 2482 Tinfo : Type_Info_Acc; 2483 Id : Name_Id; 2484 begin 2485 case Get_Kind (Def) is 2486 when Iir_Kind_Incomplete_Type_Definition => 2487 return; 2488 when Iir_Kind_Protected_Type_Declaration => 2489 if Kind in Subprg_Translate_Spec then 2490 Translate_Protected_Type_Subprograms_Spec (Def); 2491 end if; 2492 return; 2493 when Iir_Kind_Record_Type_Definition 2494 | Iir_Kind_Array_Type_Definition => 2495 null; 2496 when Iir_Kind_Integer_Type_Definition 2497 | Iir_Kind_Enumeration_Type_Definition 2498 | Iir_Kind_Floating_Type_Definition 2499 | Iir_Kind_Physical_Type_Definition 2500 | Iir_Kind_File_Type_Definition 2501 | Iir_Kind_Access_Type_Definition => 2502 -- Never complex. 2503 return; 2504 when others => 2505 raise Internal_Error; 2506 end case; 2507 2508 -- Create builder for arrays and non-static records 2509 Tinfo := Get_Info (Def); 2510 case Tinfo.Type_Mode is 2511 when Type_Mode_Fat_Array 2512 | Type_Mode_Unbounded_Record 2513 | Type_Mode_Complex_Record => 2514 null; 2515 when Type_Mode_Static_Record => 2516 return; 2517 when others => 2518 -- Must have been filtered out above. 2519 raise Internal_Error; 2520 end case; 2521 2522 if Kind in Subprg_Translate_Spec then 2523 -- Declare subprograms. 2524 Id := Get_Identifier (Decl); 2525 for Kind in Mode_Value .. Type_To_Last_Object_Kind (Def) loop 2526 Create_Builder_Subprogram_Decl (Tinfo, Id, Kind); 2527 end loop; 2528 end if; 2529 2530 if Kind in Subprg_Translate_Body then 2531 if Global_Storage = O_Storage_External then 2532 return; 2533 end if; 2534 2535 -- Define subprograms. 2536 case Get_Kind (Def) is 2537 when Iir_Kind_Array_Type_Definition => 2538 for Kind in Mode_Value .. Type_To_Last_Object_Kind (Def) loop 2539 Create_Array_Type_Builder (Def, Kind); 2540 end loop; 2541 when Iir_Kind_Record_Type_Definition => 2542 for Kind in Mode_Value .. Type_To_Last_Object_Kind (Def) loop 2543 Create_Record_Type_Builder (Def, Kind); 2544 end loop; 2545 when others => 2546 Error_Kind ("translate_type_subprograms", Def); 2547 end case; 2548 end if; 2549 end Translate_Type_Subprograms; 2550 2551 -- Initialize the objects related to a type (type range and type 2552 -- descriptor). 2553 procedure Elab_Type_Definition (Def : Iir); 2554 procedure Elab_Subtype_Definition (Def : Iir); 2555 2556 procedure Elab_Type_Definition_Depend is new Handle_Anonymous_Subtypes 2557 (Handle_A_Subtype => Elab_Subtype_Definition); 2558 2559 procedure Elab_Type_Definition (Def : Iir) is 2560 begin 2561 case Get_Kind (Def) is 2562 when Iir_Kind_Incomplete_Type_Definition => 2563 -- Nothing to do. 2564 return; 2565 when Iir_Kind_Protected_Type_Declaration => 2566 -- Elaboration subprograms interfaces. 2567 declare 2568 Final : Boolean; 2569 begin 2570 Chap4.Elab_Declaration_Chain (Def, Final); 2571 2572 -- No finalizer in protected types (only subprograms). 2573 pragma Assert (Final = False); 2574 end; 2575 return; 2576 when others => 2577 null; 2578 end case; 2579 2580 if Get_Type_Staticness (Def) = Locally then 2581 return; 2582 end if; 2583 2584 Elab_Type_Definition_Depend (Def); 2585 2586 Elab_Type_Definition_Type_Range (Def); 2587 end Elab_Type_Definition; 2588 2589 procedure Translate_Subtype_Indication (Def : Iir; With_Vars : Boolean) is 2590 begin 2591 Translate_Subtype_Definition (Def, With_Vars); 2592 end Translate_Subtype_Indication; 2593 2594 procedure Translate_Named_Subtype_Definition (Def : Iir; Id : Name_Id) 2595 is 2596 Mark : Id_Mark_Type; 2597 begin 2598 Push_Identifier_Prefix (Mark, Id); 2599 Chap3.Translate_Subtype_Indication (Def, True); 2600 Pop_Identifier_Prefix (Mark); 2601 end Translate_Named_Subtype_Definition; 2602 2603 procedure Translate_Anonymous_Subtype_Definition 2604 (Def : Iir; With_Vars : Boolean) 2605 is 2606 Type_Info : constant Type_Info_Acc := Get_Info (Def); 2607 Mark : Id_Mark_Type; 2608 begin 2609 if Type_Info /= null then 2610 return; 2611 end if; 2612 Push_Identifier_Prefix_Uniq (Mark); 2613 Chap3.Translate_Subtype_Definition (Def, With_Vars); 2614 Pop_Identifier_Prefix (Mark); 2615 end Translate_Anonymous_Subtype_Definition; 2616 2617 procedure Translate_Object_Subtype_Indication (Decl : Iir; 2618 With_Vars : Boolean := True) 2619 is 2620 Def : Iir; 2621 Ind : Iir; 2622 Mark : Id_Mark_Type; 2623 Mark2 : Id_Mark_Type; 2624 begin 2625 -- Notes about subtype_indication and type in a declaration: 2626 -- 1) The subtype_indication is owned by the first declared 2627 -- object when there is a list of identifiers. The following 2628 -- declarations are ref. 2629 if Get_Is_Ref (Decl) then 2630 return; 2631 end if; 2632 2633 -- 3) An object alias always have a type but may have no subtype 2634 -- indication. Maybe this should be handled separately. 2635 -- 4) An anonymous_signal_declaration has no subtype indication. 2636 -- 5) It is not possible to translate the type when the subtype 2637 -- indication is a subtype_attribute. So this is an exception 2638 -- TODO: if there is a list of identifiers. 2639 2640 Push_Identifier_Prefix (Mark, Get_Identifier (Decl)); 2641 2642 Def := Get_Type (Decl); 2643 2644 -- 2) Constants may have a type that is different from the subtype 2645 -- indication, when the subtype indication is not fully constrained. 2646 -- This is new with vhdl 2008, where the subtype indication may 2647 -- add some constraints on the type mark and the initial value add 2648 -- even more constraints. 2649 if Get_Kind (Decl) = Iir_Kind_Constant_Declaration then 2650 Ind := Get_Subtype_Indication (Decl); 2651 Ind := Get_Type_Of_Subtype_Indication (Ind); 2652 if Ind /= Def then 2653 Push_Identifier_Prefix (Mark2, "OTI"); 2654 Chap3.Translate_Subtype_Definition (Ind, With_Vars); 2655 Pop_Identifier_Prefix (Mark2); 2656 end if; 2657 end if; 2658 2659 Push_Identifier_Prefix (Mark2, "OT"); 2660 Chap3.Translate_Subtype_Definition (Def, With_Vars); 2661 Pop_Identifier_Prefix (Mark2); 2662 2663 Pop_Identifier_Prefix (Mark); 2664 end Translate_Object_Subtype_Indication; 2665 2666 procedure Elab_Object_Subtype_Indication (Decl : Iir) 2667 is 2668 Def : constant Iir := Get_Type (Decl); 2669 begin 2670 if not Is_Anonymous_Type_Definition (Def) then 2671 -- The type refers to a declared type, so already handled. 2672 return; 2673 end if; 2674 2675 declare 2676 Ind : constant Iir := Get_Subtype_Indication (Decl); 2677 begin 2678 if Ind /= Null_Iir 2679 and then Get_Kind (Ind) = Iir_Kind_Subtype_Attribute 2680 then 2681 if Is_Fully_Constrained_Type (Get_Type (Get_Prefix (Ind))) then 2682 return; 2683 end if; 2684 raise Internal_Error; 2685 else 2686 Elab_Subtype_Definition (Def); 2687 end if; 2688 end; 2689 end Elab_Object_Subtype_Indication; 2690 2691 procedure Elab_Type_Declaration (Decl : Iir) is 2692 begin 2693 Elab_Type_Definition (Get_Type_Definition (Decl)); 2694 end Elab_Type_Declaration; 2695 2696 procedure Elab_Subtype_Definition (Def : Iir) 2697 is 2698 Target : O_Lnode; 2699 Info : Type_Info_Acc; 2700 begin 2701 if Get_Type_Staticness (Def) = Locally then 2702 return; 2703 end if; 2704 2705 case Get_Kind (Def) is 2706 when Iir_Kinds_Scalar_Subtype_Definition => 2707 Info := Get_Info (Def); 2708 if not Info.S.Same_Range then 2709 Target := Get_Var (Info.S.Range_Var); 2710 Elab_Scalar_Type_Range (Def, Target); 2711 end if; 2712 2713 when Iir_Kind_Record_Subtype_Definition 2714 | Iir_Kind_Array_Subtype_Definition => 2715 Info := Get_Info (Def); 2716 if Info.S.Composite_Layout /= Null_Var then 2717 Elab_Composite_Subtype_Layout (Def); 2718 end if; 2719 2720 when Iir_Kind_Access_Subtype_Definition => 2721 null; 2722 2723 when others => 2724 Error_Kind ("elab_subtype_definition", Def); 2725 end case; 2726 end Elab_Subtype_Definition; 2727 2728 procedure Elab_Subtype_Declaration (Decl : Iir_Subtype_Declaration) 2729 is 2730 Def : constant Iir := Get_Type (Decl); 2731 begin 2732 Elab_Subtype_Definition (Def); 2733 end Elab_Subtype_Declaration; 2734 2735 function Get_Static_Array_Length (Atype : Iir) return Int64 2736 is 2737 Indexes_List : constant Iir_Flist := Get_Index_Subtype_List (Atype); 2738 Nbr_Dim : constant Natural := Get_Nbr_Elements (Indexes_List); 2739 Index : Iir; 2740 Val : Int64; 2741 Rng : Iir; 2742 begin 2743 Val := 1; 2744 for I in 0 .. Nbr_Dim - 1 loop 2745 Index := Get_Index_Type (Indexes_List, I); 2746 Rng := Get_Range_Constraint (Index); 2747 Val := Val * Eval_Discrete_Range_Length (Rng); 2748 end loop; 2749 return Val; 2750 -- return New_Unsigned_Literal (Ghdl_Index_Type, Unsigned_64 (Val)); 2751 end Get_Static_Array_Length; 2752 2753 function Get_Thin_Array_Length (Atype : Iir) return O_Cnode is 2754 begin 2755 return New_Index_Lit (Unsigned_64 (Get_Static_Array_Length (Atype))); 2756 end Get_Thin_Array_Length; 2757 2758 function Bounds_To_Range (B : Mnode; Atype : Iir; Dim : Positive) 2759 return Mnode 2760 is 2761 Indexes_List : constant Iir_Flist := 2762 Get_Index_Subtype_Definition_List (Get_Base_Type (Atype)); 2763 Index_Type_Mark : constant Iir := 2764 Get_Nth_Element (Indexes_List, Dim - 1); 2765 Index_Type : constant Iir := Get_Index_Type (Index_Type_Mark); 2766 Base_Index_Info : constant Index_Info_Acc := 2767 Get_Info (Index_Type_Mark); 2768 Iinfo : constant Type_Info_Acc := 2769 Get_Info (Get_Base_Type (Index_Type)); 2770 begin 2771 return Lv2M (New_Selected_Element (M2Lv (B), 2772 Base_Index_Info.Index_Field), 2773 Iinfo, Mode_Value, 2774 Iinfo.B.Range_Type, Iinfo.B.Range_Ptr_Type); 2775 end Bounds_To_Range; 2776 2777 function Record_Bounds_To_Element_Bounds (B : Mnode; El : Iir) 2778 return Mnode is 2779 begin 2780 return Layout_To_Bounds (Record_Layout_To_Element_Layout (B, El)); 2781 end Record_Bounds_To_Element_Bounds; 2782 2783 function Array_Bounds_To_Element_Bounds (B : Mnode; Arr_Type : Iir) 2784 return Mnode is 2785 begin 2786 return Layout_To_Bounds (Array_Bounds_To_Element_Layout (B, Arr_Type)); 2787 end Array_Bounds_To_Element_Bounds; 2788 2789 function Array_Bounds_To_Element_Size 2790 (B : Mnode; Arr_Type : Iir; Mode : Object_Kind_Type) return O_Lnode is 2791 begin 2792 return Layout_To_Size 2793 (Array_Bounds_To_Element_Layout (B, Arr_Type), Mode); 2794 end Array_Bounds_To_Element_Size; 2795 2796 function Type_To_Range (Atype : Iir) return Mnode 2797 is 2798 Info : constant Type_Info_Acc := Get_Info (Atype); 2799 begin 2800 return Varv2M (Info.S.Range_Var, Info, Mode_Value, 2801 Info.B.Range_Type, Info.B.Range_Ptr_Type); 2802 end Type_To_Range; 2803 2804 function Range_To_Length (R : Mnode) return Mnode 2805 is 2806 Tinfo : constant Type_Info_Acc := Get_Type_Info (R); 2807 begin 2808 return Lv2M (New_Selected_Element (M2Lv (R), 2809 Tinfo.B.Range_Length), 2810 Tinfo, 2811 Mode_Value); 2812 end Range_To_Length; 2813 2814 function Range_To_Dir (R : Mnode) return Mnode 2815 is 2816 Tinfo : constant Type_Info_Acc := Get_Type_Info (R); 2817 begin 2818 return Lv2M (New_Selected_Element (M2Lv (R), 2819 Tinfo.B.Range_Dir), 2820 Tinfo, 2821 Mode_Value); 2822 end Range_To_Dir; 2823 2824 function Range_To_Left (R : Mnode) return Mnode 2825 is 2826 Tinfo : Type_Info_Acc; 2827 begin 2828 Tinfo := Get_Type_Info (R); 2829 return Lv2M (New_Selected_Element (M2Lv (R), 2830 Tinfo.B.Range_Left), 2831 Tinfo, 2832 Mode_Value); 2833 end Range_To_Left; 2834 2835 function Range_To_Right (R : Mnode) return Mnode 2836 is 2837 Tinfo : Type_Info_Acc; 2838 begin 2839 Tinfo := Get_Type_Info (R); 2840 return Lv2M (New_Selected_Element (M2Lv (R), 2841 Tinfo.B.Range_Right), 2842 Tinfo, 2843 Mode_Value); 2844 end Range_To_Right; 2845 2846 function Get_Composite_Type_Bounds (Atype : Iir) return Mnode is 2847 begin 2848 return Layout_To_Bounds (Get_Composite_Type_Layout (Get_Info (Atype))); 2849 end Get_Composite_Type_Bounds; 2850 2851 function Get_Composite_Bounds (Obj : Mnode) return Mnode 2852 is 2853 Info : constant Type_Info_Acc := Get_Type_Info (Obj); 2854 begin 2855 case Info.Type_Mode is 2856 when Type_Mode_Unbounded_Array 2857 | Type_Mode_Unbounded_Record => 2858 declare 2859 Kind : constant Object_Kind_Type := Get_Object_Kind (Obj); 2860 begin 2861 return Lp2M 2862 (New_Selected_Element (M2Lv (Obj), 2863 Info.B.Bounds_Field (Kind)), 2864 Info, 2865 Kind, 2866 Info.B.Bounds_Type, 2867 Info.B.Bounds_Ptr_Type); 2868 end; 2869 when Type_Mode_Bounded_Arrays => 2870 return Layout_To_Bounds (Get_Composite_Type_Layout (Info)); 2871 when Type_Mode_Bounded_Records => 2872 return Get_Composite_Type_Layout (Info); 2873 when Type_Mode_Bounds_Acc => 2874 return Lp2M (M2Lv (Obj), Info, Mode_Value); 2875 when others => 2876 raise Internal_Error; 2877 end case; 2878 end Get_Composite_Bounds; 2879 2880 function Get_Array_Range (Arr : Mnode; Atype : Iir; Dim : Positive) 2881 return Mnode is 2882 begin 2883 return Bounds_To_Range (Get_Composite_Bounds (Arr), Atype, Dim); 2884 end Get_Array_Range; 2885 2886 function Get_Bounds_Length (Bounds : Mnode; Atype : Iir) return O_Enode 2887 is 2888 Type_Info : constant Type_Info_Acc := Get_Info (Atype); 2889 Index_List : constant Iir_Flist := Get_Index_Subtype_List (Atype); 2890 Nbr_Dim : constant Natural := Get_Nbr_Elements (Index_List); 2891 Dim_Length : O_Enode; 2892 Res : O_Enode; 2893 Bounds_Stable : Mnode; 2894 begin 2895 if Type_Info.Type_Locally_Constrained then 2896 return New_Lit (Get_Thin_Array_Length (Atype)); 2897 end if; 2898 2899 if Nbr_Dim > 1 then 2900 Bounds_Stable := Stabilize (Bounds); 2901 else 2902 Bounds_Stable := Bounds; 2903 end if; 2904 2905 for Dim in 1 .. Nbr_Dim loop 2906 Dim_Length := 2907 M2E (Range_To_Length 2908 (Bounds_To_Range (Bounds_Stable, Atype, Dim))); 2909 if Dim = 1 then 2910 Res := Dim_Length; 2911 else 2912 Res := New_Dyadic_Op (ON_Mul_Ov, Res, Dim_Length); 2913 end if; 2914 end loop; 2915 return Res; 2916 end Get_Bounds_Length; 2917 2918 function Get_Array_Type_Length (Atype : Iir) return O_Enode 2919 is 2920 Type_Info : constant Type_Info_Acc := Get_Info (Atype); 2921 begin 2922 if Type_Info.Type_Locally_Constrained then 2923 return New_Lit (Get_Thin_Array_Length (Atype)); 2924 else 2925 return Get_Bounds_Length (Get_Composite_Type_Bounds (Atype), Atype); 2926 end if; 2927 end Get_Array_Type_Length; 2928 2929 function Get_Array_Length (Arr : Mnode; Atype : Iir) return O_Enode 2930 is 2931 Type_Info : constant Type_Info_Acc := Get_Info (Atype); 2932 begin 2933 if Type_Info.Type_Locally_Constrained then 2934 return New_Lit (Get_Thin_Array_Length (Atype)); 2935 else 2936 return Get_Bounds_Length (Get_Composite_Bounds (Arr), Atype); 2937 end if; 2938 end Get_Array_Length; 2939 2940 -- Get the base part of a dope vector. 2941 function Get_Unbounded_Base (Arr : Mnode) return Mnode 2942 is 2943 Info : constant Type_Info_Acc := Get_Type_Info (Arr); 2944 Kind : constant Object_Kind_Type := Get_Object_Kind (Arr); 2945 begin 2946 pragma Assert (Info.Type_Mode in Type_Mode_Unbounded); 2947 return Lp2M 2948 (New_Selected_Element (M2Lv (Arr), Info.B.Base_Field (Kind)), 2949 Info, Kind, 2950 Info.B.Base_Type (Kind), Info.B.Base_Ptr_Type (Kind)); 2951 end Get_Unbounded_Base; 2952 2953 function Get_Composite_Base (Obj : Mnode) return Mnode 2954 is 2955 Info : constant Type_Info_Acc := Get_Type_Info (Obj); 2956 begin 2957 case Info.Type_Mode is 2958 when Type_Mode_Unbounded_Array 2959 | Type_Mode_Unbounded_Record => 2960 return Get_Unbounded_Base (Obj); 2961 when Type_Mode_Bounded_Arrays 2962 | Type_Mode_Bounded_Records => 2963 return Obj; 2964 when others => 2965 raise Internal_Error; 2966 end case; 2967 end Get_Composite_Base; 2968 2969 function Get_Composite_Unbounded_Base (Obj : Mnode) return Mnode 2970 is 2971 Info : constant Type_Info_Acc := Get_Type_Info (Obj); 2972 begin 2973 case Info.Type_Mode is 2974 when Type_Mode_Unbounded_Array 2975 | Type_Mode_Unbounded_Record => 2976 return Get_Unbounded_Base (Obj); 2977 when Type_Mode_Bounded_Arrays => 2978 -- This works in ortho as an access to unconstrained array is 2979 -- also an access to a constrained array. 2980 return Obj; 2981 when Type_Mode_Bounded_Records => 2982 return Obj; 2983 when others => 2984 raise Internal_Error; 2985 end case; 2986 end Get_Composite_Unbounded_Base; 2987 2988 function Create_Maybe_Fat_Array_Element (Arr : Mnode; Arr_Type : Iir) 2989 return Mnode 2990 is 2991 El_Type : constant Iir := Get_Element_Subtype (Arr_Type); 2992 El_Info : constant Type_Info_Acc := Get_Info (El_Type); 2993 El_Unbounded : constant Boolean := Is_Unbounded_Type (El_Info); 2994 Kind : constant Object_Kind_Type := Get_Object_Kind (Arr); 2995 Var_El : Mnode; 2996 begin 2997 if El_Unbounded then 2998 Var_El := Create_Temp (El_Info, Kind); 2999 New_Assign_Stmt 3000 (M2Lp (Chap3.Get_Composite_Bounds (Var_El)), 3001 M2Addr (Chap3.Array_Bounds_To_Element_Bounds 3002 (Chap3.Get_Composite_Bounds (Arr), Arr_Type))); 3003 return Var_El; 3004 else 3005 return Mnode_Null; 3006 end if; 3007 end Create_Maybe_Fat_Array_Element; 3008 3009 function Assign_Maybe_Fat_Array_Element (Var : Mnode; El : Mnode) 3010 return Mnode is 3011 begin 3012 if Var = Mnode_Null then 3013 return El; 3014 else 3015 New_Assign_Stmt (M2Lp (Chap3.Get_Composite_Base (Var)), M2Addr (El)); 3016 return Var; 3017 end if; 3018 end Assign_Maybe_Fat_Array_Element; 3019 3020 function Get_Bounds_Acc_Base 3021 (Acc : O_Enode; D_Type : Iir) return O_Enode 3022 is 3023 D_Info : constant Type_Info_Acc := Get_Info (D_Type); 3024 begin 3025 return Add_Pointer 3026 (Acc, 3027 New_Lit (New_Sizeof (D_Info.B.Bounds_Type, Ghdl_Index_Type)), 3028 D_Info.B.Base_Ptr_Type (Mode_Value)); 3029 end Get_Bounds_Acc_Base; 3030 3031 function Reindex_Complex_Array 3032 (Base : Mnode; Atype : Iir; Index : O_Enode; Res_Info : Type_Info_Acc) 3033 return Mnode 3034 is 3035 Kind : constant Object_Kind_Type := Get_Object_Kind (Base); 3036 El_Type : constant Iir := Get_Element_Subtype (Atype); 3037 Stride : O_Enode; 3038 Res : O_Enode; 3039 begin 3040 Stride := Get_Subtype_Size (El_Type, Mnode_Null, Kind); 3041 Res := Add_Pointer (M2E (Base), 3042 New_Dyadic_Op (ON_Mul_Ov, Stride, Index), 3043 Res_Info.Ortho_Ptr_Type (Kind)); 3044 return E2M (Res, Res_Info, Kind); 3045 end Reindex_Complex_Array; 3046 3047 function Index_Base (Base : Mnode; Atype : Iir; Index : O_Enode) 3048 return Mnode 3049 is 3050 Arr_Tinfo : constant Type_Info_Acc := Get_Type_Info (Base); 3051 Kind : constant Object_Kind_Type := Get_Object_Kind (Base); 3052 El_Type : constant Iir := Get_Element_Subtype (Atype); 3053 El_Tinfo : constant Type_Info_Acc := Get_Info (El_Type); 3054 begin 3055 if Arr_Tinfo.Type_Mode = Type_Mode_Static_Array 3056 or else Is_Static_Type (Get_Info (Get_Element_Subtype 3057 (Get_Base_Type (Atype)))) 3058 then 3059 -- If the array is fully constrained it can be indexed. 3060 return Lv2M (New_Indexed_Element (M2Lv (Base), Index), 3061 El_Tinfo, Kind); 3062 end if; 3063 3064 -- If the element type of the base type is static, the array 3065 -- can be directly indexed. 3066 return Reindex_Complex_Array (Base, Atype, Index, El_Tinfo); 3067 end Index_Base; 3068 3069 function Convert_Array_Base (Arr : Mnode) return Mnode 3070 is 3071 Type_Info : constant Type_Info_Acc := Get_Type_Info (Arr); 3072 Mode : constant Object_Kind_Type := Get_Object_Kind (Arr); 3073 begin 3074 if Type_Info.Ortho_Ptr_Type (Mode) /= Type_Info.B.Base_Ptr_Type (Mode) 3075 then 3076 return E2M 3077 (New_Convert_Ov (M2E (Arr), Type_Info.B.Base_Ptr_Type (Mode)), 3078 Type_Info, Mode); 3079 else 3080 return Arr; 3081 end if; 3082 end Convert_Array_Base; 3083 3084 function Index_Array (Arr : Mnode; Atype : Iir; Index : O_Enode) 3085 return Mnode 3086 is 3087 El_Type : constant Iir := Get_Element_Subtype (Atype); 3088 El_Tinfo : constant Type_Info_Acc := Get_Info (El_Type); 3089 Kind : constant Object_Kind_Type := Get_Object_Kind (Arr); 3090 Base : Mnode; 3091 begin 3092 Base := Get_Composite_Base (Arr); 3093 -- For indexing, we need to consider the size of elements. 3094 if Is_Unbounded_Type (El_Tinfo) then 3095 return E2M 3096 (Add_Pointer 3097 (M2E (Base), 3098 New_Dyadic_Op 3099 (ON_Mul_Ov, 3100 Index, 3101 New_Value (Array_Bounds_To_Element_Size 3102 (Get_Composite_Bounds (Arr), Atype, 3103 Get_Object_Kind (Arr)))), 3104 El_Tinfo.B.Base_Ptr_Type (Kind)), 3105 El_Tinfo, Kind, 3106 El_Tinfo.B.Base_Type (Kind), 3107 El_Tinfo.B.Base_Ptr_Type (Kind)); 3108 else 3109 return Index_Base (Base, Atype, Index); 3110 end if; 3111 end Index_Array; 3112 3113 function Slice_Base 3114 (Base : Mnode; Atype : Iir; Index : O_Enode; Stride : O_Enode) 3115 return Mnode 3116 is 3117 T_Info : constant Type_Info_Acc := Get_Info (Atype); 3118 El_Type : constant Iir := Get_Element_Subtype (Atype); 3119 El_Tinfo : constant Type_Info_Acc := Get_Info (El_Type); 3120 Kind : constant Object_Kind_Type := Get_Object_Kind (Base); 3121 begin 3122 if not Is_Static_Type (El_Tinfo) then 3123 pragma Assert (T_Info.Type_Mode /= Type_Mode_Static_Array); 3124 if Stride /= O_Enode_Null then 3125 return E2M 3126 (Add_Pointer (M2E (Base), 3127 New_Dyadic_Op (ON_Mul_Ov, Stride, Index), 3128 T_Info.Ortho_Ptr_Type (Kind)), 3129 T_Info, Kind); 3130 else 3131 return Reindex_Complex_Array (Base, Atype, Index, T_Info); 3132 end if; 3133 end if; 3134 3135 if T_Info.Type_Mode = Type_Mode_Static_Array then 3136 -- Static array. Use the type of the array. 3137 return Lv2M (New_Slice (M2Lv (Base), 3138 T_Info.Ortho_Type (Kind), 3139 Index), 3140 T_Info, Kind, 3141 T_Info.Ortho_Type (Kind), 3142 T_Info.Ortho_Ptr_Type (Kind)); 3143 else 3144 -- The base is sliced, so use the ortho type of the base. 3145 return Lv2M (New_Slice (M2Lv (Base), 3146 T_Info.B.Base_Type (Kind), 3147 Index), 3148 T_Info, Kind, 3149 T_Info.B.Base_Type (Kind), 3150 T_Info.B.Base_Ptr_Type (Kind)); 3151 end if; 3152 end Slice_Base; 3153 3154 procedure Allocate_Unbounded_Composite_Base (Alloc_Kind : Allocation_Kind; 3155 Res : Mnode; 3156 Arr_Type : Iir) 3157 is 3158 Dinfo : constant Type_Info_Acc := 3159 Get_Info (Get_Base_Type (Arr_Type)); 3160 Kind : constant Object_Kind_Type := Get_Object_Kind (Res); 3161 Length : O_Enode; 3162 begin 3163 -- Compute array size. 3164 Length := Get_Object_Size (Res, Arr_Type); 3165 -- Allocate the storage for the elements. 3166 New_Assign_Stmt 3167 (M2Lp (Chap3.Get_Composite_Base (Res)), 3168 Gen_Alloc (Alloc_Kind, Length, Dinfo.B.Base_Ptr_Type (Kind))); 3169 end Allocate_Unbounded_Composite_Base; 3170 3171 procedure Allocate_Unbounded_Composite_Bounds 3172 (Alloc_Kind : Allocation_Kind; 3173 Res : Mnode; 3174 Obj_Type : Iir) 3175 is 3176 Tinfo : constant Type_Info_Acc := Get_Info (Obj_Type); 3177 begin 3178 pragma Assert (Tinfo.Type_Mode in Type_Mode_Unbounded); 3179 -- Allocate memory for bounds. 3180 New_Assign_Stmt 3181 (M2Lp (Chap3.Get_Composite_Bounds (Res)), 3182 Gen_Alloc (Alloc_Kind, 3183 New_Lit (New_Sizeof (Tinfo.B.Bounds_Type, 3184 Ghdl_Index_Type)), 3185 Tinfo.B.Bounds_Ptr_Type)); 3186 end Allocate_Unbounded_Composite_Bounds; 3187 3188 -- For aliases of a slice. 3189 procedure Translate_Array_Subtype (Arr_Type : Iir) is 3190 begin 3191 Translate_Subtype_Definition (Arr_Type, False); 3192 Create_Composite_Subtype_Layout_Var (Arr_Type, False); 3193 end Translate_Array_Subtype; 3194 3195 procedure Elab_Array_Subtype (Arr_Type : Iir) is 3196 begin 3197 Chap3.Elab_Composite_Subtype_Layout (Arr_Type); 3198 end Elab_Array_Subtype; 3199 3200 procedure Create_Composite_Subtype (Sub_Type : Iir; Elab : Boolean := True) 3201 is 3202 Mark : Id_Mark_Type; 3203 begin 3204 Push_Identifier_Prefix_Uniq (Mark); 3205 if Get_Info (Sub_Type) = null then 3206 -- Minimal subtype creation. 3207 Translate_Subtype_Definition (Sub_Type, False); 3208 end if; 3209 -- Force creation of variables. 3210 Chap3.Create_Composite_Subtype_Layout_Var (Sub_Type, Elab); 3211 Pop_Identifier_Prefix (Mark); 3212 end Create_Composite_Subtype; 3213 3214 -- Copy SRC to DEST. 3215 -- Both have the same type, OTYPE. 3216 procedure Translate_Object_Copy (Dest : Mnode; 3217 Src : Mnode; 3218 Obj_Type : Iir) 3219 is 3220 Info : constant Type_Info_Acc := Get_Info (Obj_Type); 3221 D : Mnode; 3222 begin 3223 case Info.Type_Mode is 3224 when Type_Mode_Scalar 3225 | Type_Mode_Acc 3226 | Type_Mode_Bounds_Acc 3227 | Type_Mode_File => 3228 -- Scalar or thin pointer. 3229 New_Assign_Stmt (M2Lv (Dest), M2E (Src)); 3230 when Type_Mode_Unbounded_Array 3231 | Type_Mode_Unbounded_Record => 3232 -- a fat array. 3233 D := Stabilize (Dest); 3234 Gen_Memcpy (M2Addr (Get_Composite_Base (D)), 3235 M2Addr (Get_Composite_Base (Src)), 3236 Get_Object_Size (D, Obj_Type)); 3237 when Type_Mode_Bounded_Arrays 3238 | Type_Mode_Bounded_Records => 3239 D := Stabilize (Dest); 3240 Gen_Memcpy (M2Addr (D), M2Addr (Src), 3241 Get_Object_Size (D, Obj_Type)); 3242 when Type_Mode_Unknown 3243 | Type_Mode_Protected => 3244 raise Internal_Error; 3245 end case; 3246 end Translate_Object_Copy; 3247 3248 function Get_Subtype_Size 3249 (Atype : Iir; Bounds : Mnode; Kind : Object_Kind_Type) return O_Enode 3250 is 3251 Type_Info : constant Type_Info_Acc := Get_Info (Atype); 3252 begin 3253 case Type_Info.Type_Mode is 3254 when Type_Mode_Non_Composite 3255 | Type_Mode_Static_Array 3256 | Type_Mode_Static_Record => 3257 return New_Lit (New_Sizeof (Type_Info.Ortho_Type (Kind), 3258 Ghdl_Index_Type)); 3259 when Type_Mode_Complex_Array 3260 | Type_Mode_Complex_Record => 3261 -- The length is pre-computed for a complex bounded type. 3262 return New_Value 3263 (Layout_To_Size (Get_Composite_Type_Layout (Type_Info), Kind)); 3264 when Type_Mode_Unbounded_Array => 3265 declare 3266 El_Type : constant Iir := Get_Element_Subtype (Atype); 3267 El_Tinfo : constant Type_Info_Acc := Get_Info (El_Type); 3268 El_Sz : O_Enode; 3269 Bounds1 : Mnode; 3270 begin 3271 if El_Tinfo.Type_Mode in Type_Mode_Unbounded then 3272 Bounds1 := Stabilize (Bounds); 3273 El_Sz := New_Value 3274 (Layout_To_Size 3275 (Array_Bounds_To_Element_Layout (Bounds1, Atype), 3276 Kind)); 3277 else 3278 Bounds1 := Bounds; 3279 El_Sz := Get_Subtype_Size (El_Type, Mnode_Null, Kind); 3280 end if; 3281 return New_Dyadic_Op 3282 (ON_Mul_Ov, Chap3.Get_Bounds_Length (Bounds1, Atype), El_Sz); 3283 end; 3284 when Type_Mode_Unbounded_Record => 3285 return New_Value (Sizes_To_Size (Layout_To_Sizes (Bounds), Kind)); 3286 when others => 3287 raise Internal_Error; 3288 end case; 3289 end Get_Subtype_Size; 3290 3291 function Get_Object_Size (Obj : Mnode; Obj_Type : Iir) return O_Enode 3292 is 3293 Type_Info : constant Type_Info_Acc := Get_Type_Info (Obj); 3294 Kind : constant Object_Kind_Type := Get_Object_Kind (Obj); 3295 begin 3296 if Type_Info.Type_Mode in Type_Mode_Unbounded then 3297 return Get_Subtype_Size (Obj_Type, Get_Composite_Bounds (Obj), Kind); 3298 else 3299 return Get_Subtype_Size (Obj_Type, Mnode_Null, Kind); 3300 end if; 3301 end Get_Object_Size; 3302 3303 procedure Copy_Bounds (Dest : O_Enode; Src : O_Enode; Obj_Type : Iir) 3304 is 3305 Tinfo : constant Type_Info_Acc := Get_Info (Obj_Type); 3306 begin 3307 Gen_Memcpy 3308 (Dest, Src, 3309 New_Lit (New_Sizeof (Tinfo.B.Bounds_Type, Ghdl_Index_Type))); 3310 end Copy_Bounds; 3311 3312 procedure Copy_Bounds (Dest : Mnode; Src : Mnode; Obj_Type : Iir) is 3313 begin 3314 Copy_Bounds (M2Addr (Dest), M2Addr (Src), Obj_Type); 3315 end Copy_Bounds; 3316 3317 procedure Translate_Object_Allocation 3318 (Res : in out Mnode; 3319 Alloc_Kind : Allocation_Kind; 3320 Obj_Type : Iir; 3321 Bounds : Mnode) 3322 is 3323 Tinfo : constant Type_Info_Acc := Get_Info (Obj_Type); 3324 Kind : constant Object_Kind_Type := Get_Object_Kind (Res); 3325 begin 3326 if Tinfo.Type_Mode in Type_Mode_Unbounded then 3327 -- Allocate bounds and copy. 3328 Allocate_Unbounded_Composite_Bounds (Alloc_Kind, Res, Obj_Type); 3329 Copy_Bounds (Chap3.Get_Composite_Bounds (Res), Bounds, Obj_Type); 3330 -- Allocate base. 3331 Allocate_Unbounded_Composite_Base (Alloc_Kind, Res, Obj_Type); 3332 else 3333 New_Assign_Stmt 3334 (M2Lp (Res), 3335 Gen_Alloc (Alloc_Kind, 3336 Chap3.Get_Object_Size (T2M (Obj_Type, Kind), Obj_Type), 3337 Tinfo.Ortho_Ptr_Type (Kind))); 3338 end if; 3339 end Translate_Object_Allocation; 3340 3341 procedure Gen_Deallocate (Obj : O_Enode) 3342 is 3343 Assocs : O_Assoc_List; 3344 begin 3345 Start_Association (Assocs, Ghdl_Deallocate); 3346 New_Association (Assocs, New_Convert_Ov (Obj, Ghdl_Ptr_Type)); 3347 New_Procedure_Call (Assocs); 3348 end Gen_Deallocate; 3349 3350 -- Performs deallocation of PARAM (the parameter of a deallocate call). 3351 procedure Translate_Object_Deallocation (Param : Iir) 3352 is 3353 Param_Type : constant Iir := Get_Type (Param); 3354 Info : constant Type_Info_Acc := Get_Info (Param_Type); 3355 Val : Mnode; 3356 begin 3357 -- Compute parameter 3358 Val := Chap6.Translate_Name (Param, Mode_Value); 3359 Stabilize (Val); 3360 3361 -- Call deallocator. 3362 Gen_Deallocate (New_Value (M2Lv (Val))); 3363 3364 -- Set the value to null. 3365 New_Assign_Stmt 3366 (M2Lv (Val), New_Lit (New_Null_Access (Info.Ortho_Type (Mode_Value)))); 3367 end Translate_Object_Deallocation; 3368 3369 function Not_In_Range (Value : O_Dnode; Atype : Iir) return O_Enode 3370 is 3371 Constr : constant Iir := Get_Range_Constraint (Atype); 3372 Info : constant Type_Info_Acc := Get_Info (Atype); 3373 3374 function Gen_Compare (Low : O_Enode; Hi : O_Enode) return O_Enode 3375 is 3376 L, H : O_Enode; 3377 begin 3378 if not Info.S.Nocheck_Low then 3379 L := New_Compare_Op 3380 (ON_Lt, New_Obj_Value (Value), Low, Ghdl_Bool_Type); 3381 end if; 3382 if not Info.S.Nocheck_Hi then 3383 H := New_Compare_Op 3384 (ON_Gt, New_Obj_Value (Value), Hi, Ghdl_Bool_Type); 3385 end if; 3386 if Info.S.Nocheck_Hi then 3387 if Info.S.Nocheck_Low then 3388 -- Should not happen! 3389 return New_Lit (Ghdl_Bool_False_Node); 3390 else 3391 return L; 3392 end if; 3393 else 3394 if Info.S.Nocheck_Low then 3395 return H; 3396 else 3397 return New_Dyadic_Op (ON_Or, L, H); 3398 end if; 3399 end if; 3400 end Gen_Compare; 3401 3402 function Gen_Compare_To return O_Enode is 3403 begin 3404 return Gen_Compare 3405 (Chap14.Translate_Left_Type_Attribute (Atype), 3406 Chap14.Translate_Right_Type_Attribute (Atype)); 3407 end Gen_Compare_To; 3408 3409 function Gen_Compare_Downto return O_Enode is 3410 begin 3411 return Gen_Compare 3412 (Chap14.Translate_Right_Type_Attribute (Atype), 3413 Chap14.Translate_Left_Type_Attribute (Atype)); 3414 end Gen_Compare_Downto; 3415 3416 Var_Res : O_Dnode; 3417 If_Blk : O_If_Block; 3418 begin 3419 if Get_Kind (Constr) = Iir_Kind_Range_Expression then 3420 -- Constraint is a range expression, therefore, direction is 3421 -- known. 3422 case Get_Direction (Constr) is 3423 when Dir_To => 3424 return Gen_Compare_To; 3425 when Dir_Downto => 3426 return Gen_Compare_Downto; 3427 end case; 3428 end if; 3429 3430 -- Range constraint is not static 3431 -- full check (lot's of code ?). 3432 Var_Res := Create_Temp (Ghdl_Bool_Type); 3433 Start_If_Stmt 3434 (If_Blk, 3435 New_Compare_Op (ON_Eq, 3436 Chap14.Translate_Dir_Type_Attribute (Atype), 3437 New_Lit (Ghdl_Dir_To_Node), 3438 Ghdl_Bool_Type)); 3439 -- To. 3440 New_Assign_Stmt (New_Obj (Var_Res), Gen_Compare_To); 3441 New_Else_Stmt (If_Blk); 3442 -- Downto 3443 New_Assign_Stmt (New_Obj (Var_Res), Gen_Compare_Downto); 3444 Finish_If_Stmt (If_Blk); 3445 return New_Obj_Value (Var_Res); 3446 end Not_In_Range; 3447 3448 function Need_Range_Check (Expr : Iir; Atype : Iir) return Boolean 3449 is 3450 Info : constant Type_Info_Acc := Get_Info (Atype); 3451 begin 3452 if Info.S.Nocheck_Low and Info.S.Nocheck_Hi then 3453 return False; 3454 end if; 3455 if Expr /= Null_Iir and then Get_Type (Expr) = Atype then 3456 return False; 3457 end if; 3458 return True; 3459 end Need_Range_Check; 3460 3461 procedure Check_Range 3462 (Value : O_Dnode; Expr : Iir; Atype : Iir; Loc : Iir) 3463 is 3464 If_Blk : O_If_Block; 3465 begin 3466 if not Need_Range_Check (Expr, Atype) then 3467 return; 3468 end if; 3469 3470 if Expr /= Null_Iir 3471 and then Get_Expr_Staticness (Expr) = Locally 3472 and then Get_Type_Staticness (Atype) = Locally 3473 then 3474 if not Eval_Is_In_Bound (Eval_Static_Expr (Expr), Atype) then 3475 Chap6.Gen_Bound_Error (Loc); 3476 end if; 3477 else 3478 Open_Temp; 3479 Start_If_Stmt (If_Blk, Not_In_Range (Value, Atype)); 3480 Chap6.Gen_Bound_Error (Loc); 3481 Finish_If_Stmt (If_Blk); 3482 Close_Temp; 3483 end if; 3484 end Check_Range; 3485 3486 function Insert_Scalar_Check 3487 (Value : O_Enode; Expr : Iir; Atype : Iir; Loc : Iir) return O_Enode 3488 is 3489 Var : O_Dnode; 3490 begin 3491 Var := Create_Temp_Init 3492 (Get_Ortho_Type (Get_Base_Type (Atype), Mode_Value), Value); 3493 Check_Range (Var, Expr, Atype, Loc); 3494 return New_Obj_Value (Var); 3495 end Insert_Scalar_Check; 3496 3497 function Maybe_Insert_Scalar_Check 3498 (Value : O_Enode; Expr : Iir; Atype : Iir) return O_Enode 3499 is 3500 Expr_Type : constant Iir := Get_Type (Expr); 3501 begin 3502 -- pragma Assert (Base_Type = Get_Base_Type (Atype)); 3503 if Get_Kind (Expr_Type) in Iir_Kinds_Scalar_Type_And_Subtype_Definition 3504 and then Need_Range_Check (Expr, Atype) 3505 then 3506 return Insert_Scalar_Check (Value, Expr, Atype, Expr); 3507 else 3508 return Value; 3509 end if; 3510 end Maybe_Insert_Scalar_Check; 3511 3512 function Locally_Types_Match (L_Type : Iir; R_Type : Iir) 3513 return Tri_State_Type; 3514 3515 function Locally_Array_Match (L_Type, R_Type : Iir) return Tri_State_Type 3516 is 3517 L_Indexes : constant Iir_Flist := Get_Index_Subtype_List (L_Type); 3518 R_Indexes : constant Iir_Flist := Get_Index_Subtype_List (R_Type); 3519 L_El : Iir; 3520 R_El : Iir; 3521 begin 3522 for I in Flist_First .. Flist_Last (L_Indexes) loop 3523 L_El := Get_Index_Type (L_Indexes, I); 3524 R_El := Get_Index_Type (R_Indexes, I); 3525 if Get_Type_Staticness (L_El) /= Locally 3526 or else Get_Type_Staticness (R_El) /= Locally 3527 then 3528 return Unknown; 3529 end if; 3530 if Eval_Discrete_Type_Length (L_El) 3531 /= Eval_Discrete_Type_Length (R_El) 3532 then 3533 return False; 3534 end if; 3535 end loop; 3536 return Locally_Types_Match (Get_Element_Subtype (L_Type), 3537 Get_Element_Subtype (R_Type)); 3538 end Locally_Array_Match; 3539 3540 function Locally_Record_Match (L_Type : Iir; R_Type : Iir) 3541 return Tri_State_Type 3542 is 3543 L_List : constant Iir_Flist := Get_Elements_Declaration_List (L_Type); 3544 R_List : constant Iir_Flist := Get_Elements_Declaration_List (R_Type); 3545 Res : Tri_State_Type; 3546 begin 3547 Res := True; 3548 for I in Flist_First .. Flist_Last (L_List) loop 3549 case Locally_Types_Match (Get_Type (Get_Nth_Element (L_List, I)), 3550 Get_Type (Get_Nth_Element (R_List, I))) is 3551 when False => 3552 return False; 3553 when True => 3554 null; 3555 when Unknown => 3556 Res := Unknown; 3557 end case; 3558 end loop; 3559 return Res; 3560 end Locally_Record_Match; 3561 3562 -- Return True IFF locally static types L_TYPE and R_TYPE matches. 3563 function Locally_Types_Match (L_Type : Iir; R_Type : Iir) 3564 return Tri_State_Type is 3565 begin 3566 if L_Type = R_Type then 3567 return True; 3568 end if; 3569 case Get_Kind (L_Type) is 3570 when Iir_Kind_Array_Subtype_Definition => 3571 return Locally_Array_Match (L_Type, R_Type); 3572 when Iir_Kind_Record_Subtype_Definition 3573 | Iir_Kind_Record_Type_Definition => 3574 return Locally_Record_Match (L_Type, R_Type); 3575 when Iir_Kinds_Scalar_Type_And_Subtype_Definition => 3576 return True; 3577 when Iir_Kind_Access_Type_Definition 3578 | Iir_Kind_Access_Subtype_Definition => 3579 return True; 3580 when others => 3581 Error_Kind ("locally_types_match", L_Type); 3582 end case; 3583 end Locally_Types_Match; 3584 3585 function Types_Match (L_Type : Iir; R_Type : Iir) return Tri_State_Type is 3586 begin 3587 if Get_Kind (L_Type) not in Iir_Kinds_Composite_Type_Definition then 3588 return True; 3589 end if; 3590 if Get_Constraint_State (L_Type) /= Fully_Constrained 3591 or else Get_Constraint_State (R_Type) /= Fully_Constrained 3592 then 3593 -- If one of the type is not fully constrained, the check is dynamic. 3594 return Unknown; 3595 end if; 3596 if L_Type = R_Type then 3597 -- If the type is the same, they match (they are constrained). 3598 return True; 3599 end if; 3600 -- We cannot use type staticness, as a record may not be locally static 3601 -- because it has one scalar element with non-locally static bounds. 3602 return Locally_Types_Match (L_Type, R_Type); 3603 end Types_Match; 3604 3605 function Check_Match_Cond (L_Type : Iir; 3606 L_Bounds : Mnode; 3607 R_Type : Iir; 3608 R_Bounds : Mnode) return O_Enode is 3609 begin 3610 case Iir_Kinds_Composite_Type_Definition (Get_Kind (L_Type)) is 3611 when Iir_Kinds_Array_Type_Definition => 3612 -- Check length match. 3613 declare 3614 Index_List : constant Iir_Flist := 3615 Get_Index_Subtype_List (L_Type); 3616 Nbr_Dim : constant Natural := Get_Nbr_Elements (Index_List); 3617 L_El : constant Iir := Get_Element_Subtype (L_Type); 3618 R_El : constant Iir := Get_Element_Subtype (R_Type); 3619 El_Match : Tri_State_Type; 3620 Cond : O_Enode; 3621 Sub_Cond : O_Enode; 3622 L_Bounds1 : Mnode; 3623 R_Bounds1 : Mnode; 3624 begin 3625 -- FIXME: stabilize. 3626 El_Match := Types_Match (L_El, R_El); 3627 if El_Match = Unknown or Nbr_Dim > 1 then 3628 L_Bounds1 := Stabilize (L_Bounds); 3629 R_Bounds1 := Stabilize (R_Bounds); 3630 else 3631 L_Bounds1 := L_Bounds; 3632 R_Bounds1 := R_Bounds; 3633 end if; 3634 3635 for I in 1 .. Nbr_Dim loop 3636 Sub_Cond := New_Compare_Op 3637 (ON_Neq, 3638 M2E (Range_To_Length 3639 (Bounds_To_Range (L_Bounds1, L_Type, I))), 3640 M2E (Range_To_Length 3641 (Bounds_To_Range (R_Bounds1, R_Type, I))), 3642 Ghdl_Bool_Type); 3643 if I = 1 then 3644 Cond := Sub_Cond; 3645 else 3646 Cond := New_Dyadic_Op (ON_Or, Cond, Sub_Cond); 3647 end if; 3648 end loop; 3649 if El_Match = Unknown then 3650 Sub_Cond := Check_Match_Cond 3651 (L_El, Array_Bounds_To_Element_Bounds (L_Bounds1, L_Type), 3652 R_El, Array_Bounds_To_Element_Bounds (R_Bounds1, R_Type)); 3653 Cond := New_Dyadic_Op (ON_Or, Cond, Sub_Cond); 3654 end if; 3655 return Cond; 3656 end; 3657 when Iir_Kind_Record_Type_Definition 3658 | Iir_Kind_Record_Subtype_Definition => 3659 declare 3660 L_El_List : constant Iir_Flist := 3661 Get_Elements_Declaration_List (L_Type); 3662 R_El_List : constant Iir_Flist := 3663 Get_Elements_Declaration_List (R_Type); 3664 Cond : O_Enode; 3665 Sub_Cond : O_Enode; 3666 L_Bounds1 : Mnode; 3667 R_Bounds1 : Mnode; 3668 begin 3669 L_Bounds1 := Stabilize (L_Bounds); 3670 R_Bounds1 := Stabilize (R_Bounds); 3671 Cond := O_Enode_Null; 3672 for I in Flist_First .. Flist_Last (L_El_List) loop 3673 declare 3674 L_El : constant Iir := Get_Nth_Element (L_El_List, I); 3675 R_El : constant Iir := Get_Nth_Element (R_El_List, I); 3676 L_El_Type : constant Iir := Get_Type (L_El); 3677 R_El_Type : constant Iir := Get_Type (R_El); 3678 begin 3679 if Types_Match (L_El_Type, R_El_Type) = Unknown then 3680 Sub_Cond := Check_Match_Cond 3681 (L_El_Type, 3682 Record_Bounds_To_Element_Bounds (L_Bounds1, L_El), 3683 R_El_Type, 3684 Record_Bounds_To_Element_Bounds (R_Bounds1, R_El)); 3685 if Cond = O_Enode_Null then 3686 Cond := Sub_Cond; 3687 else 3688 Cond := New_Dyadic_Op (ON_Or, Cond, Sub_Cond); 3689 end if; 3690 end if; 3691 end; 3692 end loop; 3693 pragma Assert (Cond /= O_Enode_Null); 3694 return Cond; 3695 end; 3696 end case; 3697 end Check_Match_Cond; 3698 3699 procedure Check_Composite_Match (L_Type : Iir; 3700 L_Node : Mnode; 3701 R_Type : Iir; 3702 R_Node : Mnode; 3703 Loc : Iir) 3704 is 3705 Res : O_Enode; 3706 begin 3707 case Types_Match (L_Type, R_Type) is 3708 when True => 3709 return; 3710 when False => 3711 -- FIXME: emit a warning ? 3712 Chap6.Gen_Bound_Error (Loc); 3713 return; 3714 when Unknown => 3715 Res := Check_Match_Cond (L_Type, Get_Composite_Bounds (L_Node), 3716 R_Type, Get_Composite_Bounds (R_Node)); 3717 Chap6.Check_Bound_Error (Res, Loc); 3718 end case; 3719 end Check_Composite_Match; 3720 3721 procedure Create_Range_From_Array_Attribute_And_Length 3722 (Array_Attr : Iir; Length : O_Dnode; Res : Mnode) 3723 is 3724 Attr_Kind : Iir_Kind; 3725 Arr_Rng : Mnode; 3726 Iinfo : Type_Info_Acc; 3727 3728 Dir : O_Enode; 3729 Diff : O_Dnode; 3730 Left_Bound : Mnode; 3731 If_Blk : O_If_Block; 3732 If_Blk1 : O_If_Block; 3733 begin 3734 Open_Temp; 3735 Arr_Rng := Chap14.Translate_Array_Attribute_To_Range (Array_Attr); 3736 Iinfo := Get_Type_Info (Arr_Rng); 3737 Stabilize (Arr_Rng); 3738 3739 -- Length. 3740 New_Assign_Stmt (M2Lv (Range_To_Length (Res)), 3741 New_Obj_Value (Length)); 3742 3743 -- Direction. 3744 Attr_Kind := Get_Kind (Array_Attr); 3745 Dir := M2E (Range_To_Dir (Arr_Rng)); 3746 case Attr_Kind is 3747 when Iir_Kind_Range_Array_Attribute => 3748 New_Assign_Stmt (M2Lv (Range_To_Dir (Res)), Dir); 3749 when Iir_Kind_Reverse_Range_Array_Attribute => 3750 Start_If_Stmt (If_Blk, 3751 New_Compare_Op (ON_Eq, 3752 Dir, 3753 New_Lit (Ghdl_Dir_To_Node), 3754 Ghdl_Bool_Type)); 3755 New_Assign_Stmt 3756 (M2Lv (Range_To_Dir (Res)), New_Lit (Ghdl_Dir_Downto_Node)); 3757 New_Else_Stmt (If_Blk); 3758 New_Assign_Stmt 3759 (M2Lv (Range_To_Dir (Res)), New_Lit (Ghdl_Dir_To_Node)); 3760 Finish_If_Stmt (If_Blk); 3761 when others => 3762 Error_Kind ("Create_Range_From_Array_Attribute_And_Length", 3763 Array_Attr); 3764 end case; 3765 3766 Start_If_Stmt 3767 (If_Blk, 3768 New_Compare_Op (ON_Eq, 3769 New_Obj_Value (Length), 3770 New_Lit (Ghdl_Index_0), 3771 Ghdl_Bool_Type)); 3772 -- Null range. 3773 case Attr_Kind is 3774 when Iir_Kind_Range_Array_Attribute => 3775 New_Assign_Stmt (M2Lv (Range_To_Left (Res)), 3776 M2E (Range_To_Right (Arr_Rng))); 3777 New_Assign_Stmt (M2Lv (Range_To_Right (Res)), 3778 M2E (Range_To_Left (Arr_Rng))); 3779 when Iir_Kind_Reverse_Range_Array_Attribute => 3780 New_Assign_Stmt (M2Lv (Range_To_Left (Res)), 3781 M2E (Range_To_Left (Arr_Rng))); 3782 New_Assign_Stmt (M2Lv (Range_To_Right (Res)), 3783 M2E (Range_To_Right (Arr_Rng))); 3784 when others => 3785 raise Internal_Error; 3786 end case; 3787 3788 New_Else_Stmt (If_Blk); 3789 3790 -- LEFT. 3791 case Attr_Kind is 3792 when Iir_Kind_Range_Array_Attribute => 3793 Left_Bound := Range_To_Left (Arr_Rng); 3794 when Iir_Kind_Reverse_Range_Array_Attribute => 3795 Left_Bound := Range_To_Right (Arr_Rng); 3796 when others => 3797 raise Internal_Error; 3798 end case; 3799 Stabilize (Left_Bound); 3800 New_Assign_Stmt (M2Lv (Range_To_Left (Res)), M2E (Left_Bound)); 3801 3802 -- RIGHT. 3803 Diff := Create_Temp_Init 3804 (Iinfo.Ortho_Type (Mode_Value), 3805 New_Convert_Ov 3806 (New_Dyadic_Op (ON_Sub_Ov, 3807 New_Obj_Value (Length), 3808 New_Lit (Ghdl_Index_1)), 3809 Iinfo.Ortho_Type (Mode_Value))); 3810 3811 Start_If_Stmt (If_Blk1, New_Compare_Op (ON_Eq, 3812 M2E (Range_To_Dir (Res)), 3813 New_Lit (Ghdl_Dir_To_Node), 3814 Ghdl_Bool_Type)); 3815 New_Assign_Stmt (M2Lv (Range_To_Right (Res)), 3816 New_Dyadic_Op (ON_Add_Ov, 3817 M2E (Left_Bound), 3818 New_Obj_Value (Diff))); 3819 New_Else_Stmt (If_Blk1); 3820 New_Assign_Stmt (M2Lv (Range_To_Right (Res)), 3821 New_Dyadic_Op (ON_Sub_Ov, 3822 M2E (Left_Bound), 3823 New_Obj_Value (Diff))); 3824 Finish_If_Stmt (If_Blk1); 3825 3826 -- FIXME: check right bounds is inside bounds. 3827 Finish_If_Stmt (If_Blk); 3828 Close_Temp; 3829 end Create_Range_From_Array_Attribute_And_Length; 3830 3831 procedure Create_Range_From_Length 3832 (Index_Type : Iir; Length : O_Dnode; Res : Mnode; Loc : Iir) 3833 is 3834 Iinfo : constant Type_Info_Acc := Get_Info (Index_Type); 3835 Range_Constr : constant Iir := Get_Range_Constraint (Index_Type); 3836 Op : ON_Op_Kind; 3837 Diff : O_Enode; 3838 Left_Bound : O_Enode; 3839 Var_Right : O_Dnode; 3840 If_Blk : O_If_Block; 3841 Res_Range : Mnode; 3842 begin 3843 if Get_Kind (Range_Constr) /= Iir_Kind_Range_Expression then 3844 Open_Temp; 3845 Res_Range := Stabilize (Res); 3846 3847 Create_Range_From_Array_Attribute_And_Length 3848 (Range_Constr, Length, Res_Range); 3849 3850 Close_Temp; 3851 return; 3852 end if; 3853 3854 Start_Declare_Stmt; 3855 Open_Local_Temp; 3856 Res_Range := Stabilize (Res); 3857 3858 New_Var_Decl (Var_Right, Get_Identifier ("right_bound"), 3859 O_Storage_Local, Iinfo.Ortho_Type (Mode_Value)); 3860 New_Assign_Stmt 3861 (M2Lv (Range_To_Length (Res_Range)), New_Obj_Value (Length)); 3862 New_Assign_Stmt 3863 (M2Lv (Range_To_Dir (Res_Range)), 3864 New_Lit (Chap7.Translate_Static_Range_Dir (Range_Constr))); 3865 3866 case Get_Direction (Range_Constr) is 3867 when Dir_To => 3868 Op := ON_Add_Ov; 3869 when Dir_Downto => 3870 Op := ON_Sub_Ov; 3871 end case; 3872 3873 Start_If_Stmt (If_Blk, New_Compare_Op (ON_Eq, 3874 New_Obj_Value (Length), 3875 New_Lit (Ghdl_Index_0), 3876 Ghdl_Bool_Type)); 3877 -- Null range. 3878 New_Assign_Stmt 3879 (M2Lv (Range_To_Left (Res_Range)), 3880 Chap7.Translate_Range_Expression_Right (Range_Constr, Index_Type)); 3881 New_Assign_Stmt 3882 (M2Lv (Range_To_Right (Res_Range)), 3883 Chap7.Translate_Range_Expression_Left (Range_Constr, Index_Type)); 3884 3885 New_Else_Stmt (If_Blk); 3886 New_Assign_Stmt 3887 (M2Lv (Range_To_Left (Res_Range)), 3888 Chap7.Translate_Range_Expression_Left (Range_Constr, Index_Type)); 3889 Left_Bound := Chap7.Translate_Range_Expression_Left 3890 (Range_Constr, Index_Type); 3891 Diff := New_Convert_Ov 3892 (New_Dyadic_Op (ON_Sub_Ov, 3893 New_Obj_Value (Length), 3894 New_Lit (Ghdl_Index_1)), 3895 Iinfo.Ortho_Type (Mode_Value)); 3896 New_Assign_Stmt (New_Obj (Var_Right), 3897 New_Dyadic_Op (Op, Left_Bound, Diff)); 3898 3899 -- Check the right bounds is inside the bounds of the index type. 3900 Chap3.Check_Range (Var_Right, Null_Iir, Index_Type, Loc); 3901 New_Assign_Stmt 3902 (M2Lv (Range_To_Right (Res_Range)), New_Obj_Value (Var_Right)); 3903 Finish_If_Stmt (If_Blk); 3904 3905 Close_Local_Temp; 3906 Finish_Declare_Stmt; 3907 end Create_Range_From_Length; 3908end Trans.Chap3; 3909