1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- A L I -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- 10-- -- 11-- GNAT is free software; you can redistribute it and/or modify it under -- 12-- terms of the GNU General Public License as published by the Free Soft- -- 13-- ware Foundation; either version 3, or (at your option) any later ver- -- 14-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 15-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 16-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- 17-- for more details. You should have received a copy of the GNU General -- 18-- Public License distributed with GNAT; see file COPYING3. If not, go to -- 19-- http://www.gnu.org/licenses for a complete copy of the license. -- 20-- -- 21-- GNAT was originally developed by the GNAT team at New York University. -- 22-- Extensive contributions were provided by Ada Core Technologies Inc. -- 23-- -- 24------------------------------------------------------------------------------ 25 26with Butil; use Butil; 27with Debug; use Debug; 28with Fname; use Fname; 29with Opt; use Opt; 30with Osint; use Osint; 31with Output; use Output; 32 33package body ALI is 34 35 use ASCII; 36 -- Make control characters visible 37 38 -- The following variable records which characters currently are 39 -- used as line type markers in the ALI file. This is used in 40 -- Scan_ALI to detect (or skip) invalid lines. 41 42 Known_ALI_Lines : constant array (Character range 'A' .. 'Z') of Boolean := 43 ('V' => True, -- version 44 'M' => True, -- main program 45 'A' => True, -- argument 46 'P' => True, -- program 47 'R' => True, -- restriction 48 'I' => True, -- interrupt 49 'U' => True, -- unit 50 'W' => True, -- with 51 'L' => True, -- linker option 52 'N' => True, -- notes 53 'E' => True, -- external 54 'D' => True, -- dependency 55 'X' => True, -- xref 56 'S' => True, -- specific dispatching 57 'Y' => True, -- limited_with 58 'Z' => True, -- implicit with from instantiation 59 'C' => True, -- SCO information 60 'F' => True, -- Alfa information 61 others => False); 62 63 -------------------- 64 -- Initialize_ALI -- 65 -------------------- 66 67 procedure Initialize_ALI is 68 begin 69 -- When (re)initializing ALI data structures the ALI user expects to 70 -- get a fresh set of data structures. Thus we first need to erase the 71 -- marks put in the name table by the previous set of ALI routine calls. 72 -- These two loops are empty and harmless the first time in. 73 74 for J in ALIs.First .. ALIs.Last loop 75 Set_Name_Table_Info (ALIs.Table (J).Afile, 0); 76 end loop; 77 78 for J in Units.First .. Units.Last loop 79 Set_Name_Table_Info (Units.Table (J).Uname, 0); 80 end loop; 81 82 -- Free argument table strings 83 84 for J in Args.First .. Args.Last loop 85 Free (Args.Table (J)); 86 end loop; 87 88 -- Initialize all tables 89 90 ALIs.Init; 91 No_Deps.Init; 92 Units.Init; 93 Withs.Init; 94 Sdep.Init; 95 Linker_Options.Init; 96 Notes.Init; 97 Xref_Section.Init; 98 Xref_Entity.Init; 99 Xref.Init; 100 Version_Ref.Reset; 101 102 -- Add dummy zero'th item in Linker_Options and Notes for sort calls 103 104 Linker_Options.Increment_Last; 105 Notes.Increment_Last; 106 107 -- Initialize global variables recording cumulative options in all 108 -- ALI files that are read for a given processing run in gnatbind. 109 110 Dynamic_Elaboration_Checks_Specified := False; 111 Float_Format_Specified := ' '; 112 Locking_Policy_Specified := ' '; 113 No_Normalize_Scalars_Specified := False; 114 No_Object_Specified := False; 115 Normalize_Scalars_Specified := False; 116 Partition_Elaboration_Policy_Specified := ' '; 117 Queuing_Policy_Specified := ' '; 118 Static_Elaboration_Model_Used := False; 119 Task_Dispatching_Policy_Specified := ' '; 120 Unreserve_All_Interrupts_Specified := False; 121 Zero_Cost_Exceptions_Specified := False; 122 end Initialize_ALI; 123 124 -------------- 125 -- Scan_ALI -- 126 -------------- 127 128 function Scan_ALI 129 (F : File_Name_Type; 130 T : Text_Buffer_Ptr; 131 Ignore_ED : Boolean; 132 Err : Boolean; 133 Read_Xref : Boolean := False; 134 Read_Lines : String := ""; 135 Ignore_Lines : String := "X"; 136 Ignore_Errors : Boolean := False; 137 Directly_Scanned : Boolean := False) return ALI_Id 138 is 139 P : Text_Ptr := T'First; 140 Line : Logical_Line_Number := 1; 141 Id : ALI_Id; 142 C : Character; 143 NS_Found : Boolean; 144 First_Arg : Arg_Id; 145 146 Ignore : array (Character range 'A' .. 'Z') of Boolean; 147 -- Ignore (X) is set to True if lines starting with X are to 148 -- be ignored by Scan_ALI and skipped, and False if the lines 149 -- are to be read and processed. 150 151 Bad_ALI_Format : exception; 152 -- Exception raised by Fatal_Error if Err is True 153 154 function At_Eol return Boolean; 155 -- Test if at end of line 156 157 function At_End_Of_Field return Boolean; 158 -- Test if at end of line, or if at blank or horizontal tab 159 160 procedure Check_At_End_Of_Field; 161 -- Check if we are at end of field, fatal error if not 162 163 procedure Checkc (C : Character); 164 -- Check next character is C. If so bump past it, if not fatal error 165 166 procedure Check_Unknown_Line; 167 -- If Ignore_Errors mode, then checks C to make sure that it is not 168 -- an unknown ALI line type characters, and if so, skips lines 169 -- until the first character of the line is one of these characters, 170 -- at which point it does a Getc to put that character in C. The 171 -- call has no effect if C is already an appropriate character. 172 -- If not in Ignore_Errors mode, a fatal error is signalled if the 173 -- line is unknown. Note that if C is an EOL on entry, the line is 174 -- skipped (it is assumed that blank lines are never significant). 175 -- If C is EOF on entry, the call has no effect (it is assumed that 176 -- the caller will properly handle this case). 177 178 procedure Fatal_Error; 179 -- Generate fatal error message for badly formatted ALI file if 180 -- Err is false, or raise Bad_ALI_Format if Err is True. 181 182 procedure Fatal_Error_Ignore; 183 pragma Inline (Fatal_Error_Ignore); 184 -- In Ignore_Errors mode, has no effect, otherwise same as Fatal_Error 185 186 function Getc return Character; 187 -- Get next character, bumping P past the character obtained 188 189 function Get_File_Name (Lower : Boolean := False) return File_Name_Type; 190 -- Skip blanks, then scan out a file name (name is left in Name_Buffer 191 -- with length in Name_Len, as well as returning a File_Name_Type value. 192 -- If lower is false, the case is unchanged, if Lower is True then the 193 -- result is forced to all lower case for systems where file names are 194 -- not case sensitive. This ensures that gnatbind works correctly 195 -- regardless of the case of the file name on all systems. The scan 196 -- is terminated by a end of line, space or horizontal tab. Any other 197 -- special characters are included in the returned name. 198 199 function Get_Name 200 (Ignore_Spaces : Boolean := False; 201 Ignore_Special : Boolean := False) return Name_Id; 202 -- Skip blanks, then scan out a name (name is left in Name_Buffer with 203 -- length in Name_Len, as well as being returned in Name_Id form). 204 -- If Lower is set to True then the Name_Buffer will be converted to 205 -- all lower case, for systems where file names are not case sensitive. 206 -- This ensures that gnatbind works correctly regardless of the case 207 -- of the file name on all systems. The termination condition depends 208 -- on the settings of Ignore_Spaces and Ignore_Special: 209 -- 210 -- If Ignore_Spaces is False (normal case), then scan is terminated 211 -- by the normal end of field condition (EOL, space, horizontal tab) 212 -- 213 -- If Ignore_Special is False (normal case), the scan is terminated by 214 -- a typeref bracket or an equal sign except for the special case of 215 -- an operator name starting with a double quote which is terminated 216 -- by another double quote. 217 -- 218 -- It is an error to set both Ignore_Spaces and Ignore_Special to True. 219 -- This function handles wide characters properly. 220 221 function Get_Nat return Nat; 222 -- Skip blanks, then scan out an unsigned integer value in Nat range 223 -- raises ALI_Reading_Error if the encoutered type is not natural. 224 225 function Get_Stamp return Time_Stamp_Type; 226 -- Skip blanks, then scan out a time stamp 227 228 function Get_Unit_Name return Unit_Name_Type; 229 -- Skip blanks, then scan out a file name (name is left in Name_Buffer 230 -- with length in Name_Len, as well as returning a Unit_Name_Type value. 231 -- The case is unchanged and terminated by a normal end of field. 232 233 function Nextc return Character; 234 -- Return current character without modifying pointer P 235 236 procedure Get_Typeref 237 (Current_File_Num : Sdep_Id; 238 Ref : out Tref_Kind; 239 File_Num : out Sdep_Id; 240 Line : out Nat; 241 Ref_Type : out Character; 242 Col : out Nat; 243 Standard_Entity : out Name_Id); 244 -- Parse the definition of a typeref (<...>, {...} or (...)) 245 246 procedure Skip_Eol; 247 -- Skip past spaces, then skip past end of line (fatal error if not 248 -- at end of line). Also skips past any following blank lines. 249 250 procedure Skip_Line; 251 -- Skip rest of current line and any following blank lines 252 253 procedure Skip_Space; 254 -- Skip past white space (blanks or horizontal tab) 255 256 procedure Skipc; 257 -- Skip past next character, does not affect value in C. This call 258 -- is like calling Getc and ignoring the returned result. 259 260 --------------------- 261 -- At_End_Of_Field -- 262 --------------------- 263 264 function At_End_Of_Field return Boolean is 265 begin 266 return Nextc <= ' '; 267 end At_End_Of_Field; 268 269 ------------ 270 -- At_Eol -- 271 ------------ 272 273 function At_Eol return Boolean is 274 begin 275 return Nextc = EOF or else Nextc = CR or else Nextc = LF; 276 end At_Eol; 277 278 --------------------------- 279 -- Check_At_End_Of_Field -- 280 --------------------------- 281 282 procedure Check_At_End_Of_Field is 283 begin 284 if not At_End_Of_Field then 285 if Ignore_Errors then 286 while Nextc > ' ' loop 287 P := P + 1; 288 end loop; 289 else 290 Fatal_Error; 291 end if; 292 end if; 293 end Check_At_End_Of_Field; 294 295 ------------------------ 296 -- Check_Unknown_Line -- 297 ------------------------ 298 299 procedure Check_Unknown_Line is 300 begin 301 while C not in 'A' .. 'Z' 302 or else not Known_ALI_Lines (C) 303 loop 304 if C = CR or else C = LF then 305 Skip_Line; 306 C := Nextc; 307 308 elsif C = EOF then 309 return; 310 311 elsif Ignore_Errors then 312 Skip_Line; 313 C := Getc; 314 315 else 316 Fatal_Error; 317 end if; 318 end loop; 319 end Check_Unknown_Line; 320 321 ------------ 322 -- Checkc -- 323 ------------ 324 325 procedure Checkc (C : Character) is 326 begin 327 if Nextc = C then 328 P := P + 1; 329 elsif Ignore_Errors then 330 P := P + 1; 331 else 332 Fatal_Error; 333 end if; 334 end Checkc; 335 336 ----------------- 337 -- Fatal_Error -- 338 ----------------- 339 340 procedure Fatal_Error is 341 Ptr1 : Text_Ptr; 342 Ptr2 : Text_Ptr; 343 Col : Int; 344 345 procedure Wchar (C : Character); 346 -- Write a single character, replacing horizontal tab by spaces 347 348 procedure Wchar (C : Character) is 349 begin 350 if C = HT then 351 loop 352 Wchar (' '); 353 exit when Col mod 8 = 0; 354 end loop; 355 356 else 357 Write_Char (C); 358 Col := Col + 1; 359 end if; 360 end Wchar; 361 362 -- Start of processing for Fatal_Error 363 364 begin 365 if Err then 366 raise Bad_ALI_Format; 367 end if; 368 369 Set_Standard_Error; 370 Write_Str ("fatal error: file "); 371 Write_Name (F); 372 Write_Str (" is incorrectly formatted"); 373 Write_Eol; 374 375 Write_Str ("make sure you are using consistent versions " & 376 377 -- Split the following line so that it can easily be transformed for 378 -- e.g. JVM/.NET back-ends where the compiler has a different name. 379 380 "of gcc/gnatbind"); 381 382 Write_Eol; 383 384 -- Find start of line 385 386 Ptr1 := P; 387 while Ptr1 > T'First 388 and then T (Ptr1 - 1) /= CR 389 and then T (Ptr1 - 1) /= LF 390 loop 391 Ptr1 := Ptr1 - 1; 392 end loop; 393 394 Write_Int (Int (Line)); 395 Write_Str (". "); 396 397 if Line < 100 then 398 Write_Char (' '); 399 end if; 400 401 if Line < 10 then 402 Write_Char (' '); 403 end if; 404 405 Col := 0; 406 Ptr2 := Ptr1; 407 408 while Ptr2 < T'Last 409 and then T (Ptr2) /= CR 410 and then T (Ptr2) /= LF 411 loop 412 Wchar (T (Ptr2)); 413 Ptr2 := Ptr2 + 1; 414 end loop; 415 416 Write_Eol; 417 418 Write_Str (" "); 419 Col := 0; 420 421 while Ptr1 < P loop 422 if T (Ptr1) = HT then 423 Wchar (HT); 424 else 425 Wchar (' '); 426 end if; 427 428 Ptr1 := Ptr1 + 1; 429 end loop; 430 431 Wchar ('|'); 432 Write_Eol; 433 434 Exit_Program (E_Fatal); 435 end Fatal_Error; 436 437 ------------------------ 438 -- Fatal_Error_Ignore -- 439 ------------------------ 440 441 procedure Fatal_Error_Ignore is 442 begin 443 if not Ignore_Errors then 444 Fatal_Error; 445 end if; 446 end Fatal_Error_Ignore; 447 448 ------------------- 449 -- Get_File_Name -- 450 ------------------- 451 452 function Get_File_Name 453 (Lower : Boolean := False) return File_Name_Type 454 is 455 F : Name_Id; 456 457 begin 458 F := Get_Name (Ignore_Special => True); 459 460 -- Convert file name to all lower case if file names are not case 461 -- sensitive. This ensures that we handle names in the canonical 462 -- lower case format, regardless of the actual case. 463 464 if Lower and not File_Names_Case_Sensitive then 465 Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); 466 return Name_Find; 467 else 468 return File_Name_Type (F); 469 end if; 470 end Get_File_Name; 471 472 -------------- 473 -- Get_Name -- 474 -------------- 475 476 function Get_Name 477 (Ignore_Spaces : Boolean := False; 478 Ignore_Special : Boolean := False) return Name_Id 479 is 480 begin 481 Name_Len := 0; 482 Skip_Space; 483 484 if At_Eol then 485 if Ignore_Errors then 486 return Error_Name; 487 else 488 Fatal_Error; 489 end if; 490 end if; 491 492 loop 493 Add_Char_To_Name_Buffer (Getc); 494 495 exit when At_End_Of_Field and then not Ignore_Spaces; 496 497 if not Ignore_Special then 498 if Name_Buffer (1) = '"' then 499 exit when Name_Len > 1 and then Name_Buffer (Name_Len) = '"'; 500 501 else 502 -- Terminate on parens or angle brackets or equal sign 503 504 exit when Nextc = '(' or else Nextc = ')' 505 or else Nextc = '{' or else Nextc = '}' 506 or else Nextc = '<' or else Nextc = '>' 507 or else Nextc = '='; 508 509 -- Terminate on comma 510 511 exit when Nextc = ','; 512 513 -- Terminate if left bracket not part of wide char sequence 514 -- Note that we only recognize brackets notation so far ??? 515 516 exit when Nextc = '[' and then T (P + 1) /= '"'; 517 518 -- Terminate if right bracket not part of wide char sequence 519 520 exit when Nextc = ']' and then T (P - 1) /= '"'; 521 end if; 522 end if; 523 end loop; 524 525 return Name_Find; 526 end Get_Name; 527 528 ------------------- 529 -- Get_Unit_Name -- 530 ------------------- 531 532 function Get_Unit_Name return Unit_Name_Type is 533 begin 534 return Unit_Name_Type (Get_Name); 535 end Get_Unit_Name; 536 537 ------------- 538 -- Get_Nat -- 539 ------------- 540 541 function Get_Nat return Nat is 542 V : Nat; 543 544 begin 545 Skip_Space; 546 547 -- Check if we are on a number. In the case of bad ALI files, this 548 -- may not be true. 549 550 if not (Nextc in '0' .. '9') then 551 Fatal_Error; 552 end if; 553 554 V := 0; 555 loop 556 V := V * 10 + (Character'Pos (Getc) - Character'Pos ('0')); 557 558 exit when At_End_Of_Field; 559 exit when Nextc < '0' or else Nextc > '9'; 560 end loop; 561 562 return V; 563 end Get_Nat; 564 565 --------------- 566 -- Get_Stamp -- 567 --------------- 568 569 function Get_Stamp return Time_Stamp_Type is 570 T : Time_Stamp_Type; 571 Start : Integer; 572 573 begin 574 Skip_Space; 575 576 if At_Eol then 577 if Ignore_Errors then 578 return Dummy_Time_Stamp; 579 else 580 Fatal_Error; 581 end if; 582 end if; 583 584 -- Following reads old style time stamp missing first two digits 585 586 if Nextc in '7' .. '9' then 587 T (1) := '1'; 588 T (2) := '9'; 589 Start := 3; 590 591 -- Normal case of full year in time stamp 592 593 else 594 Start := 1; 595 end if; 596 597 for J in Start .. T'Last loop 598 T (J) := Getc; 599 end loop; 600 601 return T; 602 end Get_Stamp; 603 604 ----------------- 605 -- Get_Typeref -- 606 ----------------- 607 608 procedure Get_Typeref 609 (Current_File_Num : Sdep_Id; 610 Ref : out Tref_Kind; 611 File_Num : out Sdep_Id; 612 Line : out Nat; 613 Ref_Type : out Character; 614 Col : out Nat; 615 Standard_Entity : out Name_Id) 616 is 617 N : Nat; 618 begin 619 case Nextc is 620 when '<' => Ref := Tref_Derived; 621 when '(' => Ref := Tref_Access; 622 when '{' => Ref := Tref_Type; 623 when others => Ref := Tref_None; 624 end case; 625 626 -- Case of typeref field present 627 628 if Ref /= Tref_None then 629 P := P + 1; -- skip opening bracket 630 631 if Nextc in 'a' .. 'z' then 632 File_Num := No_Sdep_Id; 633 Line := 0; 634 Ref_Type := ' '; 635 Col := 0; 636 Standard_Entity := Get_Name (Ignore_Spaces => True); 637 else 638 N := Get_Nat; 639 640 if Nextc = '|' then 641 File_Num := Sdep_Id (N + Nat (First_Sdep_Entry) - 1); 642 P := P + 1; 643 N := Get_Nat; 644 else 645 File_Num := Current_File_Num; 646 end if; 647 648 Line := N; 649 Ref_Type := Getc; 650 Col := Get_Nat; 651 Standard_Entity := No_Name; 652 end if; 653 654 -- ??? Temporary workaround for nested generics case: 655 -- 4i4 Directories{1|4I9[4|6[3|3]]} 656 -- See C918-002 657 658 declare 659 Nested_Brackets : Natural := 0; 660 661 begin 662 loop 663 case Nextc is 664 when '[' => 665 Nested_Brackets := Nested_Brackets + 1; 666 when ']' => 667 Nested_Brackets := Nested_Brackets - 1; 668 when others => 669 if Nested_Brackets = 0 then 670 exit; 671 end if; 672 end case; 673 674 Skipc; 675 end loop; 676 end; 677 678 P := P + 1; -- skip closing bracket 679 Skip_Space; 680 681 -- No typeref entry present 682 683 else 684 File_Num := No_Sdep_Id; 685 Line := 0; 686 Ref_Type := ' '; 687 Col := 0; 688 Standard_Entity := No_Name; 689 end if; 690 end Get_Typeref; 691 692 ---------- 693 -- Getc -- 694 ---------- 695 696 function Getc return Character is 697 begin 698 if P = T'Last then 699 return EOF; 700 else 701 P := P + 1; 702 return T (P - 1); 703 end if; 704 end Getc; 705 706 ----------- 707 -- Nextc -- 708 ----------- 709 710 function Nextc return Character is 711 begin 712 return T (P); 713 end Nextc; 714 715 -------------- 716 -- Skip_Eol -- 717 -------------- 718 719 procedure Skip_Eol is 720 begin 721 Skip_Space; 722 723 if not At_Eol then 724 if Ignore_Errors then 725 while not At_Eol loop 726 P := P + 1; 727 end loop; 728 else 729 Fatal_Error; 730 end if; 731 end if; 732 733 -- Loop to skip past blank lines (first time through skips this EOL) 734 735 while Nextc < ' ' and then Nextc /= EOF loop 736 if Nextc = LF then 737 Line := Line + 1; 738 end if; 739 740 P := P + 1; 741 end loop; 742 end Skip_Eol; 743 744 --------------- 745 -- Skip_Line -- 746 --------------- 747 748 procedure Skip_Line is 749 begin 750 while not At_Eol loop 751 P := P + 1; 752 end loop; 753 754 Skip_Eol; 755 end Skip_Line; 756 757 ---------------- 758 -- Skip_Space -- 759 ---------------- 760 761 procedure Skip_Space is 762 begin 763 while Nextc = ' ' or else Nextc = HT loop 764 P := P + 1; 765 end loop; 766 end Skip_Space; 767 768 ----------- 769 -- Skipc -- 770 ----------- 771 772 procedure Skipc is 773 begin 774 if P /= T'Last then 775 P := P + 1; 776 end if; 777 end Skipc; 778 779 -- Start of processing for Scan_ALI 780 781 begin 782 First_Sdep_Entry := Sdep.Last + 1; 783 784 -- Acquire lines to be ignored 785 786 if Read_Xref then 787 Ignore := 788 ('U' | 'W' | 'Y' | 'Z' | 'D' | 'X' => False, others => True); 789 790 -- Read_Lines parameter given 791 792 elsif Read_Lines /= "" then 793 Ignore := ('U' => False, others => True); 794 795 for J in Read_Lines'Range loop 796 Ignore (Read_Lines (J)) := False; 797 end loop; 798 799 -- Process Ignore_Lines parameter 800 801 else 802 Ignore := (others => False); 803 804 for J in Ignore_Lines'Range loop 805 pragma Assert (Ignore_Lines (J) /= 'U'); 806 Ignore (Ignore_Lines (J)) := True; 807 end loop; 808 end if; 809 810 -- Setup ALI Table entry with appropriate defaults 811 812 ALIs.Increment_Last; 813 Id := ALIs.Last; 814 Set_Name_Table_Info (F, Int (Id)); 815 816 ALIs.Table (Id) := ( 817 Afile => F, 818 Compile_Errors => False, 819 First_Interrupt_State => Interrupt_States.Last + 1, 820 First_Sdep => No_Sdep_Id, 821 First_Specific_Dispatching => Specific_Dispatching.Last + 1, 822 First_Unit => No_Unit_Id, 823 Float_Format => 'I', 824 Last_Interrupt_State => Interrupt_States.Last, 825 Last_Sdep => No_Sdep_Id, 826 Last_Specific_Dispatching => Specific_Dispatching.Last, 827 Last_Unit => No_Unit_Id, 828 Locking_Policy => ' ', 829 Main_Priority => -1, 830 Main_CPU => -1, 831 Main_Program => None, 832 No_Object => False, 833 Normalize_Scalars => False, 834 Ofile_Full_Name => Full_Object_File_Name, 835 Partition_Elaboration_Policy => ' ', 836 Queuing_Policy => ' ', 837 Restrictions => No_Restrictions, 838 SAL_Interface => False, 839 Sfile => No_File, 840 Task_Dispatching_Policy => ' ', 841 Time_Slice_Value => -1, 842 Allocator_In_Body => False, 843 WC_Encoding => 'b', 844 Unit_Exception_Table => False, 845 Ver => (others => ' '), 846 Ver_Len => 0, 847 Zero_Cost_Exceptions => False); 848 849 -- Now we acquire the input lines from the ALI file. Note that the 850 -- convention in the following code is that as we enter each section, 851 -- C is set to contain the first character of the following line. 852 853 C := Getc; 854 Check_Unknown_Line; 855 856 -- Acquire library version 857 858 if C /= 'V' then 859 860 -- The V line missing really indicates trouble, most likely it 861 -- means we don't have an ALI file at all, so here we give a 862 -- fatal error even if we are in Ignore_Errors mode. 863 864 Fatal_Error; 865 866 elsif Ignore ('V') then 867 Skip_Line; 868 869 else 870 Checkc (' '); 871 Skip_Space; 872 Checkc ('"'); 873 874 for J in 1 .. Ver_Len_Max loop 875 C := Getc; 876 exit when C = '"'; 877 ALIs.Table (Id).Ver (J) := C; 878 ALIs.Table (Id).Ver_Len := J; 879 end loop; 880 881 Skip_Eol; 882 end if; 883 884 C := Getc; 885 Check_Unknown_Line; 886 887 -- Acquire main program line if present 888 889 if C = 'M' then 890 if Ignore ('M') then 891 Skip_Line; 892 893 else 894 Checkc (' '); 895 Skip_Space; 896 897 C := Getc; 898 899 if C = 'F' then 900 ALIs.Table (Id).Main_Program := Func; 901 elsif C = 'P' then 902 ALIs.Table (Id).Main_Program := Proc; 903 else 904 P := P - 1; 905 Fatal_Error; 906 end if; 907 908 Skip_Space; 909 910 if not At_Eol then 911 if Nextc < 'A' then 912 ALIs.Table (Id).Main_Priority := Get_Nat; 913 end if; 914 915 Skip_Space; 916 917 if Nextc = 'T' then 918 P := P + 1; 919 Checkc ('='); 920 ALIs.Table (Id).Time_Slice_Value := Get_Nat; 921 end if; 922 923 Skip_Space; 924 925 if Nextc = 'A' then 926 P := P + 1; 927 Checkc ('B'); 928 ALIs.Table (Id).Allocator_In_Body := True; 929 end if; 930 931 Skip_Space; 932 933 if Nextc = 'C' then 934 P := P + 1; 935 Checkc ('='); 936 ALIs.Table (Id).Main_CPU := Get_Nat; 937 end if; 938 939 Skip_Space; 940 941 Checkc ('W'); 942 Checkc ('='); 943 ALIs.Table (Id).WC_Encoding := Getc; 944 end if; 945 946 Skip_Eol; 947 end if; 948 949 C := Getc; 950 end if; 951 952 -- Acquire argument lines 953 954 First_Arg := Args.Last + 1; 955 956 A_Loop : loop 957 Check_Unknown_Line; 958 exit A_Loop when C /= 'A'; 959 960 if Ignore ('A') then 961 Skip_Line; 962 963 else 964 Checkc (' '); 965 966 -- Scan out argument 967 968 Name_Len := 0; 969 while not At_Eol loop 970 Add_Char_To_Name_Buffer (Getc); 971 end loop; 972 973 -- If -fstack-check, record that it occurred. Note that an 974 -- additional string parameter can be specified, in the form of 975 -- -fstack-check={no|generic|specific}. "no" means no checking, 976 -- "generic" means force the use of old-style checking, and 977 -- "specific" means use the best checking method. 978 979 if Name_Len >= 13 980 and then Name_Buffer (1 .. 13) = "-fstack-check" 981 and then Name_Buffer (1 .. Name_Len) /= "-fstack-check=no" 982 then 983 Stack_Check_Switch_Set := True; 984 end if; 985 986 -- Store the argument 987 988 Args.Increment_Last; 989 Args.Table (Args.Last) := new String'(Name_Buffer (1 .. Name_Len)); 990 991 Skip_Eol; 992 end if; 993 994 C := Getc; 995 end loop A_Loop; 996 997 -- Acquire P line 998 999 Check_Unknown_Line; 1000 1001 while C /= 'P' loop 1002 if Ignore_Errors then 1003 if C = EOF then 1004 Fatal_Error; 1005 else 1006 Skip_Line; 1007 C := Nextc; 1008 end if; 1009 else 1010 Fatal_Error; 1011 end if; 1012 end loop; 1013 1014 if Ignore ('P') then 1015 Skip_Line; 1016 1017 -- Process P line 1018 1019 else 1020 NS_Found := False; 1021 1022 while not At_Eol loop 1023 Checkc (' '); 1024 Skip_Space; 1025 C := Getc; 1026 1027 -- Processing for CE 1028 1029 if C = 'C' then 1030 Checkc ('E'); 1031 ALIs.Table (Id).Compile_Errors := True; 1032 1033 -- Processing for DB 1034 1035 elsif C = 'D' then 1036 Checkc ('B'); 1037 Detect_Blocking := True; 1038 1039 -- Processing for Ex 1040 1041 elsif C = 'E' then 1042 Partition_Elaboration_Policy_Specified := Getc; 1043 ALIs.Table (Id).Partition_Elaboration_Policy := 1044 Partition_Elaboration_Policy_Specified; 1045 1046 -- Processing for FD/FG/FI 1047 1048 elsif C = 'F' then 1049 Float_Format_Specified := Getc; 1050 ALIs.Table (Id).Float_Format := Float_Format_Specified; 1051 1052 -- Processing for Lx 1053 1054 elsif C = 'L' then 1055 Locking_Policy_Specified := Getc; 1056 ALIs.Table (Id).Locking_Policy := Locking_Policy_Specified; 1057 1058 -- Processing for flags starting with N 1059 1060 elsif C = 'N' then 1061 C := Getc; 1062 1063 -- Processing for NO 1064 1065 if C = 'O' then 1066 ALIs.Table (Id).No_Object := True; 1067 No_Object_Specified := True; 1068 1069 -- Processing for NR 1070 1071 elsif C = 'R' then 1072 No_Run_Time_Mode := True; 1073 Configurable_Run_Time_Mode := True; 1074 1075 -- Processing for NS 1076 1077 elsif C = 'S' then 1078 ALIs.Table (Id).Normalize_Scalars := True; 1079 Normalize_Scalars_Specified := True; 1080 NS_Found := True; 1081 1082 -- Invalid switch starting with N 1083 1084 else 1085 Fatal_Error_Ignore; 1086 end if; 1087 1088 -- Processing for Qx 1089 1090 elsif C = 'Q' then 1091 Queuing_Policy_Specified := Getc; 1092 ALIs.Table (Id).Queuing_Policy := Queuing_Policy_Specified; 1093 1094 -- Processing for flags starting with S 1095 1096 elsif C = 'S' then 1097 C := Getc; 1098 1099 -- Processing for SL 1100 1101 if C = 'L' then 1102 ALIs.Table (Id).SAL_Interface := True; 1103 1104 -- Processing for SS 1105 1106 elsif C = 'S' then 1107 Opt.Sec_Stack_Used := True; 1108 1109 -- Invalid switch starting with S 1110 1111 else 1112 Fatal_Error_Ignore; 1113 end if; 1114 1115 -- Processing for Tx 1116 1117 elsif C = 'T' then 1118 Task_Dispatching_Policy_Specified := Getc; 1119 ALIs.Table (Id).Task_Dispatching_Policy := 1120 Task_Dispatching_Policy_Specified; 1121 1122 -- Processing for switch starting with U 1123 1124 elsif C = 'U' then 1125 C := Getc; 1126 1127 -- Processing for UA 1128 1129 if C = 'A' then 1130 Unreserve_All_Interrupts_Specified := True; 1131 1132 -- Processing for UX 1133 1134 elsif C = 'X' then 1135 ALIs.Table (Id).Unit_Exception_Table := True; 1136 1137 -- Invalid switches starting with U 1138 1139 else 1140 Fatal_Error_Ignore; 1141 end if; 1142 1143 -- Processing for ZX 1144 1145 elsif C = 'Z' then 1146 C := Getc; 1147 1148 if C = 'X' then 1149 ALIs.Table (Id).Zero_Cost_Exceptions := True; 1150 Zero_Cost_Exceptions_Specified := True; 1151 else 1152 Fatal_Error_Ignore; 1153 end if; 1154 1155 -- Invalid parameter 1156 1157 else 1158 C := Getc; 1159 Fatal_Error_Ignore; 1160 end if; 1161 end loop; 1162 1163 if not NS_Found then 1164 No_Normalize_Scalars_Specified := True; 1165 end if; 1166 1167 Skip_Eol; 1168 end if; 1169 1170 C := Getc; 1171 Check_Unknown_Line; 1172 1173 -- Loop to skip to first restrictions line 1174 1175 while C /= 'R' loop 1176 if Ignore_Errors then 1177 if C = EOF then 1178 Fatal_Error; 1179 else 1180 Skip_Line; 1181 C := Nextc; 1182 end if; 1183 else 1184 Fatal_Error; 1185 end if; 1186 end loop; 1187 1188 -- Ignore all 'R' lines if that is required 1189 1190 if Ignore ('R') then 1191 while C = 'R' loop 1192 Skip_Line; 1193 C := Getc; 1194 end loop; 1195 1196 -- Here we process the restrictions lines (other than unit name cases) 1197 1198 else 1199 Scan_Restrictions : declare 1200 Save_R : constant Restrictions_Info := Cumulative_Restrictions; 1201 -- Save cumulative restrictions in case we have a fatal error 1202 1203 Bad_R_Line : exception; 1204 -- Signal bad restrictions line (raised on unexpected character) 1205 1206 Typ : Character; 1207 R : Restriction_Id; 1208 N : Natural; 1209 1210 begin 1211 -- Named restriction case 1212 1213 if Nextc = 'N' then 1214 Skip_Line; 1215 C := Getc; 1216 1217 -- Loop through RR and RV lines 1218 1219 while C = 'R' and then Nextc /= ' ' loop 1220 Typ := Getc; 1221 Checkc (' '); 1222 1223 -- Acquire restriction name 1224 1225 Name_Len := 0; 1226 while not At_Eol and then Nextc /= '=' loop 1227 Name_Len := Name_Len + 1; 1228 Name_Buffer (Name_Len) := Getc; 1229 end loop; 1230 1231 -- Now search list of restrictions to find match 1232 1233 declare 1234 RN : String renames Name_Buffer (1 .. Name_Len); 1235 1236 begin 1237 R := Restriction_Id'First; 1238 while R < Not_A_Restriction_Id loop 1239 if Restriction_Id'Image (R) = RN then 1240 goto R_Found; 1241 end if; 1242 1243 R := Restriction_Id'Succ (R); 1244 end loop; 1245 1246 -- We don't recognize the restriction. This might be 1247 -- thought of as an error, and it really is, but we 1248 -- want to allow building with inconsistent versions 1249 -- of the binder and ali files (see comments at the 1250 -- start of package System.Rident), so we just ignore 1251 -- this situation. 1252 1253 goto Done_With_Restriction_Line; 1254 end; 1255 1256 <<R_Found>> 1257 1258 case R is 1259 1260 -- Boolean restriction case 1261 1262 when All_Boolean_Restrictions => 1263 case Typ is 1264 when 'V' => 1265 ALIs.Table (Id).Restrictions.Violated (R) := 1266 True; 1267 Cumulative_Restrictions.Violated (R) := True; 1268 1269 when 'R' => 1270 ALIs.Table (Id).Restrictions.Set (R) := True; 1271 Cumulative_Restrictions.Set (R) := True; 1272 1273 when others => 1274 raise Bad_R_Line; 1275 end case; 1276 1277 -- Parameter restriction case 1278 1279 when All_Parameter_Restrictions => 1280 if At_Eol or else Nextc /= '=' then 1281 raise Bad_R_Line; 1282 else 1283 Skipc; 1284 end if; 1285 1286 N := Natural (Get_Nat); 1287 1288 case Typ is 1289 1290 -- Restriction set 1291 1292 when 'R' => 1293 ALIs.Table (Id).Restrictions.Set (R) := True; 1294 ALIs.Table (Id).Restrictions.Value (R) := N; 1295 1296 if Cumulative_Restrictions.Set (R) then 1297 Cumulative_Restrictions.Value (R) := 1298 Integer'Min 1299 (Cumulative_Restrictions.Value (R), N); 1300 else 1301 Cumulative_Restrictions.Set (R) := True; 1302 Cumulative_Restrictions.Value (R) := N; 1303 end if; 1304 1305 -- Restriction violated 1306 1307 when 'V' => 1308 ALIs.Table (Id).Restrictions.Violated (R) := 1309 True; 1310 Cumulative_Restrictions.Violated (R) := True; 1311 ALIs.Table (Id).Restrictions.Count (R) := N; 1312 1313 -- Checked Max_Parameter case 1314 1315 if R in Checked_Max_Parameter_Restrictions then 1316 Cumulative_Restrictions.Count (R) := 1317 Integer'Max 1318 (Cumulative_Restrictions.Count (R), N); 1319 1320 -- Other checked parameter cases 1321 1322 else 1323 declare 1324 pragma Unsuppress (Overflow_Check); 1325 1326 begin 1327 Cumulative_Restrictions.Count (R) := 1328 Cumulative_Restrictions.Count (R) + N; 1329 1330 exception 1331 when Constraint_Error => 1332 1333 -- A constraint error comes from the 1334 -- additionh. We reset to the maximum 1335 -- and indicate that the real value is 1336 -- now unknown. 1337 1338 Cumulative_Restrictions.Value (R) := 1339 Integer'Last; 1340 Cumulative_Restrictions.Unknown (R) := 1341 True; 1342 end; 1343 end if; 1344 1345 -- Deal with + case 1346 1347 if Nextc = '+' then 1348 Skipc; 1349 ALIs.Table (Id).Restrictions.Unknown (R) := 1350 True; 1351 Cumulative_Restrictions.Unknown (R) := True; 1352 end if; 1353 1354 -- Other than 'R' or 'V' 1355 1356 when others => 1357 raise Bad_R_Line; 1358 end case; 1359 1360 if not At_Eol then 1361 raise Bad_R_Line; 1362 end if; 1363 1364 -- Bizarre error case NOT_A_RESTRICTION 1365 1366 when Not_A_Restriction_Id => 1367 raise Bad_R_Line; 1368 end case; 1369 1370 if not At_Eol then 1371 raise Bad_R_Line; 1372 end if; 1373 1374 <<Done_With_Restriction_Line>> 1375 Skip_Line; 1376 C := Getc; 1377 end loop; 1378 1379 -- Positional restriction case 1380 1381 else 1382 Checkc (' '); 1383 Skip_Space; 1384 1385 -- Acquire information for boolean restrictions 1386 1387 for R in All_Boolean_Restrictions loop 1388 C := Getc; 1389 1390 case C is 1391 when 'v' => 1392 ALIs.Table (Id).Restrictions.Violated (R) := True; 1393 Cumulative_Restrictions.Violated (R) := True; 1394 1395 when 'r' => 1396 ALIs.Table (Id).Restrictions.Set (R) := True; 1397 Cumulative_Restrictions.Set (R) := True; 1398 1399 when 'n' => 1400 null; 1401 1402 when others => 1403 raise Bad_R_Line; 1404 end case; 1405 end loop; 1406 1407 -- Acquire information for parameter restrictions 1408 1409 for RP in All_Parameter_Restrictions loop 1410 case Getc is 1411 when 'n' => 1412 null; 1413 1414 when 'r' => 1415 ALIs.Table (Id).Restrictions.Set (RP) := True; 1416 1417 declare 1418 N : constant Integer := Integer (Get_Nat); 1419 begin 1420 ALIs.Table (Id).Restrictions.Value (RP) := N; 1421 1422 if Cumulative_Restrictions.Set (RP) then 1423 Cumulative_Restrictions.Value (RP) := 1424 Integer'Min 1425 (Cumulative_Restrictions.Value (RP), N); 1426 else 1427 Cumulative_Restrictions.Set (RP) := True; 1428 Cumulative_Restrictions.Value (RP) := N; 1429 end if; 1430 end; 1431 1432 when others => 1433 raise Bad_R_Line; 1434 end case; 1435 1436 -- Acquire restrictions violations information 1437 1438 case Getc is 1439 1440 when 'n' => 1441 null; 1442 1443 when 'v' => 1444 ALIs.Table (Id).Restrictions.Violated (RP) := True; 1445 Cumulative_Restrictions.Violated (RP) := True; 1446 1447 declare 1448 N : constant Integer := Integer (Get_Nat); 1449 1450 begin 1451 ALIs.Table (Id).Restrictions.Count (RP) := N; 1452 1453 if RP in Checked_Max_Parameter_Restrictions then 1454 Cumulative_Restrictions.Count (RP) := 1455 Integer'Max 1456 (Cumulative_Restrictions.Count (RP), N); 1457 1458 else 1459 declare 1460 pragma Unsuppress (Overflow_Check); 1461 1462 begin 1463 Cumulative_Restrictions.Count (RP) := 1464 Cumulative_Restrictions.Count (RP) + N; 1465 1466 exception 1467 when Constraint_Error => 1468 1469 -- A constraint error comes from the add. We 1470 -- reset to the maximum and indicate that the 1471 -- real value is now unknown. 1472 1473 Cumulative_Restrictions.Value (RP) := 1474 Integer'Last; 1475 Cumulative_Restrictions.Unknown (RP) := True; 1476 end; 1477 end if; 1478 1479 if Nextc = '+' then 1480 Skipc; 1481 ALIs.Table (Id).Restrictions.Unknown (RP) := True; 1482 Cumulative_Restrictions.Unknown (RP) := True; 1483 end if; 1484 end; 1485 1486 when others => 1487 raise Bad_R_Line; 1488 end case; 1489 end loop; 1490 1491 if not At_Eol then 1492 raise Bad_R_Line; 1493 else 1494 Skip_Line; 1495 C := Getc; 1496 end if; 1497 end if; 1498 1499 -- Here if error during scanning of restrictions line 1500 1501 exception 1502 when Bad_R_Line => 1503 1504 -- In Ignore_Errors mode, undo any changes to restrictions 1505 -- from this unit, and continue on, skipping remaining R 1506 -- lines for this unit. 1507 1508 if Ignore_Errors then 1509 Cumulative_Restrictions := Save_R; 1510 ALIs.Table (Id).Restrictions := No_Restrictions; 1511 1512 loop 1513 Skip_Eol; 1514 C := Getc; 1515 exit when C /= 'R'; 1516 end loop; 1517 1518 -- In normal mode, this is a fatal error 1519 1520 else 1521 Fatal_Error; 1522 end if; 1523 end Scan_Restrictions; 1524 end if; 1525 1526 -- Acquire additional restrictions (No_Dependence) lines if present 1527 1528 while C = 'R' loop 1529 if Ignore ('R') then 1530 Skip_Line; 1531 else 1532 Skip_Space; 1533 No_Deps.Append ((Id, Get_Name)); 1534 Skip_Eol; 1535 end if; 1536 1537 C := Getc; 1538 end loop; 1539 1540 -- Acquire 'I' lines if present 1541 1542 Check_Unknown_Line; 1543 1544 while C = 'I' loop 1545 if Ignore ('I') then 1546 Skip_Line; 1547 1548 else 1549 declare 1550 Int_Num : Nat; 1551 I_State : Character; 1552 Line_No : Nat; 1553 1554 begin 1555 Int_Num := Get_Nat; 1556 Skip_Space; 1557 I_State := Getc; 1558 Line_No := Get_Nat; 1559 1560 Interrupt_States.Append ( 1561 (Interrupt_Id => Int_Num, 1562 Interrupt_State => I_State, 1563 IS_Pragma_Line => Line_No)); 1564 1565 ALIs.Table (Id).Last_Interrupt_State := Interrupt_States.Last; 1566 Skip_Eol; 1567 end; 1568 end if; 1569 1570 C := Getc; 1571 end loop; 1572 1573 -- Acquire 'S' lines if present 1574 1575 Check_Unknown_Line; 1576 1577 while C = 'S' loop 1578 if Ignore ('S') then 1579 Skip_Line; 1580 1581 else 1582 declare 1583 Policy : Character; 1584 First_Prio : Nat; 1585 Last_Prio : Nat; 1586 Line_No : Nat; 1587 1588 begin 1589 Checkc (' '); 1590 Skip_Space; 1591 1592 Policy := Getc; 1593 Skip_Space; 1594 First_Prio := Get_Nat; 1595 Last_Prio := Get_Nat; 1596 Line_No := Get_Nat; 1597 1598 Specific_Dispatching.Append ( 1599 (Dispatching_Policy => Policy, 1600 First_Priority => First_Prio, 1601 Last_Priority => Last_Prio, 1602 PSD_Pragma_Line => Line_No)); 1603 1604 ALIs.Table (Id).Last_Specific_Dispatching := 1605 Specific_Dispatching.Last; 1606 1607 Skip_Eol; 1608 end; 1609 end if; 1610 1611 C := Getc; 1612 end loop; 1613 1614 -- Loop to acquire unit entries 1615 1616 U_Loop : loop 1617 Check_Unknown_Line; 1618 exit U_Loop when C /= 'U'; 1619 1620 -- Note: as per spec, we never ignore U lines 1621 1622 Checkc (' '); 1623 Skip_Space; 1624 Units.Increment_Last; 1625 1626 if ALIs.Table (Id).First_Unit = No_Unit_Id then 1627 ALIs.Table (Id).First_Unit := Units.Last; 1628 end if; 1629 1630 declare 1631 UL : Unit_Record renames Units.Table (Units.Last); 1632 1633 begin 1634 UL.Uname := Get_Unit_Name; 1635 UL.Predefined := Is_Predefined_Unit; 1636 UL.Internal := Is_Internal_Unit; 1637 UL.My_ALI := Id; 1638 UL.Sfile := Get_File_Name (Lower => True); 1639 UL.Pure := False; 1640 UL.Preelab := False; 1641 UL.No_Elab := False; 1642 UL.Shared_Passive := False; 1643 UL.RCI := False; 1644 UL.Remote_Types := False; 1645 UL.Has_RACW := False; 1646 UL.Init_Scalars := False; 1647 UL.Is_Generic := False; 1648 UL.Icasing := Mixed_Case; 1649 UL.Kcasing := All_Lower_Case; 1650 UL.Dynamic_Elab := False; 1651 UL.Elaborate_Body := False; 1652 UL.Set_Elab_Entity := False; 1653 UL.Version := "00000000"; 1654 UL.First_With := Withs.Last + 1; 1655 UL.First_Arg := First_Arg; 1656 UL.Elab_Position := 0; 1657 UL.SAL_Interface := ALIs.Table (Id).SAL_Interface; 1658 UL.Directly_Scanned := Directly_Scanned; 1659 UL.Body_Needed_For_SAL := False; 1660 UL.Elaborate_Body_Desirable := False; 1661 UL.Optimize_Alignment := 'O'; 1662 UL.Has_Finalizer := False; 1663 1664 if Debug_Flag_U then 1665 Write_Str (" ----> reading unit "); 1666 Write_Int (Int (Units.Last)); 1667 Write_Str (" "); 1668 Write_Unit_Name (UL.Uname); 1669 Write_Str (" from file "); 1670 Write_Name (UL.Sfile); 1671 Write_Eol; 1672 end if; 1673 end; 1674 1675 -- Check for duplicated unit in different files 1676 1677 declare 1678 Info : constant Int := Get_Name_Table_Info 1679 (Units.Table (Units.Last).Uname); 1680 begin 1681 if Info /= 0 1682 and then Units.Table (Units.Last).Sfile /= 1683 Units.Table (Unit_Id (Info)).Sfile 1684 then 1685 -- If Err is set then ignore duplicate unit name. This is the 1686 -- case of a call from gnatmake, where the situation can arise 1687 -- from substitution of source files. In such situations, the 1688 -- processing in gnatmake will always result in any required 1689 -- recompilations in any case, and if we consider this to be 1690 -- an error we get strange cases (for example when a generic 1691 -- instantiation is replaced by a normal package) where we 1692 -- read the old ali file, decide to recompile, and then decide 1693 -- that the old and new ali files are incompatible. 1694 1695 if Err then 1696 null; 1697 1698 -- If Err is not set, then this is a fatal error. This is 1699 -- the case of being called from the binder, where we must 1700 -- definitely diagnose this as an error. 1701 1702 else 1703 Set_Standard_Error; 1704 Write_Str ("error: duplicate unit name: "); 1705 Write_Eol; 1706 1707 Write_Str ("error: unit """); 1708 Write_Unit_Name (Units.Table (Units.Last).Uname); 1709 Write_Str (""" found in file """); 1710 Write_Name_Decoded (Units.Table (Units.Last).Sfile); 1711 Write_Char ('"'); 1712 Write_Eol; 1713 1714 Write_Str ("error: unit """); 1715 Write_Unit_Name (Units.Table (Unit_Id (Info)).Uname); 1716 Write_Str (""" found in file """); 1717 Write_Name_Decoded (Units.Table (Unit_Id (Info)).Sfile); 1718 Write_Char ('"'); 1719 Write_Eol; 1720 1721 Exit_Program (E_Fatal); 1722 end if; 1723 end if; 1724 end; 1725 1726 Set_Name_Table_Info 1727 (Units.Table (Units.Last).Uname, Int (Units.Last)); 1728 1729 -- Scan out possible version and other parameters 1730 1731 loop 1732 Skip_Space; 1733 exit when At_Eol; 1734 C := Getc; 1735 1736 -- Version field 1737 1738 if C in '0' .. '9' or else C in 'a' .. 'f' then 1739 Units.Table (Units.Last).Version (1) := C; 1740 1741 for J in 2 .. 8 loop 1742 C := Getc; 1743 Units.Table (Units.Last).Version (J) := C; 1744 end loop; 1745 1746 -- BD/BN parameters 1747 1748 elsif C = 'B' then 1749 C := Getc; 1750 1751 if C = 'D' then 1752 Check_At_End_Of_Field; 1753 Units.Table (Units.Last).Elaborate_Body_Desirable := True; 1754 1755 elsif C = 'N' then 1756 Check_At_End_Of_Field; 1757 Units.Table (Units.Last).Body_Needed_For_SAL := True; 1758 1759 else 1760 Fatal_Error_Ignore; 1761 end if; 1762 1763 -- DE parameter (Dynamic elaboration checks) 1764 1765 elsif C = 'D' then 1766 C := Getc; 1767 1768 if C = 'E' then 1769 Check_At_End_Of_Field; 1770 Units.Table (Units.Last).Dynamic_Elab := True; 1771 Dynamic_Elaboration_Checks_Specified := True; 1772 else 1773 Fatal_Error_Ignore; 1774 end if; 1775 1776 -- EB/EE parameters 1777 1778 elsif C = 'E' then 1779 C := Getc; 1780 1781 if C = 'B' then 1782 Units.Table (Units.Last).Elaborate_Body := True; 1783 elsif C = 'E' then 1784 Units.Table (Units.Last).Set_Elab_Entity := True; 1785 else 1786 Fatal_Error_Ignore; 1787 end if; 1788 1789 Check_At_End_Of_Field; 1790 1791 -- GE parameter (generic) 1792 1793 elsif C = 'G' then 1794 C := Getc; 1795 1796 if C = 'E' then 1797 Check_At_End_Of_Field; 1798 Units.Table (Units.Last).Is_Generic := True; 1799 else 1800 Fatal_Error_Ignore; 1801 end if; 1802 1803 -- IL/IS/IU parameters 1804 1805 elsif C = 'I' then 1806 C := Getc; 1807 1808 if C = 'L' then 1809 Units.Table (Units.Last).Icasing := All_Lower_Case; 1810 elsif C = 'S' then 1811 Units.Table (Units.Last).Init_Scalars := True; 1812 Initialize_Scalars_Used := True; 1813 elsif C = 'U' then 1814 Units.Table (Units.Last).Icasing := All_Upper_Case; 1815 else 1816 Fatal_Error_Ignore; 1817 end if; 1818 1819 Check_At_End_Of_Field; 1820 1821 -- KM/KU parameters 1822 1823 elsif C = 'K' then 1824 C := Getc; 1825 1826 if C = 'M' then 1827 Units.Table (Units.Last).Kcasing := Mixed_Case; 1828 elsif C = 'U' then 1829 Units.Table (Units.Last).Kcasing := All_Upper_Case; 1830 else 1831 Fatal_Error_Ignore; 1832 end if; 1833 1834 Check_At_End_Of_Field; 1835 1836 -- NE parameter 1837 1838 elsif C = 'N' then 1839 C := Getc; 1840 1841 if C = 'E' then 1842 Units.Table (Units.Last).No_Elab := True; 1843 Check_At_End_Of_Field; 1844 else 1845 Fatal_Error_Ignore; 1846 end if; 1847 1848 -- PF/PR/PU/PK parameters 1849 1850 elsif C = 'P' then 1851 C := Getc; 1852 1853 if C = 'F' then 1854 Units.Table (Units.Last).Has_Finalizer := True; 1855 elsif C = 'R' then 1856 Units.Table (Units.Last).Preelab := True; 1857 elsif C = 'U' then 1858 Units.Table (Units.Last).Pure := True; 1859 elsif C = 'K' then 1860 Units.Table (Units.Last).Unit_Kind := 'p'; 1861 else 1862 Fatal_Error_Ignore; 1863 end if; 1864 1865 Check_At_End_Of_Field; 1866 1867 -- OL/OO/OS/OT parameters 1868 1869 elsif C = 'O' then 1870 C := Getc; 1871 1872 if C = 'L' or else C = 'O' or else C = 'S' or else C = 'T' then 1873 Units.Table (Units.Last).Optimize_Alignment := C; 1874 else 1875 Fatal_Error_Ignore; 1876 end if; 1877 1878 Check_At_End_Of_Field; 1879 1880 -- RC/RT parameters 1881 1882 elsif C = 'R' then 1883 C := Getc; 1884 1885 if C = 'C' then 1886 Units.Table (Units.Last).RCI := True; 1887 elsif C = 'T' then 1888 Units.Table (Units.Last).Remote_Types := True; 1889 elsif C = 'A' then 1890 Units.Table (Units.Last).Has_RACW := True; 1891 else 1892 Fatal_Error_Ignore; 1893 end if; 1894 1895 Check_At_End_Of_Field; 1896 1897 elsif C = 'S' then 1898 C := Getc; 1899 1900 if C = 'P' then 1901 Units.Table (Units.Last).Shared_Passive := True; 1902 elsif C = 'U' then 1903 Units.Table (Units.Last).Unit_Kind := 's'; 1904 else 1905 Fatal_Error_Ignore; 1906 end if; 1907 1908 Check_At_End_Of_Field; 1909 1910 else 1911 C := Getc; 1912 Fatal_Error_Ignore; 1913 end if; 1914 end loop; 1915 1916 Skip_Eol; 1917 1918 -- Check if static elaboration model used 1919 1920 if not Units.Table (Units.Last).Dynamic_Elab 1921 and then not Units.Table (Units.Last).Internal 1922 then 1923 Static_Elaboration_Model_Used := True; 1924 end if; 1925 1926 C := Getc; 1927 1928 -- Scan out With lines for this unit 1929 1930 With_Loop : loop 1931 Check_Unknown_Line; 1932 exit With_Loop when C /= 'W' and then C /= 'Y' and then C /= 'Z'; 1933 1934 if Ignore ('W') then 1935 Skip_Line; 1936 1937 else 1938 Checkc (' '); 1939 Skip_Space; 1940 Withs.Increment_Last; 1941 Withs.Table (Withs.Last).Uname := Get_Unit_Name; 1942 Withs.Table (Withs.Last).Elaborate := False; 1943 Withs.Table (Withs.Last).Elaborate_All := False; 1944 Withs.Table (Withs.Last).Elab_Desirable := False; 1945 Withs.Table (Withs.Last).Elab_All_Desirable := False; 1946 Withs.Table (Withs.Last).SAL_Interface := False; 1947 Withs.Table (Withs.Last).Limited_With := (C = 'Y'); 1948 Withs.Table (Withs.Last).Implicit_With_From_Instantiation 1949 := (C = 'Z'); 1950 1951 -- Generic case with no object file available 1952 1953 if At_Eol then 1954 Withs.Table (Withs.Last).Sfile := No_File; 1955 Withs.Table (Withs.Last).Afile := No_File; 1956 1957 -- Normal case 1958 1959 else 1960 Withs.Table (Withs.Last).Sfile := Get_File_Name 1961 (Lower => True); 1962 Withs.Table (Withs.Last).Afile := Get_File_Name 1963 (Lower => True); 1964 1965 -- Scan out possible E, EA, ED, and AD parameters 1966 1967 while not At_Eol loop 1968 Skip_Space; 1969 1970 if Nextc = 'A' then 1971 P := P + 1; 1972 Checkc ('D'); 1973 Check_At_End_Of_Field; 1974 1975 -- Store AD indication unless ignore required 1976 1977 if not Ignore_ED then 1978 Withs.Table (Withs.Last).Elab_All_Desirable := 1979 True; 1980 end if; 1981 1982 elsif Nextc = 'E' then 1983 P := P + 1; 1984 1985 if At_End_Of_Field then 1986 Withs.Table (Withs.Last).Elaborate := True; 1987 1988 elsif Nextc = 'A' then 1989 P := P + 1; 1990 Check_At_End_Of_Field; 1991 Withs.Table (Withs.Last).Elaborate_All := True; 1992 1993 else 1994 Checkc ('D'); 1995 Check_At_End_Of_Field; 1996 1997 -- Store ED indication unless ignore required 1998 1999 if not Ignore_ED then 2000 Withs.Table (Withs.Last).Elab_Desirable := 2001 True; 2002 end if; 2003 end if; 2004 2005 else 2006 Fatal_Error; 2007 end if; 2008 end loop; 2009 end if; 2010 2011 Skip_Eol; 2012 end if; 2013 2014 C := Getc; 2015 end loop With_Loop; 2016 2017 Units.Table (Units.Last).Last_With := Withs.Last; 2018 Units.Table (Units.Last).Last_Arg := Args.Last; 2019 2020 -- If there are linker options lines present, scan them 2021 2022 Name_Len := 0; 2023 2024 Linker_Options_Loop : loop 2025 Check_Unknown_Line; 2026 exit Linker_Options_Loop when C /= 'L'; 2027 2028 if Ignore ('L') then 2029 Skip_Line; 2030 2031 else 2032 Checkc (' '); 2033 Skip_Space; 2034 Checkc ('"'); 2035 2036 loop 2037 C := Getc; 2038 2039 if C < Character'Val (16#20#) 2040 or else C > Character'Val (16#7E#) 2041 then 2042 Fatal_Error_Ignore; 2043 2044 elsif C = '{' then 2045 C := Character'Val (0); 2046 2047 declare 2048 V : Natural; 2049 2050 begin 2051 V := 0; 2052 for J in 1 .. 2 loop 2053 C := Getc; 2054 2055 if C in '0' .. '9' then 2056 V := V * 16 + 2057 Character'Pos (C) - 2058 Character'Pos ('0'); 2059 2060 elsif C in 'A' .. 'F' then 2061 V := V * 16 + 2062 Character'Pos (C) - 2063 Character'Pos ('A') + 2064 10; 2065 2066 else 2067 Fatal_Error_Ignore; 2068 end if; 2069 end loop; 2070 2071 Checkc ('}'); 2072 Add_Char_To_Name_Buffer (Character'Val (V)); 2073 end; 2074 2075 else 2076 if C = '"' then 2077 exit when Nextc /= '"'; 2078 C := Getc; 2079 end if; 2080 2081 Add_Char_To_Name_Buffer (C); 2082 end if; 2083 end loop; 2084 2085 Add_Char_To_Name_Buffer (NUL); 2086 Skip_Eol; 2087 end if; 2088 2089 C := Getc; 2090 end loop Linker_Options_Loop; 2091 2092 -- Store the linker options entry if one was found 2093 2094 if Name_Len /= 0 then 2095 Linker_Options.Increment_Last; 2096 2097 Linker_Options.Table (Linker_Options.Last).Name := 2098 Name_Enter; 2099 2100 Linker_Options.Table (Linker_Options.Last).Unit := 2101 Units.Last; 2102 2103 Linker_Options.Table (Linker_Options.Last).Internal_File := 2104 Is_Internal_File_Name (F); 2105 2106 Linker_Options.Table (Linker_Options.Last).Original_Pos := 2107 Linker_Options.Last; 2108 end if; 2109 2110 -- If there are notes present, scan them 2111 2112 Notes_Loop : loop 2113 Check_Unknown_Line; 2114 exit Notes_Loop when C /= 'N'; 2115 2116 if Ignore ('N') then 2117 Skip_Line; 2118 2119 else 2120 Checkc (' '); 2121 2122 Notes.Increment_Last; 2123 Notes.Table (Notes.Last).Pragma_Type := Getc; 2124 Notes.Table (Notes.Last).Pragma_Line := Get_Nat; 2125 Checkc (':'); 2126 Notes.Table (Notes.Last).Pragma_Col := Get_Nat; 2127 Notes.Table (Notes.Last).Unit := Units.Last; 2128 2129 if At_Eol then 2130 Notes.Table (Notes.Last).Pragma_Args := No_Name; 2131 2132 else 2133 Checkc (' '); 2134 2135 Name_Len := 0; 2136 while not At_Eol loop 2137 Add_Char_To_Name_Buffer (Getc); 2138 end loop; 2139 2140 Notes.Table (Notes.Last).Pragma_Args := Name_Enter; 2141 end if; 2142 2143 Skip_Eol; 2144 end if; 2145 2146 C := Getc; 2147 end loop Notes_Loop; 2148 end loop U_Loop; 2149 2150 -- End loop through units for one ALI file 2151 2152 ALIs.Table (Id).Last_Unit := Units.Last; 2153 ALIs.Table (Id).Sfile := Units.Table (ALIs.Table (Id).First_Unit).Sfile; 2154 2155 -- Set types of the units (there can be at most 2 of them) 2156 2157 if ALIs.Table (Id).First_Unit /= ALIs.Table (Id).Last_Unit then 2158 Units.Table (ALIs.Table (Id).First_Unit).Utype := Is_Body; 2159 Units.Table (ALIs.Table (Id).Last_Unit).Utype := Is_Spec; 2160 2161 else 2162 -- Deal with body only and spec only cases, note that the reason we 2163 -- do our own checking of the name (rather than using Is_Body_Name) 2164 -- is that Uname drags in far too much compiler junk! 2165 2166 Get_Name_String (Units.Table (Units.Last).Uname); 2167 2168 if Name_Buffer (Name_Len) = 'b' then 2169 Units.Table (Units.Last).Utype := Is_Body_Only; 2170 else 2171 Units.Table (Units.Last).Utype := Is_Spec_Only; 2172 end if; 2173 end if; 2174 2175 -- Scan out external version references and put in hash table 2176 2177 E_Loop : loop 2178 Check_Unknown_Line; 2179 exit E_Loop when C /= 'E'; 2180 2181 if Ignore ('E') then 2182 Skip_Line; 2183 2184 else 2185 Checkc (' '); 2186 Skip_Space; 2187 2188 Name_Len := 0; 2189 Name_Len := 0; 2190 loop 2191 C := Getc; 2192 2193 if C < ' ' then 2194 Fatal_Error; 2195 end if; 2196 2197 exit when At_End_Of_Field; 2198 Add_Char_To_Name_Buffer (C); 2199 end loop; 2200 2201 Version_Ref.Set (new String'(Name_Buffer (1 .. Name_Len)), True); 2202 Skip_Eol; 2203 end if; 2204 2205 C := Getc; 2206 end loop E_Loop; 2207 2208 -- Scan out source dependency lines for this ALI file 2209 2210 ALIs.Table (Id).First_Sdep := Sdep.Last + 1; 2211 2212 D_Loop : loop 2213 Check_Unknown_Line; 2214 exit D_Loop when C /= 'D'; 2215 2216 if Ignore ('D') then 2217 Skip_Line; 2218 2219 else 2220 Checkc (' '); 2221 Skip_Space; 2222 Sdep.Increment_Last; 2223 2224 -- In the following call, Lower is not set to True, this is either 2225 -- a bug, or it deserves a special comment as to why this is so??? 2226 2227 Sdep.Table (Sdep.Last).Sfile := Get_File_Name; 2228 2229 Sdep.Table (Sdep.Last).Stamp := Get_Stamp; 2230 Sdep.Table (Sdep.Last).Dummy_Entry := 2231 (Sdep.Table (Sdep.Last).Stamp = Dummy_Time_Stamp); 2232 2233 -- Acquire checksum value 2234 2235 Skip_Space; 2236 2237 declare 2238 Ctr : Natural; 2239 Chk : Word; 2240 2241 begin 2242 Ctr := 0; 2243 Chk := 0; 2244 2245 loop 2246 exit when At_Eol or else Ctr = 8; 2247 2248 if Nextc in '0' .. '9' then 2249 Chk := Chk * 16 + 2250 Character'Pos (Nextc) - Character'Pos ('0'); 2251 2252 elsif Nextc in 'a' .. 'f' then 2253 Chk := Chk * 16 + 2254 Character'Pos (Nextc) - Character'Pos ('a') + 10; 2255 2256 else 2257 exit; 2258 end if; 2259 2260 Ctr := Ctr + 1; 2261 P := P + 1; 2262 end loop; 2263 2264 if Ctr = 8 and then At_End_Of_Field then 2265 Sdep.Table (Sdep.Last).Checksum := Chk; 2266 else 2267 Fatal_Error; 2268 end if; 2269 end; 2270 2271 -- Acquire subunit and reference file name entries 2272 2273 Sdep.Table (Sdep.Last).Subunit_Name := No_Name; 2274 Sdep.Table (Sdep.Last).Rfile := 2275 Sdep.Table (Sdep.Last).Sfile; 2276 Sdep.Table (Sdep.Last).Start_Line := 1; 2277 2278 if not At_Eol then 2279 Skip_Space; 2280 2281 -- Here for subunit name 2282 2283 if Nextc not in '0' .. '9' then 2284 Name_Len := 0; 2285 while not At_End_Of_Field loop 2286 Add_Char_To_Name_Buffer (Getc); 2287 end loop; 2288 2289 -- Set the subunit name. Note that we use Name_Find rather 2290 -- than Name_Enter here as the subunit name may already 2291 -- have been put in the name table by the Project Manager. 2292 2293 Sdep.Table (Sdep.Last).Subunit_Name := Name_Find; 2294 2295 Skip_Space; 2296 end if; 2297 2298 -- Here for reference file name entry 2299 2300 if Nextc in '0' .. '9' then 2301 Sdep.Table (Sdep.Last).Start_Line := Get_Nat; 2302 Checkc (':'); 2303 2304 Name_Len := 0; 2305 2306 while not At_End_Of_Field loop 2307 Add_Char_To_Name_Buffer (Getc); 2308 end loop; 2309 2310 Sdep.Table (Sdep.Last).Rfile := Name_Enter; 2311 end if; 2312 end if; 2313 2314 Skip_Eol; 2315 end if; 2316 2317 C := Getc; 2318 end loop D_Loop; 2319 2320 ALIs.Table (Id).Last_Sdep := Sdep.Last; 2321 2322 -- We must at this stage be at an Xref line or the end of file 2323 2324 if C = EOF then 2325 return Id; 2326 end if; 2327 2328 Check_Unknown_Line; 2329 2330 if C /= 'X' then 2331 Fatal_Error; 2332 end if; 2333 2334 -- If we are ignoring Xref sections we are done (we ignore all 2335 -- remaining lines since only xref related lines follow X). 2336 2337 if Ignore ('X') and then not Debug_Flag_X then 2338 return Id; 2339 end if; 2340 2341 -- Loop through Xref sections 2342 2343 X_Loop : loop 2344 Check_Unknown_Line; 2345 exit X_Loop when C /= 'X'; 2346 2347 -- Make new entry in section table 2348 2349 Xref_Section.Increment_Last; 2350 2351 Read_Refs_For_One_File : declare 2352 XS : Xref_Section_Record renames 2353 Xref_Section.Table (Xref_Section.Last); 2354 2355 Current_File_Num : Sdep_Id; 2356 -- Keeps track of the current file number (changed by nn|) 2357 2358 begin 2359 XS.File_Num := Sdep_Id (Get_Nat + Nat (First_Sdep_Entry) - 1); 2360 XS.File_Name := Get_File_Name; 2361 XS.First_Entity := Xref_Entity.Last + 1; 2362 2363 Current_File_Num := XS.File_Num; 2364 2365 Skip_Space; 2366 2367 Skip_Eol; 2368 C := Nextc; 2369 2370 -- Loop through Xref entities 2371 2372 while C /= 'X' and then C /= EOF loop 2373 Xref_Entity.Increment_Last; 2374 2375 Read_Refs_For_One_Entity : declare 2376 XE : Xref_Entity_Record renames 2377 Xref_Entity.Table (Xref_Entity.Last); 2378 N : Nat; 2379 2380 procedure Read_Instantiation_Reference; 2381 -- Acquire instantiation reference. Caller has checked 2382 -- that current character is '[' and on return the cursor 2383 -- is skipped past the corresponding closing ']'. 2384 2385 ---------------------------------- 2386 -- Read_Instantiation_Reference -- 2387 ---------------------------------- 2388 2389 procedure Read_Instantiation_Reference is 2390 Local_File_Num : Sdep_Id := Current_File_Num; 2391 2392 begin 2393 Xref.Increment_Last; 2394 2395 declare 2396 XR : Xref_Record renames Xref.Table (Xref.Last); 2397 2398 begin 2399 P := P + 1; -- skip [ 2400 N := Get_Nat; 2401 2402 if Nextc = '|' then 2403 XR.File_Num := 2404 Sdep_Id (N + Nat (First_Sdep_Entry) - 1); 2405 Local_File_Num := XR.File_Num; 2406 P := P + 1; 2407 N := Get_Nat; 2408 2409 else 2410 XR.File_Num := Local_File_Num; 2411 end if; 2412 2413 XR.Line := N; 2414 XR.Rtype := ' '; 2415 XR.Col := 0; 2416 2417 -- Recursive call for next reference 2418 2419 if Nextc = '[' then 2420 pragma Warnings (Off); -- kill recursion warning 2421 Read_Instantiation_Reference; 2422 pragma Warnings (On); 2423 end if; 2424 2425 -- Skip closing bracket after recursive call 2426 2427 P := P + 1; 2428 end; 2429 end Read_Instantiation_Reference; 2430 2431 -- Start of processing for Read_Refs_For_One_Entity 2432 2433 begin 2434 XE.Line := Get_Nat; 2435 XE.Etype := Getc; 2436 XE.Col := Get_Nat; 2437 2438 case Getc is 2439 when '*' => 2440 XE.Visibility := Global; 2441 when '+' => 2442 XE.Visibility := Static; 2443 when others => 2444 XE.Visibility := Other; 2445 end case; 2446 2447 XE.Entity := Get_Name; 2448 2449 -- Handle the information about generic instantiations 2450 2451 if Nextc = '[' then 2452 Skipc; -- Opening '[' 2453 N := Get_Nat; 2454 2455 if Nextc /= '|' then 2456 XE.Iref_File_Num := Current_File_Num; 2457 XE.Iref_Line := N; 2458 else 2459 XE.Iref_File_Num := 2460 Sdep_Id (N + Nat (First_Sdep_Entry) - 1); 2461 Skipc; 2462 XE.Iref_Line := Get_Nat; 2463 end if; 2464 2465 if Getc /= ']' then 2466 Fatal_Error; 2467 end if; 2468 2469 else 2470 XE.Iref_File_Num := No_Sdep_Id; 2471 XE.Iref_Line := 0; 2472 end if; 2473 2474 Current_File_Num := XS.File_Num; 2475 2476 -- Renaming reference is present 2477 2478 if Nextc = '=' then 2479 P := P + 1; 2480 XE.Rref_Line := Get_Nat; 2481 2482 if Getc /= ':' then 2483 Fatal_Error; 2484 end if; 2485 2486 XE.Rref_Col := Get_Nat; 2487 2488 -- No renaming reference present 2489 2490 else 2491 XE.Rref_Line := 0; 2492 XE.Rref_Col := 0; 2493 end if; 2494 2495 Skip_Space; 2496 2497 XE.Oref_File_Num := No_Sdep_Id; 2498 XE.Tref_File_Num := No_Sdep_Id; 2499 XE.Tref := Tref_None; 2500 XE.First_Xref := Xref.Last + 1; 2501 2502 -- Loop to check for additional info present 2503 2504 loop 2505 declare 2506 Ref : Tref_Kind; 2507 File : Sdep_Id; 2508 Line : Nat; 2509 Typ : Character; 2510 Col : Nat; 2511 Std : Name_Id; 2512 2513 begin 2514 Get_Typeref 2515 (Current_File_Num, Ref, File, Line, Typ, Col, Std); 2516 exit when Ref = Tref_None; 2517 2518 -- Do we have an overriding procedure? 2519 2520 if Ref = Tref_Derived and then Typ = 'p' then 2521 XE.Oref_File_Num := File; 2522 XE.Oref_Line := Line; 2523 XE.Oref_Col := Col; 2524 2525 -- Arrays never override anything, and <> points to 2526 -- the index types instead 2527 2528 elsif Ref = Tref_Derived and then XE.Etype = 'A' then 2529 2530 -- Index types are stored in the list of references 2531 2532 Xref.Increment_Last; 2533 2534 declare 2535 XR : Xref_Record renames Xref.Table (Xref.Last); 2536 begin 2537 XR.File_Num := File; 2538 XR.Line := Line; 2539 XR.Rtype := Array_Index_Reference; 2540 XR.Col := Col; 2541 XR.Name := Std; 2542 end; 2543 2544 -- Interfaces are stored in the list of references, 2545 -- although the parent type itself is stored in XE. 2546 -- The first interface (when there are only 2547 -- interfaces) is stored in XE.Tref*) 2548 2549 elsif Ref = Tref_Derived 2550 and then Typ = 'R' 2551 and then XE.Tref_File_Num /= No_Sdep_Id 2552 then 2553 Xref.Increment_Last; 2554 2555 declare 2556 XR : Xref_Record renames Xref.Table (Xref.Last); 2557 begin 2558 XR.File_Num := File; 2559 XR.Line := Line; 2560 XR.Rtype := Interface_Reference; 2561 XR.Col := Col; 2562 XR.Name := Std; 2563 end; 2564 2565 else 2566 XE.Tref := Ref; 2567 XE.Tref_File_Num := File; 2568 XE.Tref_Line := Line; 2569 XE.Tref_Type := Typ; 2570 XE.Tref_Col := Col; 2571 XE.Tref_Standard_Entity := Std; 2572 end if; 2573 end; 2574 end loop; 2575 2576 -- Loop through cross-references for this entity 2577 2578 loop 2579 Skip_Space; 2580 2581 if At_Eol then 2582 Skip_Eol; 2583 exit when Nextc /= '.'; 2584 P := P + 1; 2585 end if; 2586 2587 Xref.Increment_Last; 2588 2589 declare 2590 XR : Xref_Record renames Xref.Table (Xref.Last); 2591 2592 begin 2593 N := Get_Nat; 2594 2595 if Nextc = '|' then 2596 XR.File_Num := 2597 Sdep_Id (N + Nat (First_Sdep_Entry) - 1); 2598 Current_File_Num := XR.File_Num; 2599 P := P + 1; 2600 N := Get_Nat; 2601 else 2602 XR.File_Num := Current_File_Num; 2603 end if; 2604 2605 XR.Line := N; 2606 XR.Rtype := Getc; 2607 2608 -- Imported entities reference as in: 2609 -- 494b<c,__gnat_copy_attribs>25 2610 2611 if Nextc = '<' then 2612 Skipc; 2613 XR.Imported_Lang := Get_Name; 2614 2615 pragma Assert (Nextc = ','); 2616 Skipc; 2617 2618 XR.Imported_Name := Get_Name; 2619 2620 pragma Assert (Nextc = '>'); 2621 Skipc; 2622 2623 else 2624 XR.Imported_Lang := No_Name; 2625 XR.Imported_Name := No_Name; 2626 end if; 2627 2628 XR.Col := Get_Nat; 2629 2630 if Nextc = '[' then 2631 Read_Instantiation_Reference; 2632 end if; 2633 end; 2634 end loop; 2635 2636 -- Record last cross-reference 2637 2638 XE.Last_Xref := Xref.Last; 2639 C := Nextc; 2640 2641 exception 2642 when Bad_ALI_Format => 2643 2644 -- If ignoring errors, then we skip a line with an 2645 -- unexpected error, and try to continue subsequent 2646 -- xref lines. 2647 2648 if Ignore_Errors then 2649 Xref_Entity.Decrement_Last; 2650 Skip_Line; 2651 C := Nextc; 2652 2653 -- Otherwise, we reraise the fatal exception 2654 2655 else 2656 raise; 2657 end if; 2658 end Read_Refs_For_One_Entity; 2659 end loop; 2660 2661 -- Record last entity 2662 2663 XS.Last_Entity := Xref_Entity.Last; 2664 2665 end Read_Refs_For_One_File; 2666 2667 C := Getc; 2668 end loop X_Loop; 2669 2670 -- Here after dealing with xref sections 2671 2672 -- Ignore remaining lines, which belong to an additional section of the 2673 -- ALI file not considered here (like SCO or Alfa). 2674 2675 Check_Unknown_Line; 2676 2677 return Id; 2678 2679 exception 2680 when Bad_ALI_Format => 2681 return No_ALI_Id; 2682 end Scan_ALI; 2683 2684 --------- 2685 -- SEq -- 2686 --------- 2687 2688 function SEq (F1, F2 : String_Ptr) return Boolean is 2689 begin 2690 return F1.all = F2.all; 2691 end SEq; 2692 2693 ----------- 2694 -- SHash -- 2695 ----------- 2696 2697 function SHash (S : String_Ptr) return Vindex is 2698 H : Word; 2699 2700 begin 2701 H := 0; 2702 for J in S.all'Range loop 2703 H := H * 2 + Character'Pos (S (J)); 2704 end loop; 2705 2706 return Vindex (Vindex'First + Vindex (H mod Vindex'Range_Length)); 2707 end SHash; 2708 2709end ALI; 2710