1-- GHDL driver - commands invoking gcc. 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 Ada.Command_Line; use Ada.Command_Line; 18with Interfaces.C_Streams; 19with GNAT.OS_Lib; use GNAT.OS_Lib; 20 21with Types; use Types; 22with Tables; 23with Dyn_Tables; 24with Files_Map; 25with Libraries; 26with Default_Paths; 27with Flags; 28with Simple_IO; use Simple_IO; 29with Name_Table; use Name_Table; 30with Vhdl.Std_Package; 31with Vhdl.Nodes; use Vhdl.Nodes; 32with Vhdl.Configuration; 33with Options; use Options; 34with Ghdlmain; use Ghdlmain; 35with Ghdllocal; use Ghdllocal; 36with Errorout; 37 38package body Ghdldrv is 39 -- Argument table for the tools. 40 -- Each table low bound is 1 so that the length of a table is equal to 41 -- the last bound. 42 package Argument_Table_Pkg is new Dyn_Tables 43 (Table_Component_Type => String_Access, 44 Table_Index_Type => Integer, 45 Table_Low_Bound => 1); 46 use Argument_Table_Pkg; 47 48 -- "-o" string. 49 Dash_o : constant String_Access := new String'("-o"); 50 51 -- "-c" string. 52 Dash_c : constant String_Access := new String'("-c"); 53 54 -- "-quiet" option. 55 Dash_Quiet : constant String_Access := new String'("-quiet"); 56 57 -- "-fpic" option. 58 Dash_Fpic : constant String_Access := new String'("-fpic"); 59 60 -- "-shared" string. 61 Dash_Shared : constant String_Access := new String'("-shared"); 62 63 -- Elaboration mode. 64 type Elab_Mode_Type is 65 (-- Static elaboration (or pre-elaboration). 66 Elab_Static, 67 68 -- Dynamic elaboration: design is elaborated just before being run. 69 Elab_Dynamic); 70 71 type Command_Comp is abstract new Command_Lib with record 72 -- Name of the tools used. 73 Compiler_Cmd : String_Access := null; 74 Post_Processor_Cmd : String_Access := null; 75 Assembler_Cmd : String_Access := null; 76 Linker_Cmd : String_Access := null; 77 78 -- Path of the tools. 79 Compiler_Path : String_Access; 80 Post_Processor_Path : String_Access; 81 Assembler_Path : String_Access; 82 Linker_Path : String_Access; 83 84 -- Set by the '-o' option: the output filename. If the option is not 85 -- present, then null. 86 Output_File : String_Access; 87 88 -- If set, do not assmble 89 Flag_Asm : Boolean; 90 91 -- If true, executed commands are displayed. 92 Flag_Disp_Commands : Boolean; 93 94 -- Flag not quiet 95 Flag_Not_Quiet : Boolean; 96 97 -- True if failure expected. 98 Flag_Expect_Failure : Boolean; 99 100 -- True if create a shared library. 101 Flag_Shared : Boolean; 102 103 -- Default elaboration mode is dynamic. 104 Elab_Mode : Elab_Mode_Type := Elab_Dynamic; 105 106 -- Arguments for tools. 107 Compiler_Args : Argument_Table_Pkg.Instance; 108 Postproc_Args : Argument_Table_Pkg.Instance; 109 Assembler_Args : Argument_Table_Pkg.Instance; 110 Linker_Args : Argument_Table_Pkg.Instance; 111 end record; 112 113 -- Setup GHDL. 114 procedure Init (Cmd : in out Command_Comp); 115 116 -- Handle: 117 -- all ghdl flags. 118 -- some GCC flags. 119 procedure Decode_Option (Cmd : in out Command_Comp; 120 Option : String; 121 Arg : String; 122 Res : out Option_State); 123 124 procedure Disp_Long_Help (Cmd : Command_Comp); 125 126 -- Display the program spawned in Flag_Disp_Commands is TRUE. 127 -- Return the exit status. 128 function My_Spawn_Status 129 (Cmd : Command_Comp'Class; Program_Name : String; Args : Argument_List) 130 return Integer is 131 begin 132 if Cmd.Flag_Disp_Commands then 133 Put (Program_Name); 134 for I in Args'Range loop 135 Put (' '); 136 Put (Args (I).all); 137 end loop; 138 New_Line; 139 end if; 140 return Spawn (Program_Name, Args); 141 end My_Spawn_Status; 142 143 -- Display the program spawned in Flag_Disp_Commands is TRUE. 144 -- Raise COMPILE_ERROR in case of failure. 145 procedure My_Spawn 146 (Cmd : Command_Comp'Class; Program_Name : String; Args : Argument_List) 147 is 148 Status : Integer; 149 begin 150 Status := My_Spawn_Status (Cmd, Program_Name, Args); 151 if Status = 0 then 152 return; 153 elsif Status = 1 then 154 Error ("compilation error"); 155 raise Compile_Error; 156 elsif Status > 127 then 157 Error ("executable killed by a signal"); 158 raise Exec_Error; 159 else 160 Error ("exec error"); 161 raise Exec_Error; 162 end if; 163 end My_Spawn; 164 165 -- Compile FILE with additional argument OPTIONSS. 166 procedure Do_Compile (Cmd : Command_Comp'Class; 167 Options : Argument_List; 168 File : String; 169 In_Work : Boolean) 170 is 171 Obj_File : String_Access; 172 Asm_File : String_Access; 173 Post_File : String_Access; 174 Success : Boolean; 175 begin 176 -- Create post file. 177 if Flag_Postprocess then 178 Post_File := Append_Suffix (File, Post_Suffix, In_Work); 179 end if; 180 181 -- Create asm file. 182 case Backend is 183 when Backend_Gcc => 184 Asm_File := Append_Suffix (File, Asm_Suffix, In_Work); 185 when Backend_Llvm 186 | Backend_Mcode => 187 null; 188 end case; 189 190 -- Create obj file (may not be used, but the condition isn't simple). 191 Obj_File := Append_Suffix (File, Get_Object_Suffix.all, In_Work); 192 193 -- Compile. 194 declare 195 P : Natural; 196 Nbr_Args : constant Natural := 197 Last (Cmd.Compiler_Args) + Options'Length + 5; 198 Args : Argument_List (1 .. Nbr_Args); 199 begin 200 P := 0; 201 for I in First .. Last (Cmd.Compiler_Args) loop 202 P := P + 1; 203 Args (P) := Cmd.Compiler_Args.Table (I); 204 end loop; 205 for I in Options'Range loop 206 P := P + 1; 207 Args (P) := Options (I); 208 end loop; 209 210 -- Add -quiet for gcc, add -c for llvm 211 if not Flag_Postprocess then 212 case Backend is 213 when Backend_Gcc => 214 if not Cmd.Flag_Not_Quiet then 215 P := P + 1; 216 Args (P) := Dash_Quiet; 217 end if; 218 when Backend_Llvm => 219 P := P + 1; 220 Args (P) := Dash_c; 221 when Backend_Mcode => 222 null; 223 end case; 224 end if; 225 226 -- Add -fpic for gcc/llvm. 227 if not Flag_Postprocess 228 and then Default_Paths.Default_Pie 229 then 230 case Backend is 231 when Backend_Gcc 232 | Backend_Llvm => 233 P := P + 1; 234 Args (P) := Dash_Fpic; 235 when Backend_Mcode => 236 null; 237 end case; 238 end if; 239 240 -- Object file (or assembly file). 241 Args (P + 1) := Dash_o; 242 if Flag_Postprocess then 243 Args (P + 2) := Post_File; 244 else 245 case Backend is 246 when Backend_Gcc => 247 Args (P + 2) := Asm_File; 248 when Backend_Mcode 249 | Backend_Llvm => 250 Args (P + 2) := Obj_File; 251 end case; 252 end if; 253 Args (P + 3) := new String'(File); 254 255 My_Spawn (Cmd, Cmd.Compiler_Path.all, Args (1 .. P + 3)); 256 Free (Args (P + 3)); 257 exception 258 when Compile_Error => 259 -- Delete temporary file in case of error. 260 Delete_File (Args (P + 2).all, Success); 261 -- FIXME: delete object file too ? 262 raise; 263 end; 264 265 -- Post-process. 266 if Flag_Postprocess then 267 declare 268 P : Natural; 269 Nbr_Args : constant Natural := Last (Cmd.Postproc_Args) + 5; 270 Args : Argument_List (1 .. Nbr_Args); 271 begin 272 P := 0; 273 for I in First .. Last (Cmd.Postproc_Args) loop 274 P := P + 1; 275 Args (P) := Cmd.Postproc_Args.Table (I); 276 end loop; 277 278 case Backend is 279 when Backend_Gcc => 280 if not Cmd.Flag_Not_Quiet then 281 P := P + 1; 282 Args (P) := Dash_Quiet; 283 end if; 284 when Backend_Llvm => 285 null; 286 when Backend_Mcode => 287 null; 288 end case; 289 290 Args (P + 1) := Dash_o; 291 case Backend is 292 when Backend_Gcc => 293 Args (P + 2) := Asm_File; 294 when Backend_Llvm 295 | Backend_Mcode => 296 Args (P + 2) := Obj_File; 297 end case; 298 Args (P + 3) := Post_File; 299 My_Spawn (Cmd, Cmd.Post_Processor_Path.all, Args (1 .. P + 3)); 300 end; 301 302 Free (Post_File); 303 end if; 304 305 -- Assemble. 306 case Backend is 307 when Backend_Gcc => 308 if Cmd.Flag_Expect_Failure then 309 Delete_File (Asm_File.all, Success); 310 elsif not Cmd.Flag_Asm then 311 declare 312 P : Natural; 313 Nbr_Args : constant Natural := Last (Cmd.Assembler_Args) + 4; 314 Args : Argument_List (1 .. Nbr_Args); 315 Success : Boolean; 316 begin 317 P := 0; 318 for I in First .. Last (Cmd.Assembler_Args) loop 319 P := P + 1; 320 Args (P) := Cmd.Assembler_Args.Table (I); 321 end loop; 322 323 Args (P + 1) := Dash_o; 324 Args (P + 2) := Obj_File; 325 Args (P + 3) := Asm_File; 326 My_Spawn (Cmd, Cmd.Assembler_Path.all, Args (1 .. P + 3)); 327 Delete_File (Asm_File.all, Success); 328 end; 329 end if; 330 when Backend_Mcode 331 | Backend_Llvm => 332 null; 333 end case; 334 335 Free (Asm_File); 336 Free (Obj_File); 337 end Do_Compile; 338 339 -- Table of files to be linked. 340 package Filelist is new Tables 341 (Table_Component_Type => String_Access, 342 Table_Index_Type => Natural, 343 Table_Low_Bound => 1, 344 Table_Initial => 16); 345 346 Link_Obj_Suffix : String_Access; 347 348 -- Read a list of files from file FILENAME. 349 -- Lines starting with a '#' are ignored (comments) 350 -- Lines starting with a '>' are directory lines 351 -- If first character of a line is a '@', it is replaced with 352 -- the lib_prefix_path. 353 -- If TO_OBJ is true, then each file is converted to an object file name 354 -- (suffix is replaced by the object file extension). 355 procedure Add_File_List (Filename : String; To_Obj : Boolean) 356 is 357 use Interfaces.C_Streams; 358 use System; 359 360 -- Replace the first '@' with the machine path. 361 function Substitute (Str : String) return String 362 is 363 begin 364 for I in Str'Range loop 365 if Str (I) = '@' then 366 return Str (Str'First .. I - 1) 367 & Get_Machine_Path_Prefix 368 & Str (I + 1 .. Str'Last); 369 end if; 370 end loop; 371 return Str; 372 end Substitute; 373 374 Dir : String (1 .. max_path_len); 375 Dir_Len : Natural; 376 Line : String (1 .. max_path_len); 377 Stream : Interfaces.C_Streams.FILEs; 378 Mode : constant String := "rt" & Ghdllocal.Nul; 379 L : Natural; 380 File : String_Access; 381 begin 382 Line (1 .. Filename'Length) := Filename; 383 Line (Filename'Length + 1) := Ghdllocal.Nul; 384 Stream := fopen (Line'Address, Mode'Address); 385 if Stream = NULL_Stream then 386 Error ("cannot open " & Filename); 387 raise Compile_Error; 388 end if; 389 Dir_Len := 0; 390 loop 391 exit when fgets (Line'Address, Line'Length, Stream) = NULL_Stream; 392 if Line (1) /= '#' then 393 -- Compute string length. 394 L := 0; 395 while Line (L + 1) /= Ghdllocal.Nul loop 396 L := L + 1; 397 end loop; 398 399 -- Remove trailing NL. 400 while L > 0 and then (Line (L) = ASCII.LF or Line (L) = ASCII.CR) 401 loop 402 L := L - 1; 403 end loop; 404 405 if Line (1) = '>' then 406 Dir_Len := L - 1; 407 Dir (1 .. Dir_Len) := Line (2 .. L); 408 elsif Line (1) = '+' then 409 File := new String'(Line (2 .. L)); 410 Filelist.Append (File); 411 else 412 if To_Obj then 413 File := new String'(Dir (1 .. Dir_Len) 414 & Get_Base_Name (Line (1 .. L)) 415 & Link_Obj_Suffix.all); 416 else 417 File := new String'(Substitute (Line (1 .. L))); 418 end if; 419 420 Filelist.Append (File); 421 422 Dir_Len := 0; 423 end if; 424 end if; 425 end loop; 426 if fclose (Stream) /= 0 then 427 Error ("cannot close " & Filename); 428 end if; 429 end Add_File_List; 430 431 function Get_Object_Filename (File : Iir_Design_File) return String 432 is 433 Dir : Name_Id; 434 Name : Name_Id; 435 begin 436 Dir := Get_Library_Directory (Get_Library (File)); 437 Name := Get_Design_File_Filename (File); 438 return Image (Dir) & Get_Base_Name (Image (Name)) 439 & Get_Object_Suffix.all; 440 end Get_Object_Filename; 441 442 procedure Add_Argument (Inst : in out Instance; Arg : String_Access) is 443 begin 444 Increment_Last (Inst); 445 Inst.Table (Last (Inst)) := Arg; 446 end Add_Argument; 447 448 -- Convert option "-Wx,OPTIONS" to arguments for tool X. 449 procedure Add_Arguments (Inst : in out Instance; Opt : String) is 450 begin 451 Add_Argument (Inst, new String'(Opt (Opt'First + 4 .. Opt'Last))); 452 end Add_Arguments; 453 454 procedure Tool_Not_Found (Name : String) is 455 begin 456 Error ("installation problem: " & Name & " not found"); 457 raise Option_Error; 458 end Tool_Not_Found; 459 460 -- Set the compiler command according to the configuration (and switches). 461 procedure Set_Tools_Name (Cmd : in out Command_Comp'Class) is 462 begin 463 -- Set tools name. 464 if Cmd.Compiler_Cmd = null then 465 if Flag_Postprocess then 466 Cmd.Compiler_Cmd := new String'(Default_Paths.Compiler_Debug); 467 else 468 case Backend is 469 when Backend_Gcc => 470 Cmd.Compiler_Cmd := new String'(Default_Paths.Compiler_Gcc); 471 when Backend_Mcode => 472 Cmd.Compiler_Cmd := 473 new String'(Default_Paths.Compiler_Mcode); 474 when Backend_Llvm => 475 Cmd.Compiler_Cmd := new String'(Default_Paths.Compiler_Llvm); 476 end case; 477 end if; 478 end if; 479 if Cmd.Post_Processor_Cmd = null then 480 Cmd.Post_Processor_Cmd := new String'(Default_Paths.Post_Processor); 481 end if; 482 if Cmd.Assembler_Cmd = null then 483 Cmd.Assembler_Cmd := new String'("as"); 484 end if; 485 if Cmd.Linker_Cmd = null then 486 Cmd.Linker_Cmd := new String'("cc"); 487 end if; 488 end Set_Tools_Name; 489 490 function Locate_Exec_Tool (Toolname : String) return String_Access is 491 begin 492 if Is_Absolute_Path (Toolname) then 493 if Is_Executable_File (Toolname) then 494 return new String'(Toolname); 495 end if; 496 else 497 -- Try from install prefix. This is used at least with gcc when 498 -- ghdl1 is installed in a libexec subdirectory, and also during 499 -- development. 500 if Exec_Prefix /= null then 501 declare 502 Path : constant String := 503 Exec_Prefix.all & Directory_Separator & Toolname; 504 begin 505 if Is_Executable_File (Path) then 506 return new String'(Path); 507 end if; 508 end; 509 end if; 510 511 -- Try from install prefix / bin. This is used at least for 512 -- ghdl1-llvm. 513 if Exec_Prefix /= null then 514 declare 515 Path : constant String := 516 Exec_Prefix.all & Directory_Separator 517 & "bin" & Directory_Separator & Toolname; 518 begin 519 if Is_Executable_File (Path) then 520 return new String'(Path); 521 end if; 522 end; 523 end if; 524 525 -- Try configured prefix. 526 declare 527 Path : constant String := 528 Default_Paths.Install_Prefix & Directory_Separator & Toolname; 529 begin 530 if Is_Executable_File (Path) then 531 return new String'(Path); 532 end if; 533 end; 534 end if; 535 536 -- Search the basename on path. 537 declare 538 Pos : constant Natural := Get_Basename_Pos (Toolname); 539 begin 540 return Locate_Exec_On_Path (Toolname (Pos + 1 .. Toolname'Last)); 541 end; 542 end Locate_Exec_Tool; 543 544 procedure Locate_Tools (Cmd : in out Command_Comp'Class) is 545 begin 546 -- Compiler. 547 Cmd.Compiler_Path := Locate_Exec_Tool (Cmd.Compiler_Cmd.all); 548 if Cmd.Compiler_Path = null then 549 Tool_Not_Found (Cmd.Compiler_Cmd.all); 550 end if; 551 552 -- Postprocessor. 553 if Flag_Postprocess then 554 Cmd.Post_Processor_Path := 555 Locate_Exec_Tool (Cmd.Post_Processor_Cmd.all); 556 if Cmd.Post_Processor_Path = null then 557 Tool_Not_Found (Cmd.Post_Processor_Cmd.all); 558 end if; 559 end if; 560 561 -- Assembler. 562 case Backend is 563 when Backend_Gcc => 564 Cmd.Assembler_Path := Locate_Exec_On_Path (Cmd.Assembler_Cmd.all); 565 if Cmd.Assembler_Path = null and not Cmd.Flag_Asm then 566 Tool_Not_Found (Cmd.Assembler_Cmd.all); 567 end if; 568 when Backend_Llvm 569 | Backend_Mcode => 570 null; 571 end case; 572 573 -- Linker. 574 Cmd.Linker_Path := Locate_Exec_On_Path (Cmd.Linker_Cmd.all); 575 if Cmd.Linker_Path = null then 576 Tool_Not_Found (Cmd.Linker_Cmd.all); 577 end if; 578 end Locate_Tools; 579 580 procedure Setup_Compiler (Cmd : in out Command_Comp'Class; Load : Boolean) 581 is 582 use Libraries; 583 begin 584 Set_Tools_Name (Cmd); 585 if not Setup_Libraries (Load) then 586 raise Option_Error; 587 end if; 588 Locate_Tools (Cmd); 589 for I in 2 .. Get_Nbr_Paths loop 590 Add_Argument (Cmd.Compiler_Args, 591 new String'("-P" & Image (Get_Path (I)))); 592 end loop; 593 end Setup_Compiler; 594 595 procedure Init (Cmd : in out Command_Comp) is 596 begin 597 Init (Command_Lib (Cmd)); 598 599 -- Init options. 600 Cmd.Flag_Not_Quiet := False; 601 Cmd.Flag_Disp_Commands := False; 602 Cmd.Flag_Asm := False; 603 Cmd.Flag_Expect_Failure := False; 604 Cmd.Output_File := null; 605 Cmd.Flag_Shared := False; 606 607 -- Initialize argument tables. 608 Init (Cmd.Compiler_Args, 4); 609 Init (Cmd.Postproc_Args, 4); 610 Init (Cmd.Assembler_Args, 4); 611 Init (Cmd.Linker_Args, 4); 612 end Init; 613 614 procedure Decode_Option (Cmd : in out Command_Comp; 615 Option : String; 616 Arg : String; 617 Res : out Option_State) 618 is 619 Opt : constant String (1 .. Option'Length) := Option; 620 Str : String_Access; 621 begin 622 Res := Option_Unknown; 623 if Opt = "-v" and then Flag_Verbose = False then 624 -- Note: this is also decoded for command_lib, but we set 625 -- Flag_Disp_Commands too. 626 Flag_Verbose := True; 627 --Flags.Verbose := True; 628 Cmd.Flag_Disp_Commands := True; 629 Res := Option_Ok; 630 elsif Opt'Length > 8 and then Opt (1 .. 8) = "--GHDL1=" then 631 Cmd.Compiler_Cmd := new String'(Opt (9 .. Opt'Last)); 632 Res := Option_Ok; 633 elsif Opt'Length > 5 and then Opt (1 .. 5) = "--AS=" then 634 Cmd.Assembler_Cmd := new String'(Opt (6 .. Opt'Last)); 635 Res := Option_Ok; 636 elsif Opt'Length > 7 and then Opt (1 .. 7) = "--LINK=" then 637 Cmd.Linker_Cmd := new String'(Opt (8 .. Opt'Last)); 638 Res := Option_Ok; 639 elsif Opt = "-S" then 640 Cmd.Flag_Asm := True; 641 Res := Option_Ok; 642 elsif Opt = "--post" then 643 Flag_Postprocess := True; 644 Res := Option_Ok; 645 elsif Opt = "-o" then 646 if Arg'Length = 0 then 647 Res := Option_Arg_Req; 648 else 649 Cmd.Output_File := new String'(Arg); 650 Res := Option_Arg; 651 end if; 652 elsif Opt = "-shared" then 653 Cmd.Flag_Shared := True; 654 Res := Option_Ok; 655 elsif Opt = "-m32" then 656 Add_Argument (Cmd.Compiler_Args, new String'("-m32")); 657 Add_Argument (Cmd.Assembler_Args, new String'("--32")); 658 Add_Argument (Cmd.Linker_Args, new String'("-m32")); 659 Decode_Option (Command_Lib (Cmd), Opt, Arg, Res); 660 elsif Opt'Length > 4 661 and then Opt (2) = 'W' and then Opt (4) = ',' 662 then 663 if Opt (3) = 'c' then 664 Add_Arguments (Cmd.Compiler_Args, Opt); 665 elsif Opt (3) = 'a' then 666 Add_Arguments (Cmd.Assembler_Args, Opt); 667 elsif Opt (3) = 'p' then 668 Add_Arguments (Cmd.Postproc_Args, Opt); 669 elsif Opt (3) = 'l' then 670 Add_Arguments (Cmd.Linker_Args, Opt); 671 else 672 Error ("unknown tool name in '-W" & Opt (3) & ",' option"); 673 Res := Option_Err; 674 return; 675 end if; 676 Res := Option_Ok; 677 elsif Opt'Length >= 2 and then Opt (2) = 'g' then 678 -- Debugging option. 679 Str := new String'(Opt); 680 Add_Argument (Cmd.Compiler_Args, Str); 681 Add_Argument (Cmd.Linker_Args, Str); 682 Res := Option_Ok; 683 elsif Opt = "-Q" then 684 Cmd.Flag_Not_Quiet := True; 685 Res := Option_Ok; 686 elsif Opt = "--expect-failure" then 687 Add_Argument (Cmd.Compiler_Args, new String'(Opt)); 688 Cmd.Flag_Expect_Failure := True; 689 Res := Option_Ok; 690 elsif Opt = "-C" then 691 -- Translate -C into --mb-comments, as gcc already has a definition 692 -- for -C. Done before Flags.Parse_Option. 693 Add_Argument (Cmd.Compiler_Args, new String'("--mb-comments")); 694 Res := Option_Ok; 695 elsif Opt = "--pre-elab" then 696 Cmd.Elab_Mode := Elab_Static; 697 Res := Option_Ok; 698 elsif Opt = "--dyn-elab" then 699 Cmd.Elab_Mode := Elab_Dynamic; 700 Res := Option_Ok; 701 elsif Opt'Length > 18 702 and then Opt (1 .. 18) = "--time-resolution=" 703 then 704 Error ("option --time-resolution not supported by back-end"); 705 Res := Option_Err; 706 return; 707 elsif Opt = "--ieee=synopsys" or else Opt = "--ieee=none" then 708 -- Automatically translate the option. 709 if Backend = Backend_Gcc then 710 Add_Argument (Cmd.Compiler_Args, new String'("--ghdl-fsynopsys")); 711 else 712 Add_Argument (Cmd.Compiler_Args, new String'("-fsynopsys")); 713 end if; 714 Flags.Flag_Synopsys := True; 715 Res := Option_Ok; 716 else 717 Res := Options.Parse_Option (Opt); 718 if Res = Option_Ok then 719 if Opt'Length > 2 and then Opt (1 .. 2) = "-P" then 720 -- Discard -Pxxx switches, as they are already added to 721 -- compiler_args. 722 null; 723 else 724 if Backend = Backend_Gcc then 725 -- Prefix options for gcc so that lang.opt does need to be 726 -- updated when a new option is added. 727 Str := new String'("--ghdl" & Opt); 728 else 729 Str := new String'(Opt); 730 end if; 731 Add_Argument (Cmd.Compiler_Args, Str); 732 end if; 733 elsif Res = Option_Unknown then 734 if Opt'Length >= 2 735 and then (Opt (2) = 'O' or Opt (2) = 'f') 736 then 737 -- Optimization option supported by gcc/llvm. 738 -- This is put after Flags.Parse_Option, since it may catch 739 -- -fxxx options. 740 Add_Argument (Cmd.Compiler_Args, new String'(Opt)); 741 Res := Option_Ok; 742 else 743 Decode_Option (Command_Lib (Cmd), Opt, Arg, Res); 744 end if; 745 end if; 746 end if; 747 end Decode_Option; 748 749 procedure Disp_Long_Help (Cmd : Command_Comp) is 750 begin 751 Disp_Long_Help (Command_Lib (Cmd)); 752 Put_Line (" -v"); 753 Put_Line (" Be verbose"); 754 Put_Line (" --GHDL1=PATH"); 755 Put_Line (" Set the path of the ghdl1 compiler"); 756 Put_Line (" --AS=as"); 757 Put_Line (" Use as for the assembler"); 758 Put_Line (" --LINK=cc"); 759 Put_Line (" Use cc for the linker driver"); 760 Put_Line (" -S"); 761 Put_Line (" Do not assemble"); 762 Put_Line (" -o FILE"); 763 Put_Line (" Set the name of the output file"); 764 -- Put_Line (" -m32 Generate 32bit code on 64bit machines"); 765 Put_Line (" -WX,OPTION"); 766 Put_Line (" Pass OPTION to X, where X is one of"); 767 Put_Line (" c: compiler, a: assembler, l: linker"); 768 Put_Line (" -g[XX]"); 769 Put_Line (" Pass debugging option to the compiler"); 770 Put_Line (" -O[XX]/-f[XX]"); 771 Put_Line (" Pass optimization option to the compiler"); 772 Put_Line (" -Q"); 773 Put_Line (" Do not add -quiet option to compiler"); 774 Put_Line (" --expect-failure"); 775 Put_Line (" Expect analysis/elaboration failure"); 776 end Disp_Long_Help; 777 778 -- Command dispconfig. 779 type Command_Dispconfig is new Command_Comp with null record; 780 function Decode_Command (Cmd : Command_Dispconfig; Name : String) 781 return Boolean; 782 function Get_Short_Help (Cmd : Command_Dispconfig) return String; 783 procedure Perform_Action (Cmd : in out Command_Dispconfig; 784 Args : Argument_List); 785 786 function Decode_Command (Cmd : Command_Dispconfig; Name : String) 787 return Boolean 788 is 789 pragma Unreferenced (Cmd); 790 begin 791 return Name = "disp-config" 792 or else Name = "--disp-config" 793 or else Name = "dispconfig" 794 or else Name = "--dispconfig"; 795 end Decode_Command; 796 797 function Get_Short_Help (Cmd : Command_Dispconfig) return String 798 is 799 pragma Unreferenced (Cmd); 800 begin 801 return "disp-config" 802 & ASCII.LF & " Display tools path" 803 & ASCII.LF & " aliases: --disp-config, dispconfig, --dispconfig"; 804 end Get_Short_Help; 805 806 procedure Perform_Action (Cmd : in out Command_Dispconfig; 807 Args : Argument_List) 808 is 809 use Libraries; 810 begin 811 if Args'Length /= 0 then 812 Error ("--disp-config does not accept any argument"); 813 raise Option_Error; 814 end if; 815 816 Set_Tools_Name (Cmd); 817 Put_Line ("Paths at configuration:"); 818 Put ("compiler command: "); 819 Put_Line (Cmd.Compiler_Cmd.all); 820 if Flag_Postprocess then 821 Put ("post-processor command: "); 822 Put_Line (Cmd.Post_Processor_Cmd.all); 823 end if; 824 case Backend is 825 when Backend_Gcc => 826 Put ("assembler command: "); 827 Put_Line (Cmd.Assembler_Cmd.all); 828 when Backend_Llvm 829 | Backend_Mcode => 830 null; 831 end case; 832 Put ("linker command: "); 833 Put_Line (Cmd.Linker_Cmd.all); 834 Put_Line ("default lib prefix: " & Default_Paths.Lib_Prefix); 835 836 New_Line; 837 838 Disp_Config_Prefixes; 839 840 Locate_Tools (Cmd); 841 Put ("compiler path: "); 842 Put_Line (Cmd.Compiler_Path.all); 843 if Flag_Postprocess then 844 Put ("post-processor path: "); 845 Put_Line (Cmd.Post_Processor_Path.all); 846 end if; 847 case Backend is 848 when Backend_Gcc => 849 Put ("assembler path: "); 850 Put_Line (Cmd.Assembler_Path.all); 851 when Backend_Llvm 852 | Backend_Mcode => 853 null; 854 end case; 855 Put ("linker path: "); 856 Put_Line (Cmd.Linker_Path.all); 857 858 New_Line; 859 860 Put_Line ("default library paths:"); 861 for I in 2 .. Get_Nbr_Paths loop 862 Put (' '); 863 Put_Line (Image (Get_Path (I))); 864 end loop; 865 end Perform_Action; 866 867 -- Command Bootstrap-standard 868 type Command_Bootstrap is new Command_Comp with null record; 869 function Decode_Command (Cmd : Command_Bootstrap; Name : String) 870 return Boolean; 871 function Get_Short_Help (Cmd : Command_Bootstrap) return String; 872 procedure Perform_Action (Cmd : in out Command_Bootstrap; 873 Args : Argument_List); 874 875 function Decode_Command (Cmd : Command_Bootstrap; Name : String) 876 return Boolean 877 is 878 pragma Unreferenced (Cmd); 879 begin 880 return Name = "bootstrap-std" 881 or else Name = "--bootstrap-standard"; 882 end Decode_Command; 883 884 function Get_Short_Help (Cmd : Command_Bootstrap) return String 885 is 886 pragma Unreferenced (Cmd); 887 begin 888 return "bootstrap-std" 889 & ASCII.LF & " (internal) Compile std.standard" 890 & ASCII.LF & " alias: --bootstrap-standard"; 891 end Get_Short_Help; 892 893 procedure Perform_Action (Cmd : in out Command_Bootstrap; 894 Args : Argument_List) 895 is 896 Opt : Argument_List (1 .. 1); 897 begin 898 if Args'Length /= 0 then 899 Error ("no file allowed for --bootstrap-standard"); 900 raise Option_Error; 901 end if; 902 903 Setup_Compiler (Cmd, False); 904 905 Opt (1) := new String'("--compile-standard"); 906 Do_Compile (Cmd, Opt, "std_standard.vhdl", True); 907 end Perform_Action; 908 909 -- Command Analyze. 910 type Command_Analyze is new Command_Comp with null record; 911 function Decode_Command (Cmd : Command_Analyze; Name : String) 912 return Boolean; 913 function Get_Short_Help (Cmd : Command_Analyze) return String; 914 procedure Perform_Action (Cmd : in out Command_Analyze; 915 Args : Argument_List); 916 917 function Decode_Command (Cmd : Command_Analyze; Name : String) 918 return Boolean 919 is 920 pragma Unreferenced (Cmd); 921 begin 922 return Name = "analyze" 923 or else Name = "-a" 924 or else Name = "analyse"; 925 end Decode_Command; 926 927 function Get_Short_Help (Cmd : Command_Analyze) return String 928 is 929 pragma Unreferenced (Cmd); 930 begin 931 return "analyze [OPTS] FILEs" 932 & ASCII.LF & " Analyze one or multiple VHDL files" 933 & ASCII.LF & " aliases: -a, analyse"; 934 end Get_Short_Help; 935 936 procedure Perform_Action (Cmd : in out Command_Analyze; 937 Args : Argument_List) 938 is 939 Nil_Opt : Argument_List (2 .. 1); 940 begin 941 if Args'Length = 0 then 942 Error ("no file to analyze"); 943 raise Option_Error; 944 end if; 945 946 Expect_Filenames (Args); 947 948 Setup_Compiler (Cmd, False); 949 950 for I in Args'Range loop 951 Do_Compile (Cmd, Nil_Opt, Args (I).all, True); 952 end loop; 953 end Perform_Action; 954 955 -- Elaboration. 956 957 Primary_Id : Name_Id; 958 Secondary_Id : Name_Id; 959 Base_Name : String_Access; 960 Elab_Name : String_Access; 961 Filelist_Name : String_Access; 962 Unit_Name : String_Access; 963 964 procedure Set_Elab_Units (Cmd : in out Command_Comp'Class; 965 Cmd_Name : String; 966 Args : Argument_List; 967 Run_Arg : out Natural) is 968 begin 969 Extract_Elab_Unit (Cmd_Name, Args, Run_Arg, Primary_Id, Secondary_Id); 970 if Secondary_Id = Null_Identifier then 971 Base_Name := new String'(Image (Primary_Id)); 972 Unit_Name := new String'(Image (Primary_Id)); 973 else 974 Base_Name := 975 new String'(Image (Primary_Id) & '-' & Image (Secondary_Id)); 976 Unit_Name := 977 new String'(Image (Primary_Id) & '(' & Image (Secondary_Id) & ')'); 978 end if; 979 980 Filelist_Name := null; 981 982 -- Choose a default name for the executable. 983 if Cmd.Output_File = null then 984 if Cmd.Flag_Shared then 985 Cmd.Output_File := new String' 986 (Base_Name.all & Default_Paths.Shared_Library_Extension); 987 else 988 Cmd.Output_File := new String'(Base_Name.all); 989 end if; 990 end if; 991 992 -- Set a name for the elaboration files. Use the basename of the 993 -- output file, so that parallel builds with different output files 994 -- are allowed. 995 declare 996 Dir_Pos : constant Natural := Get_Basename_Pos (Cmd.Output_File.all); 997 begin 998 Elab_Name := new String' 999 (Cmd.Output_File (Cmd.Output_File'First .. Dir_Pos) 1000 & Elab_Prefix 1001 & Cmd.Output_File (Dir_Pos + 1 .. Cmd.Output_File'Last)); 1002 end; 1003 end Set_Elab_Units; 1004 1005 procedure Set_Elab_Units (Cmd : in out Command_Comp'Class; 1006 Cmd_Name : String; 1007 Args : Argument_List) 1008 is 1009 Next_Arg : Natural; 1010 begin 1011 Set_Elab_Units (Cmd, Cmd_Name, Args, Next_Arg); 1012 if Next_Arg <= Args'Last then 1013 Error ("too many unit names for command '" & Cmd_Name & "'"); 1014 raise Option_Error; 1015 end if; 1016 end Set_Elab_Units; 1017 1018 procedure Bind (Cmd : Command_Comp'Class) 1019 is 1020 Comp_List : Argument_List (1 .. 4); 1021 Elab_Cmd : String_Access; 1022 begin 1023 Filelist_Name := new String'(Elab_Name.all & List_Suffix); 1024 1025 case Cmd.Elab_Mode is 1026 when Elab_Static => 1027 Elab_Cmd := new String'("--pre-elab"); 1028 when Elab_Dynamic => 1029 Elab_Cmd := new String'("--elab"); 1030 end case; 1031 Comp_List (1) := Elab_Cmd; 1032 Comp_List (2) := Unit_Name; 1033 Comp_List (3) := new String'("-l"); 1034 Comp_List (4) := Filelist_Name; 1035 Do_Compile (Cmd, Comp_List, Elab_Name.all, False); 1036 Free (Comp_List (3)); 1037 Free (Comp_List (1)); 1038 end Bind; 1039 1040 procedure Bind_Anaelab (Cmd : Command_Comp'Class; Files : Argument_List) 1041 is 1042 Comp_List : Argument_List (1 .. Files'Length + 2); 1043 Index : Natural; 1044 begin 1045 Comp_List (1) := new String'("--anaelab"); 1046 Comp_List (2) := Unit_Name; 1047 Index := 3; 1048 for I in Files'Range loop 1049 Comp_List (Index) := new String'("--ghdl-source=" & Files (I).all); 1050 Index := Index + 1; 1051 end loop; 1052 Do_Compile (Cmd, Comp_List, Elab_Name.all, False); 1053 Free (Comp_List (1)); 1054 for I in 3 .. Comp_List'Last loop 1055 Free (Comp_List (I)); 1056 end loop; 1057 end Bind_Anaelab; 1058 1059 -- Add PFX.lst from the install lib directory. 1060 procedure Add_Lib_File_List (Pfx : String) is 1061 begin 1062 Add_File_List (Get_Machine_Path_Prefix & Directory_Separator 1063 & Pfx & List_Suffix, False); 1064 end Add_Lib_File_List; 1065 1066 procedure Link 1067 (Cmd : Command_Comp'Class; Add_Std : Boolean; Disp_Only : Boolean) 1068 is 1069 Last_File : Natural; 1070 begin 1071 Link_Obj_Suffix := Get_Object_Suffix; 1072 1073 -- read files list 1074 if Filelist_Name /= null then 1075 Add_File_List (Filelist_Name.all, True); 1076 end if; 1077 Last_File := Filelist.Last; 1078 Add_Lib_File_List ("grt"); 1079 if Cmd.Flag_Shared then 1080 Add_Lib_File_List ("grt-shared"); 1081 else 1082 Add_Lib_File_List ("grt-exec"); 1083 end if; 1084 1085 -- call the linker 1086 declare 1087 P : Natural; 1088 Nbr_Args : constant Natural := 1089 Last (Cmd.Linker_Args) + Filelist.Last + 5; 1090 Args : Argument_List (1 .. Nbr_Args); 1091 Obj_File : String_Access; 1092 Std_File : String_Access; 1093 begin 1094 Obj_File := Append_Suffix (Elab_Name.all, Link_Obj_Suffix.all, False); 1095 P := 0; 1096 Args (P + 1) := Dash_o; 1097 Args (P + 2) := Cmd.Output_File; 1098 Args (P + 3) := Obj_File; 1099 P := P + 3; 1100 if Cmd.Flag_Shared then 1101 P := P + 1; 1102 Args (P) := Dash_Shared; 1103 end if; 1104 if Add_Std then 1105 Std_File := new 1106 String'(Get_Machine_Path_Prefix & Directory_Separator 1107 & "std" & Directory_Separator 1108 & Get_Version_Path & Directory_Separator 1109 & "std_standard" & Link_Obj_Suffix.all); 1110 P := P + 1; 1111 Args (P) := Std_File; 1112 else 1113 Std_File := null; 1114 end if; 1115 1116 -- Object files of the design. 1117 for I in Filelist.First .. Last_File loop 1118 P := P + 1; 1119 Args (P) := Filelist.Table (I); 1120 end loop; 1121 -- User added options. 1122 for I in First .. Last (Cmd.Linker_Args) loop 1123 P := P + 1; 1124 Args (P) := Cmd.Linker_Args.Table (I); 1125 end loop; 1126 -- GRT files (should be the last one, since it contains an 1127 -- optional main). 1128 for I in Last_File + 1 .. Filelist.Last loop 1129 P := P + 1; 1130 Args (P) := Filelist.Table (I); 1131 end loop; 1132 1133 if Disp_Only then 1134 for I in 3 .. P loop 1135 Put_Line (Args (I).all); 1136 end loop; 1137 else 1138 My_Spawn (Cmd, Cmd.Linker_Path.all, Args (1 .. P)); 1139 end if; 1140 1141 Free (Obj_File); 1142 Free (Std_File); 1143 end; 1144 1145 for I in Filelist.First .. Filelist.Last loop 1146 Free (Filelist.Table (I)); 1147 end loop; 1148 end Link; 1149 1150 -- Command Elab. 1151 type Command_Elab is new Command_Comp with null record; 1152 function Decode_Command (Cmd : Command_Elab; Name : String) 1153 return Boolean; 1154 function Get_Short_Help (Cmd : Command_Elab) return String; 1155 procedure Perform_Action (Cmd : in out Command_Elab; 1156 Args : Argument_List); 1157 1158 function Decode_Command (Cmd : Command_Elab; Name : String) 1159 return Boolean 1160 is 1161 pragma Unreferenced (Cmd); 1162 begin 1163 return Name = "elaborate" 1164 or else Name = "-e"; 1165 end Decode_Command; 1166 1167 function Get_Short_Help (Cmd : Command_Elab) return String 1168 is 1169 pragma Unreferenced (Cmd); 1170 begin 1171 return "elaborate [OPTS] UNIT [ARCH]" 1172 & ASCII.LF & " Elaborate design UNIT" 1173 & ASCII.LF & " alias: -e"; 1174 end Get_Short_Help; 1175 1176 procedure Perform_Action (Cmd : in out Command_Elab; Args : Argument_List) 1177 is 1178 Success : Boolean; 1179 pragma Unreferenced (Success); 1180 begin 1181 Set_Elab_Units (Cmd, "-e", Args); 1182 Setup_Compiler (Cmd, False); 1183 1184 Bind (Cmd); 1185 if not Cmd.Flag_Expect_Failure then 1186 Link (Cmd, Add_Std => True, Disp_Only => False); 1187 end if; 1188 Delete_File (Filelist_Name.all, Success); 1189 end Perform_Action; 1190 1191 -- Command Run. 1192 type Command_Run is new Command_Comp with null record; 1193 function Decode_Command (Cmd : Command_Run; Name : String) 1194 return Boolean; 1195 function Get_Short_Help (Cmd : Command_Run) return String; 1196 procedure Perform_Action (Cmd : in out Command_Run; 1197 Args : Argument_List); 1198 1199 function Decode_Command (Cmd : Command_Run; Name : String) 1200 return Boolean 1201 is 1202 pragma Unreferenced (Cmd); 1203 begin 1204 return Name = "run" 1205 or else Name = "-r"; 1206 end Decode_Command; 1207 1208 function Get_Short_Help (Cmd : Command_Run) return String 1209 is 1210 pragma Unreferenced (Cmd); 1211 begin 1212 return "run UNIT [ARCH] [RUNOPTS]" 1213 & ASCII.LF & " Run design UNIT" 1214 & ASCII.LF & " alias: -r"; 1215 end Get_Short_Help; 1216 1217 procedure Run_Design 1218 (Cmd : Command_Comp'Class; Exec : String_Access; Args : Argument_List) 1219 is 1220 Status : Integer; 1221 begin 1222 if Is_Absolute_Path (Exec.all) then 1223 Status := My_Spawn_Status (Cmd, Exec.all, Args); 1224 else 1225 Status := My_Spawn_Status 1226 (Cmd, '.' & Directory_Separator & Exec.all, Args); 1227 end if; 1228 Set_Exit_Status (Exit_Status (Status)); 1229 end Run_Design; 1230 1231 procedure Perform_Action (Cmd : in out Command_Run; Args : Argument_List) 1232 is 1233 Suffix : constant String_Access := Get_Executable_Suffix; 1234 Prim_Id : Name_Id; 1235 Sec_Id : Name_Id; 1236 Opt_Arg : Natural; 1237 begin 1238 Extract_Elab_Unit ("-r", Args, Opt_Arg, Prim_Id, Sec_Id); 1239 if Sec_Id = Null_Identifier then 1240 Base_Name := new String' 1241 (Image (Prim_Id) & Suffix.all); 1242 else 1243 Base_Name := new String' 1244 (Image (Prim_Id) & '-' & Image (Sec_Id) & Suffix.all); 1245 end if; 1246 if not Is_Regular_File (Base_Name.all & Nul) then 1247 Error ("file '" & Base_Name.all & "' does not exist"); 1248 Error ("Please elaborate your design."); 1249 raise Exec_Error; 1250 end if; 1251 Run_Design (Cmd, Base_Name, Args (Opt_Arg .. Args'Last)); 1252 end Perform_Action; 1253 1254 -- Command Elab_Run. 1255 type Command_Elab_Run is new Command_Comp with null record; 1256 function Decode_Command (Cmd : Command_Elab_Run; Name : String) 1257 return Boolean; 1258 function Get_Short_Help (Cmd : Command_Elab_Run) return String; 1259 procedure Perform_Action (Cmd : in out Command_Elab_Run; 1260 Args : Argument_List); 1261 1262 function Decode_Command (Cmd : Command_Elab_Run; Name : String) 1263 return Boolean 1264 is 1265 pragma Unreferenced (Cmd); 1266 begin 1267 return Name = "elab-run" 1268 or else Name = "--elab-run"; 1269 end Decode_Command; 1270 1271 function Get_Short_Help (Cmd : Command_Elab_Run) return String 1272 is 1273 pragma Unreferenced (Cmd); 1274 begin 1275 return "elab-run [OPTS] UNIT [ARCH] [RUNOPTS]" 1276 & ASCII.LF & " Elaborate and run design UNIT" 1277 & ASCII.LF & " alias: --elab-run"; 1278 end Get_Short_Help; 1279 1280 procedure Perform_Action (Cmd : in out Command_Elab_Run; 1281 Args : Argument_List) 1282 is 1283 Success : Boolean; 1284 Run_Arg : Natural; 1285 begin 1286 Set_Elab_Units (Cmd, "--elab-run", Args, Run_Arg); 1287 Setup_Compiler (Cmd, False); 1288 1289 Bind (Cmd); 1290 if Cmd.Flag_Expect_Failure then 1291 Delete_File (Filelist_Name.all, Success); 1292 else 1293 Link (Cmd, Add_Std => True, Disp_Only => False); 1294 Delete_File (Filelist_Name.all, Success); 1295 Run_Design (Cmd, Cmd.Output_File, Args (Run_Arg .. Args'Last)); 1296 end if; 1297 end Perform_Action; 1298 1299 -- Command Bind. 1300 type Command_Bind is new Command_Comp with null record; 1301 function Decode_Command (Cmd : Command_Bind; Name : String) 1302 return Boolean; 1303 function Get_Short_Help (Cmd : Command_Bind) return String; 1304 procedure Perform_Action (Cmd : in out Command_Bind; 1305 Args : Argument_List); 1306 1307 function Decode_Command (Cmd : Command_Bind; Name : String) 1308 return Boolean 1309 is 1310 pragma Unreferenced (Cmd); 1311 begin 1312 return Name = "bind" 1313 or else Name = "--bind"; 1314 end Decode_Command; 1315 1316 function Get_Short_Help (Cmd : Command_Bind) return String 1317 is 1318 pragma Unreferenced (Cmd); 1319 begin 1320 return "bind [OPTS] UNIT [ARCH]" 1321 & ASCII.LF & " Bind design UNIT" 1322 & ASCII.LF & " alias: --bind"; 1323 end Get_Short_Help; 1324 1325 procedure Perform_Action 1326 (Cmd : in out Command_Bind; Args : Argument_List) is 1327 begin 1328 Set_Elab_Units (Cmd, "bind", Args); 1329 Setup_Compiler (Cmd, False); 1330 1331 Bind (Cmd); 1332 end Perform_Action; 1333 1334 -- Command Link. 1335 type Command_Link is new Command_Comp with null record; 1336 function Decode_Command (Cmd : Command_Link; Name : String) 1337 return Boolean; 1338 function Get_Short_Help (Cmd : Command_Link) return String; 1339 procedure Perform_Action (Cmd : in out Command_Link; Args : Argument_List); 1340 1341 function Decode_Command (Cmd : Command_Link; Name : String) 1342 return Boolean 1343 is 1344 pragma Unreferenced (Cmd); 1345 begin 1346 return Name = "link" 1347 or else Name = "--link"; 1348 end Decode_Command; 1349 1350 function Get_Short_Help (Cmd : Command_Link) return String 1351 is 1352 pragma Unreferenced (Cmd); 1353 begin 1354 return "link [OPTS] UNIT [ARCH]" 1355 & ASCII.LF & " Link design UNIT" 1356 & ASCII.LF & " alias: --link"; 1357 end Get_Short_Help; 1358 1359 procedure Perform_Action 1360 (Cmd : in out Command_Link; Args : Argument_List) is 1361 begin 1362 Set_Elab_Units (Cmd, "--link", Args); 1363 Setup_Compiler (Cmd, False); 1364 1365 Filelist_Name := new String'(Elab_Name.all & List_Suffix); 1366 Link (Cmd, Add_Std => True, Disp_Only => False); 1367 end Perform_Action; 1368 1369 1370 -- Command List_Link. 1371 type Command_List_Link is new Command_Comp with null record; 1372 function Decode_Command (Cmd : Command_List_Link; Name : String) 1373 return Boolean; 1374 function Get_Short_Help (Cmd : Command_List_Link) return String; 1375 procedure Perform_Action (Cmd : in out Command_List_Link; 1376 Args : Argument_List); 1377 1378 function Decode_Command (Cmd : Command_List_Link; Name : String) 1379 return Boolean 1380 is 1381 pragma Unreferenced (Cmd); 1382 begin 1383 return Name = "list-link" 1384 or else Name = "--list-link"; 1385 end Decode_Command; 1386 1387 function Get_Short_Help (Cmd : Command_List_Link) return String 1388 is 1389 pragma Unreferenced (Cmd); 1390 begin 1391 return "list-link [OPTS] UNIT [ARCH]" 1392 & ASCII.LF & " List objects file to link UNIT" 1393 & ASCII.LF & " alias: --list-link"; 1394 end Get_Short_Help; 1395 1396 procedure Perform_Action (Cmd : in out Command_List_Link; 1397 Args : Argument_List) is 1398 begin 1399 Set_Elab_Units (Cmd, "--list-link", Args); 1400 Setup_Compiler (Cmd, False); 1401 1402 Filelist_Name := new String'(Elab_Name.all & List_Suffix); 1403 Link (Cmd, Add_Std => True, Disp_Only => True); 1404 end Perform_Action; 1405 1406 1407 -- Command analyze and elaborate 1408 type Command_Anaelab is new Command_Comp with null record; 1409 function Decode_Command (Cmd : Command_Anaelab; Name : String) 1410 return Boolean; 1411 function Get_Short_Help (Cmd : Command_Anaelab) return String; 1412 procedure Decode_Option (Cmd : in out Command_Anaelab; 1413 Option : String; 1414 Arg : String; 1415 Res : out Option_State); 1416 1417 procedure Perform_Action (Cmd : in out Command_Anaelab; 1418 Args : Argument_List); 1419 1420 function Decode_Command (Cmd : Command_Anaelab; Name : String) 1421 return Boolean 1422 is 1423 pragma Unreferenced (Cmd); 1424 begin 1425 return Name = "compile" 1426 or else Name = "-c"; 1427 end Decode_Command; 1428 1429 function Get_Short_Help (Cmd : Command_Anaelab) return String 1430 is 1431 pragma Unreferenced (Cmd); 1432 begin 1433 return "compile [OPTS] FILEs -e UNIT [ARCH]" 1434 & ASCII.LF & " Generate whole sequence to elaborate " 1435 & "design UNIT from FILEs" 1436 & ASCII.LF & " alias: -c"; 1437 end Get_Short_Help; 1438 1439 procedure Decode_Option (Cmd : in out Command_Anaelab; 1440 Option : String; 1441 Arg : String; 1442 Res : out Option_State) is 1443 begin 1444 if Option = "-e" then 1445 Res := Option_End; 1446 return; 1447 else 1448 Decode_Option (Command_Comp (Cmd), Option, Arg, Res); 1449 end if; 1450 end Decode_Option; 1451 1452 procedure Perform_Action (Cmd : in out Command_Anaelab; 1453 Args : Argument_List) 1454 is 1455 Elab_Index : Integer; 1456 Error : Boolean; 1457 begin 1458 Elab_Index := -1; 1459 for I in Args'Range loop 1460 if Args (I).all = "-e" then 1461 Elab_Index := I; 1462 exit; 1463 end if; 1464 end loop; 1465 if Elab_Index < 0 then 1466 -- No elaboration. 1467 Analyze_Files (Args, True, Error); 1468 if Error then 1469 raise Errorout.Compilation_Error; 1470 end if; 1471 else 1472 Set_Elab_Units (Cmd, "-c", Args (Elab_Index + 1 .. Args'Last)); 1473 Setup_Compiler (Cmd, False); 1474 1475 Bind_Anaelab (Cmd, Args (Args'First .. Elab_Index - 1)); 1476 Link (Cmd, Add_Std => False, Disp_Only => False); 1477 end if; 1478 end Perform_Action; 1479 1480 -- Command Make. 1481 type Command_Make is new Command_Comp with record 1482 -- Bind only; don't link 1483 Flag_Bind_Only : Boolean; 1484 1485 -- Disp dependences during make. 1486 Flag_Depend_Unit : Boolean; 1487 1488 -- Force recompilation of units in work library. 1489 Flag_Force : Boolean; 1490 end record; 1491 1492 function Decode_Command (Cmd : Command_Make; Name : String) 1493 return Boolean; 1494 procedure Init (Cmd : in out Command_Make); 1495 procedure Decode_Option (Cmd : in out Command_Make; 1496 Option : String; 1497 Arg : String; 1498 Res : out Option_State); 1499 1500 function Get_Short_Help (Cmd : Command_Make) return String; 1501 procedure Disp_Long_Help (Cmd : Command_Make); 1502 1503 procedure Perform_Action (Cmd : in out Command_Make; 1504 Args : Argument_List); 1505 1506 function Decode_Command (Cmd : Command_Make; Name : String) 1507 return Boolean 1508 is 1509 pragma Unreferenced (Cmd); 1510 begin 1511 return Name = "make" 1512 or else Name = "-m"; 1513 end Decode_Command; 1514 1515 function Get_Short_Help (Cmd : Command_Make) return String 1516 is 1517 pragma Unreferenced (Cmd); 1518 begin 1519 return "make [OPTS] UNIT [ARCH]" 1520 & ASCII.LF & " Make design UNIT" 1521 & ASCII.LF & " alias: -m"; 1522 end Get_Short_Help; 1523 1524 procedure Disp_Long_Help (Cmd : Command_Make) 1525 is 1526 begin 1527 Disp_Long_Help (Command_Comp (Cmd)); 1528 Put_Line (" -b" & ASCII.LF & " Bind only; don't link"); 1529 Put_Line (" -f" & ASCII.LF & " Force recompilation of work units"); 1530 Put_Line (" -Mu" & ASCII.LF & " Disp unit dependences (human format)"); 1531 end Disp_Long_Help; 1532 1533 procedure Init (Cmd : in out Command_Make) is 1534 begin 1535 Init (Command_Comp (Cmd)); 1536 Cmd.Flag_Bind_Only := False; 1537 Cmd.Flag_Depend_Unit := False; 1538 Cmd.Flag_Force := False; 1539 end Init; 1540 1541 procedure Decode_Option (Cmd : in out Command_Make; 1542 Option : String; 1543 Arg : String; 1544 Res : out Option_State) is 1545 begin 1546 if Option = "-b" then 1547 Cmd.Flag_Bind_Only := True; 1548 Res := Option_Ok; 1549 elsif Option = "-Mu" then 1550 Cmd.Flag_Depend_Unit := True; 1551 Res := Option_Ok; 1552 elsif Option = "-f" then 1553 Cmd.Flag_Force := True; 1554 Res := Option_Ok; 1555 else 1556 Decode_Option (Command_Comp (Cmd), Option, Arg, Res); 1557 end if; 1558 end Decode_Option; 1559 1560 Last_Stamp : OS_Time; 1561 Last_Stamp_File : Iir; 1562 1563 function Missing_Object_File (Design_File : Iir_Design_File) return Boolean 1564 is 1565 Name : constant Name_Id := Get_Design_File_Filename (Design_File); 1566 Obj_Pathname : constant String := Get_Object_Filename (Design_File); 1567 Stamp : OS_Time; 1568 begin 1569 Stamp := File_Time_Stamp (Obj_Pathname); 1570 1571 -- If the object file does not exist, recompile the file. 1572 if Stamp = Invalid_Time then 1573 if Flag_Verbose then 1574 Put_Line ("no object file for " & Image (Name)); 1575 end if; 1576 return True; 1577 end if; 1578 1579 -- Keep the time stamp of the most recently analyzed unit. 1580 if Last_Stamp = Invalid_Time or else Stamp > Last_Stamp then 1581 Last_Stamp := Stamp; 1582 Last_Stamp_File := Design_File; 1583 end if; 1584 1585 return False; 1586 end Missing_Object_File; 1587 1588 procedure Perform_Action (Cmd : in out Command_Make; Args : Argument_List) 1589 is 1590 use Vhdl.Configuration; 1591 1592 File : Iir_Design_File; 1593 Unit : Iir; 1594 Lib : Iir_Library_Declaration; 1595 In_Work : Boolean; 1596 1597 Files_List : Iir_List; 1598 Files_It : List_Iterator; 1599 1600 -- Set when a design file has been compiled. 1601 Has_Compiled : Boolean; 1602 1603 Need_Analyze : Boolean; 1604 1605 Need_Elaboration : Boolean; 1606 1607 Stamp : OS_Time; 1608 File_Id : Name_Id; 1609 1610 Nil_Args : Argument_List (2 .. 1); 1611 Success : Boolean; 1612 begin 1613 Set_Elab_Units (Cmd, "-m", Args); 1614 Setup_Compiler (Cmd, True); 1615 1616 -- Create list of files. 1617 Files_List := Build_Dependence (Primary_Id, Secondary_Id); 1618 1619 if Errorout.Nbr_Errors /= 0 then 1620 raise Errorout.Compilation_Error; 1621 end if; 1622 1623 if Cmd.Flag_Depend_Unit then 1624 Put_Line ("Units analysis order:"); 1625 for I in Design_Units.First .. Design_Units.Last loop 1626 Unit := Design_Units.Table (I); 1627 Put (" "); 1628 Disp_Library_Unit (Get_Library_Unit (Unit)); 1629 New_Line; 1630-- Put (" file: "); 1631-- File := Get_Design_File (Unit); 1632-- Put_Line (Image (Get_Design_File_Filename (File))); 1633 end loop; 1634 end if; 1635 if Cmd.Flag_Depend_Unit then 1636 Put_Line ("File analysis order:"); 1637 Files_It := List_Iterate (Files_List); 1638 while Is_Valid (Files_It) loop 1639 Put (" "); 1640 File := Get_Element (Files_It); 1641 Put (Image (Get_Design_File_Filename (File))); 1642 if Flag_Verbose then 1643 Put_Line (":"); 1644 declare 1645 Dep_List : constant Iir_List := 1646 Get_File_Dependence_List (File); 1647 Dep_It : List_Iterator; 1648 Dep_File : Iir; 1649 begin 1650 Dep_It := List_Iterate_Safe (Dep_List); 1651 while Is_Valid (Dep_It) loop 1652 Put (" "); 1653 Dep_File := Get_Element (Dep_It); 1654 Put_Line (Image (Get_Design_File_Filename (Dep_File))); 1655 Next (Dep_It); 1656 end loop; 1657 end; 1658 else 1659 New_Line; 1660 end if; 1661 Next (Files_It); 1662 end loop; 1663 end if; 1664 1665 Has_Compiled := False; 1666 Last_Stamp := Invalid_Time; 1667 1668 Files_It := List_Iterate (Files_List); 1669 while Is_Valid (Files_It) loop 1670 File := Get_Element (Files_It); 1671 1672 if File = Vhdl.Std_Package.Std_Standard_File then 1673 Need_Analyze := False; 1674 elsif Missing_Object_File (File) 1675 or else Source_File_Modified (File) 1676 or else Is_File_Outdated (File) 1677 then 1678 Need_Analyze := True; 1679 else 1680 Need_Analyze := False; 1681 end if; 1682 1683 Lib := Get_Library (File); 1684 In_Work := Lib = Libraries.Work_Library; 1685 1686 if Need_Analyze or else (Cmd.Flag_Force and In_Work) then 1687 File_Id := Get_Design_File_Filename (File); 1688 if not Flag_Verbose then 1689 Put ("analyze "); 1690 Put (Image (File_Id)); 1691 --Disp_Library_Unit (Get_Library_Unit (Unit)); 1692 New_Line; 1693 end if; 1694 1695 if In_Work then 1696 Do_Compile (Cmd, Nil_Args, Image (File_Id), True); 1697 else 1698 declare 1699 use Libraries; 1700 Lib_Args : Argument_List (1 .. 2); 1701 Prev_Workdir : Name_Id; 1702 begin 1703 Prev_Workdir := Work_Directory; 1704 1705 -- Must be set, since used to build the object filename. 1706 Work_Directory := Get_Library_Directory (Lib); 1707 1708 -- Always overwrite --work and --workdir. 1709 Lib_Args (1) := new String' 1710 ("--work=" & Image (Get_Identifier (Lib))); 1711 if Work_Directory = Libraries.Local_Directory then 1712 Lib_Args (2) := new String'("--workdir=."); 1713 else 1714 Lib_Args (2) := new String' 1715 ("--workdir=" & Image (Work_Directory)); 1716 end if; 1717 Do_Compile (Cmd, Lib_Args, Image (File_Id), True); 1718 1719 Work_Directory := Prev_Workdir; 1720 1721 Free (Lib_Args (1)); 1722 Free (Lib_Args (2)); 1723 end; 1724 end if; 1725 1726 Has_Compiled := True; 1727 -- Set the analysis time stamp since the file has just been 1728 -- analyzed. 1729 Set_Analysis_Time_Stamp (File, Files_Map.Get_Os_Time_Stamp); 1730 end if; 1731 Next (Files_It); 1732 end loop; 1733 1734 Need_Elaboration := False; 1735 -- Elaboration. 1736 -- if libgrt is more recent than the executable (FIXME). 1737 if Has_Compiled then 1738 if Flag_Verbose then 1739 Put_Line ("link due to a file compilation"); 1740 end if; 1741 Need_Elaboration := True; 1742 else 1743 Stamp := File_Time_Stamp (Cmd.Output_File.all); 1744 1745 if Stamp = Invalid_Time then 1746 if Flag_Verbose then 1747 Put_Line ("link due to no binary file"); 1748 end if; 1749 Need_Elaboration := True; 1750 else 1751 if Last_Stamp > Stamp then 1752 -- if a file is more recent than the executable. 1753 if Flag_Verbose then 1754 Put ("link due to outdated binary file: "); 1755 Put (Image (Get_Design_File_Filename (Last_Stamp_File))); 1756 New_Line; 1757 end if; 1758 Need_Elaboration := True; 1759 end if; 1760 end if; 1761 end if; 1762 if Need_Elaboration then 1763 if not Flag_Verbose then 1764 Put ("elaborate "); 1765 Put (Image (Primary_Id)); 1766 --Disp_Library_Unit (Get_Library_Unit (Unit)); 1767 New_Line; 1768 end if; 1769 Bind (Cmd); 1770 if not Cmd.Flag_Bind_Only then 1771 Link (Cmd, Add_Std => True, Disp_Only => False); 1772 Delete_File (Filelist_Name.all, Success); 1773 end if; 1774 end if; 1775 exception 1776 when Errorout.Compilation_Error => 1777 if Cmd.Flag_Expect_Failure then 1778 return; 1779 else 1780 raise; 1781 end if; 1782 end Perform_Action; 1783 1784 -- helper for --gen-makefile and --gen-depends 1785 procedure Gen_Makefile (Cmd : in out Command_Comp'Class; 1786 Args : Argument_List; 1787 Only_Depends : Boolean); 1788 1789 -- Command Gen_Makefile. 1790 type Command_Gen_Makefile is new Command_Comp with null record; 1791 function Decode_Command (Cmd : Command_Gen_Makefile; Name : String) 1792 return Boolean; 1793 function Get_Short_Help (Cmd : Command_Gen_Makefile) return String; 1794 procedure Perform_Action (Cmd : in out Command_Gen_Makefile; 1795 Args : Argument_List); 1796 1797 function Decode_Command (Cmd : Command_Gen_Makefile; Name : String) 1798 return Boolean 1799 is 1800 pragma Unreferenced (Cmd); 1801 begin 1802 return Name = "gen-makefile" 1803 or else Name = "--gen-makefile"; 1804 end Decode_Command; 1805 1806 function Get_Short_Help (Cmd : Command_Gen_Makefile) return String 1807 is 1808 pragma Unreferenced (Cmd); 1809 begin 1810 return "gen-makefile [OPTS] UNIT [ARCH]" 1811 & ASCII.LF & " Generate a Makefile for design UNIT" 1812 & ASCII.LF & " alias: --gen-makefile"; 1813 end Get_Short_Help; 1814 1815 function Is_Makeable_File (File : Iir_Design_File) return Boolean is 1816 begin 1817 if File = Vhdl.Std_Package.Std_Standard_File then 1818 return False; 1819 end if; 1820 return True; 1821 end Is_Makeable_File; 1822 1823 procedure Perform_Action (Cmd : in out Command_Gen_Makefile; 1824 Args : Argument_List) is 1825 begin 1826 Gen_Makefile (Cmd, Args, False); 1827 end Perform_Action; 1828 1829 -- Command Gen_Depends. 1830 type Command_Gen_Depends is new Command_Comp with null record; 1831 function Decode_Command (Cmd : Command_Gen_Depends; Name : String) 1832 return Boolean; 1833 function Get_Short_Help (Cmd : Command_Gen_Depends) return String; 1834 procedure Perform_Action (Cmd : in out Command_Gen_Depends; 1835 Args : Argument_List); 1836 1837 function Decode_Command (Cmd : Command_Gen_Depends; Name : String) 1838 return Boolean 1839 is 1840 pragma Unreferenced (Cmd); 1841 begin 1842 return Name = "gen-depends" 1843 or else Name = "--gen-depends"; 1844 end Decode_Command; 1845 1846 function Get_Short_Help (Cmd : Command_Gen_Depends) return String 1847 is 1848 pragma Unreferenced (Cmd); 1849 begin 1850 return "gen-depends [OPTS] UNIT [ARCH]" 1851 & ASCII.LF & " Generate dependencies of design UNIT" 1852 & ASCII.LF & " alias: --gen-depends"; 1853 end Get_Short_Help; 1854 1855 procedure Perform_Action (Cmd : in out Command_Gen_Depends; 1856 Args : Argument_List) is 1857 begin 1858 Gen_Makefile (Cmd, Args, True); 1859 end Perform_Action; 1860 1861 -- generate a makefile on stdout 1862 -- for --gen-depends (Only_Depends) rules and phony targets are omittted 1863 procedure Gen_Makefile (Cmd : in out Command_Comp'Class; 1864 Args : Argument_List; 1865 Only_Depends : Boolean) 1866 is 1867 HT : constant Character := ASCII.HT; 1868 Files_List : Iir_List; 1869 Files_It : List_Iterator; 1870 File : Iir_Design_File; 1871 1872 Lib : Iir_Library_Declaration; 1873 Dir_Id : Name_Id; 1874 1875 Dep_List : Iir_List; 1876 Dep_It : List_Iterator; 1877 Dep_File : Iir; 1878 begin 1879 if Only_Depends then 1880 Set_Elab_Units (Cmd, "--gen-depends", Args); 1881 else 1882 Set_Elab_Units (Cmd, "--gen-makefile", Args); 1883 end if; 1884 1885 if not Setup_Libraries (True) then 1886 raise Option_Error; 1887 end if; 1888 Files_List := Build_Dependence (Primary_Id, Secondary_Id); 1889 1890 Ghdllocal.Gen_Makefile_Disp_Header; 1891 1892 New_Line; 1893 1894 -- Omit variables. 1895 if not Only_Depends then 1896 Ghdllocal.Gen_Makefile_Disp_Variables; 1897 1898 New_Line; 1899 1900 Put_Line ("# Default target"); 1901 Put ("all: "); 1902 Put_Line (Base_Name.all); 1903 New_Line; 1904 end if; 1905 1906 Put_Line ("# Elaboration target"); 1907 Put (Base_Name.all); 1908 Put (":"); 1909 Files_It := List_Iterate (Files_List); 1910 while Is_Valid (Files_It) loop 1911 File := Get_Element (Files_It); 1912 if Is_Makeable_File (File) then 1913 Put (" "); 1914 Put (Get_Object_Filename (File)); 1915 end if; 1916 Next (Files_It); 1917 end loop; 1918 New_Line; 1919 -- Omit rule. 1920 if not Only_Depends then 1921 Put_Line (HT & "$(GHDL) -e $(GHDLFLAGS) $@"); 1922 end if; 1923 New_Line; 1924 1925 -- Omit phony target. 1926 if not Only_Depends then 1927 Put_Line ("# Run target"); 1928 Put_Line ("run: " & Base_Name.all); 1929 Put_Line (HT & "$(GHDL) -r " & Base_Name.all & " $(GHDLRUNFLAGS)"); 1930 New_Line; 1931 end if; 1932 1933 Put_Line ("# Targets to analyze files"); 1934 Files_It := List_Iterate (Files_List); 1935 while Is_Valid (Files_It) loop 1936 File := Get_Element (Files_It); 1937 Dir_Id := Get_Design_File_Directory (File); 1938 if not Is_Makeable_File (File) then 1939 -- Builtin file. 1940 null; 1941 else 1942 Put (Get_Object_Filename (File)); 1943 Put (": "); 1944 if Dir_Id /= Files_Map.Get_Home_Directory then 1945 Put (Image (Dir_Id)); 1946 Put (Image (Get_Design_File_Filename (File))); 1947 New_Line; 1948 1949 -- Omit dummy rule. 1950 if not Only_Depends then 1951 Put_Line 1952 (HT & "@echo ""This file was not locally built ($<)"""); 1953 Put_Line (HT & "exit 1"); 1954 end if; 1955 else 1956 Put (Image (Get_Design_File_Filename (File))); 1957 New_Line; 1958 1959 -- Omit rule. 1960 if not Only_Depends then 1961 Put (HT & "$(GHDL) -a $(GHDLFLAGS)"); 1962 Lib := Get_Library (File); 1963 if Lib /= Libraries.Work_Library then 1964 -- Overwrite some options. 1965 Put (" --work="); 1966 Put (Image (Get_Identifier (Lib))); 1967 Dir_Id := Get_Library_Directory (Lib); 1968 Put (" --workdir="); 1969 if Dir_Id = Libraries.Local_Directory then 1970 Put ("."); 1971 else 1972 Put (Image (Dir_Id)); 1973 end if; 1974 end if; 1975 Put_Line (" $<"); 1976 end if; 1977 end if; 1978 end if; 1979 Next (Files_It); 1980 end loop; 1981 New_Line; 1982 1983 Put_Line ("# Files dependences"); 1984 Files_It := List_Iterate (Files_List); 1985 while Is_Valid (Files_It) loop 1986 File := Get_Element (Files_It); 1987 if Is_Makeable_File (File) then 1988 Put (Get_Object_Filename (File)); 1989 Put (": "); 1990 Dep_List := Get_File_Dependence_List (File); 1991 Dep_It := List_Iterate_Safe (Dep_List); 1992 while Is_Valid (Dep_It) loop 1993 Dep_File := Get_Element (Dep_It); 1994 if Dep_File /= File and then Is_Makeable_File (Dep_File) 1995 then 1996 Put (" "); 1997 Put (Get_Object_Filename (Dep_File)); 1998 end if; 1999 Next (Dep_It); 2000 end loop; 2001 New_Line; 2002 end if; 2003 Next (Files_It); 2004 end loop; 2005 end Gen_Makefile; 2006 2007 procedure Register_Commands is 2008 begin 2009 Register_Command (new Command_Analyze); 2010 Register_Command (new Command_Elab); 2011 Register_Command (new Command_Run); 2012 Register_Command (new Command_Elab_Run); 2013 Register_Command (new Command_Bind); 2014 Register_Command (new Command_Link); 2015 Register_Command (new Command_List_Link); 2016 Register_Command (new Command_Anaelab); 2017 Register_Command (new Command_Make); 2018 Register_Command (new Command_Gen_Makefile); 2019 Register_Command (new Command_Gen_Depends); 2020 Register_Command (new Command_Dispconfig); 2021 Register_Command (new Command_Bootstrap); 2022 end Register_Commands; 2023end Ghdldrv; 2024