1-- Ortho entry point for translation. 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>. 16with System; 17with Interfaces.C_Streams; 18with GNAT.OS_Lib; 19 20with Types; use Types; 21with Name_Table; 22with Hash; 23with Interning; 24with Flags; 25with Libraries; 26with Vhdl.Nodes; use Vhdl.Nodes; 27with Vhdl.Utils; use Vhdl.Utils; 28with Vhdl.Std_Package; 29with Vhdl.Configuration; 30with Translation; 31with Vhdl.Sem; 32with Vhdl.Sem_Lib; use Vhdl.Sem_Lib; 33with Errorout; use Errorout; 34with Errorout.Console; 35with Vhdl.Errors; use Vhdl.Errors; 36with Bug; 37with Trans_Be; 38with Options; use Options; 39 40package body Ortho_Front is 41 -- The action to be performed by the compiler. 42 type Action_Type is 43 ( 44 -- Normal mode: compile a design file. 45 Action_Compile, 46 47 -- Generate code to elaborate a design unit. 48 Action_Elaborate, 49 50 -- Elaborate a design. 51 Action_Pre_Elaborate, 52 53 -- Analyze files and elaborate unit. 54 Action_Anaelab, 55 56 -- Generate code for std.package. 57 Action_Compile_Std_Package 58 ); 59 Action : Action_Type := Action_Compile; 60 61 -- Name of the entity to elaborate. 62 Elab_Entity : Name_Id; 63 -- Name of the architecture to elaborate. 64 Elab_Architecture : Name_Id; 65 -- Filename for the list of files to link. 66 Elab_Filelist : String_Acc; 67 68 Flag_Expect_Failure : Boolean; 69 70 type Id_Link; 71 type Id_Link_Acc is access Id_Link; 72 type Id_Link is record 73 -- If true, ID is the name of a library (for --work=LIB) 74 -- If false, ID is the name of a file. 75 Is_Library : Boolean; 76 Id : Name_Id; 77 Link : Id_Link_Acc; 78 end record; 79 Anaelab_Files : Id_Link_Acc := null; 80 Anaelab_Files_Last : Id_Link_Acc := null; 81 82 procedure Init is 83 begin 84 -- Set program name for error message. 85 Errorout.Console.Install_Handler; 86 87 -- Initialize. 88 Trans_Be.Register_Translation_Back_End; 89 90 Options.Initialize; 91 92 Elab_Filelist := null; 93 Elab_Entity := Null_Identifier; 94 Elab_Architecture := Null_Identifier; 95 Flag_Expect_Failure := False; 96 end Init; 97 98 function Decode_Elab_Option (Arg : String_Acc; Cmd : String) 99 return Natural is 100 begin 101 Elab_Architecture := Null_Identifier; 102 -- Entity (+ architecture) to elaborate 103 if Arg = null then 104 Error_Msg_Option 105 ("entity or configuration name required after " & Cmd); 106 return 0; 107 end if; 108 if Arg (Arg.all'Last) = ')' then 109 -- Name is ENTITY(ARCH). 110 -- Split. 111 declare 112 P : Natural; 113 Len : Natural; 114 Is_Ext : Boolean; 115 begin 116 P := Arg.all'Last - 1; 117 Len := P - Arg.all'First + 1; 118 -- Must be at least 'e(a)'. 119 if Len < 4 then 120 Error_Msg_Option ("ill-formed name after " & Cmd); 121 return 0; 122 end if; 123 -- Handle extended name. 124 if Arg (P) = '\' then 125 P := P - 1; 126 Is_Ext := True; 127 else 128 Is_Ext := False; 129 end if; 130 loop 131 if P = Arg.all'First then 132 Error_Msg_Option ("ill-formed name after " & Cmd); 133 return 0; 134 end if; 135 exit when Arg (P) = '(' and Is_Ext = False; 136 if Arg (P) = '\' then 137 if Arg (P - 1) = '\' then 138 P := P - 2; 139 elsif Arg (P - 1) = '(' then 140 P := P - 1; 141 exit; 142 else 143 Error_Msg_Option ("ill-formed name after " & Cmd); 144 return 0; 145 end if; 146 else 147 P := P - 1; 148 end if; 149 end loop; 150 Elab_Architecture := 151 Name_Table.Get_Identifier (Arg (P + 1 .. Arg'Last - 1)); 152 Elab_Entity := 153 Name_Table.Get_Identifier (Arg (Arg'First .. P - 1)); 154 end; 155 else 156 Elab_Entity := Name_Table.Get_Identifier (Arg.all); 157 Elab_Architecture := Null_Identifier; 158 end if; 159 return 2; 160 end Decode_Elab_Option; 161 162 function Decode_Option (Opt : String_Acc; Arg: String_Acc) return Natural 163 is 164 pragma Assert (Opt'First = 1); 165 begin 166 if Opt.all = "--compile-standard" then 167 Action := Action_Compile_Std_Package; 168 Flags.Bootstrap := True; 169 return 1; 170 elsif Opt.all = "--elab" then 171 if Action /= Action_Compile then 172 Error_Msg_Option ("several --elab options"); 173 return 0; 174 end if; 175 Action := Action_Elaborate; 176 return Decode_Elab_Option (Arg, "--elab"); 177 elsif Opt.all = "--pre-elab" then 178 if Action /= Action_Compile then 179 Error_Msg_Option ("several --pre-elab options"); 180 return 0; 181 end if; 182 Action := Action_Pre_Elaborate; 183 return Decode_Elab_Option (Arg, "--pre-elab"); 184 elsif Opt.all = "--anaelab" then 185 if Action /= Action_Compile then 186 Error_Msg_Option ("several --anaelab options"); 187 return 0; 188 end if; 189 Action := Action_Anaelab; 190 return Decode_Elab_Option (Arg, "--anaelab"); 191 elsif Opt'Length > 14 192 and then Opt (Opt'First .. Opt'First + 13) = "--ghdl-source=" 193 then 194 if Action /= Action_Anaelab then 195 Error_Msg_Option 196 ("--ghdl-source option allowed only after --anaelab options"); 197 return 0; 198 end if; 199 declare 200 L : Id_Link_Acc; 201 begin 202 if Opt'Length > 15 203 and then Opt (Opt'First + 14 .. Opt'First + 20) = "--work=" 204 then 205 L := new Id_Link' (Is_Library => True, 206 Id => Libraries.Decode_Work_Option 207 (Opt (Opt'First + 14 .. Opt'Last)), 208 Link => null); 209 if L.Id = Null_Identifier then 210 return 0; 211 end if; 212 else 213 L := new Id_Link'(Is_Library => False, 214 Id => Name_Table.Get_Identifier 215 (Opt (Opt'First + 14 .. Opt'Last)), 216 Link => null); 217 end if; 218 219 if Anaelab_Files = null then 220 Anaelab_Files := L; 221 else 222 Anaelab_Files_Last.Link := L; 223 end if; 224 Anaelab_Files_Last := L; 225 end; 226 return 1; 227 elsif Opt.all = "-l" then 228 if Arg = null then 229 Error_Msg_Option ("filename required after -l"); 230 end if; 231 if Elab_Filelist /= null then 232 Error_Msg_Option ("several -l options"); 233 else 234 Elab_Filelist := new String'(Arg.all); 235 end if; 236 return 2; 237 elsif Opt.all = "--help" then 238 Options.Disp_Options_Help; 239 return 1; 240 elsif Opt.all = "--expect-failure" then 241 Flag_Expect_Failure := True; 242 return 1; 243 elsif Opt'Length > 7 and then Opt (1 .. 7) = "--ghdl-" then 244 declare 245 subtype Str_Type is String (1 .. Opt'Last - 6); 246 begin 247 -- The option parameter must be normalized (starts at index 1). 248 if Parse_Option (Str_Type (Opt (7 .. Opt'Last))) = Option_Ok then 249 return 1; 250 else 251 return 0; 252 end if; 253 end; 254 elsif Options.Parse_Option (Opt.all) = Option_Ok then 255 return 1; 256 else 257 return 0; 258 end if; 259 end Decode_Option; 260 261 -- Add dependencies of UNIT to DEP_LIST. UNIT is not added to DEP_LIST. 262 procedure Add_Dependence (Unit : Iir_Design_Unit; Dep_List : Iir_List) 263 is 264 List : constant Iir_List := Get_Dependence_List (Unit); 265 It : List_Iterator; 266 El : Iir; 267 begin 268 It := List_Iterate_Safe (List); 269 while Is_Valid (It) loop 270 El := Get_Element (It); 271 El := Get_Unit_From_Dependence (El); 272 273 if not Get_Configuration_Mark_Flag (El) then 274 -- EL is not in the list. 275 Add_Dependence (El, Dep_List); 276 277 -- Add to the list (only once). 278 Set_Configuration_Mark_Flag (El, True); 279 Append_Element (Dep_List, El); 280 end if; 281 Next (It); 282 end loop; 283 end Add_Dependence; 284 285 procedure Do_Compile (Vhdl_File : Name_Id) 286 is 287 Res : Iir_Design_File; 288 New_Design_File : Iir_Design_File; 289 Design : Iir_Design_Unit; 290 Next_Design : Iir_Design_Unit; 291 Prev_Design : Iir_Design_Unit; 292 293 -- List of dependencies. 294 Dep_List : Iir_List; 295 Dep_It : List_Iterator; 296 begin 297 -- Do not elaborate. 298 Flags.Flag_Elaborate := False; 299 300 -- Read and parse the file. 301 Res := Load_File_Name (Vhdl_File); 302 if Errorout.Nbr_Errors > 0 then 303 raise Compilation_Error; 304 end if; 305 306 -- Analyze all design units. 307 -- FIXME: outdate the design file? 308 New_Design_File := Null_Iir; 309 Design := Get_First_Design_Unit (Res); 310 while Is_Valid (Design) loop 311 -- Analyze and canon a design unit. 312 Finish_Compilation (Design, True); 313 314 Next_Design := Get_Chain (Design); 315 if Errorout.Nbr_Errors = 0 then 316 Set_Chain (Design, Null_Iir); 317 Libraries.Add_Design_Unit_Into_Library (Design); 318 New_Design_File := Get_Design_File (Design); 319 end if; 320 321 Design := Next_Design; 322 end loop; 323 324 if Errorout.Nbr_Errors > 0 then 325 raise Compilation_Error; 326 end if; 327 328 -- Must have at least one design unit 329 pragma Assert (Is_Valid (New_Design_File)); 330 331 -- Do late analysis checks. 332 Design := Get_First_Design_Unit (New_Design_File); 333 while Is_Valid (Design) loop 334 Vhdl.Sem.Sem_Analysis_Checks_List 335 (Design, Is_Warning_Enabled (Warnid_Delayed_Checks)); 336 Design := Get_Chain (Design); 337 end loop; 338 339 -- Gather dependencies 340 pragma Assert (Flags.Flag_Elaborate = False); 341 Vhdl.Configuration.Flag_Load_All_Design_Units := False; 342 343 -- Exclude std.standard 344 Set_Configuration_Mark_Flag (Vhdl.Std_Package.Std_Standard_Unit, True); 345 Set_Configuration_Done_Flag (Vhdl.Std_Package.Std_Standard_Unit, True); 346 347 Dep_List := Create_Iir_List; 348 349 Design := Get_First_Design_Unit (New_Design_File); 350 Prev_Design := Null_Iir; 351 Set_First_Design_Unit (New_Design_File, Null_Iir); 352 Set_Last_Design_Unit (New_Design_File, Null_Iir); 353 while Is_Valid (Design) loop 354 -- Unlink. 355 Next_Design := Get_Chain (Design); 356 Set_Chain (Design, Null_Iir); 357 358 -- Discard obsolete units. 359 if Get_Date (Design) /= Date_Obsolete then 360 if Prev_Design = Null_Iir then 361 Set_First_Design_Unit (New_Design_File, Design); 362 else 363 Set_Last_Design_Unit (New_Design_File, Design); 364 Set_Chain (Prev_Design, Design); 365 end if; 366 Prev_Design := Design; 367 368 Add_Dependence (Design, Dep_List); 369 end if; 370 371 Design := Next_Design; 372 end loop; 373 374 if Errorout.Nbr_Errors > 0 then 375 -- Errors can happen (missing package body for instantiation). 376 raise Compilation_Error; 377 end if; 378 379 -- Translate declarations of dependencies. 380 Translation.Translate_Standard (False); 381 Dep_It := List_Iterate (Dep_List); 382 while Is_Valid (Dep_It) loop 383 Design := Get_Element (Dep_It); 384 if Get_Design_File (Design) /= New_Design_File then 385 -- Do not yet translate units to be compiled. They can appear as 386 -- dependencies. 387 Translation.Translate (Design, False); 388 end if; 389 Next (Dep_It); 390 end loop; 391 392 -- Compile only now. 393 -- Note: the order of design unit is kept. 394 Design := Get_First_Design_Unit (New_Design_File); 395 while Is_Valid (Design) loop 396 if Get_Kind (Get_Library_Unit (Design)) 397 = Iir_Kind_Configuration_Declaration 398 then 399 -- Defer code generation of configuration declaration. 400 -- (default binding may change between analysis and 401 -- elaboration). 402 Translation.Translate (Design, False); 403 else 404 Translation.Translate (Design, True); 405 end if; 406 407 if Errorout.Nbr_Errors > 0 then 408 -- This can happen (foreign attribute). 409 raise Compilation_Error; 410 end if; 411 412 Design := Get_Chain (Design); 413 end loop; 414 415 -- Save the working library. 416 Libraries.Save_Work_Library; 417 end Do_Compile; 418 419 -- Table of libraries gathered from vhpidirect. 420 function Shlib_Build (Name : String) return String_Acc is 421 begin 422 return new String'(Name); 423 end Shlib_Build; 424 425 function Shlib_Equal (Obj : String_Acc; Param : String) return Boolean is 426 begin 427 return Obj.all = Param; 428 end Shlib_Equal; 429 430 package Shlib_Interning is new Interning 431 (Params_Type => String, 432 Object_Type => String_Acc, 433 Hash => Hash.String_Hash, 434 Build => Shlib_Build, 435 Equal => Shlib_Equal); 436 437 procedure Sem_Foreign_Hook 438 (Decl : Iir; Info : Translation.Foreign_Info_Type) 439 is 440 pragma Unreferenced (Decl); 441 use Translation; 442 begin 443 case Info.Kind is 444 when Foreign_Vhpidirect => 445 declare 446 Lib : constant String := 447 Info.Lib_Name (1 .. Info.Lib_Len); 448 Shlib : String_Acc; 449 pragma Unreferenced (Shlib); 450 begin 451 if Info.Lib_Len /= 0 and then Lib /= "null" then 452 Shlib := Shlib_Interning.Get (Lib); 453 end if; 454 end; 455 when Foreign_Intrinsic => 456 null; 457 when Foreign_Unknown => 458 null; 459 end case; 460 end Sem_Foreign_Hook; 461 462 -- Write to file FILELIST all the files that are needed to link the design. 463 procedure Write_File_List (Filelist : String) 464 is 465 use Interfaces.C_Streams; 466 use System; 467 use Vhdl.Configuration; 468 use Name_Table; 469 470 Nul : constant Character := Character'Val (0); 471 Fname : String := Filelist & Nul; 472 Mode : constant String := "wt" & Nul; 473 F : FILEs; 474 R : int; 475 S : size_t; 476 pragma Unreferenced (R, S); -- FIXME 477 Id : Name_Id; 478 Lib : Iir_Library_Declaration; 479 File : Iir_Design_File; 480 Unit : Iir_Design_Unit; 481 begin 482 F := fopen (Fname'Address, Mode'Address); 483 if F = NULL_Stream then 484 Error_Msg_Elab ("cannot open " & Filelist); 485 return; 486 end if; 487 488 -- Clear elab flags on design files. 489 for I in Design_Units.First .. Design_Units.Last loop 490 Unit := Design_Units.Table (I); 491 File := Get_Design_File (Unit); 492 Set_Elab_Flag (File, False); 493 end loop; 494 495 for J in Design_Units.First .. Design_Units.Last loop 496 Unit := Design_Units.Table (J); 497 File := Get_Design_File (Unit); 498 if not Get_Elab_Flag (File) then 499 Set_Elab_Flag (File, True); 500 501 -- Write '>LIBRARY_DIRECTORY'. 502 Lib := Get_Library (File); 503 R := fputc (Character'Pos ('>'), F); 504 Id := Get_Library_Directory (Lib); 505 S := fwrite (Get_Address (Id), 506 size_t (Get_Name_Length (Id)), 1, F); 507 R := fputc (10, F); 508 509 -- Write 'FILENAME'. 510 Id := Get_Design_File_Filename (File); 511 S := fwrite (Get_Address (Id), 512 size_t (Get_Name_Length (Id)), 1, F); 513 R := fputc (10, F); 514 end if; 515 end loop; 516 517 for I in Shlib_Interning.First_Index .. Shlib_Interning.Last_Index loop 518 declare 519 Str : constant String_Acc := Shlib_Interning.Get_By_Index (I); 520 begin 521 R := fputc (Character'Pos ('+'), F); 522 S := fwrite (Str.all'Address, size_t (Str'Length), 1, F); 523 R := fputc (10, F); 524 end; 525 end loop; 526 527 R := fclose (F); 528 end Write_File_List; 529 530 Nbr_Parse : Natural := 0; 531 532 function Parse (Filename : String_Acc) return Boolean 533 is 534 Res : Iir_Design_File; 535 Design : Iir_Design_Unit; 536 Next_Design : Iir_Design_Unit; 537 Config : Iir; 538 begin 539 if Nbr_Parse = 0 then 540 -- Initialize only once... 541 if not Libraries.Load_Std_Library then 542 raise Option_Error; 543 end if; 544 545 -- Here, time_base can be set. 546 Translation.Initialize; 547 548 if Action = Action_Anaelab and then Anaelab_Files /= null then 549 Libraries.Load_Work_Library (True); 550 else 551 Libraries.Load_Work_Library (False); 552 end if; 553 end if; 554 Nbr_Parse := Nbr_Parse + 1; 555 556 case Action is 557 when Action_Elaborate => 558 Flags.Flag_Elaborate := True; 559 Flags.Flag_Only_Elab_Warnings := True; 560 if Elab_Filelist = null then 561 Error_Msg_Option ("missing -l for --elab"); 562 raise Option_Error; 563 end if; 564 565 -- Be sure to collect libraries used for vhpidirect. 566 Trans_Be.Sem_Foreign_Hook := Sem_Foreign_Hook'Access; 567 Shlib_Interning.Init; 568 569 Config := Vhdl.Configuration.Configure 570 (Elab_Entity, Elab_Architecture); 571 if Errorout.Nbr_Errors > 0 then 572 -- This may happen (bad entity for example). 573 raise Compilation_Error; 574 end if; 575 576 Translation.Elaborate (Config, False); 577 578 Write_File_List (Elab_Filelist.all); 579 580 if Errorout.Nbr_Errors > 0 then 581 -- This may happen (bad entity for example). 582 raise Compilation_Error; 583 end if; 584 when Action_Pre_Elaborate => 585 Flags.Flag_Elaborate := True; 586 Flags.Flag_Only_Elab_Warnings := True; 587 if Elab_Filelist = null then 588 Error_Msg_Option ("missing -l for --pre-elab"); 589 raise Option_Error; 590 end if; 591 raise Program_Error; 592 when Action_Anaelab => 593 -- Parse files. 594 if Anaelab_Files = null then 595 Flags.Flag_Elaborate_With_Outdated := False; 596 else 597 Flags.Flag_Elaborate_With_Outdated := True; 598 declare 599 L : Id_Link_Acc; 600 begin 601 L := Anaelab_Files; 602 while L /= null loop 603 if L.Is_Library then 604 Libraries.Work_Library_Name := L.Id; 605 Libraries.Load_Work_Library (True); 606 else 607 Res := Load_File_Name (L.Id); 608 if Errorout.Nbr_Errors > 0 then 609 raise Compilation_Error; 610 end if; 611 612 -- Put units into library. 613 Design := Get_First_Design_Unit (Res); 614 while not Is_Null (Design) loop 615 Next_Design := Get_Chain (Design); 616 Set_Chain (Design, Null_Iir); 617 Libraries.Add_Design_Unit_Into_Library (Design); 618 Design := Next_Design; 619 end loop; 620 end if; 621 L := L.Link; 622 end loop; 623 end; 624 end if; 625 626 Flags.Flag_Elaborate := True; 627 Flags.Flag_Only_Elab_Warnings := False; 628 Config := Vhdl.Configuration.Configure 629 (Elab_Entity, Elab_Architecture); 630 Translation.Elaborate (Config, True); 631 632 if Errorout.Nbr_Errors > 0 then 633 -- This may happen (bad entity for example). 634 raise Compilation_Error; 635 end if; 636 when Action_Compile_Std_Package => 637 if Filename /= null 638 and then Filename.all /= "std_standard.vhdl" 639 then 640 Error_Msg_Option 641 ("--compile-standard is not compatible with a filename"); 642 return False; 643 end if; 644 Translation.Translate_Standard (True); 645 646 when Action_Compile => 647 if Filename = null then 648 Error_Msg_Option ("no input file"); 649 return False; 650 end if; 651 if Nbr_Parse > 1 then 652 Error_Msg_Option ("can compile only one file (file """ & 653 Filename.all & """ ignored)"); 654 return False; 655 end if; 656 Do_Compile (Name_Table.Get_Identifier (Filename.all)); 657 end case; 658 659 if Flag_Expect_Failure then 660 return False; 661 else 662 return True; 663 end if; 664 exception 665 when Compilation_Error => 666 if Flag_Expect_Failure then 667 -- Very brutal... 668 GNAT.OS_Lib.OS_Exit (0); 669 end if; 670 return False; 671 when Option_Error => 672 return False; 673 when E: others => 674 Bug.Disp_Bug_Box (E); 675 raise; 676 end Parse; 677end Ortho_Front; 678