1-- Evaluation of static expressions. 2-- Copyright (C) 2002, 2003, 2004, 2005 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 Ada.Unchecked_Deallocation; 18with Ada.Characters.Handling; 19with Interfaces; 20 21with Name_Table; use Name_Table; 22with Str_Table; 23with Flags; use Flags; 24with Std_Names; 25with Errorout; use Errorout; 26with Vhdl.Scanner; 27with Vhdl.Errors; use Vhdl.Errors; 28with Vhdl.Utils; use Vhdl.Utils; 29with Vhdl.Std_Package; use Vhdl.Std_Package; 30with Vhdl.Ieee.Std_Logic_1164; 31with Grt.Fcvt; 32 33package body Vhdl.Evaluation is 34 -- If FORCE is true, always return a literal. 35 function Eval_Expr_Keep_Orig (Expr : Iir; Force : Boolean) return Iir; 36 37 function Eval_Check_Bound (Expr : Iir; Sub_Type : Iir) return Boolean; 38 39 function Eval_Enum_To_String (Lit : Iir; Orig : Iir) return Iir; 40 function Eval_Integer_Image (Val : Int64; Orig : Iir) return Iir; 41 function Eval_Floating_Image (Val : Fp64; Orig : Iir) return Iir; 42 43 function Eval_Scalar_Compare (Left, Right : Iir) return Compare_Type; 44 45 function Get_Physical_Value (Expr : Iir) return Int64 46 is 47 pragma Unsuppress (Overflow_Check); 48 Kind : constant Iir_Kind := Get_Kind (Expr); 49 Unit : Iir; 50 begin 51 case Kind is 52 when Iir_Kind_Physical_Int_Literal 53 | Iir_Kind_Physical_Fp_Literal => 54 -- Extract Unit. 55 Unit := Get_Physical_Literal 56 (Get_Named_Entity (Get_Unit_Name (Expr))); 57 pragma Assert (Get_Kind (Unit) = Iir_Kind_Integer_Literal); 58 case Kind is 59 when Iir_Kind_Physical_Int_Literal => 60 return Get_Value (Expr) * Get_Value (Unit); 61 when Iir_Kind_Physical_Fp_Literal => 62 return Int64 (Get_Fp_Value (Expr) * Fp64 (Get_Value (Unit))); 63 when others => 64 raise Program_Error; 65 end case; 66 when Iir_Kind_Integer_Literal => 67 return Get_Value (Expr); 68 when Iir_Kind_Unit_Declaration => 69 return Get_Value (Get_Physical_Literal (Expr)); 70 when others => 71 Error_Kind ("get_physical_value", Expr); 72 end case; 73 end Get_Physical_Value; 74 75 function Build_Integer (Val : Int64; Origin : Iir) 76 return Iir_Integer_Literal 77 is 78 Res : Iir_Integer_Literal; 79 begin 80 Res := Create_Iir (Iir_Kind_Integer_Literal); 81 Location_Copy (Res, Origin); 82 Set_Value (Res, Val); 83 Set_Type (Res, Get_Type (Origin)); 84 Set_Literal_Origin (Res, Origin); 85 Set_Expr_Staticness (Res, Locally); 86 return Res; 87 end Build_Integer; 88 89 function Build_Floating (Val : Fp64; Origin : Iir) 90 return Iir_Floating_Point_Literal 91 is 92 Res : Iir_Floating_Point_Literal; 93 begin 94 Res := Create_Iir (Iir_Kind_Floating_Point_Literal); 95 Location_Copy (Res, Origin); 96 Set_Fp_Value (Res, Val); 97 Set_Type (Res, Get_Type (Origin)); 98 Set_Literal_Origin (Res, Origin); 99 Set_Expr_Staticness (Res, Locally); 100 return Res; 101 end Build_Floating; 102 103 function Build_Enumeration_Constant (Val : Iir_Index32; Origin : Iir) 104 return Iir_Enumeration_Literal 105 is 106 Enum_Type : constant Iir := Get_Base_Type (Get_Type (Origin)); 107 Enum_List : constant Iir_Flist := 108 Get_Enumeration_Literal_List (Enum_Type); 109 Lit : constant Iir_Enumeration_Literal := 110 Get_Nth_Element (Enum_List, Integer (Val)); 111 Res : Iir_Enumeration_Literal; 112 begin 113 Res := Copy_Enumeration_Literal (Lit); 114 Location_Copy (Res, Origin); 115 Set_Literal_Origin (Res, Origin); 116 return Res; 117 end Build_Enumeration_Constant; 118 119 function Build_Physical (Val : Int64; Origin : Iir) 120 return Iir_Integer_Literal 121 is 122 Res : Iir_Integer_Literal; 123 begin 124 Res := Create_Iir (Iir_Kind_Integer_Literal); 125 Location_Copy (Res, Origin); 126 Set_Value (Res, Val); 127 Set_Type (Res, Get_Type (Origin)); 128 Set_Literal_Origin (Res, Origin); 129 Set_Expr_Staticness (Res, Locally); 130 return Res; 131 end Build_Physical; 132 133 function Build_Discrete (Val : Int64; Origin : Iir) return Iir is 134 begin 135 case Get_Kind (Get_Type (Origin)) is 136 when Iir_Kind_Enumeration_Type_Definition 137 | Iir_Kind_Enumeration_Subtype_Definition => 138 return Build_Enumeration_Constant (Iir_Index32 (Val), Origin); 139 when Iir_Kind_Integer_Type_Definition 140 | Iir_Kind_Integer_Subtype_Definition => 141 return Build_Integer (Val, Origin); 142 when others => 143 Error_Kind ("build_discrete", Get_Type (Origin)); 144 end case; 145 end Build_Discrete; 146 147 function Build_String (Val : String8_Id; Len : Nat32; Origin : Iir) 148 return Iir 149 is 150 Res : Iir; 151 begin 152 Res := Create_Iir (Iir_Kind_String_Literal8); 153 Location_Copy (Res, Origin); 154 Set_String8_Id (Res, Val); 155 Set_String_Length (Res, Len); 156 Set_Type (Res, Get_Type (Origin)); 157 Set_Literal_Origin (Res, Origin); 158 Set_Expr_Staticness (Res, Locally); 159 return Res; 160 end Build_String; 161 162 -- Build a simple aggregate composed of EL_LIST from ORIGIN. STYPE is the 163 -- type of the aggregate. DEF_TYPE should be either Null_Iir or STYPE. It 164 -- is set only when a new subtype has been created for the aggregate. 165 function Build_Simple_Aggregate (El_List : Iir_Flist; 166 Origin : Iir; 167 Stype : Iir; 168 Def_Type : Iir := Null_Iir) 169 return Iir_Simple_Aggregate 170 is 171 Res : Iir_Simple_Aggregate; 172 begin 173 Res := Create_Iir (Iir_Kind_Simple_Aggregate); 174 Location_Copy (Res, Origin); 175 Set_Simple_Aggregate_List (Res, El_List); 176 Set_Type (Res, Stype); 177 Set_Literal_Origin (Res, Origin); 178 Set_Expr_Staticness (Res, Locally); 179 Set_Literal_Subtype (Res, Def_Type); 180 return Res; 181 end Build_Simple_Aggregate; 182 183 function Build_Overflow (Origin : Iir; Expr_Type : Iir) return Iir 184 is 185 Res : Iir; 186 begin 187 Res := Create_Iir (Iir_Kind_Overflow_Literal); 188 Location_Copy (Res, Origin); 189 Set_Type (Res, Expr_Type); 190 Set_Literal_Origin (Res, Origin); 191 Set_Expr_Staticness (Res, Locally); 192 return Res; 193 end Build_Overflow; 194 195 function Build_Overflow (Origin : Iir) return Iir is 196 begin 197 return Build_Overflow (Origin, Get_Type (Origin)); 198 end Build_Overflow; 199 200 function Build_Constant (Val : Iir; Origin : Iir) return Iir 201 is 202 Res : Iir; 203 begin 204 -- Note: this must work for any literals, because it may be used to 205 -- replace a locally static constant by its initial value. 206 case Get_Kind (Val) is 207 when Iir_Kind_Integer_Literal => 208 Res := Create_Iir (Iir_Kind_Integer_Literal); 209 Set_Value (Res, Get_Value (Val)); 210 211 when Iir_Kind_Floating_Point_Literal => 212 Res := Create_Iir (Iir_Kind_Floating_Point_Literal); 213 Set_Fp_Value (Res, Get_Fp_Value (Val)); 214 215 when Iir_Kind_Enumeration_Literal => 216 return Build_Enumeration_Constant 217 (Iir_Index32 (Get_Enum_Pos (Val)), Origin); 218 219 when Iir_Kind_Physical_Int_Literal 220 | Iir_Kind_Physical_Fp_Literal 221 | Iir_Kind_Unit_Declaration => 222 Res := Create_Iir (Iir_Kind_Integer_Literal); 223 Set_Value (Res, Get_Physical_Value (Val)); 224 225 when Iir_Kind_String_Literal8 => 226 Res := Create_Iir (Iir_Kind_String_Literal8); 227 Set_String8_Id (Res, Get_String8_Id (Val)); 228 Set_String_Length (Res, Get_String_Length (Val)); 229 230 when Iir_Kind_Simple_Aggregate => 231 Res := Create_Iir (Iir_Kind_Simple_Aggregate); 232 Set_Simple_Aggregate_List (Res, Get_Simple_Aggregate_List (Val)); 233 234 when Iir_Kind_Overflow_Literal => 235 Res := Create_Iir (Iir_Kind_Overflow_Literal); 236 237 when others => 238 Error_Kind ("build_constant", Val); 239 end case; 240 Location_Copy (Res, Origin); 241 Set_Type (Res, Get_Type (Origin)); 242 Set_Literal_Origin (Res, Origin); 243 Set_Expr_Staticness (Res, Locally); 244 return Res; 245 end Build_Constant; 246 247 function Copy_Constant (Val : Iir) return Iir 248 is 249 Res : Iir; 250 begin 251 Res := Build_Constant (Val, Val); 252 Set_Literal_Origin (Res, Null_Iir); 253 return Res; 254 end Copy_Constant; 255 256 -- FIXME: origin ? 257 function Build_Boolean (Cond : Boolean) return Iir is 258 begin 259 if Cond then 260 return Boolean_True; 261 else 262 return Boolean_False; 263 end if; 264 end Build_Boolean; 265 266 function Build_Enumeration (Val : Iir_Index32; Origin : Iir) 267 return Iir_Enumeration_Literal 268 is 269 Enum_Type : constant Iir := Get_Base_Type (Get_Type (Origin)); 270 Enum_List : constant Iir_Flist := 271 Get_Enumeration_Literal_List (Enum_Type); 272 begin 273 return Get_Nth_Element (Enum_List, Integer (Val)); 274 end Build_Enumeration; 275 276 function Build_Enumeration (Val : Boolean; Origin : Iir) 277 return Iir_Enumeration_Literal 278 is 279 Enum_Type : constant Iir := Get_Base_Type (Get_Type (Origin)); 280 Enum_List : constant Iir_Flist := 281 Get_Enumeration_Literal_List (Enum_Type); 282 begin 283 return Get_Nth_Element (Enum_List, Boolean'Pos (Val)); 284 end Build_Enumeration; 285 286 function Build_Constant_Range (Range_Expr : Iir; Origin : Iir) return Iir 287 is 288 Res : Iir; 289 begin 290 Res := Create_Iir (Iir_Kind_Range_Expression); 291 Location_Copy (Res, Origin); 292 Set_Type (Res, Get_Type (Range_Expr)); 293 Set_Left_Limit (Res, Get_Left_Limit (Range_Expr)); 294 Set_Right_Limit (Res, Get_Right_Limit (Range_Expr)); 295 Set_Direction (Res, Get_Direction (Range_Expr)); 296 Set_Range_Origin (Res, Origin); 297 Set_Expr_Staticness (Res, Locally); 298 return Res; 299 end Build_Constant_Range; 300 301 function Build_Extreme_Value (Is_Pos : Boolean; Origin : Iir) return Iir 302 is 303 Orig_Type : constant Iir := Get_Base_Type (Get_Type (Origin)); 304 begin 305 case Get_Kind (Orig_Type) is 306 when Iir_Kind_Integer_Type_Definition => 307 if Is_Pos then 308 return Build_Integer (Int64'Last, Origin); 309 else 310 return Build_Integer (Int64'First, Origin); 311 end if; 312 when others => 313 Error_Kind ("build_extreme_value", Orig_Type); 314 end case; 315 end Build_Extreme_Value; 316 317 -- A_RANGE is a range expression, whose type, location, expr_staticness, 318 -- left_limit and direction are set. 319 -- Type of A_RANGE must have a range_constraint. 320 -- Set the right limit of A_RANGE from LEN. 321 procedure Set_Right_Limit_By_Length (A_Range : Iir; Len : Int64) 322 is 323 A_Type : constant Iir := Get_Type (A_Range); 324 Left : constant Iir := Get_Left_Limit (A_Range); 325 Right : Iir; 326 Pos : Int64; 327 begin 328 pragma Assert (Get_Expr_Staticness (A_Range) = Locally); 329 330 Pos := Eval_Pos (Left); 331 case Get_Direction (A_Range) is 332 when Dir_To => 333 Pos := Pos + Len - 1; 334 when Dir_Downto => 335 Pos := Pos - Len + 1; 336 end case; 337 if Len > 0 338 and then not Eval_Int_In_Range (Pos, Get_Range_Constraint (A_Type)) 339 then 340 Error_Msg_Sem (+A_Range, "range length is beyond subtype length"); 341 Right := Left; 342 else 343 -- FIXME: what about nul range? 344 Right := Build_Discrete (Pos, A_Range); 345 Set_Literal_Origin (Right, Null_Iir); 346 Set_Right_Limit_Expr (A_Range, Right); 347 end if; 348 Set_Right_Limit (A_Range, Right); 349 end Set_Right_Limit_By_Length; 350 351 -- Create a range of type A_TYPE whose length is LEN. 352 -- Note: only two nodes are created: 353 -- * the range_expression (node returned) 354 -- * the right bound 355 -- The left bound *IS NOT* created, but points to the left bound of A_TYPE. 356 function Create_Range_By_Length 357 (A_Type : Iir; Len : Int64; Loc : Location_Type) 358 return Iir 359 is 360 Index_Constraint : Iir; 361 Constraint : Iir; 362 begin 363 -- The left limit must be locally static in order to compute the right 364 -- limit. 365 pragma Assert (Get_Type_Staticness (A_Type) = Locally); 366 367 Index_Constraint := Get_Range_Constraint (A_Type); 368 Constraint := Create_Iir (Iir_Kind_Range_Expression); 369 Set_Location (Constraint, Loc); 370 Set_Expr_Staticness (Constraint, Locally); 371 Set_Type (Constraint, A_Type); 372 Set_Left_Limit (Constraint, Get_Left_Limit (Index_Constraint)); 373 Set_Direction (Constraint, Get_Direction (Index_Constraint)); 374 Set_Right_Limit_By_Length (Constraint, Len); 375 return Constraint; 376 end Create_Range_By_Length; 377 378 function Create_Range_Subtype_From_Type (A_Type : Iir; Loc : Location_Type) 379 return Iir 380 is 381 Res : Iir; 382 begin 383 pragma Assert (Get_Type_Staticness (A_Type) = Locally); 384 385 case Get_Kind (A_Type) is 386 when Iir_Kind_Enumeration_Type_Definition => 387 Res := Create_Iir (Iir_Kind_Enumeration_Subtype_Definition); 388 when Iir_Kind_Integer_Subtype_Definition 389 | Iir_Kind_Enumeration_Subtype_Definition => 390 Res := Create_Iir (Get_Kind (A_Type)); 391 when others => 392 Error_Kind ("create_range_subtype_by_length", A_Type); 393 end case; 394 Set_Location (Res, Loc); 395 Set_Parent_Type (Res, A_Type); 396 Set_Type_Staticness (Res, Locally); 397 398 return Res; 399 end Create_Range_Subtype_From_Type; 400 401 -- Create a subtype of A_TYPE whose length is LEN. 402 -- This is used to create subtypes for strings or aggregates. 403 function Create_Range_Subtype_By_Length 404 (A_Type : Iir; Len : Int64; Loc : Location_Type) 405 return Iir 406 is 407 Res : Iir; 408 begin 409 Res := Create_Range_Subtype_From_Type (A_Type, Loc); 410 411 Set_Range_Constraint (Res, Create_Range_By_Length (A_Type, Len, Loc)); 412 return Res; 413 end Create_Range_Subtype_By_Length; 414 415 function Create_Unidim_Array_From_Index 416 (Base_Type : Iir; Index_Type : Iir; Loc : Iir) 417 return Iir_Array_Subtype_Definition 418 is 419 Res : Iir_Array_Subtype_Definition; 420 begin 421 Res := Create_Array_Subtype (Base_Type, Get_Location (Loc)); 422 Set_Nth_Element (Get_Index_Subtype_List (Res), 0, Index_Type); 423 Set_Type_Staticness (Res, Min (Get_Type_Staticness (Res), 424 Get_Type_Staticness (Index_Type))); 425 Set_Constraint_State (Res, Fully_Constrained); 426 Set_Index_Constraint_Flag (Res, True); 427 return Res; 428 end Create_Unidim_Array_From_Index; 429 430 function Create_Unidim_Array_By_Length 431 (Base_Type : Iir; Len : Int64; Loc : Iir) 432 return Iir_Array_Subtype_Definition 433 is 434 Index_Type : constant Iir := Get_Index_Type (Base_Type, 0); 435 N_Index_Type : Iir; 436 begin 437 N_Index_Type := Create_Range_Subtype_By_Length 438 (Index_Type, Len, Get_Location (Loc)); 439 return Create_Unidim_Array_From_Index (Base_Type, N_Index_Type, Loc); 440 end Create_Unidim_Array_By_Length; 441 442 procedure Free_Eval_Static_Expr (Res : Iir; Orig : Iir) is 443 begin 444 if Res /= Orig and then Get_Literal_Origin (Res) = Orig then 445 Free_Iir (Res); 446 end if; 447 end Free_Eval_Static_Expr; 448 449 -- Free the result RES of Eval_String_Literal called with ORIG, if created. 450 procedure Free_Eval_String_Literal (Res : Iir; Orig : Iir) 451 is 452 L : Iir_Flist; 453 begin 454 if Res /= Orig then 455 L := Get_Simple_Aggregate_List (Res); 456 Destroy_Iir_Flist (L); 457 Free_Iir (Res); 458 end if; 459 end Free_Eval_String_Literal; 460 461 function String_Literal8_To_Simple_Aggregate (Str : Iir) return Iir 462 is 463 Element_Type : constant Iir := Get_Base_Type 464 (Get_Element_Subtype (Get_Base_Type (Get_Type (Str)))); 465 Literal_List : constant Iir_Flist := 466 Get_Enumeration_Literal_List (Element_Type); 467 468 Len : constant Nat32 := Get_String_Length (Str); 469 Id : constant String8_Id := Get_String8_Id (Str); 470 471 List : Iir_Flist; 472 Lit : Iir; 473 begin 474 List := Create_Iir_Flist (Natural (Len)); 475 476 for I in 1 .. Len loop 477 Lit := Get_Nth_Element 478 (Literal_List, Natural (Str_Table.Element_String8 (Id, I))); 479 Set_Nth_Element (List, Natural (I - 1), Lit); 480 end loop; 481 return Build_Simple_Aggregate (List, Str, Get_Type (Str)); 482 end String_Literal8_To_Simple_Aggregate; 483 484 -- Return the offset of EXPR in RNG. A result of 0 means the left bound, 485 -- a result of 1 mean the next element after the left bound. 486 -- Assume no overflow. 487 function Eval_Pos_In_Range (Rng : Iir; Expr : Iir) return Iir_Index32 488 is 489 Left_Pos : constant Int64 := Eval_Pos (Get_Left_Limit (Rng)); 490 Pos : constant Int64 := Eval_Pos (Expr); 491 begin 492 case Get_Direction (Rng) is 493 when Dir_To => 494 return Iir_Index32 (Pos - Left_Pos); 495 when Dir_Downto => 496 return Iir_Index32 (Left_Pos - Pos); 497 end case; 498 end Eval_Pos_In_Range; 499 500 procedure Build_Array_Choices_Vector 501 (Vect : out Iir_Array; Choice_Range : Iir; Choices_Chain : Iir) 502 is 503 pragma Assert (Vect'First = 0); 504 pragma Assert (Vect'Length = Eval_Discrete_Range_Length (Choice_Range)); 505 Assoc : Iir; 506 Choice : Iir; 507 Cur_Pos : Natural; 508 begin 509 -- Initialize Vect (to correctly handle 'others'). 510 Vect := (others => Null_Iir); 511 512 Assoc := Choices_Chain; 513 Cur_Pos := 0; 514 Choice := Null_Iir; 515 while Is_Valid (Assoc) loop 516 if not Get_Same_Alternative_Flag (Assoc) then 517 Choice := Assoc; 518 end if; 519 case Iir_Kinds_Array_Choice (Get_Kind (Assoc)) is 520 when Iir_Kind_Choice_By_None => 521 Vect (Cur_Pos) := Choice; 522 Cur_Pos := Cur_Pos + 1; 523 when Iir_Kind_Choice_By_Range => 524 declare 525 Rng : constant Iir := Get_Choice_Range (Assoc); 526 Rng_Start : Iir; 527 Rng_Len : Int64; 528 begin 529 if Get_Direction (Rng) = Get_Direction (Choice_Range) then 530 Rng_Start := Get_Left_Limit (Rng); 531 else 532 Rng_Start := Get_Right_Limit (Rng); 533 end if; 534 Cur_Pos := Natural 535 (Eval_Pos_In_Range (Choice_Range, Rng_Start)); 536 Rng_Len := Eval_Discrete_Range_Length (Rng); 537 for I in 1 .. Rng_Len loop 538 Vect (Cur_Pos) := Choice; 539 Cur_Pos := Cur_Pos + 1; 540 end loop; 541 end; 542 when Iir_Kind_Choice_By_Expression => 543 Cur_Pos := Natural 544 (Eval_Pos_In_Range (Choice_Range, 545 Get_Choice_Expression (Assoc))); 546 Vect (Cur_Pos) := Choice; 547 when Iir_Kind_Choice_By_Others => 548 for I in Vect'Range loop 549 if Vect (I) = Null_Iir then 550 Vect (I) := Choice; 551 end if; 552 end loop; 553 end case; 554 Assoc := Get_Chain (Assoc); 555 end loop; 556 end Build_Array_Choices_Vector; 557 558 function Array_Aggregate_To_Simple_Aggregate (Aggr : Iir) return Iir 559 is 560 Aggr_Type : constant Iir := Get_Type (Aggr); 561 Index_Type : constant Iir := Get_Index_Type (Aggr_Type, 0); 562 Index_Range : constant Iir := Eval_Static_Range (Index_Type); 563 Len : constant Int64 := Eval_Discrete_Range_Length (Index_Range); 564 Assocs : constant Iir := Get_Association_Choices_Chain (Aggr); 565 Vect : Iir_Array (0 .. Integer (Len - 1)); 566 List : Iir_Flist; 567 Assoc : Iir; 568 Expr : Iir; 569 begin 570 Assoc := Assocs; 571 while Is_Valid (Assoc) loop 572 if not Get_Same_Alternative_Flag (Assoc) then 573 Expr := Get_Associated_Expr (Assoc); 574 if Get_Kind (Get_Type (Expr)) 575 in Iir_Kinds_Scalar_Type_And_Subtype_Definition 576 then 577 Expr := Eval_Expr_Keep_Orig (Expr, True); 578 Set_Associated_Expr (Assoc, Expr); 579 end if; 580 end if; 581 Assoc := Get_Chain (Assoc); 582 end loop; 583 584 Build_Array_Choices_Vector (Vect, Index_Range, Assocs); 585 586 List := Create_Iir_Flist (Natural (Len)); 587 if Len > 0 then 588 -- Workaround GNAT GPL2014 compiler bug. 589 for I in Vect'Range loop 590 Set_Nth_Element (List, I, Get_Associated_Expr (Vect (I))); 591 end loop; 592 end if; 593 594 return Build_Simple_Aggregate (List, Aggr, Aggr_Type); 595 end Array_Aggregate_To_Simple_Aggregate; 596 597 function Eval_String_Literal (Str : Iir) return Iir is 598 begin 599 case Get_Kind (Str) is 600 when Iir_Kind_String_Literal8 => 601 return String_Literal8_To_Simple_Aggregate (Str); 602 603 when Iir_Kind_Aggregate => 604 return Array_Aggregate_To_Simple_Aggregate (Str); 605 606 when Iir_Kind_Simple_Aggregate => 607 return Str; 608 609 when others => 610 Error_Kind ("eval_string_literal", Str); 611 end case; 612 end Eval_String_Literal; 613 614 function Eval_Monadic_Operator (Orig : Iir; Operand : Iir) return Iir 615 is 616 pragma Unsuppress (Overflow_Check); 617 subtype Iir_Predefined_Vector_Minmax is Iir_Predefined_Functions range 618 Iir_Predefined_Vector_Minimum .. Iir_Predefined_Vector_Maximum; 619 620 Func : Iir_Predefined_Functions; 621 begin 622 if Get_Kind (Operand) = Iir_Kind_Overflow_Literal then 623 -- Propagate overflow. 624 return Build_Overflow (Orig); 625 end if; 626 627 Func := Get_Implicit_Definition (Get_Implementation (Orig)); 628 case Func is 629 when Iir_Predefined_Integer_Negation => 630 return Build_Integer (-Get_Value (Operand), Orig); 631 when Iir_Predefined_Integer_Identity => 632 return Build_Integer (Get_Value (Operand), Orig); 633 when Iir_Predefined_Integer_Absolute => 634 return Build_Integer (abs Get_Value (Operand), Orig); 635 636 when Iir_Predefined_Floating_Negation => 637 return Build_Floating (-Get_Fp_Value (Operand), Orig); 638 when Iir_Predefined_Floating_Identity => 639 return Build_Floating (Get_Fp_Value (Operand), Orig); 640 when Iir_Predefined_Floating_Absolute => 641 return Build_Floating (abs Get_Fp_Value (Operand), Orig); 642 643 when Iir_Predefined_Physical_Negation => 644 return Build_Physical (-Get_Physical_Value (Operand), Orig); 645 when Iir_Predefined_Physical_Identity => 646 return Build_Physical (Get_Physical_Value (Operand), Orig); 647 when Iir_Predefined_Physical_Absolute => 648 return Build_Physical (abs Get_Physical_Value (Operand), Orig); 649 650 when Iir_Predefined_Boolean_Not 651 | Iir_Predefined_Bit_Not => 652 return Build_Enumeration (Get_Enum_Pos (Operand) = 0, Orig); 653 654 when Iir_Predefined_Bit_Condition => 655 return Build_Enumeration (Get_Enum_Pos (Operand) = 1, Orig); 656 657 when Iir_Predefined_TF_Array_Not => 658 declare 659 Lit_Val : Iir; 660 O_List : Iir_Flist; 661 R_List : Iir_Flist; 662 El : Iir; 663 Lit : Iir; 664 begin 665 Lit_Val := Eval_String_Literal (Operand); 666 O_List := Get_Simple_Aggregate_List (Lit_Val); 667 R_List := Create_Iir_Flist (Get_Nbr_Elements (O_List)); 668 669 for I in Flist_First .. Flist_Last (O_List) loop 670 El := Get_Nth_Element (O_List, I); 671 case Get_Enum_Pos (El) is 672 when 0 => 673 Lit := Bit_1; 674 when 1 => 675 Lit := Bit_0; 676 when others => 677 raise Internal_Error; 678 end case; 679 Set_Nth_Element (R_List, I, Lit); 680 end loop; 681 Free_Eval_String_Literal (Lit_Val, Operand); 682 return Build_Simple_Aggregate 683 (R_List, Orig, Get_Type (Operand)); 684 end; 685 686 when Iir_Predefined_Enum_To_String => 687 return Eval_Enum_To_String (Operand, Orig); 688 when Iir_Predefined_Integer_To_String => 689 return Eval_Integer_Image (Get_Value (Operand), Orig); 690 when Iir_Predefined_Floating_To_String => 691 return Eval_Floating_Image (Get_Fp_Value (Operand), Orig); 692 693 when Iir_Predefined_Array_Char_To_String => 694 -- LRM08 5.7 String representation 695 -- - For a given value that is of a one-dimensional array type 696 -- whose element type is a character type that contains only 697 -- character literals, the string representation has the same 698 -- length as the given value. Each element of the string 699 -- representation is the same character literal as the matching 700 -- element of the given value. 701 declare 702 Saggr : Iir; 703 Lits : Iir_Flist; 704 El : Iir; 705 C : Character; 706 String_Id : String8_Id; 707 Len : Natural; 708 begin 709 Saggr := Eval_String_Literal (Operand); 710 Lits := Get_Simple_Aggregate_List (Saggr); 711 Len := Get_Nbr_Elements (Lits); 712 String_Id := Str_Table.Create_String8; 713 for I in Flist_First .. Flist_Last (Lits) loop 714 El := Get_Nth_Element (Lits, I); 715 C := Get_Character (Get_Identifier (El)); 716 Str_Table.Append_String8_Char (C); 717 end loop; 718 Free_Eval_String_Literal (Saggr, Operand); 719 720 return Build_String (String_Id, Nat32 (Len), Orig); 721 end; 722 723 when Iir_Predefined_Vector_Minimum 724 | Iir_Predefined_Vector_Maximum => 725 -- LRM08 5.3.2.4 Predefined operations on array types 726 declare 727 Saggr : Iir; 728 Lits : Iir_Flist; 729 Res : Iir; 730 El : Iir; 731 Cmp : Compare_Type; 732 begin 733 Saggr := Eval_String_Literal (Operand); 734 Lits := Get_Simple_Aggregate_List (Saggr); 735 736 if Get_Nbr_Elements (Lits) = 0 then 737 declare 738 Typ : constant Iir := 739 Get_Type (Get_Implementation (Orig)); 740 Rng : constant Iir := Eval_Static_Range (Typ); 741 begin 742 case Iir_Predefined_Vector_Minmax (Func) is 743 when Iir_Predefined_Vector_Minimum => 744 Res := Get_High_Limit (Rng); 745 when Iir_Predefined_Vector_Maximum => 746 Res := Get_Low_Limit (Rng); 747 end case; 748 Res := Eval_Static_Expr (Res); 749 end; 750 else 751 Res := Get_Nth_Element (Lits, 0); 752 for I in Flist_First .. Flist_Last (Lits) loop 753 El := Get_Nth_Element (Lits, I); 754 Cmp := Eval_Scalar_Compare (El, Res); 755 case Iir_Predefined_Vector_Minmax (Func) is 756 when Iir_Predefined_Vector_Minimum => 757 if Cmp <= Compare_Eq then 758 Res := El; 759 end if; 760 when Iir_Predefined_Vector_Maximum => 761 if Cmp >= Compare_Eq then 762 Res := El; 763 end if; 764 end case; 765 end loop; 766 end if; 767 Free_Eval_String_Literal (Saggr, Operand); 768 return Res; 769 end; 770 771 when others => 772 Error_Internal (Orig, "eval_monadic_operator: " & 773 Iir_Predefined_Functions'Image (Func)); 774 end case; 775 exception 776 when Constraint_Error => 777 -- Can happen for absolute. 778 Warning_Msg_Sem (Warnid_Runtime_Error, +Orig, 779 "arithmetic overflow in static expression"); 780 return Build_Overflow (Orig); 781 end Eval_Monadic_Operator; 782 783 function Eval_Dyadic_Bit_Array_Operator 784 (Expr : Iir; 785 Left, Right : Iir; 786 Func : Iir_Predefined_Dyadic_TF_Array_Functions) return Iir 787 is 788 Expr_Type : constant Iir := Get_Type (Expr); 789 El_Type : constant Iir := 790 Get_Base_Type (Get_Element_Subtype (Expr_Type)); 791 Enum_List : constant Iir_Flist := Get_Enumeration_Literal_List (El_Type); 792 Cst_0 : constant Iir := Get_Nth_Element (Enum_List, 0); 793 Cst_1 : constant Iir := Get_Nth_Element (Enum_List, 1); 794 Left_Val, Right_Val : Iir; 795 R_List, L_List : Iir_Flist; 796 Len : Natural; 797 Res : Iir; 798 Res_List : Iir_Flist; 799 El : Iir; 800 begin 801 Left_Val := Eval_String_Literal (Left); 802 Right_Val := Eval_String_Literal (Right); 803 804 L_List := Get_Simple_Aggregate_List (Left_Val); 805 R_List := Get_Simple_Aggregate_List (Right_Val); 806 Len := Get_Nbr_Elements (L_List); 807 808 if Len /= Get_Nbr_Elements (R_List) then 809 Warning_Msg_Sem (Warnid_Runtime_Error, +Expr, 810 "length of left and right operands mismatch"); 811 Res := Build_Overflow (Expr); 812 else 813 Res_List := Create_Iir_Flist (Len); 814 815 case Func is 816 when Iir_Predefined_TF_Array_And => 817 for I in 0 .. Len - 1 loop 818 El := Get_Nth_Element (L_List, I); 819 case Get_Enum_Pos (El) is 820 when 0 => 821 null; 822 when 1 => 823 El := Get_Nth_Element (R_List, I); 824 when others => 825 raise Internal_Error; 826 end case; 827 Set_Nth_Element (Res_List, I, El); 828 end loop; 829 when Iir_Predefined_TF_Array_Nand => 830 for I in 0 .. Len - 1 loop 831 El := Get_Nth_Element (L_List, I); 832 case Get_Enum_Pos (El) is 833 when 0 => 834 El := Cst_1; 835 when 1 => 836 El := Get_Nth_Element (R_List, I); 837 case Get_Enum_Pos (El) is 838 when 0 => 839 El := Cst_1; 840 when 1 => 841 El := Cst_0; 842 when others => 843 raise Internal_Error; 844 end case; 845 when others => 846 raise Internal_Error; 847 end case; 848 Set_Nth_Element (Res_List, I, El); 849 end loop; 850 when Iir_Predefined_TF_Array_Or => 851 for I in 0 .. Len - 1 loop 852 El := Get_Nth_Element (L_List, I); 853 case Get_Enum_Pos (El) is 854 when 1 => 855 null; 856 when 0 => 857 El := Get_Nth_Element (R_List, I); 858 when others => 859 raise Internal_Error; 860 end case; 861 Set_Nth_Element (Res_List, I, El); 862 end loop; 863 when Iir_Predefined_TF_Array_Nor => 864 for I in 0 .. Len - 1 loop 865 El := Get_Nth_Element (L_List, I); 866 case Get_Enum_Pos (El) is 867 when 1 => 868 El := Cst_0; 869 when 0 => 870 El := Get_Nth_Element (R_List, I); 871 case Get_Enum_Pos (El) is 872 when 0 => 873 El := Cst_1; 874 when 1 => 875 El := Cst_0; 876 when others => 877 raise Internal_Error; 878 end case; 879 when others => 880 raise Internal_Error; 881 end case; 882 Set_Nth_Element (Res_List, I, El); 883 end loop; 884 when Iir_Predefined_TF_Array_Xor => 885 for I in 0 .. Len - 1 loop 886 El := Get_Nth_Element (L_List, I); 887 case Get_Enum_Pos (El) is 888 when 1 => 889 El := Get_Nth_Element (R_List, I); 890 case Get_Enum_Pos (El) is 891 when 0 => 892 El := Cst_1; 893 when 1 => 894 El := Cst_0; 895 when others => 896 raise Internal_Error; 897 end case; 898 when 0 => 899 El := Get_Nth_Element (R_List, I); 900 when others => 901 raise Internal_Error; 902 end case; 903 Set_Nth_Element (Res_List, I, El); 904 end loop; 905 when others => 906 Error_Internal (Expr, "eval_dyadic_bit_array_functions: " & 907 Iir_Predefined_Functions'Image (Func)); 908 end case; 909 910 Res := Build_Simple_Aggregate (Res_List, Expr, Expr_Type); 911 end if; 912 913 Free_Eval_Static_Expr (Left_Val, Left); 914 Free_Eval_Static_Expr (Right_Val, Right); 915 916 -- The unconstrained type is replaced by the constrained one. 917 Set_Type (Res, Get_Type (Left)); 918 return Res; 919 end Eval_Dyadic_Bit_Array_Operator; 920 921 -- Return TRUE if VAL /= 0. 922 function Check_Integer_Division_By_Zero (Expr : Iir; Val : Iir) 923 return Boolean 924 is 925 begin 926 if Get_Value (Val) = 0 then 927 Warning_Msg_Sem (Warnid_Runtime_Error, +Expr, "division by 0"); 928 return False; 929 else 930 return True; 931 end if; 932 end Check_Integer_Division_By_Zero; 933 934 function Eval_Shift_Operator 935 (Left, Right : Iir; Origin : Iir; Func : Iir_Predefined_Shift_Functions) 936 return Iir 937 is 938 Count : constant Int64 := Get_Value (Right); 939 Arr_List : constant Iir_Flist := Get_Simple_Aggregate_List (Left); 940 Len : constant Natural := Get_Nbr_Elements (Arr_List); 941 Cnt : Natural; 942 Res_List : Iir_Flist; 943 Dir_Left : Boolean; 944 E : Iir; 945 begin 946 -- LRM93 7.2.3 947 -- That is, if R is 0 or if L is a null array, the return value is L. 948 if Count = 0 or Len = 0 then 949 return Build_Simple_Aggregate (Arr_List, Origin, Get_Type (Left)); 950 end if; 951 case Func is 952 when Iir_Predefined_Array_Sll 953 | Iir_Predefined_Array_Sla 954 | Iir_Predefined_Array_Rol => 955 Dir_Left := True; 956 when Iir_Predefined_Array_Srl 957 | Iir_Predefined_Array_Sra 958 | Iir_Predefined_Array_Ror => 959 Dir_Left := False; 960 end case; 961 if Count < 0 then 962 Cnt := Natural (-Count); 963 Dir_Left := not Dir_Left; 964 else 965 Cnt := Natural (Count); 966 end if; 967 968 case Func is 969 when Iir_Predefined_Array_Sll 970 | Iir_Predefined_Array_Srl => 971 declare 972 Enum_List : constant Iir_Flist := 973 Get_Enumeration_Literal_List 974 (Get_Base_Type (Get_Element_Subtype (Get_Type (Left)))); 975 begin 976 E := Get_Nth_Element (Enum_List, 0); 977 end; 978 when Iir_Predefined_Array_Sla 979 | Iir_Predefined_Array_Sra => 980 if Dir_Left then 981 E := Get_Nth_Element (Arr_List, Len - 1); 982 else 983 E := Get_Nth_Element (Arr_List, 0); 984 end if; 985 when Iir_Predefined_Array_Rol 986 | Iir_Predefined_Array_Ror => 987 Cnt := Cnt mod Len; 988 if not Dir_Left then 989 Cnt := (Len - Cnt) mod Len; 990 end if; 991 end case; 992 993 Res_List := Create_Iir_Flist (Len); 994 995 case Func is 996 when Iir_Predefined_Array_Sll 997 | Iir_Predefined_Array_Srl 998 | Iir_Predefined_Array_Sla 999 | Iir_Predefined_Array_Sra => 1000 if Dir_Left then 1001 if Cnt < Len then 1002 for I in Cnt .. Len - 1 loop 1003 Set_Nth_Element 1004 (Res_List, I - Cnt, Get_Nth_Element (Arr_List, I)); 1005 end loop; 1006 else 1007 Cnt := Len; 1008 end if; 1009 for I in 0 .. Cnt - 1 loop 1010 Set_Nth_Element (Res_List, Len - Cnt + I, E); 1011 end loop; 1012 else 1013 if Cnt > Len then 1014 Cnt := Len; 1015 end if; 1016 for I in 0 .. Cnt - 1 loop 1017 Set_Nth_Element (Res_List, I, E); 1018 end loop; 1019 for I in Cnt .. Len - 1 loop 1020 Set_Nth_Element 1021 (Res_List, I, Get_Nth_Element (Arr_List, I - Cnt)); 1022 end loop; 1023 end if; 1024 when Iir_Predefined_Array_Rol 1025 | Iir_Predefined_Array_Ror => 1026 for I in 1 .. Len loop 1027 Set_Nth_Element 1028 (Res_List, I - 1, Get_Nth_Element (Arr_List, Cnt)); 1029 Cnt := Cnt + 1; 1030 if Cnt = Len then 1031 Cnt := 0; 1032 end if; 1033 end loop; 1034 end case; 1035 return Build_Simple_Aggregate (Res_List, Origin, Get_Type (Left)); 1036 end Eval_Shift_Operator; 1037 1038 -- Concatenate all the elements of OPERANDS. 1039 -- The first element of OPERANDS is the rightest one, the last the 1040 -- leftest one. All the elements are concatenation operators. 1041 -- All the elements are static. 1042 function Eval_Concatenation (Operands : Iir_Array) return Iir 1043 is 1044 pragma Assert (Operands'First = 1); 1045 Orig : constant Iir := Operands (1); 1046 Origin_Type : constant Iir := Get_Type (Orig); 1047 1048 Ops_Val : Iir_Array (Operands'Range); 1049 Str_Lits : Iir_Array (Operands'Range); 1050 Left_Op : Iir; 1051 Left_Val : Iir; 1052 Left_Lit : Iir; 1053 Res_List : Iir_Flist; 1054 Res_Len : Natural; 1055 Res_Type : Iir; 1056 Def, Left_Def : Iir_Predefined_Functions; 1057 Op : Iir; 1058 El : Iir; 1059 El_List : Iir_Flist; 1060 El_Len : Natural; 1061 Err_Orig : Iir; 1062 1063 -- To compute the index range of the result for vhdl87. 1064 Leftest_Non_Null : Iir; 1065 Bounds_From_Subtype : Boolean; 1066 begin 1067 -- Eval operands, compute length of the result. 1068 Err_Orig := Null_Iir; 1069 Res_Len := 0; 1070 for I in Operands'Range loop 1071 Op := Operands (I); 1072 Def := Get_Implicit_Definition (Get_Implementation (Op)); 1073 if Get_Kind (Op) = Iir_Kind_Function_Call then 1074 El := Get_Actual 1075 (Get_Chain (Get_Parameter_Association_Chain (Op))); 1076 else 1077 El := Get_Right (Op); 1078 end if; 1079 Ops_Val (I) := Eval_Static_Expr (El); 1080 if Get_Kind (Ops_Val (I)) = Iir_Kind_Overflow_Literal then 1081 Err_Orig := El; 1082 else 1083 case Iir_Predefined_Concat_Functions (Def) is 1084 when Iir_Predefined_Array_Element_Concat 1085 | Iir_Predefined_Element_Element_Concat => 1086 Res_Len := Res_Len + 1; 1087 when Iir_Predefined_Element_Array_Concat 1088 | Iir_Predefined_Array_Array_Concat => 1089 Str_Lits (I) := Eval_String_Literal (Ops_Val (I)); 1090 El_List := Get_Simple_Aggregate_List (Str_Lits (I)); 1091 Res_Len := Res_Len + Get_Nbr_Elements (El_List); 1092 end case; 1093 end if; 1094 end loop; 1095 1096 Op := Operands (Operands'Last); 1097 if Get_Kind (Op) = Iir_Kind_Function_Call then 1098 Left_Op := Get_Actual (Get_Parameter_Association_Chain (Op)); 1099 else 1100 Left_Op := Get_Left (Op); 1101 end if; 1102 Left_Val := Eval_Static_Expr (Left_Op); 1103 if Get_Kind (Left_Val) = Iir_Kind_Overflow_Literal then 1104 Err_Orig := Left_Op; 1105 else 1106 Left_Def := Def; 1107 case Iir_Predefined_Concat_Functions (Left_Def) is 1108 when Iir_Predefined_Element_Array_Concat 1109 | Iir_Predefined_Element_Element_Concat => 1110 Res_Len := Res_Len + 1; 1111 when Iir_Predefined_Array_Element_Concat 1112 | Iir_Predefined_Array_Array_Concat => 1113 Left_Lit := Eval_String_Literal (Left_Val); 1114 El_List := Get_Simple_Aggregate_List (Left_Lit); 1115 Res_Len := Res_Len + Get_Nbr_Elements (El_List); 1116 end case; 1117 end if; 1118 1119 -- Handle overflow. 1120 if Err_Orig /= Null_Iir then 1121 -- Free all. 1122 for I in Ops_Val'Range loop 1123 Free_Eval_Static_Expr (Ops_Val (I), Operands (I)); 1124 end loop; 1125 Free_Eval_Static_Expr (Left_Val, Left_Op); 1126 1127 return Build_Overflow (Err_Orig); 1128 end if; 1129 1130 Res_List := Create_Iir_Flist (Res_Len); 1131 1132 -- Do the concatenation. 1133 -- Left: 1134 Leftest_Non_Null := Null_Iir; 1135 case Iir_Predefined_Concat_Functions (Left_Def) is 1136 when Iir_Predefined_Element_Array_Concat 1137 | Iir_Predefined_Element_Element_Concat => 1138 Set_Nth_Element (Res_List, 0, Left_Val); 1139 Bounds_From_Subtype := True; 1140 Res_Len := 1; 1141 when Iir_Predefined_Array_Element_Concat 1142 | Iir_Predefined_Array_Array_Concat => 1143 El_List := Get_Simple_Aggregate_List (Left_Lit); 1144 Res_Len := Get_Nbr_Elements (El_List); 1145 for I in 0 .. Res_Len - 1 loop 1146 Set_Nth_Element (Res_List, I, Get_Nth_Element (El_List, I)); 1147 end loop; 1148 Bounds_From_Subtype := Def = Iir_Predefined_Array_Element_Concat; 1149 if Res_Len > 0 then 1150 Leftest_Non_Null := Get_Type (Left_Lit); 1151 end if; 1152 Free_Eval_String_Literal (Left_Lit, Left_Val); 1153 end case; 1154 1155 -- Right: 1156 for I in reverse Operands'Range loop 1157 Def := Get_Implicit_Definition (Get_Implementation (Operands (I))); 1158 case Iir_Predefined_Concat_Functions (Def) is 1159 when Iir_Predefined_Array_Element_Concat 1160 | Iir_Predefined_Element_Element_Concat => 1161 Set_Nth_Element (Res_List, Res_Len, Ops_Val (I)); 1162 Bounds_From_Subtype := True; 1163 Res_Len := Res_Len + 1; 1164 when Iir_Predefined_Element_Array_Concat 1165 | Iir_Predefined_Array_Array_Concat => 1166 El_List := Get_Simple_Aggregate_List (Str_Lits (I)); 1167 El_Len := Get_Nbr_Elements (El_List); 1168 for I in 0 .. El_Len - 1 loop 1169 Set_Nth_Element 1170 (Res_List, Res_Len + I, Get_Nth_Element (El_List, I)); 1171 end loop; 1172 Bounds_From_Subtype := Bounds_From_Subtype 1173 or Def = Iir_Predefined_Element_Array_Concat; 1174 if Leftest_Non_Null = Null_Iir and then El_Len /= 0 then 1175 Leftest_Non_Null := Get_Type (Ops_Val (I)); 1176 end if; 1177 Free_Eval_String_Literal (Str_Lits (I), Ops_Val (I)); 1178 Res_Len := Res_Len + El_Len; 1179 end case; 1180 end loop; 1181 1182 -- Compute subtype... 1183 if Flags.Vhdl_Std > Vhdl_87 then 1184 -- LRM93 7.2.4 1185 -- If both operands are null arrays, then the result of the 1186 -- concatenation is the right operand. 1187 if Res_Len = 0 then 1188 Res_Type := Get_Type (Get_Right (Operands (1))); 1189 else 1190 -- LRM93 7.2.4 1191 -- Otherwise, the direction and bounds of the result are 1192 -- determined as follows: let S be the index subtype of the base 1193 -- type of the result. The direction of the result of the 1194 -- concatenation is the direction of S, and the left bound of the 1195 -- result is S'LEFT. 1196 Res_Type := Create_Unidim_Array_By_Length 1197 (Origin_Type, Int64 (Res_Len), Orig); 1198 end if; 1199 else 1200 -- LRM87 7.2.3 1201 -- The left bound of the result is the left operand, [...] 1202 -- 1203 -- LRM87 7.2.3 1204 -- The direction of the result is the direction of the left 1205 -- operand, [...] 1206 -- 1207 -- LRM87 7.2.3 1208 -- [...], unless the left operand is a null array, in which case 1209 -- the result of the concatenation is the right operand. 1210 1211 -- Look for the first operand that is either an element or 1212 -- a non-null array. If it is an element, create the bounds 1213 -- by length. If it is an array, create the bounds from it. If 1214 -- there is no such operand, use the leftest operands for the 1215 -- bounds. 1216 if Bounds_From_Subtype then 1217 -- There is at least one concatenation with an element. 1218 Res_Type := Create_Unidim_Array_By_Length 1219 (Origin_Type, Int64 (Res_Len), Orig); 1220 else 1221 if Res_Len = 0 then 1222 Res_Type := Get_Type (Get_Right (Operands (1))); 1223 else 1224 declare 1225 Left_Index : constant Iir := 1226 Get_Index_Type (Leftest_Non_Null, 0); 1227 Left_Range : constant Iir := 1228 Get_Range_Constraint (Left_Index); 1229 Ret_Type : constant Iir := 1230 Get_Return_Type (Get_Implementation (Orig)); 1231 Rng_Type : constant Iir := Get_Index_Type (Ret_Type, 0); 1232 A_Range : Iir; 1233 Index_Type : Iir; 1234 begin 1235 A_Range := Create_Iir (Iir_Kind_Range_Expression); 1236 Location_Copy (A_Range, Orig); 1237 Set_Type (A_Range, Rng_Type); 1238 Set_Expr_Staticness (A_Range, Locally); 1239 Set_Left_Limit (A_Range, Get_Left_Limit (Left_Range)); 1240 Set_Direction (A_Range, Get_Direction (Left_Range)); 1241 Set_Right_Limit_By_Length (A_Range, Int64 (Res_Len)); 1242 1243 Index_Type := Create_Range_Subtype_From_Type 1244 (Rng_Type, Get_Location (Orig)); 1245 Set_Range_Constraint (Index_Type, A_Range); 1246 Res_Type := Create_Unidim_Array_From_Index 1247 (Origin_Type, Index_Type, Orig); 1248 end; 1249 end if; 1250 end if; 1251 end if; 1252 1253 for I in Ops_Val'Range loop 1254 Free_Eval_Static_Expr (Ops_Val (I), Operands (I)); 1255 end loop; 1256 Free_Eval_Static_Expr (Left_Val, Left_Op); 1257 1258 -- FIXME: this is not necessarily a string, it may be an aggregate if 1259 -- element type is not a character type. 1260 return Build_Simple_Aggregate (Res_List, Orig, Res_Type, Res_Type); 1261 end Eval_Concatenation; 1262 1263 function Eval_Scalar_Compare (Left, Right : Iir) return Compare_Type 1264 is 1265 Ltype : constant Iir := Get_Base_Type (Get_Type (Left)); 1266 begin 1267 pragma Assert 1268 (Get_Kind (Ltype) = Get_Kind (Get_Base_Type (Get_Type (Right)))); 1269 1270 case Get_Kind (Ltype) is 1271 when Iir_Kind_Enumeration_Type_Definition => 1272 declare 1273 L_Pos : constant Iir_Int32 := Get_Enum_Pos (Left); 1274 R_Pos : constant Iir_Int32 := Get_Enum_Pos (Right); 1275 begin 1276 if L_Pos = R_Pos then 1277 return Compare_Eq; 1278 else 1279 if L_Pos < R_Pos then 1280 return Compare_Lt; 1281 else 1282 return Compare_Gt; 1283 end if; 1284 end if; 1285 end; 1286 when Iir_Kind_Physical_Type_Definition => 1287 declare 1288 L_Val : constant Int64 := Get_Physical_Value (Left); 1289 R_Val : constant Int64 := Get_Physical_Value (Right); 1290 begin 1291 if L_Val = R_Val then 1292 return Compare_Eq; 1293 else 1294 if L_Val < R_Val then 1295 return Compare_Lt; 1296 else 1297 return Compare_Gt; 1298 end if; 1299 end if; 1300 end; 1301 when Iir_Kind_Integer_Type_Definition => 1302 declare 1303 L_Val : constant Int64 := Get_Value (Left); 1304 R_Val : constant Int64 := Get_Value (Right); 1305 begin 1306 if L_Val = R_Val then 1307 return Compare_Eq; 1308 else 1309 if L_Val < R_Val then 1310 return Compare_Lt; 1311 else 1312 return Compare_Gt; 1313 end if; 1314 end if; 1315 end; 1316 when Iir_Kind_Floating_Type_Definition => 1317 declare 1318 L_Val : constant Fp64 := Get_Fp_Value (Left); 1319 R_Val : constant Fp64 := Get_Fp_Value (Right); 1320 begin 1321 if L_Val = R_Val then 1322 return Compare_Eq; 1323 else 1324 if L_Val < R_Val then 1325 return Compare_Lt; 1326 else 1327 return Compare_Gt; 1328 end if; 1329 end if; 1330 end; 1331 when others => 1332 Error_Kind ("eval_scalar_compare", Ltype); 1333 end case; 1334 end Eval_Scalar_Compare; 1335 1336 function Eval_Array_Compare (Left, Right : Iir) return Compare_Type is 1337 begin 1338 if Get_Kind (Left) = Iir_Kind_String_Literal8 1339 and then Get_Kind (Right) = Iir_Kind_String_Literal8 1340 then 1341 -- Common case: both parameters are strings. 1342 declare 1343 L_Id : constant String8_Id := Get_String8_Id (Left); 1344 R_Id : constant String8_Id := Get_String8_Id (Right); 1345 L_Len : constant Int32 := Get_String_Length (Left); 1346 R_Len : constant Int32 := Get_String_Length (Right); 1347 L_El, R_El : Nat8; 1348 P : Nat32; 1349 begin 1350 P := 1; 1351 while P <= L_Len and P <= R_Len loop 1352 L_El := Str_Table.Element_String8 (L_Id, P); 1353 R_El := Str_Table.Element_String8 (R_Id, P); 1354 if L_El /= R_El then 1355 if L_El < R_El then 1356 return Compare_Lt; 1357 else 1358 return Compare_Gt; 1359 end if; 1360 end if; 1361 P := P + 1; 1362 end loop; 1363 if L_Len = R_Len then 1364 return Compare_Eq; 1365 elsif L_Len < R_Len then 1366 return Compare_Lt; 1367 else 1368 return Compare_Gt; 1369 end if; 1370 end; 1371 else 1372 -- General case. 1373 declare 1374 Left_Val, Right_Val : Iir; 1375 R_List, L_List : Iir_Flist; 1376 R_Len, L_Len : Natural; 1377 P : Natural; 1378 Res : Compare_Type; 1379 begin 1380 Left_Val := Eval_String_Literal (Left); 1381 Right_Val := Eval_String_Literal (Right); 1382 1383 L_List := Get_Simple_Aggregate_List (Left_Val); 1384 R_List := Get_Simple_Aggregate_List (Right_Val); 1385 L_Len := Get_Nbr_Elements (L_List); 1386 R_Len := Get_Nbr_Elements (R_List); 1387 1388 Res := Compare_Eq; 1389 P := 0; 1390 while P < L_Len and P < R_Len loop 1391 Res := Eval_Scalar_Compare (Get_Nth_Element (L_List, P), 1392 Get_Nth_Element (R_List, P)); 1393 exit when Res /= Compare_Eq; 1394 P := P + 1; 1395 end loop; 1396 if Res = Compare_Eq then 1397 if L_Len < R_Len then 1398 Res := Compare_Lt; 1399 elsif L_Len > R_Len then 1400 Res := Compare_Gt; 1401 end if; 1402 end if; 1403 1404 Free_Eval_Static_Expr (Left_Val, Left); 1405 Free_Eval_Static_Expr (Right_Val, Right); 1406 1407 return Res; 1408 end; 1409 end if; 1410 end Eval_Array_Compare; 1411 1412 function Eval_Logic_Match_Equality (L, R : Iir_Int32; Loc : Iir) 1413 return Iir_Index32 1414 is 1415 use Vhdl.Ieee.Std_Logic_1164; 1416 Lb, Rb : Boolean; 1417 begin 1418 if L = Std_Logic_D_Pos or R = Std_Logic_D_Pos then 1419 Warning_Msg_Sem 1420 (Warnid_Analyze_Assert, +Loc, 1421 "STD_LOGIC_1164: '-' operand for matching ordering operator"); 1422 return Std_Logic_1_Pos; 1423 end if; 1424 if L = Std_Logic_U_Pos or R = Std_Logic_U_Pos then 1425 return Std_Logic_U_Pos; 1426 end if; 1427 if L = Std_Logic_X_Pos 1428 or L = Std_Logic_Z_Pos 1429 or L = Std_Logic_W_Pos 1430 then 1431 return Std_Logic_X_Pos; 1432 end if; 1433 if R = Std_Logic_X_Pos 1434 or R = Std_Logic_Z_Pos 1435 or R = Std_Logic_W_Pos 1436 then 1437 return Std_Logic_X_Pos; 1438 end if; 1439 Lb := L = Std_Logic_1_Pos or L = Std_Logic_H_Pos; 1440 Rb := R = Std_Logic_1_Pos or R = Std_Logic_H_Pos; 1441 if Lb = Rb then 1442 return Std_Logic_1_Pos; 1443 else 1444 return Std_Logic_0_Pos; 1445 end if; 1446 end Eval_Logic_Match_Equality; 1447 1448 function Eval_Equality (Left, Right : Iir) return Boolean; 1449 1450 -- CHOICES is a chain of choice from a record aggregate; FEL is an Flist 1451 -- whose length is the number of element of the record type. 1452 -- Fill FEL with the associated expressions from CHOICES, so that it is 1453 -- easier to deal than the aggregate as elements are ordered. 1454 procedure Fill_Flist_From_Record_Aggregate (Choices : Iir; Fel : Iir_Flist) 1455 is 1456 Pos : Natural; 1457 Ch : Iir; 1458 Expr : Iir; 1459 begin 1460 Pos := 0; 1461 Ch := Choices; 1462 while Ch /= Null_Iir loop 1463 Expr := Get_Associated_Expr (Ch); 1464 case Iir_Kinds_Record_Choice (Get_Kind (Ch)) is 1465 when Iir_Kind_Choice_By_None => 1466 Set_Nth_Element (Fel, Pos, Expr); 1467 Pos := Pos + 1; 1468 when Iir_Kind_Choice_By_Name => 1469 Pos := Natural (Get_Element_Position 1470 (Get_Named_Entity (Get_Choice_Name (Ch)))); 1471 Set_Nth_Element (Fel, Pos, Expr); 1472 when Iir_Kind_Choice_By_Others => 1473 for I in 0 .. Get_Nbr_Elements (Fel) - 1 loop 1474 if Get_Nth_Element (Fel, I) = Null_Iir then 1475 Set_Nth_Element (Fel, I, Expr); 1476 end if; 1477 end loop; 1478 end case; 1479 Ch := Get_Chain (Ch); 1480 end loop; 1481 end Fill_Flist_From_Record_Aggregate; 1482 1483 1484 function Eval_Record_Equality (Left, Right : Iir) return Boolean 1485 is 1486 pragma Assert (Get_Kind (Left) = Iir_Kind_Aggregate); 1487 pragma Assert (Get_Kind (Right) = Iir_Kind_Aggregate); 1488 Lch, Rch : Iir; 1489 begin 1490 Lch := Get_Association_Choices_Chain (Left); 1491 Rch := Get_Association_Choices_Chain (Right); 1492 1493 if Get_Kind (Lch) = Iir_Kind_Choice_By_None 1494 and then Get_Kind (Rch) = Iir_Kind_Choice_By_None 1495 then 1496 -- All choices are positionnal. 1497 while Lch /= Null_Iir loop 1498 pragma Assert (Rch /= Null_Iir); 1499 pragma Assert (Get_Kind (Lch) = Iir_Kind_Choice_By_None); 1500 pragma Assert (Get_Kind (Rch) = Iir_Kind_Choice_By_None); 1501 if not Eval_Equality (Get_Associated_Expr (Lch), 1502 Get_Associated_Expr (Rch)) 1503 then 1504 return False; 1505 end if; 1506 Lch := Get_Chain (Lch); 1507 Rch := Get_Chain (Rch); 1508 end loop; 1509 pragma Assert (Rch = Null_Iir); 1510 return True; 1511 else 1512 declare 1513 Els : constant Iir_Flist := 1514 Get_Elements_Declaration_List (Get_Type (Left)); 1515 Nels : constant Natural := Get_Nbr_Elements (Els); 1516 Lel, Rel : Iir_Flist; 1517 Res : Boolean; 1518 begin 1519 Lel := Create_Iir_Flist (Nels); 1520 Rel := Create_Iir_Flist (Nels); 1521 Fill_Flist_From_Record_Aggregate (Lch, Lel); 1522 Fill_Flist_From_Record_Aggregate (Rch, Rel); 1523 1524 Res := True; 1525 for I in 0 .. Nels - 1 loop 1526 if not Eval_Equality (Get_Nth_Element (Lel, I), 1527 Get_Nth_Element (Rel, I)) 1528 then 1529 Res := False; 1530 exit; 1531 end if; 1532 end loop; 1533 1534 Destroy_Iir_Flist (Lel); 1535 Destroy_Iir_Flist (Rel); 1536 1537 return Res; 1538 end; 1539 end if; 1540 end Eval_Record_Equality; 1541 1542 function Eval_Equality (Left, Right : Iir) return Boolean 1543 is 1544 Ltype : constant Iir := Get_Base_Type (Get_Type (Left)); 1545 begin 1546 pragma Assert 1547 (Get_Kind (Ltype) = Get_Kind (Get_Base_Type (Get_Type (Right)))); 1548 1549 case Get_Kind (Ltype) is 1550 when Iir_Kind_Enumeration_Type_Definition => 1551 return Get_Enum_Pos (Left) = Get_Enum_Pos (Right); 1552 when Iir_Kind_Physical_Type_Definition => 1553 return Get_Physical_Value (Left) = Get_Physical_Value (Right); 1554 when Iir_Kind_Integer_Type_Definition => 1555 return Get_Value (Left) = Get_Value (Right); 1556 when Iir_Kind_Floating_Type_Definition => 1557 return Get_Fp_Value (Left) = Get_Fp_Value (Right); 1558 when Iir_Kind_Array_Type_Definition => 1559 return Eval_Array_Compare (Left, Right) = Compare_Eq; 1560 when Iir_Kind_Record_Type_Definition => 1561 return Eval_Record_Equality (Left, Right); 1562 when others => 1563 Error_Kind ("eval_equality", Ltype); 1564 end case; 1565 end Eval_Equality; 1566 1567 -- ORIG is either a dyadic operator or a function call. 1568 function Eval_Dyadic_Operator (Orig : Iir; Imp : Iir; Left, Right : Iir) 1569 return Iir 1570 is 1571 pragma Unsuppress (Overflow_Check); 1572 Func : constant Iir_Predefined_Functions := 1573 Get_Implicit_Definition (Imp); 1574 begin 1575 if Get_Kind (Left) = Iir_Kind_Overflow_Literal 1576 or else Get_Kind (Right) = Iir_Kind_Overflow_Literal 1577 then 1578 return Build_Overflow (Orig); 1579 end if; 1580 1581 case Func is 1582 when Iir_Predefined_Integer_Plus => 1583 return Build_Integer (Get_Value (Left) + Get_Value (Right), Orig); 1584 when Iir_Predefined_Integer_Minus => 1585 return Build_Integer (Get_Value (Left) - Get_Value (Right), Orig); 1586 when Iir_Predefined_Integer_Mul => 1587 return Build_Integer (Get_Value (Left) * Get_Value (Right), Orig); 1588 when Iir_Predefined_Integer_Div => 1589 if Check_Integer_Division_By_Zero (Orig, Right) then 1590 return Build_Integer 1591 (Get_Value (Left) / Get_Value (Right), Orig); 1592 else 1593 return Build_Overflow (Orig); 1594 end if; 1595 when Iir_Predefined_Integer_Mod => 1596 if Check_Integer_Division_By_Zero (Orig, Right) then 1597 return Build_Integer 1598 (Get_Value (Left) mod Get_Value (Right), Orig); 1599 else 1600 return Build_Overflow (Orig); 1601 end if; 1602 when Iir_Predefined_Integer_Rem => 1603 if Check_Integer_Division_By_Zero (Orig, Right) then 1604 return Build_Integer 1605 (Get_Value (Left) rem Get_Value (Right), Orig); 1606 else 1607 return Build_Overflow (Orig); 1608 end if; 1609 when Iir_Predefined_Integer_Exp => 1610 return Build_Integer 1611 (Get_Value (Left) ** Integer (Get_Value (Right)), Orig); 1612 1613 when Iir_Predefined_Integer_Equality => 1614 return Build_Boolean (Get_Value (Left) = Get_Value (Right)); 1615 when Iir_Predefined_Integer_Inequality => 1616 return Build_Boolean (Get_Value (Left) /= Get_Value (Right)); 1617 when Iir_Predefined_Integer_Greater_Equal => 1618 return Build_Boolean (Get_Value (Left) >= Get_Value (Right)); 1619 when Iir_Predefined_Integer_Greater => 1620 return Build_Boolean (Get_Value (Left) > Get_Value (Right)); 1621 when Iir_Predefined_Integer_Less_Equal => 1622 return Build_Boolean (Get_Value (Left) <= Get_Value (Right)); 1623 when Iir_Predefined_Integer_Less => 1624 return Build_Boolean (Get_Value (Left) < Get_Value (Right)); 1625 1626 when Iir_Predefined_Integer_Minimum => 1627 if Get_Value (Left) < Get_Value (Right) then 1628 return Left; 1629 else 1630 return Right; 1631 end if; 1632 when Iir_Predefined_Integer_Maximum => 1633 if Get_Value (Left) > Get_Value (Right) then 1634 return Left; 1635 else 1636 return Right; 1637 end if; 1638 1639 when Iir_Predefined_Floating_Equality => 1640 return Build_Boolean (Get_Fp_Value (Left) = Get_Fp_Value (Right)); 1641 when Iir_Predefined_Floating_Inequality => 1642 return Build_Boolean (Get_Fp_Value (Left) /= Get_Fp_Value (Right)); 1643 when Iir_Predefined_Floating_Greater => 1644 return Build_Boolean (Get_Fp_Value (Left) > Get_Fp_Value (Right)); 1645 when Iir_Predefined_Floating_Greater_Equal => 1646 return Build_Boolean (Get_Fp_Value (Left) >= Get_Fp_Value (Right)); 1647 when Iir_Predefined_Floating_Less => 1648 return Build_Boolean (Get_Fp_Value (Left) < Get_Fp_Value (Right)); 1649 when Iir_Predefined_Floating_Less_Equal => 1650 return Build_Boolean (Get_Fp_Value (Left) <= Get_Fp_Value (Right)); 1651 1652 when Iir_Predefined_Floating_Minus => 1653 return Build_Floating 1654 (Get_Fp_Value (Left) - Get_Fp_Value (Right), Orig); 1655 when Iir_Predefined_Floating_Plus => 1656 return Build_Floating 1657 (Get_Fp_Value (Left) + Get_Fp_Value (Right), Orig); 1658 when Iir_Predefined_Floating_Mul => 1659 return Build_Floating 1660 (Get_Fp_Value (Left) * Get_Fp_Value (Right), Orig); 1661 when Iir_Predefined_Floating_Div => 1662 if Get_Fp_Value (Right) = 0.0 then 1663 Warning_Msg_Sem (Warnid_Runtime_Error, +Orig, 1664 "right operand of division is 0"); 1665 return Build_Overflow (Orig); 1666 else 1667 return Build_Floating 1668 (Get_Fp_Value (Left) / Get_Fp_Value (Right), Orig); 1669 end if; 1670 when Iir_Predefined_Floating_Exp => 1671 declare 1672 Exp : Int64; 1673 Res : Fp64; 1674 Val : Fp64; 1675 begin 1676 Res := 1.0; 1677 Val := Get_Fp_Value (Left); 1678 -- LRM08 9.2.8 Misellaneous operators 1679 -- Exponentiation with an integer exponent is equivalent to 1680 -- repeated multiplication of the left operand by itself for 1681 -- a number of times indicated by the absolute value of the 1682 -- exponent and from left to right; [...] 1683 -- GHDL: use the standard power-of-2 approach. This is not 1684 -- strictly equivalent however. 1685 Exp := abs Get_Value (Right); 1686 while Exp /= 0 loop 1687 if Exp mod 2 = 1 then 1688 Res := Res * Val; 1689 end if; 1690 Exp := Exp / 2; 1691 Val := Val * Val; 1692 end loop; 1693 -- LRM08 9.2.8 Misellaneous operators 1694 -- [...] if the exponent is negative then the result is the 1695 -- reciprocal of that [...] 1696 if Get_Value (Right) < 0 then 1697 Res := 1.0 / Res; 1698 end if; 1699 return Build_Floating (Res, Orig); 1700 end; 1701 1702 when Iir_Predefined_Floating_Minimum => 1703 if Get_Fp_Value (Left) < Get_Fp_Value (Right) then 1704 return Left; 1705 else 1706 return Right; 1707 end if; 1708 when Iir_Predefined_Floating_Maximum => 1709 if Get_Fp_Value (Left) > Get_Fp_Value (Right) then 1710 return Left; 1711 else 1712 return Right; 1713 end if; 1714 1715 when Iir_Predefined_Physical_Equality => 1716 return Build_Boolean 1717 (Get_Physical_Value (Left) = Get_Physical_Value (Right)); 1718 when Iir_Predefined_Physical_Inequality => 1719 return Build_Boolean 1720 (Get_Physical_Value (Left) /= Get_Physical_Value (Right)); 1721 when Iir_Predefined_Physical_Greater_Equal => 1722 return Build_Boolean 1723 (Get_Physical_Value (Left) >= Get_Physical_Value (Right)); 1724 when Iir_Predefined_Physical_Greater => 1725 return Build_Boolean 1726 (Get_Physical_Value (Left) > Get_Physical_Value (Right)); 1727 when Iir_Predefined_Physical_Less_Equal => 1728 return Build_Boolean 1729 (Get_Physical_Value (Left) <= Get_Physical_Value (Right)); 1730 when Iir_Predefined_Physical_Less => 1731 return Build_Boolean 1732 (Get_Physical_Value (Left) < Get_Physical_Value (Right)); 1733 1734 when Iir_Predefined_Physical_Physical_Div => 1735 return Build_Integer 1736 (Get_Physical_Value (Left) / Get_Physical_Value (Right), Orig); 1737 when Iir_Predefined_Physical_Integer_Div => 1738 return Build_Physical 1739 (Get_Physical_Value (Left) / Get_Value (Right), Orig); 1740 when Iir_Predefined_Physical_Minus => 1741 return Build_Physical 1742 (Get_Physical_Value (Left) - Get_Physical_Value (Right), Orig); 1743 when Iir_Predefined_Physical_Plus => 1744 return Build_Physical 1745 (Get_Physical_Value (Left) + Get_Physical_Value (Right), Orig); 1746 when Iir_Predefined_Integer_Physical_Mul => 1747 return Build_Physical 1748 (Get_Value (Left) * Get_Physical_Value (Right), Orig); 1749 when Iir_Predefined_Physical_Integer_Mul => 1750 return Build_Physical 1751 (Get_Physical_Value (Left) * Get_Value (Right), Orig); 1752 when Iir_Predefined_Real_Physical_Mul => 1753 -- FIXME: overflow?? 1754 return Build_Physical 1755 (Int64 (Get_Fp_Value (Left) 1756 * Fp64 (Get_Physical_Value (Right))), Orig); 1757 when Iir_Predefined_Physical_Real_Mul => 1758 -- FIXME: overflow?? 1759 return Build_Physical 1760 (Int64 (Fp64 (Get_Physical_Value (Left)) 1761 * Get_Fp_Value (Right)), Orig); 1762 when Iir_Predefined_Physical_Real_Div => 1763 -- FIXME: overflow?? 1764 return Build_Physical 1765 (Int64 (Fp64 (Get_Physical_Value (Left)) 1766 / Get_Fp_Value (Right)), Orig); 1767 1768 when Iir_Predefined_Physical_Minimum => 1769 return Build_Physical (Int64'Min (Get_Physical_Value (Left), 1770 Get_Physical_Value (Right)), 1771 Orig); 1772 when Iir_Predefined_Physical_Maximum => 1773 return Build_Physical (Int64'Max (Get_Physical_Value (Left), 1774 Get_Physical_Value (Right)), 1775 Orig); 1776 1777 when Iir_Predefined_Element_Array_Concat 1778 | Iir_Predefined_Array_Element_Concat 1779 | Iir_Predefined_Array_Array_Concat 1780 | Iir_Predefined_Element_Element_Concat => 1781 raise Internal_Error; 1782 1783 when Iir_Predefined_Enum_Equality 1784 | Iir_Predefined_Bit_Match_Equality => 1785 return Build_Enumeration 1786 (Get_Enum_Pos (Left) = Get_Enum_Pos (Right), Orig); 1787 when Iir_Predefined_Enum_Inequality 1788 | Iir_Predefined_Bit_Match_Inequality => 1789 return Build_Enumeration 1790 (Get_Enum_Pos (Left) /= Get_Enum_Pos (Right), Orig); 1791 when Iir_Predefined_Enum_Greater_Equal 1792 | Iir_Predefined_Bit_Match_Greater_Equal => 1793 return Build_Enumeration 1794 (Get_Enum_Pos (Left) >= Get_Enum_Pos (Right), Orig); 1795 when Iir_Predefined_Enum_Greater 1796 | Iir_Predefined_Bit_Match_Greater => 1797 return Build_Enumeration 1798 (Get_Enum_Pos (Left) > Get_Enum_Pos (Right), Orig); 1799 when Iir_Predefined_Enum_Less_Equal 1800 | Iir_Predefined_Bit_Match_Less_Equal => 1801 return Build_Enumeration 1802 (Get_Enum_Pos (Left) <= Get_Enum_Pos (Right), Orig); 1803 when Iir_Predefined_Enum_Less 1804 | Iir_Predefined_Bit_Match_Less => 1805 return Build_Enumeration 1806 (Get_Enum_Pos (Left) < Get_Enum_Pos (Right), Orig); 1807 1808 when Iir_Predefined_Enum_Minimum => 1809 if Get_Enum_Pos (Left) < Get_Enum_Pos (Right) then 1810 return Left; 1811 else 1812 return Right; 1813 end if; 1814 when Iir_Predefined_Enum_Maximum => 1815 if Get_Enum_Pos (Left) > Get_Enum_Pos (Right) then 1816 return Left; 1817 else 1818 return Right; 1819 end if; 1820 1821 when Iir_Predefined_Boolean_And 1822 | Iir_Predefined_Bit_And => 1823 return Build_Enumeration 1824 (Get_Enum_Pos (Left) = 1 and Get_Enum_Pos (Right) = 1, Orig); 1825 when Iir_Predefined_Boolean_Nand 1826 | Iir_Predefined_Bit_Nand => 1827 return Build_Enumeration 1828 (not (Get_Enum_Pos (Left) = 1 and Get_Enum_Pos (Right) = 1), 1829 Orig); 1830 when Iir_Predefined_Boolean_Or 1831 | Iir_Predefined_Bit_Or => 1832 return Build_Enumeration 1833 (Get_Enum_Pos (Left) = 1 or Get_Enum_Pos (Right) = 1, Orig); 1834 when Iir_Predefined_Boolean_Nor 1835 | Iir_Predefined_Bit_Nor => 1836 return Build_Enumeration 1837 (not (Get_Enum_Pos (Left) = 1 or Get_Enum_Pos (Right) = 1), 1838 Orig); 1839 when Iir_Predefined_Boolean_Xor 1840 | Iir_Predefined_Bit_Xor => 1841 return Build_Enumeration 1842 (Get_Enum_Pos (Left) = 1 xor Get_Enum_Pos (Right) = 1, Orig); 1843 when Iir_Predefined_Boolean_Xnor 1844 | Iir_Predefined_Bit_Xnor => 1845 return Build_Enumeration 1846 (not (Get_Enum_Pos (Left) = 1 xor Get_Enum_Pos (Right) = 1), 1847 Orig); 1848 1849 when Iir_Predefined_Dyadic_TF_Array_Functions => 1850 -- FIXME: only for bit ? 1851 return Eval_Dyadic_Bit_Array_Operator (Orig, Left, Right, Func); 1852 1853 when Iir_Predefined_Universal_R_I_Mul => 1854 return Build_Floating 1855 (Get_Fp_Value (Left) * Fp64 (Get_Value (Right)), Orig); 1856 when Iir_Predefined_Universal_I_R_Mul => 1857 return Build_Floating 1858 (Fp64 (Get_Value (Left)) * Get_Fp_Value (Right), Orig); 1859 when Iir_Predefined_Universal_R_I_Div => 1860 return Build_Floating 1861 (Get_Fp_Value (Left) / Fp64 (Get_Value (Right)), Orig); 1862 1863 when Iir_Predefined_Array_Sll 1864 | Iir_Predefined_Array_Srl 1865 | Iir_Predefined_Array_Sla 1866 | Iir_Predefined_Array_Sra 1867 | Iir_Predefined_Array_Rol 1868 | Iir_Predefined_Array_Ror => 1869 declare 1870 Left_Aggr : Iir; 1871 Res : Iir; 1872 begin 1873 Left_Aggr := Eval_String_Literal (Left); 1874 Res := Eval_Shift_Operator (Left_Aggr, Right, Orig, Func); 1875 Free_Eval_String_Literal (Left_Aggr, Left); 1876 return Res; 1877 end; 1878 1879 when Iir_Predefined_Array_Equality => 1880 return Build_Boolean 1881 (Eval_Array_Compare (Left, Right) = Compare_Eq); 1882 when Iir_Predefined_Array_Inequality => 1883 return Build_Boolean 1884 (Eval_Array_Compare (Left, Right) /= Compare_Eq); 1885 when Iir_Predefined_Array_Less => 1886 return Build_Boolean 1887 (Eval_Array_Compare (Left, Right) = Compare_Lt); 1888 when Iir_Predefined_Array_Less_Equal => 1889 return Build_Boolean 1890 (Eval_Array_Compare (Left, Right) <= Compare_Eq); 1891 when Iir_Predefined_Array_Greater => 1892 return Build_Boolean 1893 (Eval_Array_Compare (Left, Right) = Compare_Gt); 1894 when Iir_Predefined_Array_Greater_Equal => 1895 return Build_Boolean 1896 (Eval_Array_Compare (Left, Right) >= Compare_Eq); 1897 1898 when Iir_Predefined_Record_Equality => 1899 return Build_Boolean (Eval_Record_Equality (Left, Right)); 1900 when Iir_Predefined_Record_Inequality => 1901 return Build_Boolean (not Eval_Record_Equality (Left, Right)); 1902 1903 when Iir_Predefined_Boolean_Not 1904 | Iir_Predefined_Boolean_Rising_Edge 1905 | Iir_Predefined_Boolean_Falling_Edge 1906 | Iir_Predefined_Bit_Not 1907 | Iir_Predefined_Bit_Rising_Edge 1908 | Iir_Predefined_Bit_Falling_Edge 1909 | Iir_Predefined_Integer_Absolute 1910 | Iir_Predefined_Integer_Identity 1911 | Iir_Predefined_Integer_Negation 1912 | Iir_Predefined_Floating_Absolute 1913 | Iir_Predefined_Floating_Negation 1914 | Iir_Predefined_Floating_Identity 1915 | Iir_Predefined_Physical_Absolute 1916 | Iir_Predefined_Physical_Identity 1917 | Iir_Predefined_Physical_Negation 1918 | Iir_Predefined_Error 1919 | Iir_Predefined_Access_Equality 1920 | Iir_Predefined_Access_Inequality 1921 | Iir_Predefined_TF_Array_Not 1922 | Iir_Predefined_Now_Function 1923 | Iir_Predefined_Real_Now_Function 1924 | Iir_Predefined_Frequency_Function 1925 | Iir_Predefined_Deallocate 1926 | Iir_Predefined_Write 1927 | Iir_Predefined_Read 1928 | Iir_Predefined_Read_Length 1929 | Iir_Predefined_Flush 1930 | Iir_Predefined_File_Open 1931 | Iir_Predefined_File_Open_Status 1932 | Iir_Predefined_File_Close 1933 | Iir_Predefined_Endfile 1934 | Iir_Predefined_Array_Char_To_String 1935 | Iir_Predefined_Bit_Vector_To_Ostring 1936 | Iir_Predefined_Bit_Vector_To_Hstring => 1937 -- Not binary or never locally static. 1938 Error_Internal (Orig, "eval_dyadic_operator: " & 1939 Iir_Predefined_Functions'Image (Func)); 1940 1941 when Iir_Predefined_Bit_Condition => 1942 raise Internal_Error; 1943 1944 when Iir_Predefined_Array_Minimum 1945 | Iir_Predefined_Array_Maximum 1946 | Iir_Predefined_Vector_Minimum 1947 | Iir_Predefined_Vector_Maximum => 1948 raise Internal_Error; 1949 1950 when Iir_Predefined_Std_Ulogic_Match_Equality => 1951 return Build_Enumeration 1952 (Eval_Logic_Match_Equality (Get_Enum_Pos (Left), 1953 Get_Enum_Pos (Right), Orig), 1954 Orig); 1955 when Iir_Predefined_Std_Ulogic_Match_Inequality 1956 | Iir_Predefined_Std_Ulogic_Match_Less 1957 | Iir_Predefined_Std_Ulogic_Match_Less_Equal 1958 | Iir_Predefined_Std_Ulogic_Match_Greater 1959 | Iir_Predefined_Std_Ulogic_Match_Greater_Equal => 1960 -- TODO 1961 raise Internal_Error; 1962 1963 when Iir_Predefined_Enum_To_String 1964 | Iir_Predefined_Integer_To_String 1965 | Iir_Predefined_Floating_To_String 1966 | Iir_Predefined_Real_To_String_Digits 1967 | Iir_Predefined_Real_To_String_Format 1968 | Iir_Predefined_Physical_To_String 1969 | Iir_Predefined_Time_To_String_Unit => 1970 -- TODO 1971 raise Internal_Error; 1972 1973 when Iir_Predefined_TF_Array_Element_And 1974 | Iir_Predefined_TF_Element_Array_And 1975 | Iir_Predefined_TF_Array_Element_Or 1976 | Iir_Predefined_TF_Element_Array_Or 1977 | Iir_Predefined_TF_Array_Element_Nand 1978 | Iir_Predefined_TF_Element_Array_Nand 1979 | Iir_Predefined_TF_Array_Element_Nor 1980 | Iir_Predefined_TF_Element_Array_Nor 1981 | Iir_Predefined_TF_Array_Element_Xor 1982 | Iir_Predefined_TF_Element_Array_Xor 1983 | Iir_Predefined_TF_Array_Element_Xnor 1984 | Iir_Predefined_TF_Element_Array_Xnor => 1985 -- TODO 1986 raise Internal_Error; 1987 1988 when Iir_Predefined_TF_Reduction_And 1989 | Iir_Predefined_TF_Reduction_Or 1990 | Iir_Predefined_TF_Reduction_Nand 1991 | Iir_Predefined_TF_Reduction_Nor 1992 | Iir_Predefined_TF_Reduction_Xor 1993 | Iir_Predefined_TF_Reduction_Xnor 1994 | Iir_Predefined_TF_Reduction_Not => 1995 -- TODO 1996 raise Internal_Error; 1997 1998 when Iir_Predefined_Bit_Array_Match_Equality 1999 | Iir_Predefined_Bit_Array_Match_Inequality 2000 | Iir_Predefined_Std_Ulogic_Array_Match_Equality 2001 | Iir_Predefined_Std_Ulogic_Array_Match_Inequality => 2002 -- TODO 2003 raise Internal_Error; 2004 2005 when Iir_Predefined_Explicit => 2006 raise Internal_Error; 2007 end case; 2008 exception 2009 when Constraint_Error => 2010 Warning_Msg_Sem (Warnid_Runtime_Error, +Orig, 2011 "arithmetic overflow in static expression"); 2012 return Build_Overflow (Orig); 2013 end Eval_Dyadic_Operator; 2014 2015 -- Get the parameter of an attribute, or 1 if doesn't exist. 2016 function Eval_Attribute_Parameter_Or_1 (Attr : Iir) return Natural 2017 is 2018 Parameter : constant Iir := Get_Parameter (Attr); 2019 begin 2020 if Is_Null (Parameter) or else Is_Error (Parameter) then 2021 return 1; 2022 else 2023 return Natural (Get_Value (Parameter)); 2024 end if; 2025 end Eval_Attribute_Parameter_Or_1; 2026 2027 -- Evaluate any array attribute, return the type for the prefix. 2028 function Eval_Array_Attribute (Attr : Iir) return Iir 2029 is 2030 Prefix : Iir; 2031 Prefix_Type : Iir; 2032 Dim : Natural; 2033 begin 2034 Prefix := Get_Prefix (Attr); 2035 case Get_Kind (Prefix) is 2036 when Iir_Kinds_Object_Declaration -- FIXME: remove 2037 | Iir_Kind_Selected_Element 2038 | Iir_Kind_Indexed_Name 2039 | Iir_Kind_Slice_Name 2040 | Iir_Kind_Subtype_Declaration 2041 | Iir_Kind_Type_Declaration 2042 | Iir_Kind_Implicit_Dereference 2043 | Iir_Kind_Function_Call 2044 | Iir_Kind_Attribute_Value 2045 | Iir_Kind_Attribute_Name 2046 | Iir_Kind_Subtype_Attribute => 2047 Prefix_Type := Get_Type (Prefix); 2048 when Iir_Kinds_Subtype_Definition => 2049 Prefix_Type := Prefix; 2050 when Iir_Kinds_Denoting_Name => 2051 Prefix_Type := Get_Type (Prefix); 2052 when others => 2053 Error_Kind ("eval_array_attribute", Prefix); 2054 end case; 2055 if Get_Kind (Prefix_Type) /= Iir_Kind_Array_Subtype_Definition then 2056 Error_Kind ("eval_array_attribute(2)", Prefix_Type); 2057 end if; 2058 2059 Dim := Eval_Attribute_Parameter_Or_1 (Attr); 2060 return Get_Nth_Element (Get_Index_Subtype_List (Prefix_Type), Dim - 1); 2061 end Eval_Array_Attribute; 2062 2063 function Eval_Integer_Image (Val : Int64; Orig : Iir) return Iir 2064 is 2065 use Str_Table; 2066 Img : String (1 .. 24); -- 23 is enough, 24 is rounded. 2067 L : Natural; 2068 V : Int64; 2069 Id : String8_Id; 2070 begin 2071 V := Val; 2072 L := Img'Last; 2073 loop 2074 Img (L) := Character'Val (Character'Pos ('0') + abs (V rem 10)); 2075 V := V / 10; 2076 L := L - 1; 2077 exit when V = 0; 2078 end loop; 2079 if Val < 0 then 2080 Img (L) := '-'; 2081 L := L - 1; 2082 end if; 2083 Id := Create_String8; 2084 for I in L + 1 .. Img'Last loop 2085 Append_String8_Char (Img (I)); 2086 end loop; 2087 return Build_String (Id, Nat32 (Img'Last - L), Orig); 2088 end Eval_Integer_Image; 2089 2090 function Eval_Floating_Image (Val : Fp64; Orig : Iir) return Iir 2091 is 2092 use Str_Table; 2093 Id : String8_Id; 2094 2095 -- Sign (1) + digit (1) + dot (1) + digits (15) + 'e' (1) + sign (1) 2096 -- + exp_digits (4) -> 24. 2097 Str : String (1 .. 25); 2098 P : Natural; 2099 2100 Res : Iir; 2101 begin 2102 P := Str'First; 2103 2104 Grt.Fcvt.Format_Image (Str, P, Interfaces.IEEE_Float_64 (Val)); 2105 2106 Id := Create_String8; 2107 for I in 1 .. P loop 2108 Append_String8_Char (Str (I)); 2109 end loop; 2110 Res := Build_String (Id, Int32 (P), Orig); 2111 -- FIXME: this is not correct since the type is *not* constrained. 2112 Set_Type (Res, Create_Unidim_Array_By_Length 2113 (Get_Type (Orig), Int64 (P), Orig)); 2114 return Res; 2115 end Eval_Floating_Image; 2116 2117 function Eval_Enumeration_Image (Lit : Iir; Orig : Iir) return Iir 2118 is 2119 use Str_Table; 2120 Name : constant String := Image_Identifier (Lit); 2121 Image_Id : constant String8_Id := Str_Table.Create_String8; 2122 begin 2123 Append_String8_String (Name); 2124 return Build_String (Image_Id, Name'Length, Orig); 2125 end Eval_Enumeration_Image; 2126 2127 function Build_Enumeration_Value (Val : String; Enum, Expr : Iir) return Iir 2128 is 2129 List : constant Iir_Flist := Get_Enumeration_Literal_List (Enum); 2130 Value : String (Val'range); 2131 Id : Name_Id; 2132 Res : Iir; 2133 begin 2134 if Val'Length = 3 2135 and then Val (Val'First) = ''' and then Val (Val'Last) = ''' 2136 then 2137 -- A single character. 2138 Id := Get_Identifier (Val (Val'First + 1)); 2139 else 2140 for I in Val'range loop 2141 Value (I) := Ada.Characters.Handling.To_Lower (Val (I)); 2142 end loop; 2143 Id := Get_Identifier (Value); 2144 end if; 2145 Res := Find_Name_In_Flist (List, Id); 2146 if Res /= Null_Iir then 2147 return Build_Constant (Res, Expr); 2148 else 2149 Warning_Msg_Sem (Warnid_Runtime_Error, +Expr, 2150 "value %i not in enumeration %n", (+Id, +Enum)); 2151 return Build_Overflow (Expr); 2152 end if; 2153 end Build_Enumeration_Value; 2154 2155 function Eval_Physical_Image (Phys, Expr: Iir) return Iir 2156 is 2157 -- Reduces to the base unit (e.g. femtoseconds). 2158 Value : constant String := Int64'Image (Get_Physical_Value (Phys)); 2159 Unit : constant Iir := 2160 Get_Primary_Unit (Get_Base_Type (Get_Type (Phys))); 2161 UnitName : constant String := Image_Identifier (Unit); 2162 Image_Id : constant String8_Id := Str_Table.Create_String8; 2163 Length : Nat32 := Value'Length + UnitName'Length + 1; 2164 begin 2165 for I in Value'range loop 2166 -- Suppress the Ada +ve integer'image leading space 2167 if I > Value'first or else Value (I) /= ' ' then 2168 Str_Table.Append_String8_Char (Value (I)); 2169 else 2170 Length := Length - 1; 2171 end if; 2172 end loop; 2173 Str_Table.Append_String8_Char (' '); 2174 for I in UnitName'range loop 2175 Str_Table.Append_String8_Char (UnitName (I)); 2176 end loop; 2177 2178 return Build_String (Image_Id, Length, Expr); 2179 end Eval_Physical_Image; 2180 2181 function Build_Physical_Value (Val: String; Phys_Type, Expr: Iir) return Iir 2182 is 2183 UnitName : String (Val'range); 2184 Mult : Int64; 2185 Sep : Natural; 2186 Found_Unit : Boolean := false; 2187 Found_Real : Boolean := false; 2188 Unit : Iir; 2189 begin 2190 -- Separate string into numeric value and make lowercase unit. 2191 for I in reverse Val'range loop 2192 UnitName (I) := Ada.Characters.Handling.To_Lower (Val (I)); 2193 if Vhdl.Scanner.Is_Whitespace (Val (I)) and Found_Unit then 2194 Sep := I; 2195 exit; 2196 else 2197 Found_Unit := true; 2198 end if; 2199 end loop; 2200 2201 -- Unit name is UnitName(Sep+1..Unit'Last) 2202 for I in Val'First .. Sep loop 2203 if Val (I) = '.' then 2204 Found_Real := true; 2205 end if; 2206 end loop; 2207 2208 -- Chain down the units looking for matching one 2209 Unit := Get_Primary_Unit (Phys_Type); 2210 while Unit /= Null_Iir loop 2211 exit when (UnitName (Sep + 1 .. UnitName'Last) 2212 = Image_Identifier (Unit)); 2213 Unit := Get_Chain (Unit); 2214 end loop; 2215 if Unit = Null_Iir then 2216 Warning_Msg_Sem (Warnid_Runtime_Error, +Expr, 2217 "Unit """ & UnitName (Sep + 1 .. UnitName'Last) 2218 & """ not in physical type"); 2219 return Build_Overflow (Expr); 2220 end if; 2221 2222 Mult := Get_Value (Get_Physical_Literal (Unit)); 2223 if Found_Real then 2224 return Build_Physical 2225 (Int64 (Fp64'Value (Val (Val'First .. Sep)) 2226 * Fp64 (Mult)), 2227 Expr); 2228 else 2229 return Build_Physical 2230 (Int64'Value (Val (Val'First .. Sep)) * Mult, Expr); 2231 end if; 2232 end Build_Physical_Value; 2233 2234 function Eval_Enum_To_String (Lit : Iir; Orig : Iir) return Iir 2235 is 2236 use Str_Table; 2237 Id : constant Name_Id := Get_Identifier (Lit); 2238 Image_Id : constant String8_Id := Str_Table.Create_String8; 2239 Len : Natural; 2240 begin 2241 if Get_Base_Type (Get_Type (Lit)) = Character_Type_Definition then 2242 -- LRM08 5.7 String representations 2243 -- - For a given value of type CHARACTER, the string representation 2244 -- contains one element that is the given value. 2245 Append_String8 (Nat8 (Get_Enum_Pos (Lit))); 2246 Len := 1; 2247 elsif Is_Character (Id) then 2248 -- LRM08 5.7 String representations 2249 -- - For a given value of an enumeration type other than CHARACTER, 2250 -- if the value is a character literal, the string representation 2251 -- contains a single element that is the character literal; [...] 2252 Append_String8_Char (Get_Character (Id)); 2253 Len := 1; 2254 else 2255 -- LRM08 5.7 String representations 2256 -- - [...] otherwise, the string representation is the sequence of 2257 -- characters in the identifier that is the given value. 2258 declare 2259 Img : constant String := Image (Id); 2260 begin 2261 if Img (Img'First) /= '\' then 2262 Append_String8_String (Img); 2263 Len := Img'Length; 2264 else 2265 declare 2266 Skip : Boolean; 2267 C : Character; 2268 begin 2269 Len := 0; 2270 Skip := False; 2271 for I in Img'First + 1 .. Img'Last - 1 loop 2272 if Skip then 2273 Skip := False; 2274 else 2275 C := Img (I); 2276 Append_String8_Char (C); 2277 Skip := C = '\'; 2278 Len := Len + 1; 2279 end if; 2280 end loop; 2281 end; 2282 end if; 2283 end; 2284 end if; 2285 return Build_String (Image_Id, Nat32 (Len), Orig); 2286 end Eval_Enum_To_String; 2287 2288 function Eval_Incdec (Expr : Iir; N : Int64; Origin : Iir) return Iir 2289 is 2290 P : Int64; 2291 begin 2292 case Get_Kind (Expr) is 2293 when Iir_Kind_Integer_Literal => 2294 return Build_Integer (Get_Value (Expr) + N, Origin); 2295 when Iir_Kind_Enumeration_Literal => 2296 P := Int64 (Get_Enum_Pos (Expr)) + N; 2297 if P < 0 2298 or else (P >= Int64 2299 (Get_Nbr_Elements 2300 (Get_Enumeration_Literal_List 2301 (Get_Base_Type (Get_Type (Expr)))))) 2302 then 2303 Warning_Msg_Sem (Warnid_Runtime_Error, +Expr, 2304 "static constant violates bounds"); 2305 return Build_Overflow (Origin); 2306 else 2307 return Build_Enumeration (Iir_Index32 (P), Origin); 2308 end if; 2309 when Iir_Kind_Physical_Int_Literal 2310 | Iir_Kind_Unit_Declaration => 2311 return Build_Physical (Get_Physical_Value (Expr) + N, Origin); 2312 when others => 2313 Error_Kind ("eval_incdec", Expr); 2314 end case; 2315 end Eval_Incdec; 2316 2317 function Convert_Range (Rng : Iir; Res_Type : Iir; Loc : Iir) return Iir 2318 is 2319 Res_Btype : Iir; 2320 2321 function Create_Bound (Val : Iir) return Iir 2322 is 2323 R : Iir; 2324 begin 2325 R := Create_Iir (Iir_Kind_Integer_Literal); 2326 Location_Copy (R, Loc); 2327 Set_Value (R, Get_Value (Val)); 2328 Set_Type (R, Res_Btype); 2329 Set_Expr_Staticness (R, Locally); 2330 return R; 2331 end Create_Bound; 2332 2333 Res : Iir; 2334 Lit : Iir; 2335 begin 2336 Res_Btype := Get_Base_Type (Res_Type); 2337 Res := Create_Iir (Iir_Kind_Range_Expression); 2338 Location_Copy (Res, Loc); 2339 Set_Type (Res, Res_Btype); 2340 Lit := Create_Bound (Get_Left_Limit (Rng)); 2341 Set_Left_Limit (Res, Lit); 2342 Set_Left_Limit_Expr (Res, Lit); 2343 Lit := Create_Bound (Get_Right_Limit (Rng)); 2344 Set_Right_Limit (Res, Lit); 2345 Set_Right_Limit_Expr (Res, Lit); 2346 Set_Direction (Res, Get_Direction (Rng)); 2347 Set_Expr_Staticness (Res, Locally); 2348 return Res; 2349 end Convert_Range; 2350 2351 function Eval_Array_Type_Conversion (Conv : Iir; Val : Iir) return Iir 2352 is 2353 Conv_Type : constant Iir := Get_Type (Conv); 2354 Val_Type : constant Iir := Get_Type (Val); 2355 Conv_Index_Type : constant Iir := Get_Index_Type (Conv_Type, 0); 2356 Val_Index_Type : constant Iir := Get_Index_Type (Val_Type, 0); 2357 Index_Type : Iir; 2358 Res_Type : Iir; 2359 Res : Iir; 2360 Rng : Iir; 2361 begin 2362 -- The expression is either a simple aggregate or a (bit) string. 2363 Res := Build_Constant (Val, Conv); 2364 if Get_Constraint_State (Conv_Type) = Fully_Constrained then 2365 Set_Type (Res, Conv_Type); 2366 if not Eval_Is_In_Bound (Val, Conv_Type, True) then 2367 Warning_Msg_Sem (Warnid_Runtime_Error, +Conv, 2368 "non matching length in type conversion"); 2369 return Build_Overflow (Conv); 2370 end if; 2371 return Res; 2372 else 2373 if Get_Base_Type (Conv_Index_Type) = Get_Base_Type (Val_Index_Type) 2374 then 2375 Index_Type := Val_Index_Type; 2376 else 2377 -- Convert the index range. 2378 -- It is an integer type. 2379 Rng := Convert_Range (Get_Range_Constraint (Val_Index_Type), 2380 Conv_Index_Type, Conv); 2381 Index_Type := Create_Iir (Iir_Kind_Integer_Subtype_Definition); 2382 Location_Copy (Index_Type, Conv); 2383 Set_Range_Constraint (Index_Type, Rng); 2384 Set_Parent_Type (Index_Type, Conv_Index_Type); 2385 Set_Type_Staticness (Index_Type, Locally); 2386 end if; 2387 Res_Type := Create_Unidim_Array_From_Index 2388 (Get_Base_Type (Conv_Type), Index_Type, Conv); 2389 Set_Type (Res, Res_Type); 2390 Set_Type_Conversion_Subtype (Conv, Res_Type); 2391 return Res; 2392 end if; 2393 end Eval_Array_Type_Conversion; 2394 2395 function Eval_Type_Conversion (Conv : Iir) return Iir 2396 is 2397 Expr : constant Iir := Get_Expression (Conv); 2398 Val : Iir; 2399 Val_Type : Iir; 2400 Conv_Type : Iir; 2401 Res : Iir; 2402 begin 2403 Val := Eval_Static_Expr (Expr); 2404 Val_Type := Get_Base_Type (Get_Type (Val)); 2405 Conv_Type := Get_Base_Type (Get_Type (Conv)); 2406 if Conv_Type = Val_Type then 2407 Res := Build_Constant (Val, Conv); 2408 else 2409 case Get_Kind (Conv_Type) is 2410 when Iir_Kind_Integer_Type_Definition => 2411 case Get_Kind (Val_Type) is 2412 when Iir_Kind_Integer_Type_Definition => 2413 Res := Build_Integer (Get_Value (Val), Conv); 2414 when Iir_Kind_Floating_Type_Definition => 2415 Res := Build_Integer 2416 (Int64 (Get_Fp_Value (Val)), Conv); 2417 when others => 2418 Error_Kind ("eval_type_conversion(1)", Val_Type); 2419 end case; 2420 when Iir_Kind_Floating_Type_Definition => 2421 case Get_Kind (Val_Type) is 2422 when Iir_Kind_Integer_Type_Definition => 2423 Res := Build_Floating (Fp64 (Get_Value (Val)), Conv); 2424 when Iir_Kind_Floating_Type_Definition => 2425 Res := Build_Floating (Get_Fp_Value (Val), Conv); 2426 when others => 2427 Error_Kind ("eval_type_conversion(2)", Val_Type); 2428 end case; 2429 when Iir_Kind_Array_Type_Definition => 2430 -- Not a scalar, do not check bounds. 2431 return Eval_Array_Type_Conversion (Conv, Val); 2432 when others => 2433 Error_Kind ("eval_type_conversion(3)", Conv_Type); 2434 end case; 2435 end if; 2436 if not Eval_Is_In_Bound (Res, Get_Type (Conv), True) then 2437 Warning_Msg_Sem (Warnid_Runtime_Error, +Conv, 2438 "result of conversion out of bounds"); 2439 Free_Eval_Static_Expr (Res, Conv); 2440 Res := Build_Overflow (Conv); 2441 end if; 2442 return Res; 2443 end Eval_Type_Conversion; 2444 2445 function Eval_Physical_Literal (Expr : Iir) return Iir 2446 is 2447 Val : Iir; 2448 begin 2449 case Get_Kind (Expr) is 2450 when Iir_Kind_Physical_Fp_Literal => 2451 Val := Expr; 2452 when Iir_Kind_Physical_Int_Literal => 2453 -- Create a copy even if the literal has the primary unit. This 2454 -- is required for ownership rule. 2455 Val := Expr; 2456 when Iir_Kind_Unit_Declaration => 2457 Val := Expr; 2458 when Iir_Kinds_Denoting_Name => 2459 Val := Get_Named_Entity (Expr); 2460 pragma Assert (Get_Kind (Val) = Iir_Kind_Unit_Declaration); 2461 when others => 2462 Error_Kind ("eval_physical_literal", Expr); 2463 end case; 2464 return Build_Physical (Get_Physical_Value (Val), Expr); 2465 end Eval_Physical_Literal; 2466 2467 function Eval_Value_Attribute 2468 (Value : String; Atype : Iir; Orig : Iir) return Iir 2469 is 2470 Base_Type : constant Iir := Get_Base_Type (Atype); 2471 First, Last : Positive; 2472 begin 2473 -- LRM93 14.1 Predefined attributes. 2474 -- Leading and trailing whitespace are ignored. 2475 First := Value'First; 2476 Last := Value'Last; 2477 while First <= Last loop 2478 exit when not Vhdl.Scanner.Is_Whitespace (Value (First)); 2479 First := First + 1; 2480 end loop; 2481 while Last >= First loop 2482 exit when not Vhdl.Scanner.Is_Whitespace (Value (Last)); 2483 Last := Last - 1; 2484 end loop; 2485 2486 declare 2487 Value1 : String renames Value (First .. Last); 2488 begin 2489 case Get_Kind (Base_Type) is 2490 when Iir_Kind_Integer_Type_Definition => 2491 return Build_Discrete (Int64'Value (Value1), Orig); 2492 when Iir_Kind_Enumeration_Type_Definition => 2493 return Build_Enumeration_Value (Value1, Base_Type, Orig); 2494 when Iir_Kind_Floating_Type_Definition => 2495 return Build_Floating (Fp64'value (Value1), Orig); 2496 when Iir_Kind_Physical_Type_Definition => 2497 return Build_Physical_Value (Value1, Base_Type, Orig); 2498 when others => 2499 Error_Kind ("eval_value_attribute", Base_Type); 2500 end case; 2501 end; 2502 end Eval_Value_Attribute; 2503 2504 -- Be sure that all expressions within an aggregate have been evaluated. 2505 procedure Eval_Aggregate (Aggr : Iir) 2506 is 2507 Assoc : Iir; 2508 Expr : Iir; 2509 begin 2510 Assoc := Get_Association_Choices_Chain (Aggr); 2511 while Is_Valid (Assoc) loop 2512 case Iir_Kinds_Choice (Get_Kind (Assoc)) is 2513 when Iir_Kind_Choice_By_None => 2514 null; 2515 when Iir_Kind_Choice_By_Name => 2516 null; 2517 when Iir_Kind_Choice_By_Range => 2518 Set_Choice_Range 2519 (Assoc, Eval_Range (Get_Choice_Range (Assoc))); 2520 when Iir_Kind_Choice_By_Expression => 2521 Set_Choice_Expression 2522 (Assoc, Eval_Expr (Get_Choice_Expression (Assoc))); 2523 when Iir_Kind_Choice_By_Others => 2524 null; 2525 end case; 2526 if not Get_Same_Alternative_Flag (Assoc) then 2527 Expr := Get_Associated_Expr (Assoc); 2528 end if; 2529 if Get_Kind (Expr) = Iir_Kind_Aggregate then 2530 Eval_Aggregate (Expr); 2531 end if; 2532 Assoc := Get_Chain (Assoc); 2533 end loop; 2534 end Eval_Aggregate; 2535 2536 function Eval_Selected_Element (Expr : Iir) return Iir 2537 is 2538 Selected_El : constant Iir := Get_Named_Entity (Expr); 2539 El_Pos : constant Iir_Index32 := Get_Element_Position (Selected_El); 2540 Prefix : Iir; 2541 Cur_Pos : Iir_Index32; 2542 Assoc : Iir; 2543 Assoc_Expr : Iir; 2544 Res : Iir; 2545 begin 2546 Prefix := Get_Prefix (Expr); 2547 Prefix := Eval_Static_Expr (Prefix); 2548 if Get_Kind (Prefix) = Iir_Kind_Overflow_Literal then 2549 return Build_Overflow (Expr, Get_Type (Expr)); 2550 end if; 2551 2552 pragma Assert (Get_Kind (Prefix) = Iir_Kind_Aggregate); 2553 Assoc := Get_Association_Choices_Chain (Prefix); 2554 Cur_Pos := 0; 2555 Assoc_Expr := Null_Iir; 2556 loop 2557 if not Get_Same_Alternative_Flag (Assoc) then 2558 Assoc_Expr := Assoc; 2559 end if; 2560 case Iir_Kinds_Record_Choice (Get_Kind (Assoc)) is 2561 when Iir_Kind_Choice_By_None => 2562 exit when Cur_Pos = El_Pos; 2563 Cur_Pos := Cur_Pos + 1; 2564 when Iir_Kind_Choice_By_Name => 2565 declare 2566 Choice : constant Iir := Get_Choice_Name (Assoc); 2567 begin 2568 exit when Get_Element_Position (Get_Named_Entity (Choice)) 2569 = El_Pos; 2570 end; 2571 when Iir_Kind_Choice_By_Others => 2572 exit; 2573 end case; 2574 Assoc := Get_Chain (Assoc); 2575 end loop; 2576 2577 -- Eval element and save it. 2578 Res := Eval_Expr_Keep_Orig (Get_Associated_Expr (Assoc_Expr), True); 2579 Set_Associated_Expr (Assoc_Expr, Res); 2580 return Res; 2581 end Eval_Selected_Element; 2582 2583 function Eval_Indexed_Aggregate (Prefix : Iir; Expr : Iir) return Iir 2584 is 2585 Indexes : constant Iir_Flist := Get_Index_List (Expr); 2586 Prefix_Type : constant Iir := Get_Type (Prefix); 2587 Indexes_Type : constant Iir_Flist := 2588 Get_Index_Subtype_List (Prefix_Type); 2589 Idx : Iir; 2590 Assoc : Iir; 2591 Assoc_Expr : Iir; 2592 Aggr_Bounds : Iir; 2593 Aggr : Iir; 2594 Cur_Pos : Int64; 2595 Res : Iir; 2596 begin 2597 Aggr := Prefix; 2598 2599 for Dim in Flist_First .. Flist_Last (Indexes) loop 2600 Idx := Get_Nth_Element (Indexes, Dim); 2601 2602 -- Find Idx in choices. 2603 Assoc := Get_Association_Choices_Chain (Aggr); 2604 Aggr_Bounds := Eval_Static_Range 2605 (Get_Nth_Element (Indexes_Type, Dim)); 2606 Cur_Pos := Eval_Pos (Eval_Discrete_Range_Left (Aggr_Bounds)); 2607 Assoc_Expr := Null_Iir; 2608 loop 2609 if not Get_Same_Alternative_Flag (Assoc) then 2610 Assoc_Expr := Assoc; 2611 end if; 2612 case Get_Kind (Assoc) is 2613 when Iir_Kind_Choice_By_None => 2614 exit when Cur_Pos = Eval_Pos (Idx); 2615 case Get_Direction (Aggr_Bounds) is 2616 when Dir_To => 2617 Cur_Pos := Cur_Pos + 1; 2618 when Dir_Downto => 2619 Cur_Pos := Cur_Pos - 1; 2620 end case; 2621 when Iir_Kind_Choice_By_Expression => 2622 exit when Eval_Is_Eq (Get_Choice_Expression (Assoc), Idx); 2623 when Iir_Kind_Choice_By_Range => 2624 declare 2625 Rng : Iir; 2626 begin 2627 Rng := Get_Choice_Range (Assoc); 2628 Rng := Eval_Static_Range (Rng); 2629 exit when Eval_Int_In_Range (Eval_Pos (Idx), Rng); 2630 end; 2631 when Iir_Kind_Choice_By_Others => 2632 exit; 2633 when others => 2634 raise Internal_Error; 2635 end case; 2636 Assoc := Get_Chain (Assoc); 2637 end loop; 2638 Aggr := Get_Associated_Expr (Assoc_Expr); 2639 end loop; 2640 2641 -- Eval element and save it. 2642 Res := Eval_Expr_Keep_Orig (Aggr, True); 2643 Set_Associated_Expr (Assoc_Expr, Res); 2644 2645 return Res; 2646 end Eval_Indexed_Aggregate; 2647 2648 function Eval_Indexed_String_Literal8 (Str : Iir; Expr : Iir) return Iir 2649 is 2650 Str_Type : constant Iir := Get_Type (Str); 2651 2652 Index_Type : constant Iir := Get_Index_Type (Str_Type, 0); 2653 Index_Range : constant Iir := Eval_Static_Range (Index_Type); 2654 2655 Indexes : constant Iir_Flist := Get_Index_List (Expr); 2656 2657 Id : constant String8_Id := Get_String8_Id (Str); 2658 2659 Idx : Iir; 2660 Pos : Iir_Index32; 2661 begin 2662 Idx := Eval_Static_Expr (Get_Nth_Element (Indexes, 0)); 2663 Pos := Eval_Pos_In_Range (Index_Range, Idx); 2664 2665 return Build_Enumeration_Constant 2666 (Iir_Index32 (Str_Table.Element_String8 (Id, Int32 (Pos + 1))), Expr); 2667 end Eval_Indexed_String_Literal8; 2668 2669 function Eval_Indexed_Simple_Aggregate (Aggr : Iir; Expr : Iir) return Iir 2670 is 2671 Aggr_Type : constant Iir := Get_Type (Aggr); 2672 2673 Index_Type : constant Iir := Get_Index_Type (Aggr_Type, 0); 2674 Index_Range : constant Iir := Eval_Static_Range (Index_Type); 2675 2676 Indexes : constant Iir_Flist := Get_Index_List (Expr); 2677 2678 Idx : Iir; 2679 Pos : Iir_Index32; 2680 El : Iir; 2681 begin 2682 Idx := Eval_Static_Expr (Get_Nth_Element (Indexes, 0)); 2683 Set_Nth_Element (Indexes, 0, Idx); 2684 Pos := Eval_Pos_In_Range (Index_Range, Idx); 2685 2686 El := Get_Nth_Element (Get_Simple_Aggregate_List (Aggr), Natural (Pos)); 2687 return Build_Constant (El, Expr); 2688 end Eval_Indexed_Simple_Aggregate; 2689 2690 function Eval_Indexed_Name (Expr : Iir) return Iir 2691 is 2692 Prefix : Iir; 2693 begin 2694 Prefix := Get_Prefix (Expr); 2695 Prefix := Eval_Static_Expr (Prefix); 2696 2697 declare 2698 Prefix_Type : constant Iir := Get_Type (Prefix); 2699 Indexes_Type : constant Iir_Flist := 2700 Get_Index_Subtype_List (Prefix_Type); 2701 Indexes_List : constant Iir_Flist := Get_Index_List (Expr); 2702 Prefix_Index : Iir; 2703 Index : Iir; 2704 begin 2705 for I in Flist_First .. Flist_Last (Indexes_Type) loop 2706 Prefix_Index := Get_Nth_Element (Indexes_Type, I); 2707 2708 -- Eval index. 2709 Index := Get_Nth_Element (Indexes_List, I); 2710 Index := Eval_Static_Expr (Index); 2711 Set_Nth_Element (Indexes_List, I, Index); 2712 2713 -- Return overflow if out of range. 2714 if not Eval_Is_In_Bound (Index, Prefix_Index) then 2715 return Build_Overflow (Expr, Get_Type (Expr)); 2716 end if; 2717 end loop; 2718 end; 2719 2720 case Get_Kind (Prefix) is 2721 when Iir_Kind_Aggregate => 2722 return Eval_Indexed_Aggregate (Prefix, Expr); 2723 when Iir_Kind_String_Literal8 => 2724 return Eval_Indexed_String_Literal8 (Prefix, Expr); 2725 when Iir_Kind_Simple_Aggregate => 2726 return Eval_Indexed_Simple_Aggregate (Prefix, Expr); 2727 when Iir_Kind_Overflow_Literal => 2728 return Build_Overflow (Expr, Get_Type (Expr)); 2729 when others => 2730 Error_Kind ("eval_indexed_name", Prefix); 2731 end case; 2732 end Eval_Indexed_Name; 2733 2734 function Eval_Indexed_Aggregate_By_Offset 2735 (Aggr : Iir; Off : Iir_Index32; Dim : Natural := 0) return Iir 2736 is 2737 Prefix_Type : constant Iir := Get_Type (Aggr); 2738 Indexes_Type : constant Iir_Flist := 2739 Get_Index_Subtype_List (Prefix_Type); 2740 Assoc : Iir; 2741 Assoc_Expr : Iir; 2742 Assoc_Len : Iir_Index32; 2743 Aggr_Bounds : Iir; 2744 Cur_Off : Iir_Index32; 2745 Res : Iir; 2746 Left_Pos : Int64; 2747 Assoc_Pos : Int64; 2748 begin 2749 Aggr_Bounds := Eval_Static_Range (Get_Nth_Element (Indexes_Type, Dim)); 2750 Left_Pos := Eval_Pos (Eval_Discrete_Range_Left (Aggr_Bounds)); 2751 2752 Cur_Off := 0; 2753 Assoc := Get_Association_Choices_Chain (Aggr); 2754 Assoc_Expr := Null_Iir; 2755 while Assoc /= Null_Iir loop 2756 if not Get_Same_Alternative_Flag (Assoc) then 2757 Assoc_Expr := Assoc; 2758 end if; 2759 case Get_Kind (Assoc) is 2760 when Iir_Kind_Choice_By_None => 2761 if Get_Element_Type_Flag (Assoc) then 2762 if Off = Cur_Off then 2763 return Get_Associated_Expr (Assoc); 2764 end if; 2765 Assoc_Len := 1; 2766 else 2767 Res := Get_Associated_Expr (Assoc); 2768 Assoc_Len := Iir_Index32 2769 (Eval_Discrete_Range_Length 2770 (Get_Index_Type (Get_Type (Res), 0))); 2771 if Off >= Cur_Off and then Off < Cur_Off + Assoc_Len then 2772 return Eval_Indexed_Name_By_Offset (Res, Off - Cur_Off); 2773 end if; 2774 end if; 2775 Cur_Off := Cur_Off + Assoc_Len; 2776 when Iir_Kind_Choice_By_Expression => 2777 Assoc_Pos := Eval_Pos (Get_Choice_Expression (Assoc)); 2778 case Get_Direction (Aggr_Bounds) is 2779 when Dir_To => 2780 Cur_Off := Iir_Index32 (Assoc_Pos - Left_Pos); 2781 when Dir_Downto => 2782 Cur_Off := Iir_Index32 (Left_Pos - Assoc_Pos); 2783 end case; 2784 if Cur_Off = Off then 2785 return Get_Associated_Expr (Assoc); 2786 end if; 2787 when Iir_Kind_Choice_By_Range => 2788 declare 2789 Rng : Iir; 2790 Left : Int64; 2791 Right : Int64; 2792 Hi, Lo : Int64; 2793 Lo_Off, Hi_Off : Iir_Index32; 2794 begin 2795 Rng := Eval_Range (Get_Choice_Range (Assoc)); 2796 Set_Choice_Range (Assoc, Rng); 2797 2798 Left := Eval_Pos (Get_Left_Limit (Rng)); 2799 Right := Eval_Pos (Get_Right_Limit (Rng)); 2800 case Get_Direction (Rng) is 2801 when Dir_To => 2802 Lo := Left; 2803 Hi := Right; 2804 when Dir_Downto => 2805 Lo := Right; 2806 Hi := Left; 2807 end case; 2808 case Get_Direction (Aggr_Bounds) is 2809 when Dir_To => 2810 Lo_Off := Iir_Index32 (Lo - Left_Pos); 2811 Hi_Off := Iir_Index32 (Hi - Left_Pos); 2812 when Dir_Downto => 2813 Lo_Off := Iir_Index32 (Left_Pos - Lo); 2814 Hi_Off := Iir_Index32 (Left_Pos - Hi); 2815 end case; 2816 if Off >= Lo_Off and then Off <= Hi_Off then 2817 Res := Get_Associated_Expr (Assoc); 2818 if Get_Element_Type_Flag (Assoc) then 2819 return Res; 2820 else 2821 return Eval_Indexed_Name_By_Offset 2822 (Res, Off - Lo_Off); 2823 end if; 2824 end if; 2825 end; 2826 when Iir_Kind_Choice_By_Others => 2827 return Get_Associated_Expr (Assoc_Expr); 2828 when others => 2829 raise Internal_Error; 2830 end case; 2831 Assoc := Get_Chain (Assoc); 2832 end loop; 2833 raise Internal_Error; 2834 end Eval_Indexed_Aggregate_By_Offset; 2835 2836 function Eval_Indexed_Name_By_Offset (Prefix : Iir; Off : Iir_Index32) 2837 return Iir 2838 is 2839 begin 2840 case Get_Kind (Prefix) is 2841 when Iir_Kind_Aggregate => 2842 return Eval_Indexed_Aggregate_By_Offset (Prefix, Off); 2843 when Iir_Kind_String_Literal8 => 2844 declare 2845 Id : constant String8_Id := Get_String8_Id (Prefix); 2846 El_Type : constant Iir := 2847 Get_Element_Subtype (Get_Type (Prefix)); 2848 Enums : constant Iir_Flist := 2849 Get_Enumeration_Literal_List (El_Type); 2850 Lit : Pos32; 2851 begin 2852 Lit := Str_Table.Element_String8 (Id, Int32 (Off + 1)); 2853 return Get_Nth_Element (Enums, Natural (Lit)); 2854 end; 2855 when Iir_Kind_Simple_Aggregate => 2856 return Get_Nth_Element (Get_Simple_Aggregate_List (Prefix), 2857 Natural (Off)); 2858 when others => 2859 Error_Kind ("eval_indexed_name_by_offset", Prefix); 2860 end case; 2861 end Eval_Indexed_Name_By_Offset; 2862 2863 function Eval_Static_Expr (Expr: Iir) return Iir 2864 is 2865 Res : Iir; 2866 Val : Iir; 2867 begin 2868 case Get_Kind (Expr) is 2869 when Iir_Kinds_Denoting_Name => 2870 return Eval_Static_Expr (Get_Named_Entity (Expr)); 2871 2872 when Iir_Kind_Integer_Literal 2873 | Iir_Kind_Enumeration_Literal 2874 | Iir_Kind_Floating_Point_Literal 2875 | Iir_Kind_String_Literal8 2876 | Iir_Kind_Overflow_Literal 2877 | Iir_Kind_Physical_Int_Literal 2878 | Iir_Kind_Physical_Fp_Literal => 2879 return Expr; 2880 when Iir_Kind_Constant_Declaration => 2881 Val := Eval_Static_Expr (Get_Default_Value (Expr)); 2882 -- Type of the expression should be type of the constant 2883 -- declaration at least in case of array subtype. 2884 -- If the constant is declared as an unconstrained array, get type 2885 -- from the default value. 2886 -- FIXME: handle this during semantisation of the declaration: 2887 -- add an implicit subtype conversion node ? 2888 -- FIXME: this currently creates a node at each evalation. 2889 if Get_Kind (Get_Type (Val)) = Iir_Kind_Array_Type_Definition then 2890 Res := Build_Constant (Val, Expr); 2891 Set_Type (Res, Get_Type (Val)); 2892 return Res; 2893 else 2894 return Val; 2895 end if; 2896 when Iir_Kind_Object_Alias_Declaration => 2897 return Eval_Static_Expr (Get_Name (Expr)); 2898 when Iir_Kind_Unit_Declaration => 2899 return Get_Physical_Literal (Expr); 2900 when Iir_Kind_Simple_Aggregate => 2901 return Expr; 2902 when Iir_Kind_Aggregate => 2903 Eval_Aggregate (Expr); 2904 return Expr; 2905 2906 when Iir_Kind_Selected_Element => 2907 return Eval_Selected_Element (Expr); 2908 when Iir_Kind_Indexed_Name => 2909 return Eval_Indexed_Name (Expr); 2910 2911 when Iir_Kind_Parenthesis_Expression => 2912 return Eval_Static_Expr (Get_Expression (Expr)); 2913 when Iir_Kind_Qualified_Expression => 2914 return Eval_Static_Expr (Get_Expression (Expr)); 2915 when Iir_Kind_Type_Conversion => 2916 return Eval_Type_Conversion (Expr); 2917 2918 when Iir_Kinds_Monadic_Operator => 2919 declare 2920 Operand : Iir; 2921 begin 2922 Operand := Eval_Static_Expr (Get_Operand (Expr)); 2923 return Eval_Monadic_Operator (Expr, Operand); 2924 end; 2925 when Iir_Kinds_Dyadic_Operator => 2926 declare 2927 Imp : constant Iir := Get_Implementation (Expr); 2928 Left : constant Iir := Get_Left (Expr); 2929 Right : constant Iir := Get_Right (Expr); 2930 Left_Val, Right_Val : Iir; 2931 Res : Iir; 2932 begin 2933 if (Get_Implicit_Definition (Imp) 2934 in Iir_Predefined_Concat_Functions) 2935 then 2936 return Eval_Concatenation ((1 => Expr)); 2937 else 2938 Left_Val := Eval_Static_Expr (Left); 2939 Right_Val := Eval_Static_Expr (Right); 2940 2941 Res := Eval_Dyadic_Operator (Expr, Imp, Left_Val, Right_Val); 2942 2943 Free_Eval_Static_Expr (Left_Val, Left); 2944 Free_Eval_Static_Expr (Right_Val, Right); 2945 2946 return Res; 2947 end if; 2948 end; 2949 2950 when Iir_Kind_Attribute_Name => 2951 -- An attribute name designates an attribute value. 2952 declare 2953 Attr_Expr : constant Iir := 2954 Get_Attribute_Name_Expression (Expr); 2955 Val : Iir; 2956 begin 2957 Val := Eval_Static_Expr (Attr_Expr); 2958 -- FIXME: see constant_declaration. 2959 -- Currently, this avoids weird nodes, such as a string literal 2960 -- whose type is an unconstrained array type. 2961 Res := Build_Constant (Val, Expr); 2962 Set_Type (Res, Get_Type (Val)); 2963 return Res; 2964 end; 2965 2966 when Iir_Kind_Pos_Attribute => 2967 declare 2968 Param : constant Iir := Get_Parameter (Expr); 2969 Val : Iir; 2970 Res : Iir; 2971 begin 2972 Val := Eval_Static_Expr (Param); 2973 -- FIXME: check bounds, handle overflow. 2974 Res := Build_Integer (Eval_Pos (Val), Expr); 2975 Free_Eval_Static_Expr (Val, Param); 2976 return Res; 2977 end; 2978 when Iir_Kind_Val_Attribute => 2979 declare 2980 Expr_Type : constant Iir := Get_Type (Expr); 2981 Val_Expr : Iir; 2982 Val : Int64; 2983 begin 2984 Val_Expr := Eval_Static_Expr (Get_Parameter (Expr)); 2985 Val := Eval_Pos (Val_Expr); 2986 -- Note: the type of 'val is a base type. 2987 -- FIXME: handle VHDL93 restrictions. 2988 if Get_Kind (Expr_Type) = Iir_Kind_Enumeration_Type_Definition 2989 and then 2990 not Eval_Int_In_Range (Val, Get_Range_Constraint (Expr_Type)) 2991 then 2992 Warning_Msg_Sem (Warnid_Runtime_Error, +Expr, 2993 "static argument out of the type range"); 2994 return Build_Overflow (Expr); 2995 end if; 2996 if Get_Kind (Get_Base_Type (Get_Type (Expr))) 2997 = Iir_Kind_Physical_Type_Definition 2998 then 2999 return Build_Physical (Val, Expr); 3000 else 3001 return Build_Discrete (Val, Expr); 3002 end if; 3003 end; 3004 when Iir_Kind_Image_Attribute => 3005 declare 3006 Param : Iir; 3007 Param_Type : Iir; 3008 begin 3009 Param := Get_Parameter (Expr); 3010 Param := Eval_Static_Expr (Param); 3011 Set_Parameter (Expr, Param); 3012 3013 -- Special case for overflow. 3014 if not Eval_Is_In_Bound (Param, Get_Type (Get_Prefix (Expr))) 3015 then 3016 return Build_Overflow (Expr); 3017 end if; 3018 3019 Param_Type := Get_Base_Type (Get_Type (Param)); 3020 case Get_Kind (Param_Type) is 3021 when Iir_Kind_Integer_Type_Definition => 3022 return Eval_Integer_Image (Get_Value (Param), Expr); 3023 when Iir_Kind_Floating_Type_Definition => 3024 return Eval_Floating_Image (Get_Fp_Value (Param), Expr); 3025 when Iir_Kind_Enumeration_Type_Definition => 3026 return Eval_Enumeration_Image (Param, Expr); 3027 when Iir_Kind_Physical_Type_Definition => 3028 return Eval_Physical_Image (Param, Expr); 3029 when others => 3030 Error_Kind ("eval_static_expr('image)", Param); 3031 end case; 3032 end; 3033 when Iir_Kind_Value_Attribute => 3034 declare 3035 Param : Iir; 3036 begin 3037 Param := Get_Parameter (Expr); 3038 Param := Eval_Static_Expr (Param); 3039 Set_Parameter (Expr, Param); 3040 if Get_Kind (Param) /= Iir_Kind_String_Literal8 then 3041 -- FIXME: Isn't it an implementation restriction. 3042 Warning_Msg_Sem (Warnid_Runtime_Error, +Expr, 3043 "'value argument not a string"); 3044 return Build_Overflow (Expr); 3045 else 3046 return Eval_Value_Attribute 3047 (Image_String_Lit (Param), Get_Type (Expr), Expr); 3048 end if; 3049 end; 3050 3051 when Iir_Kind_Left_Type_Attribute => 3052 return Eval_Static_Expr 3053 (Get_Left_Limit (Eval_Static_Range (Get_Prefix (Expr)))); 3054 when Iir_Kind_Right_Type_Attribute => 3055 return Eval_Static_Expr 3056 (Get_Right_Limit (Eval_Static_Range (Get_Prefix (Expr)))); 3057 when Iir_Kind_High_Type_Attribute => 3058 return Eval_Static_Expr 3059 (Get_High_Limit (Eval_Static_Range (Get_Prefix (Expr)))); 3060 when Iir_Kind_Low_Type_Attribute => 3061 return Eval_Static_Expr 3062 (Get_Low_Limit (Eval_Static_Range (Get_Prefix (Expr)))); 3063 when Iir_Kind_Ascending_Type_Attribute => 3064 return Build_Boolean 3065 (Get_Direction (Eval_Static_Range (Get_Prefix (Expr))) = Dir_To); 3066 3067 when Iir_Kind_Length_Array_Attribute => 3068 declare 3069 Index : Iir; 3070 begin 3071 Index := Eval_Array_Attribute (Expr); 3072 return Build_Discrete (Eval_Discrete_Type_Length (Index), Expr); 3073 end; 3074 when Iir_Kind_Left_Array_Attribute => 3075 declare 3076 Index : Iir; 3077 begin 3078 Index := Eval_Array_Attribute (Expr); 3079 return Eval_Static_Expr 3080 (Get_Left_Limit (Get_Range_Constraint (Index))); 3081 end; 3082 when Iir_Kind_Right_Array_Attribute => 3083 declare 3084 Index : Iir; 3085 begin 3086 Index := Eval_Array_Attribute (Expr); 3087 return Eval_Static_Expr 3088 (Get_Right_Limit (Get_Range_Constraint (Index))); 3089 end; 3090 when Iir_Kind_Low_Array_Attribute => 3091 declare 3092 Index : Iir; 3093 begin 3094 Index := Eval_Array_Attribute (Expr); 3095 return Eval_Static_Expr 3096 (Get_Low_Limit (Get_Range_Constraint (Index))); 3097 end; 3098 when Iir_Kind_High_Array_Attribute => 3099 declare 3100 Index : Iir; 3101 begin 3102 Index := Eval_Array_Attribute (Expr); 3103 return Eval_Static_Expr 3104 (Get_High_Limit (Get_Range_Constraint (Index))); 3105 end; 3106 when Iir_Kind_Ascending_Array_Attribute => 3107 declare 3108 Index : Iir; 3109 begin 3110 Index := Eval_Array_Attribute (Expr); 3111 return Build_Boolean 3112 (Get_Direction (Get_Range_Constraint (Index)) = Dir_To); 3113 end; 3114 3115 when Iir_Kind_Pred_Attribute => 3116 Res := Eval_Incdec 3117 (Eval_Static_Expr (Get_Parameter (Expr)), -1, Expr); 3118 Eval_Check_Bound (Res, Get_Type (Get_Prefix (Expr))); 3119 return Res; 3120 when Iir_Kind_Succ_Attribute => 3121 Res := Eval_Incdec 3122 (Eval_Static_Expr (Get_Parameter (Expr)), +1, Expr); 3123 Eval_Check_Bound (Res, Get_Type (Get_Prefix (Expr))); 3124 return Res; 3125 when Iir_Kind_Leftof_Attribute 3126 | Iir_Kind_Rightof_Attribute => 3127 declare 3128 Rng : Iir; 3129 N : Int64; 3130 Prefix_Type : constant Iir := Get_Type (Get_Prefix (Expr)); 3131 Res : Iir; 3132 begin 3133 Rng := Eval_Static_Range (Prefix_Type); 3134 case Get_Direction (Rng) is 3135 when Dir_To => 3136 N := 1; 3137 when Dir_Downto => 3138 N := -1; 3139 end case; 3140 case Get_Kind (Expr) is 3141 when Iir_Kind_Leftof_Attribute => 3142 N := -N; 3143 when Iir_Kind_Rightof_Attribute => 3144 null; 3145 when others => 3146 raise Internal_Error; 3147 end case; 3148 Res := Eval_Incdec 3149 (Eval_Static_Expr (Get_Parameter (Expr)), N, Expr); 3150 Eval_Check_Bound (Res, Prefix_Type); 3151 return Res; 3152 end; 3153 3154 when Iir_Kind_Simple_Name_Attribute => 3155 declare 3156 use Str_Table; 3157 Img : constant String := 3158 Image (Get_Simple_Name_Identifier (Expr)); 3159 Id : String8_Id; 3160 begin 3161 Id := Create_String8; 3162 for I in Img'Range loop 3163 Append_String8_Char (Img (I)); 3164 end loop; 3165 return Build_String (Id, Nat32 (Img'Length), Expr); 3166 end; 3167 3168 when Iir_Kind_Null_Literal => 3169 return Expr; 3170 3171 when Iir_Kind_Function_Call => 3172 declare 3173 Imp : constant Iir := Get_Implementation (Expr); 3174 Left, Right : Iir; 3175 begin 3176 if (Get_Implicit_Definition (Imp) 3177 in Iir_Predefined_Concat_Functions) 3178 then 3179 return Eval_Concatenation ((1 => Expr)); 3180 else 3181 -- Note: there can't be association by name. 3182 Left := Get_Parameter_Association_Chain (Expr); 3183 Right := Get_Chain (Left); 3184 3185 Left := Eval_Static_Expr (Get_Actual (Left)); 3186 if Right = Null_Iir then 3187 return Eval_Monadic_Operator (Expr, Left); 3188 else 3189 Right := Eval_Static_Expr (Get_Actual (Right)); 3190 return Eval_Dyadic_Operator (Expr, Imp, Left, Right); 3191 end if; 3192 end if; 3193 end; 3194 3195 when Iir_Kind_Error => 3196 return Expr; 3197 when others => 3198 Error_Kind ("eval_static_expr", Expr); 3199 end case; 3200 end Eval_Static_Expr; 3201 3202 -- If FORCE is true, always return a literal. 3203 function Eval_Expr_Keep_Orig (Expr : Iir; Force : Boolean) return Iir 3204 is 3205 Res : Iir; 3206 begin 3207 case Get_Kind (Expr) is 3208 when Iir_Kinds_Denoting_Name => 3209 declare 3210 Orig : constant Iir := Get_Named_Entity (Expr); 3211 begin 3212 Res := Eval_Static_Expr (Orig); 3213 if Res /= Orig or else Force then 3214 return Build_Constant (Res, Expr); 3215 else 3216 return Expr; 3217 end if; 3218 end; 3219 when others => 3220 Res := Eval_Static_Expr (Expr); 3221 if Res /= Expr 3222 and then Get_Literal_Origin (Res) /= Expr 3223 then 3224 -- Need to build a constant if the result is a different 3225 -- literal not tied to EXPR. 3226 return Build_Constant (Res, Expr); 3227 else 3228 return Res; 3229 end if; 3230 end case; 3231 end Eval_Expr_Keep_Orig; 3232 3233 function Eval_Expr (Expr: Iir) return Iir is 3234 begin 3235 if Get_Expr_Staticness (Expr) /= Locally then 3236 Error_Msg_Sem (+Expr, "expression must be locally static"); 3237 return Expr; 3238 else 3239 return Eval_Expr_Keep_Orig (Expr, False); 3240 end if; 3241 end Eval_Expr; 3242 3243 -- Subroutine of Can_Eval_Composite_Value. Return True iff EXPR is 3244 -- considered as a small composite. 3245 function Is_Small_Composite_Value (Expr : Iir) return Boolean 3246 is 3247 Expr_Type : constant Iir := Get_Type (Expr); 3248 Indexes : Iir_Flist; 3249 Len : Int64; 3250 begin 3251 -- Consider only arrays. Records are never composite. 3252 if Get_Kind (Expr_Type) /= Iir_Kind_Array_Subtype_Definition then 3253 return False; 3254 end if; 3255 3256 -- Element must be scalar. 3257 if Get_Kind (Get_Element_Subtype (Expr_Type)) 3258 not in Iir_Kinds_Scalar_Type_And_Subtype_Definition 3259 then 3260 return False; 3261 end if; 3262 3263 Indexes := Get_Index_Subtype_List (Expr_Type); 3264 3265 -- Multi-dimensional arrays aren't considered as small. 3266 if Get_Nbr_Elements (Indexes) /= 1 then 3267 return False; 3268 end if; 3269 3270 Len := Eval_Discrete_Type_Length (Get_Nth_Element (Indexes, 0)); 3271 return Len <= 128; 3272 end Is_Small_Composite_Value; 3273 3274 function Can_Eval_Composite_Value (Expr : Iir; Top : Boolean := False) 3275 return Boolean; 3276 3277 -- Return True if EXPR should be evaluated. 3278 function Can_Eval_Value (Expr : Iir; Top : Boolean) return Boolean is 3279 begin 3280 -- Always evaluate scalar values. 3281 if Get_Kind (Get_Type (Expr)) 3282 in Iir_Kinds_Scalar_Type_And_Subtype_Definition 3283 then 3284 return True; 3285 end if; 3286 return Can_Eval_Composite_Value (Expr, Top); 3287 end Can_Eval_Value; 3288 3289 -- For composite values. 3290 -- Evaluating a composite value is a trade-off: it can simplify the 3291 -- generated code if the value is small enough, or it can be a bad idea if 3292 -- the value is very large. It is very easy to create large static 3293 -- composite values (like: bit_vector'(1 to 10**4 => '0')) 3294 function Can_Eval_Composite_Value (Expr : Iir; Top : Boolean := False) 3295 return Boolean 3296 is 3297 -- We are only considering static values. 3298 pragma Assert (Get_Expr_Staticness (Expr) = Locally); 3299 3300 -- We are only considering composite types. 3301 pragma Assert (Get_Kind (Get_Type (Expr)) 3302 not in Iir_Kinds_Scalar_Type_And_Subtype_Definition); 3303 begin 3304 case Get_Kind (Expr) is 3305 when Iir_Kind_Type_Conversion 3306 | Iir_Kind_Qualified_Expression => 3307 -- Not yet handled. 3308 return False; 3309 when Iir_Kinds_Denoting_Name => 3310 return Can_Eval_Composite_Value (Get_Named_Entity (Expr), Top); 3311 when Iir_Kind_Constant_Declaration => 3312 -- Pass through names only for small values. 3313 if Top or else not Is_Small_Composite_Value (Expr) then 3314 return False; 3315 else 3316 return Can_Eval_Composite_Value (Get_Default_Value (Expr)); 3317 end if; 3318 when Iir_Kind_Attribute_Name => 3319 if Top or else not Is_Small_Composite_Value (Expr) then 3320 return False; 3321 else 3322 return Can_Eval_Composite_Value 3323 (Get_Attribute_Name_Expression (Expr)); 3324 end if; 3325 when Iir_Kinds_Dyadic_Operator => 3326 -- Concatenation can increase the size. 3327 -- Others (rol, ror...) don't. 3328 return Can_Eval_Value (Get_Left (Expr), False) 3329 and then Can_Eval_Value (Get_Right (Expr), False); 3330 when Iir_Kinds_Monadic_Operator => 3331 -- For not. 3332 return Can_Eval_Composite_Value (Get_Operand (Expr)); 3333 when Iir_Kind_Aggregate => 3334 return Is_Small_Composite_Value (Expr); 3335 when Iir_Kinds_Literal 3336 | Iir_Kind_Enumeration_Literal 3337 | Iir_Kind_Simple_Aggregate 3338 | Iir_Kind_Image_Attribute 3339 | Iir_Kind_Simple_Name_Attribute => 3340 return True; 3341 when Iir_Kind_Overflow_Literal => 3342 return True; 3343 when Iir_Kind_Function_Call => 3344 -- Either using post-fixed notation or implicit functions like 3345 -- to_string. 3346 -- Cannot be a user function (won't be locally static). 3347 declare 3348 Assoc : Iir; 3349 Assoc_Expr : Iir; 3350 begin 3351 Assoc := Get_Parameter_Association_Chain (Expr); 3352 while Is_Valid (Assoc) loop 3353 case Iir_Kinds_Association_Element_Parameters 3354 (Get_Kind (Assoc)) 3355 is 3356 when Iir_Kind_Association_Element_By_Expression => 3357 Assoc_Expr := Get_Actual (Assoc); 3358 if not Can_Eval_Value (Assoc_Expr, False) then 3359 return False; 3360 end if; 3361 when Iir_Kind_Association_Element_Open => 3362 null; 3363 when Iir_Kind_Association_Element_By_Individual => 3364 return False; 3365 end case; 3366 Assoc := Get_Chain (Assoc); 3367 end loop; 3368 return True; 3369 end; 3370 3371 when others => 3372 -- Be safe, don't crash on unhandled expression. 3373 -- Error_Kind ("can_eval_composite_value", Expr); 3374 return False; 3375 end case; 3376 end Can_Eval_Composite_Value; 3377 3378 function Eval_Expr_If_Static (Expr : Iir) return Iir is 3379 begin 3380 if Expr /= Null_Iir and then Get_Expr_Staticness (Expr) = Locally then 3381 -- Evaluate only when there is a positive effect. 3382 if Can_Eval_Value (Expr, True) then 3383 return Eval_Expr_Keep_Orig (Expr, False); 3384 else 3385 return Expr; 3386 end if; 3387 else 3388 return Expr; 3389 end if; 3390 end Eval_Expr_If_Static; 3391 3392 function Eval_Expr_Check (Expr : Iir; Sub_Type : Iir) return Iir 3393 is 3394 Res : Iir; 3395 begin 3396 Res := Eval_Expr_Keep_Orig (Expr, False); 3397 Eval_Check_Bound (Res, Sub_Type); 3398 return Res; 3399 end Eval_Expr_Check; 3400 3401 function Eval_Expr_Check_If_Static (Expr : Iir; Atype : Iir) return Iir 3402 is 3403 Res : Iir; 3404 begin 3405 if Expr /= Null_Iir and then Get_Expr_Staticness (Expr) = Locally then 3406 -- Expression is static and can be evaluated. Don't try to 3407 -- evaluate non-scalar expressions, that may create too large data. 3408 if Get_Kind (Atype) in Iir_Kinds_Scalar_Type_And_Subtype_Definition 3409 then 3410 Res := Eval_Expr_Keep_Orig (Expr, False); 3411 else 3412 Res := Expr; 3413 end if; 3414 3415 if Res /= Null_Iir 3416 and then Get_Type_Staticness (Atype) = Locally 3417 and then Get_Kind (Atype) in Iir_Kinds_Range_Type_Definition 3418 then 3419 -- Check bounds (as this can be done). 3420 if not Eval_Check_Bound (Res, Atype) then 3421 Res := Build_Overflow (Res, Atype); 3422 end if; 3423 end if; 3424 3425 return Res; 3426 else 3427 return Expr; 3428 end if; 3429 end Eval_Expr_Check_If_Static; 3430 3431 function Eval_Int_In_Range (Val : Int64; Bound : Iir) return Boolean is 3432 begin 3433 case Get_Kind (Bound) is 3434 when Iir_Kind_Range_Expression => 3435 case Get_Direction (Bound) is 3436 when Dir_To => 3437 if Val < Eval_Pos (Get_Left_Limit (Bound)) 3438 or else Val > Eval_Pos (Get_Right_Limit (Bound)) 3439 then 3440 return False; 3441 end if; 3442 when Dir_Downto => 3443 if Val > Eval_Pos (Get_Left_Limit (Bound)) 3444 or else Val < Eval_Pos (Get_Right_Limit (Bound)) 3445 then 3446 return False; 3447 end if; 3448 end case; 3449 when others => 3450 Error_Kind ("eval_int_in_range", Bound); 3451 end case; 3452 return True; 3453 end Eval_Int_In_Range; 3454 3455 function Eval_Phys_In_Range (Val : Int64; Bound : Iir) return Boolean 3456 is 3457 Left, Right : Int64; 3458 begin 3459 case Get_Kind (Bound) is 3460 when Iir_Kind_Range_Expression => 3461 case Get_Kind (Get_Type (Get_Left_Limit (Bound))) is 3462 when Iir_Kind_Integer_Type_Definition 3463 | Iir_Kind_Integer_Subtype_Definition => 3464 Left := Get_Value (Get_Left_Limit (Bound)); 3465 Right := Get_Value (Get_Right_Limit (Bound)); 3466 when Iir_Kind_Physical_Type_Definition 3467 | Iir_Kind_Physical_Subtype_Definition => 3468 Left := Get_Physical_Value (Get_Left_Limit (Bound)); 3469 Right := Get_Physical_Value (Get_Right_Limit (Bound)); 3470 when others => 3471 Error_Kind ("eval_phys_in_range(1)", Get_Type (Bound)); 3472 end case; 3473 case Get_Direction (Bound) is 3474 when Dir_To => 3475 if Val < Left or else Val > Right then 3476 return False; 3477 end if; 3478 when Dir_Downto => 3479 if Val > Left or else Val < Right then 3480 return False; 3481 end if; 3482 end case; 3483 when others => 3484 Error_Kind ("eval_phys_in_range", Bound); 3485 end case; 3486 return True; 3487 end Eval_Phys_In_Range; 3488 3489 function Eval_Fp_In_Range (Val : Fp64; Bound : Iir) return Boolean is 3490 begin 3491 case Get_Kind (Bound) is 3492 when Iir_Kind_Range_Expression => 3493 case Get_Direction (Bound) is 3494 when Dir_To => 3495 if Val < Get_Fp_Value (Get_Left_Limit (Bound)) 3496 or else Val > Get_Fp_Value (Get_Right_Limit (Bound)) 3497 then 3498 return False; 3499 end if; 3500 when Dir_Downto => 3501 if Val > Get_Fp_Value (Get_Left_Limit (Bound)) 3502 or else Val < Get_Fp_Value (Get_Right_Limit (Bound)) 3503 then 3504 return False; 3505 end if; 3506 end case; 3507 when others => 3508 Error_Kind ("eval_fp_in_range", Bound); 3509 end case; 3510 return True; 3511 end Eval_Fp_In_Range; 3512 3513 -- Return FALSE if literal EXPR is not in SUB_TYPE bounds. 3514 function Eval_Is_In_Bound 3515 (Expr : Iir; Sub_Type : Iir; Overflow : Boolean := False) return Boolean 3516 is 3517 Type_Range : Iir; 3518 Val : Iir; 3519 begin 3520 case Get_Kind (Expr) is 3521 when Iir_Kind_Simple_Name 3522 | Iir_Kind_Character_Literal 3523 | Iir_Kind_Selected_Name 3524 | Iir_Kind_Parenthesis_Name => 3525 Val := Get_Named_Entity (Expr); 3526 when others => 3527 Val := Expr; 3528 end case; 3529 3530 case Get_Kind (Val) is 3531 when Iir_Kind_Error => 3532 -- Ignore errors. 3533 return True; 3534 when Iir_Kind_Overflow_Literal => 3535 return Overflow; 3536 when others => 3537 null; 3538 end case; 3539 3540 case Get_Kind (Sub_Type) is 3541 when Iir_Kind_Integer_Subtype_Definition => 3542 if Get_Expr_Staticness (Val) /= Locally 3543 or else Get_Type_Staticness (Sub_Type) /= Locally 3544 then 3545 return True; 3546 end if; 3547 Type_Range := Get_Range_Constraint (Sub_Type); 3548 return Eval_Int_In_Range (Get_Value (Val), Type_Range); 3549 3550 when Iir_Kind_Floating_Subtype_Definition => 3551 if Get_Expr_Staticness (Val) /= Locally 3552 or else Get_Type_Staticness (Sub_Type) /= Locally 3553 then 3554 return True; 3555 end if; 3556 Type_Range := Get_Range_Constraint (Sub_Type); 3557 return Eval_Fp_In_Range (Get_Fp_Value (Val), Type_Range); 3558 3559 when Iir_Kind_Enumeration_Subtype_Definition 3560 | Iir_Kind_Enumeration_Type_Definition => 3561 if Get_Expr_Staticness (Val) /= Locally 3562 or else Get_Type_Staticness (Sub_Type) /= Locally 3563 then 3564 return True; 3565 end if; 3566 -- A check is required for an enumeration type definition for 3567 -- 'val attribute. 3568 Type_Range := Get_Range_Constraint (Sub_Type); 3569 return Eval_Int_In_Range 3570 (Int64 (Get_Enum_Pos (Val)), Type_Range); 3571 3572 when Iir_Kind_Physical_Subtype_Definition => 3573 if Get_Expr_Staticness (Val) /= Locally 3574 or else Get_Type_Staticness (Sub_Type) /= Locally 3575 then 3576 return True; 3577 end if; 3578 Type_Range := Get_Range_Constraint (Sub_Type); 3579 return Eval_Phys_In_Range (Get_Physical_Value (Val), Type_Range); 3580 3581 when Iir_Kind_Base_Attribute => 3582 if Get_Expr_Staticness (Val) /= Locally 3583 or else Get_Type_Staticness (Sub_Type) /= Locally 3584 then 3585 return True; 3586 end if; 3587 return Eval_Is_In_Bound (Val, Get_Type (Sub_Type)); 3588 3589 when Iir_Kind_Array_Subtype_Definition => 3590 declare 3591 Val_Type : constant Iir := Get_Type (Val); 3592 begin 3593 if Is_Null (Val_Type) then 3594 -- Punt on errors. 3595 return True; 3596 end if; 3597 3598 if Get_Constraint_State (Sub_Type) /= Fully_Constrained 3599 or else 3600 Get_Kind (Val_Type) /= Iir_Kind_Array_Subtype_Definition 3601 or else 3602 Get_Constraint_State (Val_Type) /= Fully_Constrained 3603 then 3604 -- Cannot say no. 3605 return True; 3606 end if; 3607 declare 3608 E_Indexes : constant Iir_Flist := 3609 Get_Index_Subtype_List (Val_Type); 3610 T_Indexes : constant Iir_Flist := 3611 Get_Index_Subtype_List (Sub_Type); 3612 E_El : Iir; 3613 T_El : Iir; 3614 begin 3615 for I in Flist_First .. Flist_Last (E_Indexes) loop 3616 E_El := Get_Index_Type (E_Indexes, I); 3617 T_El := Get_Index_Type (T_Indexes, I); 3618 3619 if Get_Type_Staticness (E_El) = Locally 3620 and then Get_Type_Staticness (T_El) = Locally 3621 and then (Eval_Discrete_Type_Length (E_El) 3622 /= Eval_Discrete_Type_Length (T_El)) 3623 then 3624 return False; 3625 end if; 3626 end loop; 3627 return True; 3628 end; 3629 end; 3630 3631 when Iir_Kind_Access_Type_Definition 3632 | Iir_Kind_Access_Subtype_Definition => 3633 return True; 3634 3635 when Iir_Kind_Array_Type_Definition 3636 | Iir_Kind_Record_Type_Definition 3637 | Iir_Kind_Record_Subtype_Definition => 3638 -- FIXME: do it. 3639 return True; 3640 3641 when Iir_Kind_File_Type_Definition => 3642 return True; 3643 3644 when Iir_Kind_Integer_Type_Definition 3645 | Iir_Kind_Physical_Type_Definition 3646 | Iir_Kind_Floating_Type_Definition => 3647 return True; 3648 3649 when Iir_Kind_Interface_Type_Definition 3650 | Iir_Kind_Protected_Type_Declaration => 3651 return True; 3652 3653 when Iir_Kind_Error => 3654 return True; 3655 3656 when others => 3657 Error_Kind ("eval_is_in_bound", Sub_Type); 3658 end case; 3659 end Eval_Is_In_Bound; 3660 3661 function Eval_Check_Bound (Expr : Iir; Sub_Type : Iir) return Boolean is 3662 begin 3663 -- Note: use True not to repeat a message in case of overflow. 3664 if Eval_Is_In_Bound (Expr, Sub_Type, True) then 3665 return True; 3666 end if; 3667 3668 Warning_Msg_Sem (Warnid_Runtime_Error, +Expr, 3669 "static expression violates bounds"); 3670 return False; 3671 end Eval_Check_Bound; 3672 3673 procedure Eval_Check_Bound (Expr : Iir; Sub_Type : Iir) 3674 is 3675 Res : Boolean; 3676 begin 3677 Res := Eval_Check_Bound (Expr, Sub_Type); 3678 pragma Unreferenced (Res); 3679 end Eval_Check_Bound; 3680 3681 function Eval_Is_Range_In_Bound 3682 (A_Range : Iir; Sub_Type : Iir; Any_Dir : Boolean) 3683 return Boolean 3684 is 3685 Type_Range : Iir; 3686 Range_Constraint : constant Iir := Eval_Static_Range (A_Range); 3687 begin 3688 Type_Range := Get_Range_Constraint (Sub_Type); 3689 if not Any_Dir 3690 and then Get_Direction (Type_Range) /= Get_Direction (Range_Constraint) 3691 then 3692 return True; 3693 end if; 3694 3695 case Get_Kind (Sub_Type) is 3696 when Iir_Kind_Integer_Subtype_Definition 3697 | Iir_Kind_Physical_Subtype_Definition 3698 | Iir_Kind_Enumeration_Subtype_Definition 3699 | Iir_Kind_Enumeration_Type_Definition => 3700 declare 3701 L, R : Int64; 3702 begin 3703 -- Check for null range. 3704 L := Eval_Pos (Get_Left_Limit (Range_Constraint)); 3705 R := Eval_Pos (Get_Right_Limit (Range_Constraint)); 3706 case Get_Direction (Range_Constraint) is 3707 when Dir_To => 3708 if L > R then 3709 return True; 3710 end if; 3711 when Dir_Downto => 3712 if L < R then 3713 return True; 3714 end if; 3715 end case; 3716 return Eval_Int_In_Range (L, Type_Range) 3717 and then Eval_Int_In_Range (R, Type_Range); 3718 end; 3719 when Iir_Kind_Floating_Subtype_Definition => 3720 declare 3721 L, R : Fp64; 3722 begin 3723 -- Check for null range. 3724 L := Get_Fp_Value (Get_Left_Limit (Range_Constraint)); 3725 R := Get_Fp_Value (Get_Right_Limit (Range_Constraint)); 3726 case Get_Direction (Range_Constraint) is 3727 when Dir_To => 3728 if L > R then 3729 return True; 3730 end if; 3731 when Dir_Downto => 3732 if L < R then 3733 return True; 3734 end if; 3735 end case; 3736 return Eval_Fp_In_Range (L, Type_Range) 3737 and then Eval_Fp_In_Range (R, Type_Range); 3738 end; 3739 when others => 3740 Error_Kind ("eval_is_range_in_bound", Sub_Type); 3741 end case; 3742 3743 -- Should check L <= R or L >= R according to direction. 3744 --return Eval_Is_In_Bound (Get_Left_Limit (A_Range), Sub_Type) 3745 -- and then Eval_Is_In_Bound (Get_Right_Limit (A_Range), Sub_Type); 3746 end Eval_Is_Range_In_Bound; 3747 3748 procedure Eval_Check_Range 3749 (A_Range : Iir; Sub_Type : Iir; Any_Dir : Boolean) 3750 is 3751 begin 3752 if not Eval_Is_Range_In_Bound (A_Range, Sub_Type, Any_Dir) then 3753 Warning_Msg_Sem (Warnid_Runtime_Error, +A_Range, 3754 "static range violates bounds"); 3755 end if; 3756 end Eval_Check_Range; 3757 3758 function Eval_Discrete_Range_Length (Constraint : Iir) return Int64 3759 is 3760 -- We don't want to deal with very large ranges here. 3761 pragma Suppress (Overflow_Check); 3762 Res : Int64; 3763 Left, Right : Int64; 3764 begin 3765 Left := Eval_Pos (Get_Left_Limit (Constraint)); 3766 Right := Eval_Pos (Get_Right_Limit (Constraint)); 3767 case Get_Direction (Constraint) is 3768 when Dir_To => 3769 if Right < Left then 3770 -- Null range. 3771 return 0; 3772 else 3773 Res := Right - Left + 1; 3774 end if; 3775 when Dir_Downto => 3776 if Left < Right then 3777 -- Null range 3778 return 0; 3779 else 3780 Res := Left - Right + 1; 3781 end if; 3782 end case; 3783 return Res; 3784 end Eval_Discrete_Range_Length; 3785 3786 function Eval_Discrete_Type_Length (Sub_Type : Iir) return Int64 3787 is 3788 begin 3789 case Get_Kind (Sub_Type) is 3790 when Iir_Kind_Enumeration_Subtype_Definition 3791 | Iir_Kind_Enumeration_Type_Definition 3792 | Iir_Kind_Integer_Subtype_Definition => 3793 return Eval_Discrete_Range_Length 3794 (Get_Range_Constraint (Sub_Type)); 3795 when others => 3796 Error_Kind ("eval_discrete_type_length", Sub_Type); 3797 end case; 3798 end Eval_Discrete_Type_Length; 3799 3800 function Eval_Is_Null_Discrete_Range (Rng : Iir) return Boolean 3801 is 3802 Left, Right : Int64; 3803 begin 3804 Left := Eval_Pos (Get_Left_Limit (Rng)); 3805 Right := Eval_Pos (Get_Right_Limit (Rng)); 3806 case Get_Direction (Rng) is 3807 when Dir_To => 3808 return Right < Left; 3809 when Dir_Downto => 3810 return Left < Right; 3811 end case; 3812 end Eval_Is_Null_Discrete_Range; 3813 3814 function Eval_Pos (Expr : Iir) return Int64 is 3815 begin 3816 case Get_Kind (Expr) is 3817 when Iir_Kind_Integer_Literal => 3818 return Get_Value (Expr); 3819 when Iir_Kind_Enumeration_Literal => 3820 return Int64 (Get_Enum_Pos (Expr)); 3821 when Iir_Kind_Physical_Int_Literal 3822 | Iir_Kind_Physical_Fp_Literal 3823 | Iir_Kind_Unit_Declaration => 3824 return Get_Physical_Value (Expr); 3825 when Iir_Kinds_Denoting_Name => 3826 return Eval_Pos (Get_Named_Entity (Expr)); 3827 when others => 3828 Error_Kind ("eval_pos", Expr); 3829 end case; 3830 end Eval_Pos; 3831 3832 function Eval_Static_Range (Rng : Iir) return Iir 3833 is 3834 Expr : Iir; 3835 Kind : Iir_Kind; 3836 begin 3837 Expr := Rng; 3838 loop 3839 Kind := Get_Kind (Expr); 3840 case Kind is 3841 when Iir_Kind_Range_Expression => 3842 if Get_Expr_Staticness (Expr) /= Locally then 3843 return Null_Iir; 3844 end if; 3845 3846 -- Normalize the range expression. 3847 declare 3848 Left : Iir; 3849 Right : Iir; 3850 begin 3851 Left := Get_Left_Limit_Expr (Expr); 3852 if Is_Valid (Left) then 3853 Left := Eval_Expr_Keep_Orig (Left, False); 3854 Set_Left_Limit_Expr (Expr, Left); 3855 Set_Left_Limit (Expr, Left); 3856 end if; 3857 Right := Get_Right_Limit_Expr (Expr); 3858 if Is_Valid (Right) then 3859 Right := Eval_Expr_Keep_Orig (Right, False); 3860 Set_Right_Limit_Expr (Expr, Right); 3861 Set_Right_Limit (Expr, Right); 3862 end if; 3863 end; 3864 return Expr; 3865 when Iir_Kind_Integer_Subtype_Definition 3866 | Iir_Kind_Floating_Subtype_Definition 3867 | Iir_Kind_Enumeration_Type_Definition 3868 | Iir_Kind_Enumeration_Subtype_Definition 3869 | Iir_Kind_Physical_Subtype_Definition => 3870 Expr := Get_Range_Constraint (Expr); 3871 when Iir_Kind_Range_Array_Attribute 3872 | Iir_Kind_Reverse_Range_Array_Attribute => 3873 declare 3874 Indexes_List : Iir_Flist; 3875 Prefix : Iir; 3876 Res : Iir; 3877 Dim : Natural; 3878 begin 3879 Prefix := Get_Prefix (Expr); 3880 if Get_Kind (Prefix) /= Iir_Kind_Array_Subtype_Definition 3881 then 3882 Prefix := Get_Type (Prefix); 3883 end if; 3884 if Get_Kind (Prefix) /= Iir_Kind_Array_Subtype_Definition 3885 then 3886 -- Unconstrained object. 3887 return Null_Iir; 3888 end if; 3889 Indexes_List := Get_Index_Subtype_List (Prefix); 3890 Dim := Eval_Attribute_Parameter_Or_1 (Expr); 3891 if Dim < 1 3892 or else Dim > Get_Nbr_Elements (Indexes_List) 3893 then 3894 -- Avoid cascaded errors. 3895 Dim := 1; 3896 end if; 3897 Expr := Get_Nth_Element (Indexes_List, Dim - 1); 3898 if Kind = Iir_Kind_Reverse_Range_Array_Attribute then 3899 Expr := Eval_Static_Range (Expr); 3900 3901 Res := Create_Iir (Iir_Kind_Range_Expression); 3902 Location_Copy (Res, Expr); 3903 Set_Type (Res, Get_Type (Expr)); 3904 case Get_Direction (Expr) is 3905 when Dir_To => 3906 Set_Direction (Res, Dir_Downto); 3907 when Dir_Downto => 3908 Set_Direction (Res, Dir_To); 3909 end case; 3910 Set_Left_Limit (Res, Get_Right_Limit (Expr)); 3911 Set_Right_Limit (Res, Get_Left_Limit (Expr)); 3912 Set_Range_Origin (Res, Rng); 3913 Set_Expr_Staticness (Res, Get_Expr_Staticness (Expr)); 3914 return Res; 3915 end if; 3916 end; 3917 3918 when Iir_Kind_Subtype_Declaration 3919 | Iir_Kind_Base_Attribute 3920 | Iir_Kind_Subtype_Attribute 3921 | Iir_Kind_Element_Attribute => 3922 Expr := Get_Type (Expr); 3923 when Iir_Kind_Type_Declaration => 3924 Expr := Get_Type_Definition (Expr); 3925 when Iir_Kind_Simple_Name 3926 | Iir_Kind_Selected_Name => 3927 Expr := Get_Named_Entity (Expr); 3928 when others => 3929 Error_Kind ("eval_static_range", Expr); 3930 end case; 3931 end loop; 3932 end Eval_Static_Range; 3933 3934 function Eval_Range (Arange : Iir) return Iir is 3935 Res : Iir; 3936 begin 3937 Res := Eval_Static_Range (Arange); 3938 if Res /= Arange 3939 and then Get_Range_Origin (Res) /= Arange 3940 then 3941 return Build_Constant_Range (Res, Arange); 3942 else 3943 return Res; 3944 end if; 3945 end Eval_Range; 3946 3947 function Eval_Range_If_Static (Arange : Iir) return Iir is 3948 begin 3949 if Get_Expr_Staticness (Arange) /= Locally then 3950 return Arange; 3951 else 3952 return Eval_Range (Arange); 3953 end if; 3954 end Eval_Range_If_Static; 3955 3956 -- Return the range constraint of a discrete range. 3957 function Eval_Discrete_Range_Expression (Constraint : Iir) return Iir 3958 is 3959 Res : Iir; 3960 begin 3961 Res := Eval_Static_Range (Constraint); 3962 if Res = Null_Iir then 3963 Error_Kind ("eval_discrete_range_expression", Constraint); 3964 else 3965 return Res; 3966 end if; 3967 end Eval_Discrete_Range_Expression; 3968 3969 function Eval_Discrete_Range_Left (Constraint : Iir) return Iir 3970 is 3971 Range_Expr : Iir; 3972 begin 3973 Range_Expr := Eval_Discrete_Range_Expression (Constraint); 3974 return Get_Left_Limit (Range_Expr); 3975 end Eval_Discrete_Range_Left; 3976 3977 function Eval_Is_Eq (L, R : Iir) return Boolean 3978 is 3979 Expr_Type : constant Iir := Get_Type (L); 3980 begin 3981 case Get_Kind (Expr_Type) is 3982 when Iir_Kind_Integer_Subtype_Definition 3983 | Iir_Kind_Integer_Type_Definition 3984 | Iir_Kind_Physical_Subtype_Definition 3985 | Iir_Kind_Physical_Type_Definition 3986 | Iir_Kind_Enumeration_Subtype_Definition 3987 | Iir_Kind_Enumeration_Type_Definition => 3988 return Eval_Pos (L) = Eval_Pos (R); 3989 when Iir_Kind_Floating_Subtype_Definition 3990 | Iir_Kind_Floating_Type_Definition => 3991 return Get_Fp_Value (L) = Get_Fp_Value (R); 3992 when others => 3993 Error_Kind ("eval_is_eq", Expr_Type); 3994 end case; 3995 end Eval_Is_Eq; 3996 3997 function Eval_Operator_Symbol_Name (Id : Name_Id) return String is 3998 begin 3999 return '"' & Image (Id) & '"'; 4000 end Eval_Operator_Symbol_Name; 4001 4002 function Eval_Simple_Name (Id : Name_Id) return String is 4003 begin 4004 -- LRM 14.1 4005 -- E'SIMPLE_NAME 4006 -- Result: [...] but with apostrophes (in the case of a character 4007 -- literal) 4008 if Is_Character (Id) then 4009 return ''' & Get_Character (Id) & '''; 4010 end if; 4011 case Id is 4012 when Std_Names.Name_Word_Operators 4013 | Std_Names.Name_First_Operator .. Std_Names.Name_Last_Operator => 4014 return Eval_Operator_Symbol_Name (Id); 4015 when Std_Names.Name_Xnor 4016 | Std_Names.Name_Shift_Operators => 4017 if Flags.Vhdl_Std > Vhdl_87 then 4018 return Eval_Operator_Symbol_Name (Id); 4019 end if; 4020 when others => 4021 null; 4022 end case; 4023 return Image (Id); 4024 end Eval_Simple_Name; 4025 4026 package body String_Utils is 4027 -- Fill Res from EL. This is used to speed up Lt and Eq operations. 4028 function Get_Str_Info (Expr : Iir) return Str_Info is 4029 begin 4030 case Get_Kind (Expr) is 4031 when Iir_Kind_Simple_Aggregate => 4032 declare 4033 List : constant Iir_Flist := 4034 Get_Simple_Aggregate_List (Expr); 4035 begin 4036 return Str_Info'(Is_String => False, 4037 Len => Nat32 (Get_Nbr_Elements (List)), 4038 List => List); 4039 end; 4040 when Iir_Kind_String_Literal8 => 4041 return Str_Info'(Is_String => True, 4042 Len => Get_String_Length (Expr), 4043 Id => Get_String8_Id (Expr)); 4044 when others => 4045 Error_Kind ("string_utils.get_info", Expr); 4046 end case; 4047 end Get_Str_Info; 4048 4049 -- Return the position of element IDX of STR. 4050 function Get_Pos (Str : Str_Info; Idx : Nat32) return Iir_Int32 4051 is 4052 S : Iir; 4053 P : Nat32; 4054 begin 4055 case Str.Is_String is 4056 when False => 4057 S := Get_Nth_Element (Str.List, Natural (Idx)); 4058 return Get_Enum_Pos (S); 4059 when True => 4060 P := Str_Table.Element_String8 (Str.Id, Idx + 1); 4061 return Iir_Int32 (P); 4062 end case; 4063 end Get_Pos; 4064 end String_Utils; 4065 4066 function Compare_String_Literals (L, R : Iir) return Compare_Type 4067 is 4068 use String_Utils; 4069 L_Info : constant Str_Info := Get_Str_Info (L); 4070 R_Info : constant Str_Info := Get_Str_Info (R); 4071 L_Pos, R_Pos : Iir_Int32; 4072 begin 4073 if L_Info.Len /= R_Info.Len then 4074 raise Internal_Error; 4075 end if; 4076 4077 for I in 0 .. L_Info.Len - 1 loop 4078 L_Pos := Get_Pos (L_Info, I); 4079 R_Pos := Get_Pos (R_Info, I); 4080 if L_Pos /= R_Pos then 4081 if L_Pos < R_Pos then 4082 return Compare_Lt; 4083 else 4084 return Compare_Gt; 4085 end if; 4086 end if; 4087 end loop; 4088 return Compare_Eq; 4089 end Compare_String_Literals; 4090 4091 function Get_Path_Instance_Name_Suffix (Attr : Iir) 4092 return Path_Instance_Name_Type 4093 is 4094 -- Current path for name attributes. 4095 Path_Str : String_Acc := null; 4096 Path_Maxlen : Natural := 0; 4097 Path_Len : Natural; 4098 Path_Instance : Iir; 4099 4100 procedure Deallocate is new Ada.Unchecked_Deallocation 4101 (Name => String_Acc, Object => String); 4102 4103 procedure Path_Reset is 4104 begin 4105 Path_Len := 0; 4106 Path_Instance := Null_Iir; 4107 if Path_Maxlen = 0 then 4108 Path_Maxlen := 256; 4109 Path_Str := new String (1 .. Path_Maxlen); 4110 end if; 4111 end Path_Reset; 4112 4113 procedure Path_Add (Str : String) 4114 is 4115 N_Len : Natural; 4116 N_Path : String_Acc; 4117 begin 4118 N_Len := Path_Maxlen; 4119 loop 4120 exit when Path_Len + Str'Length <= N_Len; 4121 N_Len := N_Len * 2; 4122 end loop; 4123 if N_Len /= Path_Maxlen then 4124 N_Path := new String (1 .. N_Len); 4125 N_Path (1 .. Path_Len) := Path_Str (1 .. Path_Len); 4126 Deallocate (Path_Str); 4127 Path_Str := N_Path; 4128 Path_Maxlen := N_Len; 4129 end if; 4130 Path_Str (Path_Len + 1 .. Path_Len + Str'Length) := Str; 4131 Path_Len := Path_Len + Str'Length; 4132 end Path_Add; 4133 4134 procedure Path_Add_Type_Name (Atype : Iir) 4135 is 4136 Mark : Iir; 4137 begin 4138 if Get_Kind (Atype) in Iir_Kinds_Denoting_Name then 4139 Mark := Atype; 4140 else 4141 Mark := Get_Subtype_Type_Mark (Atype); 4142 end if; 4143 Path_Add (Image (Get_Identifier (Mark))); 4144 end Path_Add_Type_Name; 4145 4146 procedure Path_Add_Signature (Subprg : Iir) 4147 is 4148 Inter : Iir; 4149 Inter_Type, Prev_Type : Iir; 4150 begin 4151 Path_Add ("["); 4152 Prev_Type := Null_Iir; 4153 Inter := Get_Interface_Declaration_Chain (Subprg); 4154 while Inter /= Null_Iir loop 4155 Inter_Type := Get_Subtype_Indication (Inter); 4156 if Inter_Type = Null_Iir then 4157 Inter_Type := Prev_Type; 4158 end if; 4159 Path_Add_Type_Name (Inter_Type); 4160 Prev_Type := Inter_Type; 4161 4162 Inter := Get_Chain (Inter); 4163 if Inter /= Null_Iir then 4164 Path_Add (","); 4165 end if; 4166 end loop; 4167 4168 case Get_Kind (Subprg) is 4169 when Iir_Kind_Function_Declaration => 4170 Path_Add (" return "); 4171 Path_Add_Type_Name (Get_Return_Type_Mark (Subprg)); 4172 when others => 4173 null; 4174 end case; 4175 Path_Add ("]"); 4176 end Path_Add_Signature; 4177 4178 procedure Path_Add_Name (N : Iir) 4179 is 4180 Img : constant String := Eval_Simple_Name (Get_Identifier (N)); 4181 begin 4182 if Img (Img'First) /= 'P' then 4183 -- Skip anonymous processes. 4184 Path_Add (Img); 4185 end if; 4186 end Path_Add_Name; 4187 4188 procedure Path_Add_Element (El : Iir; Is_Instance : Boolean) is 4189 begin 4190 -- LRM 14.1 4191 -- E'INSTANCE_NAME 4192 -- There is one full path instance element for each component 4193 -- instantiation, block statement, generate statemenent, process 4194 -- statement, or subprogram body in the design hierarchy between 4195 -- the top design entity and the named entity denoted by the 4196 -- prefix. 4197 -- 4198 -- E'PATH_NAME 4199 -- There is one path instance element for each component 4200 -- instantiation, block statement, generate statement, process 4201 -- statement, or subprogram body in the design hierarchy between 4202 -- the root design entity and the named entity denoted by the 4203 -- prefix. 4204 case Get_Kind (El) is 4205 when Iir_Kind_Library_Declaration => 4206 Path_Add (":"); 4207 Path_Add_Name (El); 4208 Path_Add (":"); 4209 when Iir_Kind_Package_Declaration 4210 | Iir_Kind_Package_Body 4211 | Iir_Kind_Package_Instantiation_Declaration => 4212 if Is_Nested_Package (El) then 4213 Path_Add_Element (Get_Parent (El), Is_Instance); 4214 else 4215 Path_Add_Element 4216 (Get_Library (Get_Design_File (Get_Design_Unit (El))), 4217 Is_Instance); 4218 end if; 4219 Path_Add_Name (El); 4220 Path_Add (":"); 4221 when Iir_Kind_Entity_Declaration => 4222 Path_Instance := El; 4223 when Iir_Kind_Architecture_Body => 4224 Path_Instance := El; 4225 when Iir_Kind_Design_Unit => 4226 Path_Add_Element (Get_Library_Unit (El), Is_Instance); 4227 when Iir_Kind_Sensitized_Process_Statement 4228 | Iir_Kind_Process_Statement 4229 | Iir_Kind_Block_Statement 4230 | Iir_Kind_Protected_Type_Body => 4231 Path_Add_Element (Get_Parent (El), Is_Instance); 4232 Path_Add_Name (El); 4233 Path_Add (":"); 4234 when Iir_Kind_Protected_Type_Declaration => 4235 declare 4236 Decl : constant Iir := Get_Type_Declarator (El); 4237 begin 4238 Path_Add_Element (Get_Parent (Decl), Is_Instance); 4239 Path_Add_Name (Decl); 4240 Path_Add (":"); 4241 end; 4242 when Iir_Kind_Function_Declaration 4243 | Iir_Kind_Procedure_Declaration => 4244 Path_Add_Element (Get_Parent (El), Is_Instance); 4245 Path_Add_Name (El); 4246 if Flags.Vhdl_Std >= Vhdl_02 then 4247 -- Add signature. 4248 Path_Add_Signature (El); 4249 end if; 4250 Path_Add (":"); 4251 when Iir_Kind_Procedure_Body => 4252 Path_Add_Element (Get_Subprogram_Specification (El), 4253 Is_Instance); 4254 when Iir_Kind_For_Generate_Statement => 4255 Path_Instance := El; 4256 when Iir_Kind_If_Generate_Statement => 4257 Path_Add_Element (Get_Parent (El), Is_Instance); 4258 Path_Add_Name (El); 4259 Path_Add (":"); 4260 when Iir_Kind_Generate_Statement_Body => 4261 declare 4262 Parent : constant Iir := Get_Parent (El); 4263 begin 4264 if Get_Kind (Parent) = Iir_Kind_For_Generate_Statement then 4265 Path_Instance := El; 4266 else 4267 Path_Add_Element (Parent, Is_Instance); 4268 end if; 4269 end; 4270 when Iir_Kinds_Sequential_Statement => 4271 Path_Add_Element (Get_Parent (El), Is_Instance); 4272 when others => 4273 Error_Kind ("path_add_element", El); 4274 end case; 4275 end Path_Add_Element; 4276 4277 Prefix : constant Iir := Get_Named_Entity (Get_Prefix (Attr)); 4278 Is_Instance : constant Boolean := 4279 Get_Kind (Attr) = Iir_Kind_Instance_Name_Attribute; 4280 begin 4281 Path_Reset; 4282 4283 -- LRM 14.1 4284 -- E'PATH_NAME 4285 -- The local item name in E'PATH_NAME equals E'SIMPLE_NAME, unless 4286 -- E denotes a library, package, subprogram or label. In this 4287 -- latter case, the package based path or instance based path, 4288 -- as appropriate, will not contain a local item name. 4289 -- 4290 -- E'INSTANCE_NAME 4291 -- The local item name in E'INSTANCE_NAME equals E'SIMPLE_NAME, 4292 -- unless E denotes a library, package, subprogram, or label. In 4293 -- this latter case, the package based path or full instance based 4294 -- path, as appropriate, will not contain a local item name. 4295 case Get_Kind (Prefix) is 4296 when Iir_Kind_Constant_Declaration 4297 | Iir_Kind_Interface_Constant_Declaration 4298 | Iir_Kind_Iterator_Declaration 4299 | Iir_Kind_Variable_Declaration 4300 | Iir_Kind_Interface_Variable_Declaration 4301 | Iir_Kind_Signal_Declaration 4302 | Iir_Kind_Interface_Signal_Declaration 4303 | Iir_Kind_File_Declaration 4304 | Iir_Kind_Interface_File_Declaration 4305 | Iir_Kind_Type_Declaration 4306 | Iir_Kind_Subtype_Declaration => 4307 Path_Add_Element (Get_Parent (Prefix), Is_Instance); 4308 Path_Add_Name (Prefix); 4309 when Iir_Kind_Library_Declaration 4310 | Iir_Kinds_Library_Unit 4311 | Iir_Kind_Function_Declaration 4312 | Iir_Kind_Procedure_Declaration 4313 | Iir_Kinds_Concurrent_Statement 4314 | Iir_Kinds_Sequential_Statement => 4315 Path_Add_Element (Prefix, Is_Instance); 4316 when others => 4317 Error_Kind ("get_path_instance_name_suffix", Prefix); 4318 end case; 4319 4320 declare 4321 Result : constant Path_Instance_Name_Type := 4322 (Len => Path_Len, 4323 Path_Instance => Path_Instance, 4324 Suffix => Path_Str (1 .. Path_Len)); 4325 begin 4326 Deallocate (Path_Str); 4327 return Result; 4328 end; 4329 end Get_Path_Instance_Name_Suffix; 4330 4331end Vhdl.Evaluation; 4332