1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- S I N P U T . L -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1992-2019, 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 Alloc; 27with Atree; use Atree; 28with Debug; use Debug; 29with Einfo; use Einfo; 30with Errout; use Errout; 31with Fname; use Fname; 32with Lib; use Lib; 33with Opt; use Opt; 34with Osint; use Osint; 35with Output; use Output; 36with Prep; use Prep; 37with Prepcomp; use Prepcomp; 38with Scans; use Scans; 39with Scn; use Scn; 40with Sem_Aux; use Sem_Aux; 41with Sem_Util; use Sem_Util; 42with Sinfo; use Sinfo; 43with Snames; use Snames; 44with System; use System; 45 46with System.OS_Lib; use System.OS_Lib; 47 48package body Sinput.L is 49 50 Prep_Buffer : Text_Buffer_Ptr := null; 51 -- A buffer to temporarily stored the result of preprocessing a source. 52 -- It is only allocated if there is at least one source to preprocess. 53 54 Prep_Buffer_Last : Text_Ptr := 0; 55 -- Index of the last significant character in Prep_Buffer 56 57 Initial_Size_Of_Prep_Buffer : constant := 10_000; 58 -- Size of Prep_Buffer when it is first allocated 59 60 -- When a file is to be preprocessed and the options to list symbols 61 -- has been selected (switch -s), Prep.List_Symbols is called with a 62 -- "foreword", a single line indicating what source the symbols apply to. 63 -- The following two constant String are the start and the end of this 64 -- foreword. 65 66 Foreword_Start : constant String := 67 "Preprocessing Symbols for source """; 68 69 Foreword_End : constant String := """"; 70 71 ----------------- 72 -- Subprograms -- 73 ----------------- 74 75 procedure Put_Char_In_Prep_Buffer (C : Character); 76 -- Add one character in Prep_Buffer, extending Prep_Buffer if need be. 77 -- Used to initialize the preprocessor. 78 79 procedure New_EOL_In_Prep_Buffer; 80 -- Add an LF to Prep_Buffer (used to initialize the preprocessor) 81 82 function Load_File 83 (N : File_Name_Type; 84 T : Osint.File_Type) return Source_File_Index; 85 -- Load a source file, a configuration pragmas file or a definition file 86 -- Coding also allows preprocessing file, but not a library file ??? 87 88 ------------------------------- 89 -- Adjust_Instantiation_Sloc -- 90 ------------------------------- 91 92 procedure Adjust_Instantiation_Sloc 93 (N : Node_Id; 94 Factor : Sloc_Adjustment) 95 is 96 Loc : constant Source_Ptr := Sloc (N); 97 98 begin 99 -- We only do the adjustment if the value is between the appropriate low 100 -- and high values. It is not clear that this should ever not be the 101 -- case, but in practice there seem to be some nodes that get copied 102 -- twice, and this is a defence against that happening. 103 104 if Loc in Factor.Lo .. Factor.Hi then 105 Set_Sloc (N, Loc + Factor.Adjust); 106 end if; 107 end Adjust_Instantiation_Sloc; 108 109 -------------------------------- 110 -- Complete_Source_File_Entry -- 111 -------------------------------- 112 113 procedure Complete_Source_File_Entry is 114 CSF : constant Source_File_Index := Current_Source_File; 115 begin 116 Trim_Lines_Table (CSF); 117 Source_File.Table (CSF).Source_Checksum := Checksum; 118 end Complete_Source_File_Entry; 119 120 --------------------------------- 121 -- Create_Instantiation_Source -- 122 --------------------------------- 123 124 procedure Create_Instantiation_Source 125 (Inst_Node : Entity_Id; 126 Template_Id : Entity_Id; 127 Factor : out Sloc_Adjustment; 128 Inlined_Body : Boolean := False; 129 Inherited_Pragma : Boolean := False) 130 is 131 Dnod : constant Node_Id := Declaration_Node (Template_Id); 132 Xold : Source_File_Index; 133 Xnew : Source_File_Index; 134 135 begin 136 Xold := Get_Source_File_Index (Sloc (Template_Id)); 137 Factor.Lo := Source_File.Table (Xold).Source_First; 138 Factor.Hi := Source_File.Table (Xold).Source_Last; 139 140 Source_File.Append (Source_File.Table (Xold)); 141 Xnew := Source_File.Last; 142 143 if Debug_Flag_L then 144 Write_Eol; 145 Write_Str ("*** Create_Instantiation_Source: created source "); 146 Write_Int (Int (Xnew)); 147 Write_Line (""); 148 end if; 149 150 declare 151 Sold : Source_File_Record renames Source_File.Table (Xold); 152 Snew : Source_File_Record renames Source_File.Table (Xnew); 153 154 Inst_Spec : Node_Id; 155 156 begin 157 Snew.Index := Xnew; 158 Snew.Inlined_Body := Inlined_Body; 159 Snew.Inherited_Pragma := Inherited_Pragma; 160 Snew.Template := Xold; 161 162 -- For a genuine generic instantiation, assign new instance id. For 163 -- inlined bodies or inherited pragmas, we retain that of the 164 -- template, but we save the call location. 165 166 if Inlined_Body or Inherited_Pragma then 167 Snew.Inlined_Call := Sloc (Inst_Node); 168 169 else 170 -- If the spec has been instantiated already, and we are now 171 -- creating the instance source for the corresponding body now, 172 -- retrieve the instance id that was assigned to the spec, which 173 -- corresponds to the same instantiation sloc. 174 175 Inst_Spec := Instance_Spec (Inst_Node); 176 if Present (Inst_Spec) then 177 declare 178 Inst_Spec_Ent : Entity_Id; 179 -- Instance spec entity 180 181 Inst_Spec_Sloc : Source_Ptr; 182 -- Virtual sloc of the spec instance source 183 184 Inst_Spec_Inst_Id : Instance_Id; 185 -- Instance id assigned to the instance spec 186 187 begin 188 Inst_Spec_Ent := Defining_Entity (Inst_Spec); 189 190 -- For a subprogram instantiation, we want the subprogram 191 -- instance, not the wrapper package. 192 193 if Present (Related_Instance (Inst_Spec_Ent)) then 194 Inst_Spec_Ent := Related_Instance (Inst_Spec_Ent); 195 end if; 196 197 -- The specification of the instance entity has a virtual 198 -- sloc within the instance sloc range. 199 200 -- ??? But the Unit_Declaration_Node has the sloc of the 201 -- instantiation, which is somewhat of an oddity. 202 203 Inst_Spec_Sloc := 204 Sloc 205 (Specification (Unit_Declaration_Node (Inst_Spec_Ent))); 206 Inst_Spec_Inst_Id := 207 Source_File.Table 208 (Get_Source_File_Index (Inst_Spec_Sloc)).Instance; 209 210 pragma Assert 211 (Sloc (Inst_Node) = Instances.Table (Inst_Spec_Inst_Id)); 212 Snew.Instance := Inst_Spec_Inst_Id; 213 end; 214 215 else 216 Instances.Append (Sloc (Inst_Node)); 217 Snew.Instance := Instances.Last; 218 end if; 219 end if; 220 221 -- Now compute the new values of Source_First and Source_Last and 222 -- adjust the source file pointer to have the correct bounds for the 223 -- new range of values. 224 225 -- Source_First must be greater than the last Source_Last value and 226 -- also must be a multiple of Source_Align. 227 228 Snew.Source_First := 229 ((Source_File.Table (Xnew - 1).Source_Last + Source_Align) / 230 Source_Align) * Source_Align; 231 Factor.Adjust := Snew.Source_First - Factor.Lo; 232 Snew.Source_Last := Factor.Hi + Factor.Adjust; 233 234 Set_Source_File_Index_Table (Xnew); 235 236 Snew.Sloc_Adjust := Sold.Sloc_Adjust - Factor.Adjust; 237 238 -- Modify the Dope of the instance Source_Text to use the 239 -- above-computed bounds. 240 241 declare 242 Dope : constant Dope_Ptr := 243 new Dope_Rec'(Snew.Source_First, Snew.Source_Last); 244 begin 245 Snew.Source_Text := Sold.Source_Text; 246 Set_Dope (Snew.Source_Text'Address, Dope); 247 pragma Assert (Snew.Source_Text'First = Snew.Source_First); 248 pragma Assert (Snew.Source_Text'Last = Snew.Source_Last); 249 end; 250 251 if Debug_Flag_L then 252 Write_Str (" for "); 253 254 if Nkind (Dnod) in N_Proper_Body 255 and then Was_Originally_Stub (Dnod) 256 then 257 Write_Str ("subunit "); 258 259 elsif Ekind (Template_Id) = E_Generic_Package then 260 if Nkind (Dnod) = N_Package_Body then 261 Write_Str ("body of package "); 262 else 263 Write_Str ("spec of package "); 264 end if; 265 266 elsif Ekind (Template_Id) = E_Function then 267 Write_Str ("body of function "); 268 269 elsif Ekind (Template_Id) = E_Procedure then 270 Write_Str ("body of procedure "); 271 272 elsif Ekind (Template_Id) = E_Generic_Function then 273 Write_Str ("spec of function "); 274 275 elsif Ekind (Template_Id) = E_Generic_Procedure then 276 Write_Str ("spec of procedure "); 277 278 elsif Ekind (Template_Id) = E_Package_Body then 279 Write_Str ("body of package "); 280 281 else pragma Assert (Ekind (Template_Id) = E_Subprogram_Body); 282 if Nkind (Dnod) = N_Procedure_Specification then 283 Write_Str ("body of procedure "); 284 else 285 Write_Str ("body of function "); 286 end if; 287 end if; 288 289 Write_Name (Chars (Template_Id)); 290 Write_Eol; 291 292 Write_Str (" copying from file name = "); 293 Write_Name (File_Name (Xold)); 294 Write_Eol; 295 296 Write_Str (" old source index = "); 297 Write_Int (Int (Xold)); 298 Write_Eol; 299 300 Write_Str (" old lo = "); 301 Write_Int (Int (Factor.Lo)); 302 Write_Eol; 303 304 Write_Str (" old hi = "); 305 Write_Int (Int (Factor.Hi)); 306 Write_Eol; 307 308 Write_Str (" new lo = "); 309 Write_Int (Int (Snew.Source_First)); 310 Write_Eol; 311 312 Write_Str (" new hi = "); 313 Write_Int (Int (Snew.Source_Last)); 314 Write_Eol; 315 316 Write_Str (" adjustment factor = "); 317 Write_Int (Int (Factor.Adjust)); 318 Write_Eol; 319 320 Write_Str (" instantiation location: "); 321 Write_Location (Sloc (Inst_Node)); 322 Write_Eol; 323 end if; 324 end; 325 end Create_Instantiation_Source; 326 327 ---------------------- 328 -- Load_Config_File -- 329 ---------------------- 330 331 function Load_Config_File 332 (N : File_Name_Type) return Source_File_Index 333 is 334 begin 335 return Load_File (N, Osint.Config); 336 end Load_Config_File; 337 338 -------------------------- 339 -- Load_Definition_File -- 340 -------------------------- 341 342 function Load_Definition_File 343 (N : File_Name_Type) return Source_File_Index 344 is 345 begin 346 return Load_File (N, Osint.Definition); 347 end Load_Definition_File; 348 349 --------------- 350 -- Load_File -- 351 --------------- 352 353 function Load_File 354 (N : File_Name_Type; 355 T : Osint.File_Type) return Source_File_Index 356 is 357 FD : File_Descriptor; 358 Hi : Source_Ptr; 359 Lo : Source_Ptr; 360 Src : Source_Buffer_Ptr; 361 X : Source_File_Index; 362 363 Preprocessing_Needed : Boolean := False; 364 365 begin 366 -- If already there, don't need to reload file. An exception occurs 367 -- in multiple unit per file mode. It would be nice in this case to 368 -- share the same source file for each unit, but this leads to many 369 -- difficulties with assumptions (e.g. in the body of lib), that a 370 -- unit can be found by locating its source file index. Since we do 371 -- not expect much use of this mode, it's no big deal to waste a bit 372 -- of space and time by reading and storing the source multiple times. 373 374 if Multiple_Unit_Index = 0 then 375 for J in 1 .. Source_File.Last loop 376 if Source_File.Table (J).File_Name = N then 377 return J; 378 end if; 379 end loop; 380 end if; 381 382 -- Here we must build a new entry in the file table 383 384 -- But first, we must check if a source needs to be preprocessed, 385 -- because we may have to load and parse a definition file, and we want 386 -- to do that before we load the source, so that the buffer of the 387 -- source will be the last created, and we will be able to replace it 388 -- and modify Hi without stepping on another buffer. 389 390 if T = Osint.Source and then not Is_Internal_File_Name (N) then 391 Prepare_To_Preprocess 392 (Source => N, Preprocessing_Needed => Preprocessing_Needed); 393 end if; 394 395 Source_File.Increment_Last; 396 X := Source_File.Last; 397 398 if Debug_Flag_L then 399 Write_Eol; 400 Write_Str ("Sinput.L.Load_File: created source "); 401 Write_Int (Int (X)); 402 Write_Str (" for "); 403 Write_Str (Get_Name_String (N)); 404 end if; 405 406 -- Compute starting index, respecting alignment requirement 407 408 if X = Source_File.First then 409 Lo := First_Source_Ptr; 410 else 411 Lo := ((Source_File.Table (X - 1).Source_Last + Source_Align) / 412 Source_Align) * Source_Align; 413 end if; 414 415 Osint.Read_Source_File (N, Lo, Hi, Src, FD, T); 416 417 if Null_Source_Buffer_Ptr (Src) then 418 Source_File.Decrement_Last; 419 420 if FD = Null_FD then 421 return No_Source_File; 422 else 423 return No_Access_To_Source_File; 424 end if; 425 else 426 if Debug_Flag_L then 427 Write_Eol; 428 Write_Str ("*** Build source file table entry, Index = "); 429 Write_Int (Int (X)); 430 Write_Str (", file name = "); 431 Write_Name (N); 432 Write_Eol; 433 Write_Str (" lo = "); 434 Write_Int (Int (Lo)); 435 Write_Eol; 436 Write_Str (" hi = "); 437 Write_Int (Int (Hi)); 438 Write_Eol; 439 440 Write_Str (" first 10 chars -->"); 441 442 declare 443 procedure Wchar (C : Character); 444 -- Writes character or ? for control character 445 446 ----------- 447 -- Wchar -- 448 ----------- 449 450 procedure Wchar (C : Character) is 451 begin 452 if C < ' ' 453 or else C in ASCII.DEL .. Character'Val (16#9F#) 454 then 455 Write_Char ('?'); 456 else 457 Write_Char (C); 458 end if; 459 end Wchar; 460 461 begin 462 for J in Lo .. Lo + 9 loop 463 Wchar (Src (J)); 464 end loop; 465 466 Write_Str ("<--"); 467 Write_Eol; 468 469 Write_Str (" last 10 chars -->"); 470 471 for J in Hi - 10 .. Hi - 1 loop 472 Wchar (Src (J)); 473 end loop; 474 475 Write_Str ("<--"); 476 Write_Eol; 477 478 if Src (Hi) /= EOF then 479 Write_Str (" error: no EOF at end"); 480 Write_Eol; 481 end if; 482 end; 483 end if; 484 485 declare 486 S : Source_File_Record renames Source_File.Table (X); 487 File_Type : Type_Of_File; 488 489 begin 490 case T is 491 when Osint.Source => 492 File_Type := Sinput.Src; 493 494 when Osint.Library => 495 raise Program_Error; 496 497 when Osint.Config => 498 File_Type := Sinput.Config; 499 500 when Osint.Definition => 501 File_Type := Def; 502 503 when Osint.Preprocessing_Data => 504 File_Type := Preproc; 505 end case; 506 507 S := (Debug_Source_Name => N, 508 File_Name => N, 509 File_Type => File_Type, 510 First_Mapped_Line => No_Line_Number, 511 Full_Debug_Name => Osint.Full_Source_Name, 512 Full_File_Name => Osint.Full_Source_Name, 513 Full_Ref_Name => Osint.Full_Source_Name, 514 Instance => No_Instance_Id, 515 Identifier_Casing => Unknown, 516 Inlined_Call => No_Location, 517 Inlined_Body => False, 518 Inherited_Pragma => False, 519 Keyword_Casing => Unknown, 520 Last_Source_Line => 1, 521 License => Unknown, 522 Lines_Table => null, 523 Lines_Table_Max => 1, 524 Logical_Lines_Table => null, 525 Num_SRef_Pragmas => 0, 526 Reference_Name => N, 527 Sloc_Adjust => 0, 528 Source_Checksum => 0, 529 Source_First => Lo, 530 Source_Last => Hi, 531 Source_Text => Src, 532 Template => No_Source_File, 533 Unit => No_Unit, 534 Time_Stamp => Osint.Current_Source_File_Stamp, 535 Index => X); 536 537 Alloc_Line_Tables (S, Opt.Table_Factor * Alloc.Lines_Initial); 538 S.Lines_Table (1) := Lo; 539 end; 540 541 -- Preprocess the source if it needs to be preprocessed 542 543 if Preprocessing_Needed then 544 545 -- Temporarily set the Source_File_Index_Table entries for the 546 -- source, to avoid crash when reporting an error. 547 548 Set_Source_File_Index_Table (X); 549 550 if Opt.List_Preprocessing_Symbols then 551 Get_Name_String (N); 552 553 declare 554 Foreword : String (1 .. Foreword_Start'Length + 555 Name_Len + Foreword_End'Length); 556 557 begin 558 Foreword (1 .. Foreword_Start'Length) := Foreword_Start; 559 Foreword (Foreword_Start'Length + 1 .. 560 Foreword_Start'Length + Name_Len) := 561 Name_Buffer (1 .. Name_Len); 562 Foreword (Foreword'Last - Foreword_End'Length + 1 .. 563 Foreword'Last) := Foreword_End; 564 Prep.List_Symbols (Foreword); 565 end; 566 end if; 567 568 declare 569 T : constant Nat := Total_Errors_Detected; 570 -- Used to check if there were errors during preprocessing 571 572 Save_Style_Check : Boolean; 573 -- Saved state of the Style_Check flag (which needs to be 574 -- temporarily set to False during preprocessing, see below). 575 576 Modified : Boolean; 577 578 begin 579 -- If this is the first time we preprocess a source, allocate 580 -- the preprocessing buffer. 581 582 if Prep_Buffer = null then 583 Prep_Buffer := 584 new Text_Buffer (1 .. Initial_Size_Of_Prep_Buffer); 585 end if; 586 587 -- Make sure the preprocessing buffer is empty 588 589 Prep_Buffer_Last := 0; 590 591 -- Initialize the preprocessor hooks 592 593 Prep.Setup_Hooks 594 (Error_Msg => Errout.Error_Msg'Access, 595 Scan => Scn.Scanner.Scan'Access, 596 Set_Ignore_Errors => Errout.Set_Ignore_Errors'Access, 597 Put_Char => Put_Char_In_Prep_Buffer'Access, 598 New_EOL => New_EOL_In_Prep_Buffer'Access); 599 600 -- Initialize scanner and set its behavior for preprocessing, 601 -- then preprocess. Also disable style checks, since some of 602 -- them are done in the scanner (specifically, those dealing 603 -- with line length and line termination), and cannot be done 604 -- during preprocessing (because the source file index table 605 -- has not been set yet). 606 607 Scn.Scanner.Initialize_Scanner (X); 608 609 Scn.Scanner.Set_Special_Character ('#'); 610 Scn.Scanner.Set_Special_Character ('$'); 611 Scn.Scanner.Set_End_Of_Line_As_Token (True); 612 Save_Style_Check := Opt.Style_Check; 613 Opt.Style_Check := False; 614 615 -- The actual preprocessing step 616 617 Preprocess (Modified); 618 619 -- Reset the scanner to its standard behavior, and restore the 620 -- Style_Checks flag. 621 622 Scn.Scanner.Reset_Special_Characters; 623 Scn.Scanner.Set_End_Of_Line_As_Token (False); 624 Opt.Style_Check := Save_Style_Check; 625 626 -- If there were errors during preprocessing, record an error 627 -- at the start of the file, and do not change the source 628 -- buffer. 629 630 if T /= Total_Errors_Detected then 631 Errout.Error_Msg 632 ("file could not be successfully preprocessed", Lo); 633 return No_Source_File; 634 635 else 636 -- Output the result of the preprocessing, if requested and 637 -- the source has been modified by the preprocessing. Only 638 -- do that for the main unit (spec, body and subunits). 639 640 if Generate_Processed_File 641 and then Modified 642 and then 643 ((Compiler_State = Parsing 644 and then Parsing_Main_Extended_Source) 645 or else 646 (Compiler_State = Analyzing 647 and then Analysing_Subunit_Of_Main)) 648 then 649 declare 650 FD : File_Descriptor; 651 NB : Integer; 652 Status : Boolean; 653 654 begin 655 Get_Name_String (N); 656 Add_Str_To_Name_Buffer (Prep_Suffix); 657 658 Delete_File (Name_Buffer (1 .. Name_Len), Status); 659 660 FD := 661 Create_New_File (Name_Buffer (1 .. Name_Len), Text); 662 663 Status := FD /= Invalid_FD; 664 665 if Status then 666 NB := 667 Write 668 (FD, 669 Prep_Buffer (1)'Address, 670 Integer (Prep_Buffer_Last)); 671 Status := NB = Integer (Prep_Buffer_Last); 672 end if; 673 674 if Status then 675 Close (FD, Status); 676 end if; 677 678 if not Status then 679 Errout.Error_Msg 680 ("??could not write processed file """ & 681 Name_Buffer (1 .. Name_Len) & '"', 682 Lo); 683 end if; 684 end; 685 end if; 686 687 -- Set the new value of Hi 688 689 Hi := Lo + Source_Ptr (Prep_Buffer_Last); 690 691 -- Create the new source buffer 692 693 declare 694 Var_Ptr : constant Source_Buffer_Ptr_Var := 695 new Source_Buffer (Lo .. Hi); 696 -- Allocate source buffer, allowing extra character at 697 -- end for EOF. 698 699 begin 700 Var_Ptr (Lo .. Hi - 1) := 701 Prep_Buffer (1 .. Prep_Buffer_Last); 702 Var_Ptr (Hi) := EOF; 703 Src := Var_Ptr.all'Access; 704 end; 705 706 -- Record in the table the new source buffer and the 707 -- new value of Hi. 708 709 Source_File.Table (X).Source_Text := Src; 710 Source_File.Table (X).Source_Last := Hi; 711 712 -- Reset Last_Line to 1, because the lines do not 713 -- have necessarily the same starts and lengths. 714 715 Source_File.Table (X).Last_Source_Line := 1; 716 end if; 717 end; 718 end if; 719 720 Set_Source_File_Index_Table (X); 721 return X; 722 end if; 723 end Load_File; 724 725 ---------------------------------- 726 -- Load_Preprocessing_Data_File -- 727 ---------------------------------- 728 729 function Load_Preprocessing_Data_File 730 (N : File_Name_Type) return Source_File_Index 731 is 732 begin 733 return Load_File (N, Osint.Preprocessing_Data); 734 end Load_Preprocessing_Data_File; 735 736 ---------------------- 737 -- Load_Source_File -- 738 ---------------------- 739 740 function Load_Source_File 741 (N : File_Name_Type) return Source_File_Index 742 is 743 begin 744 return Load_File (N, Osint.Source); 745 end Load_Source_File; 746 747 ---------------------------- 748 -- New_EOL_In_Prep_Buffer -- 749 ---------------------------- 750 751 procedure New_EOL_In_Prep_Buffer is 752 begin 753 Put_Char_In_Prep_Buffer (ASCII.LF); 754 end New_EOL_In_Prep_Buffer; 755 756 ----------------------------- 757 -- Put_Char_In_Prep_Buffer -- 758 ----------------------------- 759 760 procedure Put_Char_In_Prep_Buffer (C : Character) is 761 begin 762 -- If preprocessing buffer is not large enough, double it 763 764 if Prep_Buffer_Last = Prep_Buffer'Last then 765 declare 766 New_Prep_Buffer : constant Text_Buffer_Ptr := 767 new Text_Buffer (1 .. 2 * Prep_Buffer_Last); 768 769 begin 770 New_Prep_Buffer (Prep_Buffer'Range) := Prep_Buffer.all; 771 Free (Prep_Buffer); 772 Prep_Buffer := New_Prep_Buffer; 773 end; 774 end if; 775 776 Prep_Buffer_Last := Prep_Buffer_Last + 1; 777 Prep_Buffer (Prep_Buffer_Last) := C; 778 end Put_Char_In_Prep_Buffer; 779 780 ------------------------- 781 -- Source_File_Is_Body -- 782 ------------------------- 783 784 function Source_File_Is_Body (X : Source_File_Index) return Boolean is 785 Pcount : Natural; 786 787 begin 788 Initialize_Scanner (No_Unit, X); 789 790 -- Loop to look for subprogram or package body 791 792 loop 793 case Token is 794 795 -- PRAGMA, WITH, USE (which can appear before a body) 796 797 when Tok_Pragma 798 | Tok_Use 799 | Tok_With 800 => 801 -- We just want to skip any of these, do it by skipping to a 802 -- semicolon, but check for EOF, in case we have bad syntax. 803 804 loop 805 if Token = Tok_Semicolon then 806 Scan; 807 exit; 808 elsif Token = Tok_EOF then 809 return False; 810 else 811 Scan; 812 end if; 813 end loop; 814 815 -- PACKAGE 816 817 when Tok_Package => 818 Scan; -- Past PACKAGE 819 820 -- We have a body if and only if BODY follows 821 822 return Token = Tok_Body; 823 824 -- FUNCTION or PROCEDURE 825 826 when Tok_Function 827 | Tok_Procedure 828 => 829 Pcount := 0; 830 831 -- Loop through tokens following PROCEDURE or FUNCTION 832 833 loop 834 Scan; 835 836 case Token is 837 838 -- For parens, count paren level (note that paren level 839 -- can get greater than 1 if we have default parameters). 840 841 when Tok_Left_Paren => 842 Pcount := Pcount + 1; 843 844 when Tok_Right_Paren => 845 Pcount := Pcount - 1; 846 847 -- EOF means something weird, probably no body 848 849 when Tok_EOF => 850 return False; 851 852 -- BEGIN or IS or END definitely means body is present 853 854 when Tok_Begin 855 | Tok_End 856 | Tok_Is 857 => 858 return True; 859 860 -- Semicolon means no body present if at outside any 861 -- parens. If within parens, ignore, since it could be 862 -- a parameter separator. 863 864 when Tok_Semicolon => 865 if Pcount = 0 then 866 return False; 867 end if; 868 869 -- Skip anything else 870 871 when others => 872 null; 873 end case; 874 end loop; 875 876 -- Anything else in main scan means we don't have a body 877 878 when others => 879 return False; 880 end case; 881 end loop; 882 end Source_File_Is_Body; 883 884 ---------------------------- 885 -- Source_File_Is_No_Body -- 886 ---------------------------- 887 888 function Source_File_Is_No_Body (X : Source_File_Index) return Boolean is 889 begin 890 Initialize_Scanner (No_Unit, X); 891 892 if Token /= Tok_Pragma then 893 return False; 894 end if; 895 896 Scan; -- past pragma 897 898 if Token /= Tok_Identifier 899 or else Chars (Token_Node) /= Name_No_Body 900 then 901 return False; 902 end if; 903 904 Scan; -- past No_Body 905 906 if Token /= Tok_Semicolon then 907 return False; 908 end if; 909 910 Scan; -- past semicolon 911 912 return Token = Tok_EOF; 913 end Source_File_Is_No_Body; 914 915end Sinput.L; 916