1------------------------------------------------------------------------------ 2-- -- 3-- ASIS-for-GNAT IMPLEMENTATION COMPONENTS -- 4-- -- 5-- A 4 G . C O N T T -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1995-2014, Free Software Foundation, Inc. -- 10-- -- 11-- ASIS-for-GNAT is free software; you can redistribute it and/or modify it -- 12-- under terms of the GNU General Public License as published by the Free -- 13-- Software Foundation; either version 3, or (at your option) any later -- 14-- version. ASIS-for-GNAT is distributed in the hope that it will be -- 15-- useful, but WITHOUT ANY WARRANTY; without even the implied warranty of -- 16-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- 17-- -- 18-- -- 19-- -- 20-- -- 21-- -- 22-- You should have received a copy of the GNU General Public License and -- 23-- a copy of the GCC Runtime Library Exception distributed with GNAT; see -- 24-- the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- 25-- <http://www.gnu.org/licenses/>. -- 26-- -- 27-- ASIS-for-GNAT was originally developed by the ASIS-for-GNAT team at the -- 28-- Software Engineering Laboratory of the Swiss Federal Institute of -- 29-- Technology (LGL-EPFL) in Lausanne, Switzerland, in cooperation with the -- 30-- Scientific Research Computer Center of Moscow State University (SRCC -- 31-- MSU), Russia, with funding partially provided by grants from the Swiss -- 32-- National Science Foundation and the Swiss Academy of Engineering -- 33-- Sciences. ASIS-for-GNAT is now maintained by AdaCore. -- 34-- (http://www.adacore.com). -- 35-- -- 36------------------------------------------------------------------------------ 37 38pragma Ada_2012; 39 40with Ada.Command_Line; 41 42with GNAT.Directory_Operations; 43 44with Asis; use Asis; 45with Asis.Errors; use Asis.Errors; 46with Asis.Exceptions; use Asis.Exceptions; 47with Asis.Extensions; use Asis.Extensions; 48 49with A4G.A_Debug; use A4G.A_Debug; 50with A4G.A_Osint; use A4G.A_Osint; 51with A4G.A_Output; use A4G.A_Output; 52with A4G.Contt.Dp; use A4G.Contt.Dp; 53with A4G.Contt.SD; use A4G.Contt.SD; 54with A4G.Contt.TT; use A4G.Contt.TT; 55with A4G.Contt.UT; use A4G.Contt.UT; 56with A4G.Defaults; use A4G.Defaults; 57with A4G.Vcheck; use A4G.Vcheck; 58 59with Namet; use Namet; 60with Output; use Output; 61 62package body A4G.Contt is 63 64 ------------------------------------------- 65 -- Local Subprograms and Data Structures -- 66 ------------------------------------------- 67 68 procedure Set_Empty_Context (C : Context_Id); 69 -- Set all the attribute of the Context indicated by C as for a 70 -- Context having no associations (being empty) 71 72 procedure Set_Predefined_Units; 73 -- Sets in the Unit Table the unit entries corresponding to the predefined 74 -- Ada environment. For now it sets the entries for the package Standard 75 -- only. 76 77 procedure Print_Context_Search_Dirs 78 (C : Context_Id; 79 Dir_Kind : Search_Dir_Kinds); 80 -- outputs the list of the directories making up the Dir_Kind search path 81 -- for the context C; is intended to be used to produce a part of the 82 -- Context debug output 83 84 procedure Process_Dir (Dir_Name : String; Dir_Kind : Search_Dir_Kinds); 85 -- verifies the part of the context association parameter following the 86 -- two leading "-<option>" by checking if it is the name of the 87 -- existing directory. If this check fails, this routine raises 88 -- ASIS_Failed with Status setting as Parameter_Error (as required by 89 -- Asis.Ada_Environmemts.Associate. Otherwise this value is stored in 90 -- a normalized form in some temporary data structures as a part of the 91 -- search path for the current Context. 92 -- 93 -- For now, normalization consists on appending the directory separator 94 -- for the stored name, if Dir_Name does not end with the separator. 95 -- 96 -- To store the search paths for the given context, the Set_Search_Paths 97 -- procedure should be called after processing all the actual for the 98 -- Parameters parameter of Asis.Ada_Environment.Associate query 99 100 ----------------------------------------------------------------- 101 -- Structures for temporary handling search directories names -- 102 -- during processing the Parameters of the Context Association -- 103 ----------------------------------------------------------------- 104 105 type Dir_Rec; 106 107 type Link is access Dir_Rec; 108 109 type Dir_Rec is record 110 Dir_Name : String_Access; 111 Next : Link; 112 end record; 113 114 type Dir_List is record 115 First : Link; 116 Last : Link; 117 end record; 118 119 Source_Dirs : Dir_List; 120 Object_Dirs : Dir_List; 121 Tree_Dirs : Dir_List; 122 123 Source_Dirs_Count : Natural := 0; 124 Object_Dirs_Count : Natural := 0; 125 Tree_Dirs_Count : Natural := 0; 126 127 procedure Append_Dir (Dirs : in out Dir_List; Dir : Link); 128 -- appends a new element with the directory name to a directory list 129 130 GNSA_Source : String_Ptr; 131 -- Temporary variable for storing the source name for GNSA Context, may 132 -- be used for -C1 Context only, multiple-trees Contexts will need some 133 -- general solution 134 135 Config_File : String_Ptr; 136 -- Here we keep the '-gnatec<file_name> option when processing context 137 -- parameters 138 139 GnatA_Set : Boolean := False; 140 -- Flag indicating if '-gnatA' option is provided as a Context parameter 141 142 -- ??? Handling of '-gnatec and -gnatA Context parameters is really awful 143 -- It was added to the rather hard-wired processing of Context parameters 144 -- coded in the very beginning of the ASIS project. This stuff should be 145 -- reimplemented at some point 146 147 -------------------------- 148 -- Allocate_New_Context -- 149 -------------------------- 150 151 function Allocate_New_Context return Context_Id is 152 C : Context_Id; 153 begin 154 Contexts.Increment_Last; 155 C := Contexts.Last; 156 Set_Empty_Context (C); 157 158 return Contexts.Last; 159 end Allocate_New_Context; 160 161 ---------------- 162 -- Append_Dir -- 163 ---------------- 164 165 procedure Append_Dir (Dirs : in out Dir_List; Dir : Link) is 166 begin 167 if Dirs.First = null then 168 Dirs.First := Dir; 169 else 170 Dirs.Last.Next := Dir; 171 end if; 172 Dirs.Last := Dir; 173 174 end Append_Dir; 175 176 ------------------ 177 -- Context_Info -- 178 ------------------ 179 180 function Context_Info (C : Context_Id) return String is 181 Cont_Id_Image : constant String := Context_Id'Image (C); 182 First_Digit : Natural; 183 begin 184 for I in Cont_Id_Image'Range loop 185 if Cont_Id_Image (I) /= ' ' then 186 First_Digit := I; 187 exit; 188 end if; 189 end loop; 190 191 return "ASIS Context " & 192 Cont_Id_Image (First_Digit .. Cont_Id_Image'Last); 193 end Context_Info; 194 195 --------------- 196 -- Erase_Old -- 197 --------------- 198 199 procedure Erase_Old (C : Context_Id) is 200 begin 201 -- Old (previously associated) Context Name and Parameter values 202 Free (Contexts.Table (C).Name); 203 Free (Contexts.Table (C).Parameters); 204 205 Free (Contexts.Table (C).GCC); 206 207 -- Context search paths 208 Free_Argument_List (Contexts.Table (C).Source_Path); 209 Free_Argument_List (Contexts.Table (C).Object_Path); 210 Free_Argument_List (Contexts.Table (C).Tree_Path); 211 -- Context "-I" options for the compiler 212 Free_Argument_List (Contexts.Table (C).Context_I_Options); 213 -- a list of tree files for C1/CN modes (if any) 214 Free_Argument_List (Contexts.Table (C).Context_Tree_Files); 215 216 Cache_EE_Results := False; 217 218 end Erase_Old; 219 220 -------------- 221 -- Finalize -- 222 -------------- 223 224 procedure Finalize is 225 begin 226 for C in First_Context_Id .. Contexts.Last loop 227 Finalize (C); 228 end loop; 229 end Finalize; 230 231 -------------- 232 -- Finalize -- 233 -------------- 234 235 procedure Finalize (C : Context_Id) is 236 begin 237 Reset_Context (C); 238 if Debug_Lib_Model then 239 Print_Context_Info (C); 240 end if; 241 242 if Is_Associated (C) then 243 Erase_Old (C); 244 -- probably, some more cleaning up is needed... 245 end if; 246 -- at least we have to put off these flags: 247 Contexts.Table (C).Is_Associated := False; 248 Contexts.Table (C).Is_Opened := False; 249 end Finalize; 250 251 ---------------------- 252 -- Get_Context_Name -- 253 ---------------------- 254 255 function Get_Context_Name (C : Context_Id) return String is 256 S : constant String_Access := Contexts.Table (C).Name; 257 begin 258 if S = null then 259 return ""; 260 else 261 return S.all; 262 end if; 263 end Get_Context_Name; 264 265 ---------------------------- 266 -- Get_Context_Parameters -- 267 ---------------------------- 268 269 function Get_Context_Parameters (C : Context_Id) return String is 270 S : constant String_Access := Contexts.Table (C).Parameters; 271 begin 272 if S = null then 273 return ""; 274 else 275 return S.all; 276 end if; 277 end Get_Context_Parameters; 278 279 --------------------- 280 -- Get_Current_Cont -- 281 --------------------- 282 283 function Get_Current_Cont return Context_Id is 284 begin 285 return Current_Context; 286 end Get_Current_Cont; 287 288 ---------------------- 289 -- Get_Current_Tree -- 290 ---------------------- 291 292 function Get_Current_Tree return Tree_Id is 293 begin 294 return Current_Tree; 295 end Get_Current_Tree; 296 297 ----------------------- 298 -- Get_Extra_Options -- 299 ----------------------- 300 301 function Get_Extra_Options (C : Context_Id) return Argument_List is 302 begin 303 return Contexts.Table (C).Extra_Options.all; 304 end Get_Extra_Options; 305 306 ---------- 307 -- Hash -- 308 ---------- 309 310 function Hash return Hash_Index_Type is 311 subtype Int_1_12 is Int range 1 .. 12; 312 -- Used to avoid when others on case jump below 313 314 Even_Name_Len : Integer; 315 -- Last even numbered position (used for >12 case) 316 317 begin 318 319 -- Special test for 12 (rather than counting on a when others for the 320 -- case statement below) avoids some Ada compilers converting the case 321 -- statement into successive jumps. 322 323 -- The case of a name longer than 12 characters is handled by taking 324 -- the first 6 odd numbered characters and the last 6 even numbered 325 -- characters 326 327 if A_Name_Len > 12 then 328 Even_Name_Len := (A_Name_Len) / 2 * 2; 329 330 return (((((((((((( 331 Character'Pos (A_Name_Buffer (01))) * 2 + 332 Character'Pos (A_Name_Buffer (Even_Name_Len - 10))) * 2 + 333 Character'Pos (A_Name_Buffer (03))) * 2 + 334 Character'Pos (A_Name_Buffer (Even_Name_Len - 08))) * 2 + 335 Character'Pos (A_Name_Buffer (05))) * 2 + 336 Character'Pos (A_Name_Buffer (Even_Name_Len - 06))) * 2 + 337 Character'Pos (A_Name_Buffer (07))) * 2 + 338 Character'Pos (A_Name_Buffer (Even_Name_Len - 04))) * 2 + 339 Character'Pos (A_Name_Buffer (09))) * 2 + 340 Character'Pos (A_Name_Buffer (Even_Name_Len - 02))) * 2 + 341 Character'Pos (A_Name_Buffer (11))) * 2 + 342 Character'Pos (A_Name_Buffer (Even_Name_Len))) mod Hash_Num; 343 end if; 344 345 -- For the cases of 1-12 characters, all characters participate in the 346 -- hash. The positioning is randomized, with the bias that characters 347 -- later on participate fully (i.e. are added towards the right side). 348 349 case (Int_1_12 (A_Name_Len)) is 350 351 when 1 => 352 return 353 Character'Pos (A_Name_Buffer (1)); 354 355 when 2 => 356 return (( 357 Character'Pos (A_Name_Buffer (1))) * 64 + 358 Character'Pos (A_Name_Buffer (2))) mod Hash_Num; 359 360 when 3 => 361 return ((( 362 Character'Pos (A_Name_Buffer (1))) * 16 + 363 Character'Pos (A_Name_Buffer (3))) * 16 + 364 Character'Pos (A_Name_Buffer (2))) mod Hash_Num; 365 366 when 4 => 367 return (((( 368 Character'Pos (A_Name_Buffer (1))) * 8 + 369 Character'Pos (A_Name_Buffer (2))) * 8 + 370 Character'Pos (A_Name_Buffer (3))) * 8 + 371 Character'Pos (A_Name_Buffer (4))) mod Hash_Num; 372 373 when 5 => 374 return ((((( 375 Character'Pos (A_Name_Buffer (4))) * 8 + 376 Character'Pos (A_Name_Buffer (1))) * 4 + 377 Character'Pos (A_Name_Buffer (3))) * 4 + 378 Character'Pos (A_Name_Buffer (5))) * 8 + 379 Character'Pos (A_Name_Buffer (2))) mod Hash_Num; 380 381 when 6 => 382 return (((((( 383 Character'Pos (A_Name_Buffer (5))) * 4 + 384 Character'Pos (A_Name_Buffer (1))) * 4 + 385 Character'Pos (A_Name_Buffer (4))) * 4 + 386 Character'Pos (A_Name_Buffer (2))) * 4 + 387 Character'Pos (A_Name_Buffer (6))) * 4 + 388 Character'Pos (A_Name_Buffer (3))) mod Hash_Num; 389 390 when 7 => 391 return ((((((( 392 Character'Pos (A_Name_Buffer (4))) * 4 + 393 Character'Pos (A_Name_Buffer (3))) * 4 + 394 Character'Pos (A_Name_Buffer (1))) * 4 + 395 Character'Pos (A_Name_Buffer (2))) * 2 + 396 Character'Pos (A_Name_Buffer (5))) * 2 + 397 Character'Pos (A_Name_Buffer (7))) * 2 + 398 Character'Pos (A_Name_Buffer (6))) mod Hash_Num; 399 400 when 8 => 401 return (((((((( 402 Character'Pos (A_Name_Buffer (2))) * 4 + 403 Character'Pos (A_Name_Buffer (1))) * 4 + 404 Character'Pos (A_Name_Buffer (3))) * 2 + 405 Character'Pos (A_Name_Buffer (5))) * 2 + 406 Character'Pos (A_Name_Buffer (7))) * 2 + 407 Character'Pos (A_Name_Buffer (6))) * 2 + 408 Character'Pos (A_Name_Buffer (4))) * 2 + 409 Character'Pos (A_Name_Buffer (8))) mod Hash_Num; 410 411 when 9 => 412 return ((((((((( 413 Character'Pos (A_Name_Buffer (2))) * 4 + 414 Character'Pos (A_Name_Buffer (1))) * 4 + 415 Character'Pos (A_Name_Buffer (3))) * 4 + 416 Character'Pos (A_Name_Buffer (4))) * 2 + 417 Character'Pos (A_Name_Buffer (8))) * 2 + 418 Character'Pos (A_Name_Buffer (7))) * 2 + 419 Character'Pos (A_Name_Buffer (5))) * 2 + 420 Character'Pos (A_Name_Buffer (6))) * 2 + 421 Character'Pos (A_Name_Buffer (9))) mod Hash_Num; 422 423 when 10 => 424 return (((((((((( 425 Character'Pos (A_Name_Buffer (01))) * 2 + 426 Character'Pos (A_Name_Buffer (02))) * 2 + 427 Character'Pos (A_Name_Buffer (08))) * 2 + 428 Character'Pos (A_Name_Buffer (03))) * 2 + 429 Character'Pos (A_Name_Buffer (04))) * 2 + 430 Character'Pos (A_Name_Buffer (09))) * 2 + 431 Character'Pos (A_Name_Buffer (06))) * 2 + 432 Character'Pos (A_Name_Buffer (05))) * 2 + 433 Character'Pos (A_Name_Buffer (07))) * 2 + 434 Character'Pos (A_Name_Buffer (10))) mod Hash_Num; 435 436 when 11 => 437 return ((((((((((( 438 Character'Pos (A_Name_Buffer (05))) * 2 + 439 Character'Pos (A_Name_Buffer (01))) * 2 + 440 Character'Pos (A_Name_Buffer (06))) * 2 + 441 Character'Pos (A_Name_Buffer (09))) * 2 + 442 Character'Pos (A_Name_Buffer (07))) * 2 + 443 Character'Pos (A_Name_Buffer (03))) * 2 + 444 Character'Pos (A_Name_Buffer (08))) * 2 + 445 Character'Pos (A_Name_Buffer (02))) * 2 + 446 Character'Pos (A_Name_Buffer (10))) * 2 + 447 Character'Pos (A_Name_Buffer (04))) * 2 + 448 Character'Pos (A_Name_Buffer (11))) mod Hash_Num; 449 450 when 12 => 451 return (((((((((((( 452 Character'Pos (A_Name_Buffer (03))) * 2 + 453 Character'Pos (A_Name_Buffer (02))) * 2 + 454 Character'Pos (A_Name_Buffer (05))) * 2 + 455 Character'Pos (A_Name_Buffer (01))) * 2 + 456 Character'Pos (A_Name_Buffer (06))) * 2 + 457 Character'Pos (A_Name_Buffer (04))) * 2 + 458 Character'Pos (A_Name_Buffer (08))) * 2 + 459 Character'Pos (A_Name_Buffer (11))) * 2 + 460 Character'Pos (A_Name_Buffer (07))) * 2 + 461 Character'Pos (A_Name_Buffer (09))) * 2 + 462 Character'Pos (A_Name_Buffer (10))) * 2 + 463 Character'Pos (A_Name_Buffer (12))) mod Hash_Num; 464 465 when others => 466 -- ??? !!! ??? 467 -- this alternative can never been reached, but it looks like 468 -- there is something wrong here with the compiler, it does not 469 -- want to compile the code without this line (up to 3.10b) 470 return 0; 471 472 end case; 473 end Hash; 474 475 --------------- 476 -- I_Options -- 477 --------------- 478 479 function I_Options (C : Context_Id) return Argument_List is 480 Nul_Argument_List : constant Argument_List (1 .. 0) := (others => null); 481 begin 482 if Contexts.Table (C).Context_I_Options = null then 483 return Nul_Argument_List; 484 else 485 return Contexts.Table (C).Context_I_Options.all; 486 end if; 487 end I_Options; 488 489 ---------------- 490 -- Initialize -- 491 ---------------- 492 493 procedure Initialize is 494 begin 495 Contexts.Init; 496 Current_Context := Non_Associated; 497 Current_Tree := Nil_Tree; 498 end Initialize; 499 500 -------------------- 501 -- Pre_Initialize -- 502 -------------------- 503 504 procedure Pre_Initialize (C : Context_Id) is 505 begin 506 507 Backup_Current_Context; 508 509 -- Clearing the Context Hash Table: 510 for J in Hash_Index_Type loop 511 Contexts.Table (C).Hash_Table (J) := No_Unit_Id; 512 end loop; 513 514 -- Initializing Context's internal tables: 515 A_Name_Chars.Init; 516 Unit_Table.Init; 517 Tree_Table.Init; 518 A4G.A_Elists.Initialize; 519 520 Current_Context := C; 521 Current_Tree := Nil_Tree; 522 end Pre_Initialize; 523 524 ---------------- 525 -- Initialize -- 526 ---------------- 527 528 procedure Initialize (C : Context_Id) is 529 begin 530 531 Contexts.Table (C).Opened_At := A_OS_Time; 532 Contexts.Table (C).Specs := 0; 533 Contexts.Table (C).Bodies := 0; 534 535 -- Clearing the Context Hash Table: 536 for J in Hash_Index_Type loop 537 Contexts.Table (C).Hash_Table (J) := No_Unit_Id; 538 end loop; 539 540 Set_Predefined_Units; 541 end Initialize; 542 543 --------------------------- 544 -- Locate_In_Search_Path -- 545 --------------------------- 546 547 function Locate_In_Search_Path 548 (C : Context_Id; 549 File_Name : String; 550 Dir_Kind : Search_Dir_Kinds) 551 return String_Access 552 is 553 Curr_Dir : String_Access; 554 Search_Path : Directory_List_Ptr; 555 begin 556 557 case Dir_Kind is 558 when Source => 559 Search_Path := Contexts.Table (C).Source_Path; 560 when Object => 561 Search_Path := Contexts.Table (C).Object_Path; 562 when Tree => 563 Search_Path := Contexts.Table (C).Tree_Path; 564 end case; 565 566 if Search_Path = null then 567 -- this means that the current directory only should be used 568 -- for locating the file 569 if Is_Regular_File (File_Name) then 570 return new String'(File_Name & ASCII.NUL); 571 else 572 return null; 573 end if; 574 end if; 575 576 -- and here we have to look through the directory search path 577 578 for I in 1 .. Search_Path'Last loop 579 580 Curr_Dir := Search_Path (I); 581 582 if Is_Regular_File 583 (Curr_Dir.all & Directory_Separator & File_Name) 584 then 585 return new String' 586 (Curr_Dir.all & Directory_Separator & 587 File_Name & ASCII.NUL); 588 end if; 589 590 end loop; 591 592 return null; 593 end Locate_In_Search_Path; 594 595 ------------- 596 -- NB_Save -- 597 ------------- 598 599 procedure NB_Save is 600 begin 601 Backup_Name_Len := A_Name_Len; 602 Backup_Name_Buffer (1 .. Backup_Name_Len) := 603 A_Name_Buffer (1 .. A_Name_Len); 604 end NB_Save; 605 606 ---------------- 607 -- NB_Restore -- 608 ---------------- 609 610 procedure NB_Restore is 611 begin 612 A_Name_Len := Backup_Name_Len; 613 A_Name_Buffer (1 .. A_Name_Len) := 614 Backup_Name_Buffer (1 .. Backup_Name_Len); 615 end NB_Restore; 616 617 ------------------------ 618 -- Print_Context_Info -- 619 ------------------------ 620 621 procedure Print_Context_Info is 622 begin 623 Write_Str ("ASIS Context Table - general information:"); 624 Write_Eol; 625 Write_Eol; 626 Write_Str ("The number of contexts which have been allocated: "); 627 Write_Int (Int (Contexts.Last - First_Context_Id + 1)); 628 Write_Eol; 629 Write_Eol; 630 Write_Str ("Default search paths:"); 631 Write_Eol; 632 Write_Eol; 633 Write_Str ("Source search path:"); 634 Write_Eol; 635 Print_Source_Defaults; 636 Write_Eol; 637 Write_Str ("Object/ALI search path:"); 638 Write_Eol; 639 Print_Lib_Defaults; 640 Write_Eol; 641 Write_Str ("Tree search path:"); 642 Write_Eol; 643 Print_Tree_Defaults; 644 Write_Eol; 645 Write_Str ("====================================================="); 646 Write_Eol; 647 648 for C in First_Context_Id .. Contexts.Last loop 649 Print_Context_Info (C); 650 Write_Eol; 651 end loop; 652 653 end Print_Context_Info; 654 655 ------------------------ 656 -- Print_Context_Info -- 657 ------------------------ 658 659 procedure Print_Context_Info (C : Context_Id) is 660 begin 661 Reset_Context (C); 662 Write_Str ("Debug output for context number: "); 663 Write_Int (Int (C)); 664 Write_Eol; 665 666 if C = Non_Associated then 667 Write_Str (" Nil Context, it can never be associated"); 668 Write_Eol; 669 return; 670 end if; 671 672 if Is_Associated (C) then 673 Print_Context_Parameters (C); 674 675 if Is_Opened (C) then 676 Print_Units (C); 677 Print_Trees (C); 678 else 679 Write_Str ("This Context is closed"); 680 Write_Eol; 681 end if; 682 683 else 684 Write_Str ("This Context is dissociated"); 685 Write_Eol; 686 end if; 687 688 end Print_Context_Info; 689 690 ------------------------------ 691 -- Print_Context_Parameters -- 692 ------------------------------ 693 694 procedure Print_Context_Parameters (C : Context_Id) is 695 begin 696 697 Write_Str ("Association parameters for Context number: "); 698 Write_Int (Int (C)); 699 Write_Eol; 700 701 if C = Non_Associated then 702 Write_Str (" Nil Context, it can never be associated"); 703 Write_Eol; 704 return; 705 end if; 706 707 if Is_Associated (C) then 708 Write_Str ("Context name: "); 709 710 if Contexts.Table (C).Name = null or else 711 Contexts.Table (C).Name.all = "" 712 then 713 Write_Str ("no name has been associated"); 714 else 715 Write_Str (Contexts.Table (C).Name.all); 716 end if; 717 718 Write_Eol; 719 720 Write_Str ("Context parameters:"); 721 Write_Eol; 722 723 if Contexts.Table (C).Parameters = null then 724 Write_Str (" no parameter has been associated"); 725 else 726 Write_Str (" " & Contexts.Table (C).Parameters.all); 727 end if; 728 729 Write_Eol; 730 731 Write_Str ("Context Search Dirs:"); 732 Write_Eol; 733 Write_Str ("--------------------"); 734 Write_Eol; 735 Write_Str ("Source Dirs"); 736 Write_Eol; 737 Print_Context_Search_Dirs (C, Source); 738 Write_Eol; 739 740 Write_Str ("The source search path for calling GNAT is "); 741 Write_Eol; 742 743 if Contexts.Table (C).Context_I_Options = null then 744 Write_Str (" no ""-I"" option has been associated"); 745 Write_Eol; 746 else 747 748 for I in 1 .. Contexts.Table (C).Context_I_Options'Last loop 749 Write_Str (" " & 750 Contexts.Table (C).Context_I_Options (I).all); 751 Write_Eol; 752 end loop; 753 754 end if; 755 756 Write_Eol; 757 758 Write_Str ("Object/ALI Dirs"); 759 Write_Eol; 760 Print_Context_Search_Dirs (C, Object); 761 Write_Eol; 762 Write_Eol; 763 Write_Str ("Tree Dirs"); 764 Write_Eol; 765 Print_Context_Search_Dirs (C, Tree); 766 Write_Eol; 767 Write_Eol; 768 else 769 Write_Str ("The Context is dissociated"); 770 Write_Eol; 771 end if; 772 773 end Print_Context_Parameters; 774 775 ------------------------------- 776 -- Print_Context_Search_Dirs -- 777 ------------------------------- 778 779 procedure Print_Context_Search_Dirs 780 (C : Context_Id; 781 Dir_Kind : Search_Dir_Kinds) 782 is 783 Path : Directory_List_Ptr; 784 -- search path to print 785 begin 786 case Dir_Kind is 787 when Source => 788 Path := Contexts.Table (C).Source_Path; 789 when Object => 790 Path := Contexts.Table (C).Object_Path; 791 when Tree => 792 Path := Contexts.Table (C).Tree_Path; 793 end case; 794 795 if Path = null then 796 Write_Str (" No directory has been associated"); 797 return; 798 end if; 799 800 for I in Path'Range loop 801 Write_Str (" " & Path (I).all); 802 Write_Eol; 803 end loop; 804 805 Write_Eol; 806 end Print_Context_Search_Dirs; 807 808 -------------------------------- 809 -- Process_Context_Parameters -- 810 -------------------------------- 811 812 procedure Process_Context_Parameters 813 (Parameters : String; 814 Cont : Context_Id := Non_Associated) 815 is 816 Cont_Parameters : Argument_List_Access; 817 818 C_Set : Boolean := False; 819 F_Set : Boolean := False; 820 S_Set : Boolean := False; 821 GCC_Set : Boolean := False; 822 823 Next_TF_Name : Natural := 0; 824 825 procedure Process_One_Parameter (Param : String); 826 -- incapsulates processing of a separate parameter 827 828 procedure Check_Parameters; 829 -- Checks, that context options are compatible with each other and with 830 -- the presence of tree files (if any). The check made by this procedure 831 -- is not very smart - it detects only one error, and it does not try to 832 -- provide a very detailed diagnostic 833 834 procedure Process_Tree_File_Name (TF_Name : String); 835 -- Checks, that TF_Name has tree file name suffix (.ats or .atb), and 836 -- generates an ASIS warning if this check fails. Stores TF_Name in 837 -- Context_Tree_Files list for the Context Cont. 838 839 procedure Process_Source_File_For_GNSA (SF_Name : String); 840 -- Checks if SF_Name is the name of the regular file, and if it is, 841 -- stores it in the temporary variable 842 843 procedure Process_gnatec_Option (Option : String); 844 -- Checks if the string after '-gnatec' is the name of some file. If 845 -- it is, frees Config_File and stores the -gnatec option into this 846 -- variable. Otherwise raises ASIS_Failed with Status setting as 847 -- Parameter_Error. 848 849 ---------------------- 850 -- Check_Parameters -- 851 ---------------------- 852 853 procedure Check_Parameters is 854 Mode_Str : String := "-C?"; 855 begin 856 -- first, set defaults if needed: 857 if not C_Set then 858 Set_Default_Context_Processing_Mode (Cont); 859 C_Set := True; 860 end if; 861 862 if not F_Set then 863 Set_Default_Tree_Processing_Mode (Cont); 864 F_Set := True; 865 end if; 866 867 if not S_Set then 868 Set_Default_Source_Processing_Mode (Cont); 869 S_Set := True; 870 end if; 871 872 -- Special processing for GNSA mode: 873 874 if Tree_Processing_Mode (Cont) = GNSA and then 875 Context_Processing_Mode (Cont) /= One_Tree 876 then 877 Set_Error_Status 878 (Status => Asis.Errors.Parameter_Error, 879 Diagnosis => "Asis.Ada_Environments.Associate:" 880 & ASIS_Line_Terminator 881 & "only -C1 mode can be set for -GNSA mode"); 882 raise ASIS_Failed; 883 end if; 884 885 case Context_Processing_Mode (Cont) is 886 887 when One_Tree | N_Trees => 888 if Context_Processing_Mode (Cont) = One_Tree then 889 Mode_Str (3) := '1'; 890 else 891 Mode_Str (3) := 'N'; 892 end if; 893 894 if not (Tree_Processing_Mode (Cont) = Pre_Created 895 or else 896 (Tree_Processing_Mode (Cont) = GNSA and then 897 Context_Processing_Mode (Cont) = One_Tree)) 898 then 899 Set_Error_Status 900 (Status => Asis.Errors.Parameter_Error, 901 Diagnosis => "Asis.Ada_Environments.Associate:" 902 & ASIS_Line_Terminator 903 & "only -FT mode can be set for " 904 & Mode_Str & " mode"); 905 raise ASIS_Failed; 906 end if; 907 908 -- Process_Association_Option already checks, that at most one 909 -- tree file can be set for this mode, and here we have to 910 -- check, that at least one tree file is set GNSA is a special 911 -- case at the moment): 912 913 if Last_Tree_File < First_Tree_File and then 914 Tree_Processing_Mode (Cont) /= GNSA 915 then 916 -- this means, that first tree file just has not been 917 -- processed 918 Set_Error_Status 919 (Status => Asis.Errors.Parameter_Error, 920 Diagnosis => "Asis.Ada_Environments.Associate:" 921 & ASIS_Line_Terminator 922 & "no tree file is set for " 923 & Mode_Str & " mode"); 924 raise ASIS_Failed; 925 end if; 926 when Partition => 927 -- for now, this is not implemented :-( 928 Not_Implemented_Yet (Diagnosis => 929 "Asis.Ada_Environments.Associate (-CP option)"); 930 when All_Trees => 931 932 -- all tree processing modes are allowed for All_Trees 933 -- contexts, but no tree files should be explicitly set: 934 935 if Last_Tree_File >= First_Tree_File then 936 -- this means, that at least one tree file has been 937 -- processed 938 Set_Error_Status 939 (Status => Asis.Errors.Parameter_Error, 940 Diagnosis => "Asis.Ada_Environments.Associate:" 941 & ASIS_Line_Terminator 942 & "no tree file must be set for -CA mode"); 943 raise ASIS_Failed; 944 end if; 945 end case; 946 947 if (Tree_Processing_Mode (Cont) = Mixed or else 948 Tree_Processing_Mode (Cont) = On_The_Fly or else 949 Tree_Processing_Mode (Cont) = Incremental or else 950 Tree_Processing_Mode (Cont) = GNSA) 951 and then 952 Source_Processing_Mode (Cont) /= All_Sources 953 then 954 Set_Error_Status 955 (Status => Asis.Errors.Parameter_Error, 956 Diagnosis => "Asis.Ada_Environments.Associate:" 957 & ASIS_Line_Terminator 958 & "only -SA option is allowed if trees can be " 959 & "created on the fly"); 960 raise ASIS_Failed; 961 end if; 962 963 -- If we can create trees on the fly and the GCC field for the given 964 -- context is not set, try to define from the ASIS tool name 965 -- if we have to use some specific gcc 966 967 if (Tree_Processing_Mode (Cont) = Mixed or else 968 Tree_Processing_Mode (Cont) = On_The_Fly or else 969 Tree_Processing_Mode (Cont) = Incremental) 970 and then 971 Contexts.Table (Cont).GCC = null 972 then 973 declare 974 Tool_Name : constant String := 975 GNAT.Directory_Operations.Base_Name 976 (Normalize_Pathname (Ada.Command_Line.Command_Name)); 977 Dash_Idx : Natural := 0; 978 begin 979 980 for J in reverse Tool_Name'Range loop 981 982 if Tool_Name (J) = '-' then 983 Dash_Idx := J; 984 exit; 985 end if; 986 987 end loop; 988 989 if Dash_Idx > 0 then 990 Contexts.Table (Cont).GCC := 991 Locate_Exec_On_Path 992 (Tool_Name (Tool_Name'First .. Dash_Idx) & "gcc"); 993 end if; 994 995 end; 996 997 end if; 998 999 end Check_Parameters; 1000 1001 --------------------------- 1002 -- Process_gnatec_Option -- 1003 --------------------------- 1004 1005 procedure Process_gnatec_Option (Option : String) is 1006 File_Name_Start : Natural := Option'First + 7; 1007 begin 1008 1009 if Option (File_Name_Start) = '=' then 1010 File_Name_Start := File_Name_Start + 1; 1011 end if; 1012 1013 if File_Name_Start <= Option'Last and then 1014 Is_Regular_File (Option (File_Name_Start .. Option'Last)) 1015 then 1016 Free (Config_File); 1017 Config_File := new String'(Option); 1018 else 1019 Set_Error_Status 1020 (Status => Asis.Errors.Parameter_Error, 1021 Diagnosis => "Asis.Ada_Environments.Associate:" 1022 & ASIS_Line_Terminator 1023 & "cannot find configuration pragmas file " 1024 & Option (File_Name_Start .. Option'Last)); 1025 1026 raise ASIS_Failed; 1027 end if; 1028 1029 end Process_gnatec_Option; 1030 1031 --------------------------- 1032 -- Process_One_Parameter -- 1033 --------------------------- 1034 1035 procedure Process_One_Parameter (Param : String) is 1036 Parameter : constant String (1 .. Param'Length) := Param; 1037 Par_Len : constant Positive := Parameter'Length; 1038 1039 procedure Process_Parameter; 1040 procedure Process_Option; 1041 -- Process_Option works if Param starts from '-', and 1042 -- Process_Parameter works otherwise 1043 1044 procedure Process_Parameter is 1045 begin 1046 -- the only parameter currently available for Context association 1047 -- is a tree file (or source file in case of GNSA context) name 1048 1049 -- Special processing for GNSA mode: 1050 1051 if Tree_Processing_Mode (Cont) = GNSA then 1052 Process_Source_File_For_GNSA (Parameter); 1053 return; 1054 end if; 1055 1056 if Last_Tree_File < First_Tree_File then 1057 -- This means, that we've just encountered the first candidate 1058 -- for a tree file name as a part of the Parameters string. 1059 -- Therefore, we should set the default Context, tree and 1060 -- source processing options (if needed) and the corresponding 1061 -- flags: 1062 1063 if not C_Set then 1064 Set_Default_Context_Processing_Mode (Cont); 1065 C_Set := True; 1066 end if; 1067 1068 if not F_Set then 1069 Set_Default_Tree_Processing_Mode (Cont); 1070 F_Set := True; 1071 end if; 1072 1073 if not S_Set then 1074 Set_Default_Source_Processing_Mode (Cont); 1075 S_Set := True; 1076 end if; 1077 else 1078 -- more than one tree file is illegal in -C1 mode 1079 if Context_Processing_Mode (Cont) = One_Tree then 1080 Set_Error_Status 1081 (Status => Asis.Errors.Parameter_Error, 1082 Diagnosis => "Asis.Ada_Environments.Associate:" 1083 & ASIS_Line_Terminator 1084 & "only one tree file is allowed in " 1085 & "-C1 mode"); 1086 raise ASIS_Failed; 1087 end if; 1088 end if; 1089 1090 Process_Tree_File_Name (Parameter); 1091 1092 end Process_Parameter; 1093 1094 procedure Process_Option is 1095 Switch_Char : Character; 1096 begin 1097 1098 if Par_Len < 3 then 1099 goto Wrong_Par; 1100 else 1101 Switch_Char := Parameter (2); 1102 end if; 1103 1104 if Switch_Char = 'C' and then Par_Len = 3 then 1105 1106 if C_Set then 1107 Set_Error_Status 1108 (Status => Asis.Errors.Parameter_Error, 1109 Diagnosis => "Asis.Ada_Environments.Associate:" 1110 & ASIS_Line_Terminator 1111 & "-C option is either misplaced " 1112 & "or duplicated"); 1113 raise ASIS_Failed; 1114 1115 else 1116 Switch_Char := Parameter (3); 1117 1118 case Switch_Char is 1119 when '1' => 1120 Set_Context_Processing_Mode (Cont, One_Tree); 1121 when 'N' => 1122 Set_Context_Processing_Mode (Cont, N_Trees); 1123 when 'P' => 1124 Set_Context_Processing_Mode (Cont, Partition); 1125 when 'A' => 1126 Set_Context_Processing_Mode (Cont, All_Trees); 1127 when others => 1128 goto Wrong_Par; 1129 end case; 1130 1131 C_Set := True; 1132 end if; 1133 1134 elsif Switch_Char = 'F' and then Par_Len = 3 then 1135 1136 if F_Set then 1137 Set_Error_Status 1138 (Status => Asis.Errors.Parameter_Error, 1139 Diagnosis => "Asis.Ada_Environments.Associate:" 1140 & ASIS_Line_Terminator 1141 & "-F option is either misplaced " 1142 & "or duplicated"); 1143 raise ASIS_Failed; 1144 1145 else 1146 Switch_Char := Parameter (3); 1147 1148 case Switch_Char is 1149 when 'S' => 1150 Set_Tree_Processing_Mode (Cont, On_The_Fly); 1151 when 'T' => 1152 Set_Tree_Processing_Mode (Cont, Pre_Created); 1153 when 'M' => 1154 Set_Tree_Processing_Mode (Cont, Mixed); 1155 when 'I' => 1156 Set_Tree_Processing_Mode (Cont, Incremental); 1157 when others => 1158 goto Wrong_Par; 1159 end case; 1160 1161 F_Set := True; 1162 end if; 1163 1164 elsif Switch_Char = 'S' and then Par_Len = 3 then 1165 1166 if S_Set then 1167 Set_Error_Status 1168 (Status => Asis.Errors.Parameter_Error, 1169 Diagnosis => "Asis.Ada_Environments.Associate:" 1170 & ASIS_Line_Terminator 1171 & "-S option is either misplaced" 1172 & " or duplicated"); 1173 raise ASIS_Failed; 1174 else 1175 Switch_Char := Parameter (3); 1176 1177 case Switch_Char is 1178 when 'A' => 1179 Set_Source_Processing_Mode (Cont, All_Sources); 1180 when 'E' => 1181 Set_Source_Processing_Mode (Cont, Existing_Sources); 1182 when 'N' => 1183 Set_Source_Processing_Mode (Cont, No_Sources); 1184 when others => 1185 goto Wrong_Par; 1186 end case; 1187 1188 S_Set := True; 1189 end if; 1190 1191 elsif Switch_Char = 'I' then 1192 Process_Dir (Parameter (3 .. Par_Len), Source); 1193 1194 elsif Switch_Char = 'O' then 1195 Process_Dir (Parameter (3 .. Par_Len), Object); 1196 1197 elsif Switch_Char = 'T' then 1198 Process_Dir (Parameter (3 .. Par_Len), Tree); 1199 1200 elsif Switch_Char = 'g' and then 1201 Par_Len >= 8 and then 1202 Parameter (1 .. 7) = "-gnatec" 1203 then 1204 Process_gnatec_Option (Parameter); 1205 1206 elsif Parameter = "-AOP" then 1207 Set_Use_Default_Trees (Cont, True); 1208 1209 elsif Switch_Char = '-' then 1210 if Parameter (1 .. 6) = "--GCC=" then 1211 1212 if GCC_Set then 1213 Set_Error_Status 1214 (Status => Asis.Errors.Parameter_Error, 1215 Diagnosis => "Asis.Ada_Environments.Associate:" 1216 & ASIS_Line_Terminator 1217 & "--GCC option is duplicated"); 1218 raise ASIS_Failed; 1219 else 1220 GCC_Set := True; 1221 Contexts.Table (Cont).GCC := 1222 Locate_Exec_On_Path (Parameter (7 .. Parameter'Last)); 1223 end if; 1224 elsif Parameter = "--cache_ee" then 1225 Cache_EE_Results := True; 1226 else 1227 goto Wrong_Par; 1228 end if; 1229 1230 elsif Parameter = "-gnatA" then 1231 GnatA_Set := True; 1232 1233 elsif Parameter = "-GNSA" then 1234 -- Special processing for GNSA 1235 1236 Set_Tree_Processing_Mode (Cont, GNSA); 1237 Set_Source_Processing_Mode (Cont, All_Sources); 1238 Set_Context_Processing_Mode (Cont, One_Tree); 1239 F_Set := True; 1240 C_Set := True; 1241 S_Set := True; 1242 else 1243 goto Wrong_Par; 1244 end if; 1245 1246 return; 1247 1248 <<Wrong_Par>> 1249 ASIS_Warning 1250 (Message => "Asis.Ada_Environments.Associate: " 1251 & "unknown option " 1252 & Parameter, 1253 Error => Parameter_Error); 1254 1255 end Process_Option; 1256 1257 begin -- Process_One_Parameter 1258 if Parameter (1) = '-' then 1259 Process_Option; 1260 else 1261 Process_Parameter; 1262 end if; 1263 end Process_One_Parameter; 1264 1265 ---------------------------------- 1266 -- Process_Source_File_For_GNSA -- 1267 ---------------------------------- 1268 1269 procedure Process_Source_File_For_GNSA (SF_Name : String) is 1270 begin 1271 1272 if not Is_Regular_File (SF_Name) then 1273 1274 Set_Error_Status 1275 (Status => Asis.Errors.Parameter_Error, 1276 Diagnosis => "Asis.Ada_Environments.Associate: " 1277 & "file " & SF_Name & "does not exist"); 1278 1279 raise ASIS_Failed; 1280 end if; 1281 1282 Free (GNSA_Source); 1283 GNSA_Source := new String'(SF_Name); 1284 1285 end Process_Source_File_For_GNSA; 1286 1287 ---------------------------- 1288 -- Process_Tree_File_Name -- 1289 ---------------------------- 1290 1291 procedure Process_Tree_File_Name (TF_Name : String) is 1292 TF_First : Positive := TF_Name'First; 1293 TF_Last : Positive := TF_Name'Last; 1294 TF_Len : Positive; 1295 Wrong_Name : Boolean; 1296 T_File_Name : Name_Id; 1297 1298 begin 1299 if TF_Name (TF_First) = '"' 1300 and then 1301 TF_Name (TF_Last) = '"' 1302 then 1303 TF_First := TF_First + 1; 1304 TF_Last := TF_Last - 1; 1305 end if; 1306 1307 TF_Len := TF_Last - TF_First + 1; 1308 1309 Wrong_Name := not ( 1310 TF_Len >= 5 1311 and then 1312 (TF_Name (TF_Last) = 't' or else TF_Name (TF_Last) = 'T') 1313 and then 1314 (TF_Name (TF_Last - 1) = 'd' 1315 or else TF_Name (TF_Last - 1) = 'D') 1316 and then 1317 (TF_Name (TF_Last - 2) = 'a' 1318 or else TF_Name (TF_Last - 2) = 'A') 1319 and then 1320 TF_Name (TF_Last - 3) = '.'); 1321 1322 if Wrong_Name then 1323 ASIS_Warning 1324 (Message => "Asis.Ada_Environments.Associate: " 1325 & TF_Name 1326 & " does not have a form of a tree file name", 1327 Error => Parameter_Error); 1328 end if; 1329 1330 for I in TF_First .. TF_Last loop 1331 Name_Buffer (I) := TF_Name (I); 1332 end loop; 1333 1334 Name_Len := TF_Len; 1335 1336 T_File_Name := Name_Find; 1337 1338 if T_File_Name > Last_Tree_File then 1339 Last_Tree_File := T_File_Name; 1340 Next_TF_Name := Next_TF_Name + 1; 1341 Contexts.Table (Cont).Context_Tree_Files (Next_TF_Name) := 1342 new String'(TF_Name (TF_First .. TF_Last)); 1343 end if; 1344 1345 end Process_Tree_File_Name; 1346 1347 begin -- Process_Context_Parameters 1348 1349 Free (Config_File); 1350 GnatA_Set := False; 1351 1352 if Tree_Processing_Mode (Cont) /= GNSA then 1353 -- In GNSA mode we should not destroy the GNAT name table. 1354 -- ??? But why? We run GNSA after that? 1355 -- Should be revised for non -C1 GNSA modes, if any 1356 1357 Namet.Initialize; -- ??? 1358 First_Tree_File := First_Name_Id; 1359 Last_Tree_File := First_Name_Id - 1; 1360 end if; 1361 1362 Set_Use_Default_Trees (Cont, False); 1363 1364 if Parameters /= "" then 1365 1366 Cont_Parameters := Parameter_String_To_List (Parameters); 1367 1368 Contexts.Table (Cont).Context_Tree_Files := 1369 new Argument_List (1 .. Cont_Parameters'Length); 1370 1371 for I in Cont_Parameters'Range loop 1372 Process_One_Parameter (Cont_Parameters (I).all); 1373 end loop; 1374 1375 Free_Argument_List (Cont_Parameters); 1376 end if; 1377 1378 Check_Parameters; 1379 Set_Context_Parameters (Cont, Parameters); 1380 Set_Search_Paths (Cont); 1381 end Process_Context_Parameters; 1382 1383 ----------------- 1384 -- Process_Dir -- 1385 ----------------- 1386 1387 procedure Process_Dir (Dir_Name : String; Dir_Kind : Search_Dir_Kinds) is 1388 First : Positive := Dir_Name'First; 1389 Last : Natural := Dir_Name'Last; 1390 New_Dir : Link; 1391 begin 1392 1393 if Dir_Name (First) = '"' 1394 and then 1395 Dir_Name (Last) = '"' 1396 then 1397 First := First + 1; 1398 Last := Last - 1; 1399 end if; 1400 1401 if not Is_Directory (Dir_Name (First .. Last)) then 1402 Set_Error_Status (Status => Asis.Errors.Parameter_Error, 1403 Diagnosis => "Asis.Ada_Environments.Associate:" 1404 & ASIS_Line_Terminator 1405 & "Wrong parameter for Context " 1406 & "Association: " 1407 & Dir_Name 1408 & " is not a directory name"); 1409 raise ASIS_Failed; 1410 end if; 1411 1412 New_Dir := new Dir_Rec; 1413 New_Dir.Dir_Name := new String'(Dir_Name (First .. Last)); 1414 1415 case Dir_Kind is 1416 when Source => 1417 Source_Dirs_Count := Source_Dirs_Count + 1; 1418 Append_Dir (Source_Dirs, New_Dir); 1419 when Object => 1420 Object_Dirs_Count := Object_Dirs_Count + 1; 1421 Append_Dir (Object_Dirs, New_Dir); 1422 when Tree => 1423 Tree_Dirs_Count := Tree_Dirs_Count + 1; 1424 Append_Dir (Tree_Dirs, New_Dir); 1425 end case; 1426 end Process_Dir; 1427 1428 -------------------- 1429 -- Scan_Trees_New -- 1430 -------------------- 1431 1432 procedure Scan_Trees_New (C : Context_Id) is 1433 begin 1434 Scan_Tree_Files_New (C); 1435 Investigate_Trees_New (C); 1436 1437 -- And now, when all the unit attributes are set, we compute integrated 1438 -- dependencies 1439 Set_All_Dependencies; 1440 1441 Reorder_Trees (C); 1442 end Scan_Trees_New; 1443 1444 ---------------------- 1445 -- Set_Context_Name -- 1446 ---------------------- 1447 1448 procedure Set_Context_Name (C : Context_Id; Name : String) is 1449 begin 1450 Contexts.Table (C).Name := new String'(Name); 1451 end Set_Context_Name; 1452 1453 ---------------------------- 1454 -- Set_Context_Parameters -- 1455 ---------------------------- 1456 1457 procedure Set_Context_Parameters (C : Context_Id; Parameters : String) 1458 is 1459 begin 1460 Contexts.Table (C).Parameters := new String'(Parameters); 1461 end Set_Context_Parameters; 1462 1463 ----------------------- 1464 -- Set_Empty_Context -- 1465 ----------------------- 1466 1467 No_Args : aliased Argument_List := (1 .. 0 => <>); 1468 1469 procedure Set_Empty_Context (C : Context_Id) is 1470 Cont : constant Context_Id := C; 1471 begin 1472 -- We explicitly set all the fields of the context record 1473 1474 Contexts.Table (C).Name := null; 1475 Contexts.Table (C).Parameters := null; 1476 Contexts.Table (C).GCC := null; 1477 1478 Set_Is_Associated (Cont, False); 1479 Set_Is_Opened (Cont, False); 1480 Set_Use_Default_Trees (Cont, False); 1481 1482 Contexts.Table (C).Opened_At := Last_ASIS_OS_Time; 1483 Contexts.Table (C).Specs := 0; 1484 Contexts.Table (C).Bodies := 0; 1485 1486 for J in Hash_Index_Type loop 1487 Contexts.Table (C).Hash_Table (J) := Nil_Unit; 1488 end loop; 1489 1490 Contexts.Table (C).Current_Main_Unit := Nil_Unit; 1491 1492 Contexts.Table (C).Source_Path := null; 1493 Contexts.Table (C).Object_Path := null; 1494 Contexts.Table (C).Tree_Path := null; 1495 Contexts.Table (C).Context_I_Options := null; 1496 Contexts.Table (C).Extra_Options := No_Args'Access; 1497 Contexts.Table (C).Context_Tree_Files := null; 1498 1499 Contexts.Table (C).Mode := All_Trees; 1500 Contexts.Table (C).Tree_Processing := Pre_Created; 1501 Contexts.Table (C).Source_Processing := All_Sources; 1502 1503 end Set_Empty_Context; 1504 1505 ----------------------- 1506 -- Set_Extra_Options -- 1507 ----------------------- 1508 1509 procedure Set_Extra_Options 1510 (C : Context_Id; Extra_Options : Argument_List) 1511 is 1512 begin 1513 Contexts.Table (C).Extra_Options := new Argument_List'(Extra_Options); 1514 end Set_Extra_Options; 1515 1516 --------------------- 1517 -- Set_Current_Cont -- 1518 --------------------- 1519 1520 procedure Set_Current_Cont (L : Context_Id) is 1521 begin 1522 Current_Context := L; 1523 end Set_Current_Cont; 1524 1525 ---------------------- 1526 -- Set_Current_Tree -- 1527 ---------------------- 1528 1529 procedure Set_Current_Tree (Tree : Tree_Id) is 1530 begin 1531 Current_Tree := Tree; 1532 end Set_Current_Tree; 1533 1534 ---------------------- 1535 -- Set_Name_String -- 1536 ---------------------- 1537 1538 procedure Set_Name_String (S : String) is 1539 begin 1540 A_Name_Len := S'Length; 1541 A_Name_Buffer (1 .. A_Name_Len) := S; 1542 end Set_Name_String; 1543 1544 -------------------------- 1545 -- Set_Predefined_Units -- 1546 -------------------------- 1547 1548 procedure Set_Predefined_Units is 1549 Cont : constant Context_Id := Get_Current_Cont; 1550 C_U : Unit_Id; 1551 begin 1552 1553 -- set the entry for the package Standard: 1554 1555 -- The problem here is that Ada allows to redefine Standard, so we use 1556 -- a special normalized name for predefined Standard, and a "normal" 1557 -- normalized name for redefinition of Standard. See also 1558 -- A4G.Get_Unit.Fetch_Unit_By_Ada_Name 1559 1560 Set_Name_String ("__standard%s"); 1561 C_U := Allocate_Unit_Entry (Cont); 1562 -- C_U should be equal to Standard_Id. Should we check this here? 1563 1564 Set_Name_String ("Standard"); 1565 Set_Ada_Name (C_U); 1566 Set_Kind (Cont, C_U, A_Package); 1567 Set_Class (Cont, C_U, A_Public_Declaration); 1568 Set_Top (Cont, C_U, Empty); 1569 -- What is the best solution for computing the top node of the 1570 -- subtree for the package Standard? Now we compute it in 1571 -- Asis.Set_Get.Top... 1572 1573 Set_Time_Stamp (Cont, C_U, Empty_Time_Stamp); 1574 Set_Origin (Cont, C_U, A_Predefined_Unit); 1575 1576 Set_Is_Main_Unit (Cont, C_U, False); 1577 Set_Is_Body_Required (Cont, C_U, False); 1578 1579 Set_Source_Status (Cont, C_U, Absent); 1580 1581 -- as for the source file, it was set to Nil when allocating the 1582 -- unit entry 1583 1584 end Set_Predefined_Units; 1585 1586 ---------------------- 1587 -- Set_Search_Paths -- 1588 ---------------------- 1589 1590 procedure Set_Search_Paths (C : Context_Id) is 1591 1592 I_Opt_Len : constant Natural := Source_Dirs_Count; 1593 1594 N_Config_File_Options : Natural := 0; 1595 Idx : Natural; 1596 1597 procedure Set_Path 1598 (Path : in out Directory_List_Ptr; 1599 From : in out Dir_List; 1600 N : in out Natural); 1601 -- Sets the given search path, N is the count of the directories. 1602 -- resets the temporary data structures used to keep and to count 1603 -- directory names 1604 1605 procedure Set_Path 1606 (Path : in out Directory_List_Ptr; 1607 From : in out Dir_List; 1608 N : in out Natural) 1609 is 1610 Next_Dir : Link := From.First; 1611 begin 1612 if N = 0 then 1613 From.First := null; -- just in case 1614 From.Last := null; -- just in case 1615 return; 1616 -- we have nothing to do, and the corresponding search path 1617 -- will remain null, as it should have been before the call 1618 end if; 1619 1620 Path := new Argument_List (1 .. N); 1621 1622 for I in 1 .. N loop 1623 Path (I) := new String'(Next_Dir.Dir_Name.all); 1624 Free (Next_Dir.Dir_Name); 1625 Next_Dir := Next_Dir.Next; 1626 end loop; 1627 1628 From.First := null; 1629 From.Last := null; 1630 N := 0; 1631 1632 -- we free the memory occupied by strings stored in this temporary 1633 -- list of directories, but we do not free the memory used by the 1634 -- links. We hope we can skip this optimization 1635 1636 end Set_Path; 1637 1638 begin -- Set_Search_Paths 1639 1640 Set_Path 1641 (Contexts.Table (C).Source_Path, Source_Dirs, Source_Dirs_Count); 1642 Set_Path 1643 (Contexts.Table (C).Object_Path, Object_Dirs, Object_Dirs_Count); 1644 Set_Path 1645 (Contexts.Table (C).Tree_Path, Tree_Dirs, Tree_Dirs_Count); 1646 1647 -- And the last thing to do is to set for a given Context its 1648 -- Context_I_Options field: 1649 1650 if I_Opt_Len = 0 and then 1651 Config_File = null and then 1652 not GnatA_Set and then 1653 Tree_Processing_Mode (C) /= GNSA 1654 then 1655 Contexts.Table (C).Context_I_Options := null; -- just in case 1656 return; 1657 end if; 1658 1659 if Config_File /= null then 1660 N_Config_File_Options := N_Config_File_Options + 1; 1661 end if; 1662 1663 if GnatA_Set then 1664 N_Config_File_Options := N_Config_File_Options + 1; 1665 end if; 1666 1667 Contexts.Table (C).Context_I_Options := 1668 new Argument_List (1 .. I_Opt_Len + N_Config_File_Options + 1); 1669 1670 for I in 1 .. I_Opt_Len loop 1671 Contexts.Table (C).Context_I_Options (I) := 1672 new String'("-I" & Contexts.Table (C).Source_Path (I).all); 1673 end loop; 1674 1675 Idx := I_Opt_Len; 1676 1677 if Config_File /= null then 1678 Idx := Idx + 1; 1679 Contexts.Table (C).Context_I_Options (Idx) := 1680 new String'(Config_File.all); 1681 end if; 1682 1683 if GnatA_Set then 1684 Idx := Idx + 1; 1685 Contexts.Table (C).Context_I_Options (Idx) := 1686 new String'("-gnatA"); 1687 end if; 1688 1689 Idx := Idx + 1; 1690 1691 if Tree_Processing_Mode (C) = GNSA then 1692 Contexts.Table (C).Context_I_Options (Idx) := 1693 new String'(GNSA_Source.all); 1694 else 1695 -- For non-GNSA on the fly compilation we always set -I- 1696 Contexts.Table (C).Context_I_Options (Idx) := 1697 new String'("-I-"); 1698 end if; 1699 1700 end Set_Search_Paths; 1701 1702 --------------------------------------------------- 1703 -- Context Attributes Access and Update Routines -- 1704 --------------------------------------------------- 1705 1706 function Is_Associated (C : Context_Id) return Boolean is 1707 begin 1708 return C /= Non_Associated and then 1709 Contexts.Table (C).Is_Associated; 1710 end Is_Associated; 1711 1712 function Is_Opened (C : Context_Id) return Boolean is 1713 begin 1714 return C /= Non_Associated and then 1715 Contexts.Table (C).Is_Opened; 1716 end Is_Opened; 1717 1718 function Opened_At (C : Context_Id) return ASIS_OS_Time is 1719 begin 1720 return Contexts.Table (C).Opened_At; 1721 end Opened_At; 1722 1723 function Context_Processing_Mode (C : Context_Id) return Context_Mode is 1724 begin 1725 return Contexts.Table (C).Mode; 1726 end Context_Processing_Mode; 1727 1728 function Tree_Processing_Mode (C : Context_Id) return Tree_Mode is 1729 begin 1730 return Contexts.Table (C).Tree_Processing; 1731 end Tree_Processing_Mode; 1732 1733 function Source_Processing_Mode (C : Context_Id) return Source_Mode is 1734 begin 1735 return Contexts.Table (C).Source_Processing; 1736 end Source_Processing_Mode; 1737 1738 function Use_Default_Trees (C : Context_Id) return Boolean is 1739 begin 1740 return Contexts.Table (C).Use_Default_Trees; 1741 end Use_Default_Trees; 1742 1743 function Gcc_To_Call (C : Context_Id) return String_Access is 1744 begin 1745 return Contexts.Table (C).GCC; 1746 end Gcc_To_Call; 1747 1748 -------- 1749 1750 procedure Set_Is_Associated (C : Context_Id; Ass : Boolean) is 1751 begin 1752 Contexts.Table (C).Is_Associated := Ass; 1753 end Set_Is_Associated; 1754 1755 procedure Set_Is_Opened (C : Context_Id; Op : Boolean) is 1756 begin 1757 Contexts.Table (C).Is_Opened := Op; 1758 end Set_Is_Opened; 1759 1760 procedure Set_Context_Processing_Mode (C : Context_Id; M : Context_Mode) is 1761 begin 1762 Contexts.Table (C).Mode := M; 1763 end Set_Context_Processing_Mode; 1764 1765 procedure Set_Tree_Processing_Mode (C : Context_Id; M : Tree_Mode) is 1766 begin 1767 Contexts.Table (C).Tree_Processing := M; 1768 end Set_Tree_Processing_Mode; 1769 1770 procedure Set_Source_Processing_Mode (C : Context_Id; M : Source_Mode) is 1771 begin 1772 Contexts.Table (C).Source_Processing := M; 1773 end Set_Source_Processing_Mode; 1774 1775 procedure Set_Use_Default_Trees (C : Context_Id; B : Boolean) is 1776 begin 1777 Contexts.Table (C).Use_Default_Trees := B; 1778 end Set_Use_Default_Trees; 1779 1780 procedure Set_Default_Context_Processing_Mode (C : Context_Id) is 1781 begin 1782 Contexts.Table (C).Mode := All_Trees; 1783 end Set_Default_Context_Processing_Mode; 1784 1785 procedure Set_Default_Tree_Processing_Mode (C : Context_Id) is 1786 begin 1787 Contexts.Table (C).Tree_Processing := Pre_Created; 1788 end Set_Default_Tree_Processing_Mode; 1789 1790 procedure Set_Default_Source_Processing_Mode (C : Context_Id) is 1791 begin 1792 Contexts.Table (C).Source_Processing := All_Sources; 1793 end Set_Default_Source_Processing_Mode; 1794 1795----------------- 1796-- NEW STUFF -- 1797----------------- 1798 1799 ---------------------------- 1800 -- Backup_Current_Context -- 1801 ---------------------------- 1802 1803 procedure Backup_Current_Context is 1804 begin 1805 if Current_Context /= Nil_Context_Id then 1806 Save_Context (Current_Context); 1807 end if; 1808 end Backup_Current_Context; 1809 1810 ------------------- 1811 -- Reset_Context -- 1812 ------------------- 1813 1814 procedure Reset_Context (C : Context_Id) is 1815 begin 1816 if C = Nil_Context_Id then 1817 return; 1818 elsif C /= Current_Context then 1819 1820 if Is_Opened (Current_Context) then 1821 Save_Context (Current_Context); 1822 end if; 1823 1824 if Is_Opened (C) then 1825 Restore_Context (C); 1826 end if; 1827 1828 Current_Context := C; 1829 -- we have to do also this: 1830 Current_Tree := Nil_Tree; 1831 -- otherwise node/tree access in a new Context may not reset the tree 1832 -- in case in tree Ids in the old and new Contexts are the same 1833 end if; 1834 end Reset_Context; 1835 1836 --------------------- 1837 -- Restore_Context -- 1838 --------------------- 1839 1840 procedure Restore_Context (C : Context_Id) is 1841 begin 1842 A_Name_Chars.Restore 1843 (Contexts.Table (C).Back_Up.Context_Name_Chars); 1844 Unit_Table.Restore (Contexts.Table (C).Back_Up.Units); 1845 Tree_Table.Restore (Contexts.Table (C).Back_Up.Trees); 1846 1847 -- restoring lists tables: 1848 A4G.A_Elists.Elmts.Restore 1849 (Contexts.Table (C).Back_Up.Context_Unit_Lists.Saved_Elmts); 1850 A4G.A_Elists.Elists.Restore 1851 (Contexts.Table (C).Back_Up.Context_Unit_Lists.Saved_Elists); 1852 end Restore_Context; 1853 1854 ------------------ 1855 -- Save_Context -- 1856 ------------------ 1857 1858 procedure Save_Context (C : Context_Id) is 1859 begin 1860 if Is_Opened (C) then 1861 Contexts.Table (C).Back_Up.Context_Name_Chars := A_Name_Chars.Save; 1862 Contexts.Table (C).Back_Up.Units := Unit_Table.Save; 1863 Contexts.Table (C).Back_Up.Trees := Tree_Table.Save; 1864 1865 -- saving lists tables: 1866 Contexts.Table (C).Back_Up.Context_Unit_Lists.Saved_Elmts := 1867 A4G.A_Elists.Elmts.Save; 1868 Contexts.Table (C).Back_Up.Context_Unit_Lists.Saved_Elists := 1869 A4G.A_Elists.Elists.Save; 1870 end if; 1871 end Save_Context; 1872 1873 ------------------------- 1874 -- Verify_Context_Name -- 1875 ------------------------- 1876 1877 procedure Verify_Context_Name (Name : String; Cont : Context_Id) is 1878 begin 1879 -- no verification is performed now - we simply have no idea, what 1880 -- and how to verify :-I 1881 1882 Set_Context_Name (Cont, Name); 1883 end Verify_Context_Name; 1884 1885end A4G.Contt; 1886