1------------------------------------------------------------------------------ 2-- -- 3-- GNAT2XML COMPONENTS -- 4-- -- 5-- G N A T 2 X M L . A D A _ T R E E S -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 2012-2016, AdaCore -- 10-- -- 11-- Gnat2xml 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 2, or (at your option) any later -- 14-- version. Gnat2xml is distributed in the hope that it will be useful, -- 15-- but WITHOUT ANY WARRANTY; without even the implied warranty of MER- -- 16-- CHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General -- 17-- Public License for more details. You should have received a copy of the -- 18-- GNU General Public License distributed with GNAT; see file COPYING. If -- 19-- not, write to the Free Software Foundation, 59 Temple Place Suite 330, -- 20-- Boston, MA 02111-1307, USA. -- 21-- The gnat2xml tool was derived from the Avatox sources. -- 22------------------------------------------------------------------------------ 23 24pragma Ada_2012; 25 26with Ada.Characters.Handling; use Ada.Characters.Handling; 27with Ada.Strings.Unbounded; 28with Ada.Wide_Text_IO; 29with Unchecked_Deallocation; 30with System.WCh_Con; 31use type System.WCh_Con.WC_Encoding_Method; 32with GNAT.OS_Lib; 33 34with Snames; 35with Types; 36use type Types.Int; 37 38with ASIS_UL.Generic_Formatted_Output; 39with ASIS_UL.Output; use ASIS_UL; 40with ASIS_UL.Options; 41with ASIS_UL.Common; 42with Ada_Trees.Formatting.Dictionaries; 43with Ada_Trees.Self_Rep; 44 45with GNATCOLL.Paragraph_Filling; 46 47separate (Ada_Trees.Formatting) 48 49procedure Tree_To_Ada 50 (Root : Ada_Tree; 51 Src_Buf : in out Buffer; 52 Write_BOM : Boolean; 53 Options : Formatting_Options; 54 Output_Name : String; 55 Form_String : String; 56 Do_Diff : Boolean; 57 Output_Written : out Boolean) 58is 59 60 ---------------------------------------------------------------- 61 -- 62 -- Tree_To_Ada performs the following major passes: 63 -- 64 -- Convert_Tree_To_Ada 65 -- Walks the Ada_Tree, using Ada_Templates to convert the tree into 66 -- text form in Out_Buf. Out_Buf is further modified by subsequent 67 -- passes. Builds the Line_Break table for use by Split_Lines and 68 -- Insert_NLs_And_Indentation. Builds the Tabs table for use by 69 -- Insert_Alignment. 70 -- 71 -- Subsequent passes work on the text in Out_Buf, and not the 72 -- Ada_Tree. Therefore, if they need any syntactic/structural 73 -- information, it must be encoded in other data structures, such as the 74 -- Line_Breaks and Tabs tables. 75 -- 76 -- Split_Lines (first time) 77 -- Determine which soft line breaks should be enabled. 78 -- 79 -- Insert_Comments_And_Blank_Lines 80 -- Step through the source tokens and Out_Buf tokens. Copy comment and 81 -- blank line tokens into Out_Buf as they are encountered. 82 -- 83 -- Split_Lines (again) 84 -- We do this again because inserted end-of-line comments can cause 85 -- lines to be too long. We don't want to split the line just before the 86 -- comment; we want to split at some auspicious soft line break(s). 87 -- 88 -- Insert_NLs_And_Indentation 89 -- Insert newline characters and leading blanks for each soft line break 90 -- that was enabled by Split_Lines. 91 -- 92 -- Insert_Alignment 93 -- Walk the Tabs table to calculate how many blanks (if any) should be 94 -- inserted for each Tab. Then insert those blanks in Out_Buf. 95 -- 96 -- Keyword_Casing 97 -- Convert reserved words to the appropriate case as specified by 98 -- command-line options. 99 -- 100 -- Insert_Form_Feeds 101 -- Implement the -ff switch, by inserting FF characters after 102 -- "pragma Page;". 103 -- 104 -- Copy_Pp_Off_Regions 105 -- Regions where pretty printing should be turned off have been 106 -- formatted as usual. This phase undoes all that formatting by copying 107 -- text from Src_Buf to Out_Buf. 108 -- 109 -- Final_Check 110 -- Go through the source tokens and Out_Buf tokens (the latter now 111 -- containing comments and blank lines), and make sure they (mostly) 112 -- match. If there is any mismatch besides a small set of allowed ones, 113 -- raise an exception. This pass makes no changes, so it serves no 114 -- useful purpose unless there is a bug in some previous pass; the 115 -- purpose is to prevent gnatpp from damaging the user's source code. 116 -- The algorithm in this pass is quite similar to the one in 117 -- Insert_Comments_And_Blank_Lines. 118 -- 119 -- Write_Out_Buf 120 -- Write Out_Buf to the appropriate file (or Current_Output). 121 -- 122 -- Each pass expects to be entered with Out_Buf's 'point' at the beginning, 123 -- and returns with Out_Buf's 'point' STILL at the beginning. Thus, passes 124 -- that step through Out_Buf need to call Reset(Out_Buf) before returning. 125 -- 126 ---------------------------------------------------------------- 127 128 Simulate_Token_Mismatch : Boolean renames Debug.Debug_Flag_8; 129 Disable_Final_Check : Boolean renames Debug.Debug_Flag_7; 130 function Enable_Token_Mismatch return Boolean is 131 ((Assert_Enabled or Debug.Debug_Flag_5) 132 and not Simulate_Token_Mismatch 133 and not Debug.Debug_Flag_6); 134 135 -- Miscellaneous useful Name_Ids: 136 137 Name_Empty : constant Name_Id := Name_Find (""); 138 139 Name_Semicolon : constant Name_Id := Name_Find (";"); 140 Name_L_Paren : constant Name_Id := Name_Find ("("); 141 Name_R_Paren : constant Name_Id := Name_Find (")"); 142 Name_Colon : constant Name_Id := Name_Find (":"); 143 Name_Assign : constant Name_Id := Name_Find (":="); 144 Name_Bang : constant Name_Id := Name_Find ("!"); 145 Name_Bar : constant Name_Id := Name_Find ("|"); 146 Name_Arrow : constant Name_Id := Name_Find ("=>"); 147 Name_Dot : constant Name_Id := Name_Find ("."); 148 149 Name_And_Then : constant Name_Id := Name_Find ("and then"); 150 Name_Or_Else : constant Name_Id := Name_Find ("or else"); 151 152 Name_Q_And : constant Name_Id := Name_Find ("""and"""); 153 Name_Q_Or : constant Name_Id := Name_Find ("""or"""); 154 Name_Q_Xor : constant Name_Id := Name_Find ("""xor"""); 155 Name_Q_Mod : constant Name_Id := Name_Find ("""mod"""); 156 Name_Q_Rem : constant Name_Id := Name_Find ("""rem"""); 157 Name_Q_Abs : constant Name_Id := Name_Find ("""abs"""); 158 Name_Q_Not : constant Name_Id := Name_Find ("""not"""); 159 160 Name_Depends : constant Name_Id := Name_Find ("Depends"); 161 162 Name_Tab_Insertion_Point : constant Name_Id := 163 Name_Find ("tab insertion point"); 164 Name_Tab_In_Out : constant Name_Id := Name_Find ("tab in out"); 165 Name_Dot_Dot : constant Name_Id := Name_Find (".."); 166 Name_R_Sq : constant Name_Id := Name_Find ("]"); 167 168 Op_Sym_Table : constant array (Positive range <>) of Name_Id := 169 (Name_Q_And, 170 Name_Q_Or, 171 Name_Q_Xor, 172 Name_Q_Mod, 173 Name_Q_Rem, 174 Name_Q_Abs, 175 Name_Q_Not); 176 177 function Is_Op_Sym_With_Letters 178 (N : Name_Id) 179 return Boolean is 180 (for some Op of Op_Sym_Table => N = Op); 181 -- True if N looks like a string literal that can be used as an operator 182 -- symbol containing letters, so case might matter. N should be in all 183 -- lower case. 184 185 Comment_Filling_Enabled : constant Boolean := 186 Options.Format_Comments and Options.Reformat_Comment_Block; 187 188 Alignment_Enabled : constant Boolean := 189 (Options.Align_Colons_In_Decl 190 or else Options.Align_Asign_In_Decl 191 or else Options.Align_Asign_In_Stmts 192 or else Options.Align_Arrows 193 or else Options.Align_Ats) 194 and then not ASIS_UL.Options.Generate_Representation_Clauses; 195 -- The old gnatpp had the ability to individually enable different kinds of 196 -- alignment; the new gnatpp does not. Instead, we align if ANY alignment 197 -- option is enabled; if all alignment is turned off, we don't align. 198 -- Alignment doesn't work when representation clauses are being generated. 199 200 procedure Put_To_Buffer (C : W_Char); 201 -- Append C to Buffer 202 203 Check_Whitespace : Boolean := True; 204 -- For debugging. Used during the Subtree_To_Ada phase. True except within 205 -- literals. Check for two blanks in a row. 206 207 procedure Init_Template_Table; 208 -- We call this to initialize Template_Table the first time Tree_To_Ada 209 -- is called, so that we can base the initialization in part on the 210 -- command-line options. 211 212 procedure Init_Pp_Off_And_On; 213 -- Initialize Pp_Off_On_Delimiters from Options 214 215 procedure Assert_No_Trailing_Blanks (S : W_Str); 216 -- Assert that there are no lines with trailing blanks in S. 217 218 function Id_With_Casing 219 (Id : Name_Id; 220 Kind : Opt_ASIS_Elems; 221 Is_Predef : Boolean; 222 Use_Name_Casing_For_Nils : Boolean := False) 223 return W_Str; 224 -- This handles casing of defining names and usage names, converting to 225 -- the appropriate case based on command-line options. Kind is the kind of 226 -- declaration denoted by Id, or an attribute, or nil. Is_Predef is True if 227 -- Id denotes a predefined Ada or GNAT identifier. 228 -- 229 -- This is called early (during Subtree_To_Ada). Casing of reserved words 230 -- is handled later, in a separate pass (see Keyword_Casing), because they 231 -- are not explicit in the tree, except that operator symbols are handled 232 -- here. All of the Ada_Templates have reserved words in lower case. 233 -- 234 -- Id_With_Casing is used for Def_Names, Usage_Names and pragmas. For 235 -- Def_Names, the Kind comes from the Symbol_Table, which only works 236 -- because it's within one unit. That doesn't work for Usage_Names; we 237 -- use the Decl_Kind attribute, which includes declared entities and 238 -- attributes. For pragmas, we use the Kind of the pragma node. 239 -- 240 -- Is_Predef comes from the Is_Predef attribute of Usage_Names. It is 241 -- always False for Def_Names and pragmas. 242 -- 243 -- Use_Name_Casing_For_Nils is documented in Do_Usage_Name. 244 245 function Good_Column (Indentation : Natural) return Natural is 246 ((Indentation / Options.PP_Indentation) * Options.PP_Indentation); 247 -- Make sure indentation is a multiple of PP_Indentation; otherwise style 248 -- checking complains "(style) bad column". 249 250 procedure Put_To_Buffer (C : W_Char) is 251 begin 252 pragma Assert 253 (if 254 Check_Whitespace and then Options.Par_Specs_Threshold = Natural'Last 255 then 256 (if C = ' ' then Lookback (Out_Buf) /= ' ')); 257 -- No double blanks. Except that there is one special case when the 258 -- Par_Specs_Threshold switch is used, where we have an extra blank 259 -- (see Subp_Decl_With_Hard_Breaks). 260 pragma Assert (if C = NL then Lookback (Out_Buf) /= ' '); 261 -- no trailing blanks 262 263 Append_Any (Out_Buf, C); 264 end Put_To_Buffer; 265 266 Name_CPP_Class : aliased constant W_Str := "CPP_Class"; 267 Name_CPP_Constructor : aliased constant W_Str := "CPP_Constructor"; 268 Name_CPP_Virtual : aliased constant W_Str := "CPP_Virtual"; 269 Name_CPP_Vtable : aliased constant W_Str := "CPP_Vtable "; 270 Name_CPU : aliased constant W_Str := "CPU"; 271 Name_Persistent_BSS : aliased constant W_Str := "Persistent_BSS"; 272 Name_SPARK_Mode : aliased constant W_Str := "SPARK_Mode"; 273 Name_Use_VADS_Size : aliased constant W_Str := "Use_VADS_Size"; 274 Name_VADS_Size : aliased constant W_Str := "VADS_size"; 275 276 Special_Case_Names : constant 277 array (Positive range <>) of access constant W_Str := 278 (Name_CPP_Class'Access, 279 Name_CPP_Constructor'Access, 280 Name_CPP_Virtual'Access, 281 Name_CPP_Vtable 'Access, 282 Name_CPU'Access, 283 Name_Persistent_BSS'Access, 284 Name_SPARK_Mode'Access, 285 Name_Use_VADS_Size'Access, 286 Name_VADS_Size'Access); 287 288 function Id_With_Casing 289 (Id : Name_Id; 290 Kind : Opt_ASIS_Elems; 291 Is_Predef : Boolean; 292 Use_Name_Casing_For_Nils : Boolean := False) 293 return W_Str 294 is 295 296 Str : W_Str := Get_Name_String (Id); 297 -- This is the name as declared 298 pragma Assert (Str'First = 1); 299 300 -- If it's a character literal, we want As_Declared -- it would be 301 -- unfortunate to turn 'a' into 'A'. Operators go by keyword casing. 302 -- Operator symbols (quoted) do so also, which seems wrong, but we're 303 -- going to mimic the old gnatpp for now. Note that some reserved 304 -- words can be an operator or an attribute name; hence the check 305 -- for Flat_Attribute_Reference_Kinds below. Predefined names use 306 -- As_Declared unless Use_Predefined_Casing is turned off. For 307 -- everything else, we use the appropriate option based on the Kind. 308 309 Casing : constant PP_Casing := 310 (if Str (1) = ''' then As_Declared 311 elsif 312 Kind not in Flat_Attribute_Reference_Kinds 313 and then 314 (Str (1) = '"' -- operator symbol 315 or else Snames.Is_Keyword_Name (Id) 316 or else Id = Name_And_Then 317 or else Id = Name_Or_Else) 318 then 319 Options.PP_Keyword_Casing 320 elsif 321 Is_Predef and then Options.Use_Predefined_Casing 322 then 323 As_Declared 324 else 325 (case Kind is 326 when Flat_Attribute_Reference_Kinds => 327 Options.PP_Attribute_Casing, 328 when Flat_Pragma_Kinds => Options.PP_Pragma_Casing, 329 when An_Enumeration_Literal_Specification => 330 Options.PP_Enum_Literal_Casing, 331 when A_Flat_Type_Declaration | 332 A_Subtype_Declaration | 333 A_Formal_Type_Declaration | 334 A_Formal_Incomplete_Type_Declaration | 335 A_Task_Body_Declaration | 336 A_Protected_Body_Declaration => 337 Options.PP_Type_Casing, 338 when A_Flat_Number_Declaration => Options.PP_Nnumbers_Casing, 339 when Not_An_Element => 340 (if 341 Options.Is_PP 342 and then not Use_Name_Casing_For_Nils 343 and then Options.PP_Name_Casing = As_Declared 344 then 345 Mixed 346 else Options.PP_Name_Casing), 347 when others => Options.PP_Name_Casing)); 348 -- The Not_An_Element case is for identifiers specific to pragmas 349 -- and the like. But that only works if the Decl_Kind field is set, 350 -- which isn't true in xml2gnat, so we use PP_Name_Casing (which is 351 -- As_Declared) in that case. 352 353 use Ada_Trees.Formatting.Dictionaries; 354 begin 355 if Options.Use_Dictionary then 356 Check_With_Dictionary (Ada_Name => Str, Casing => Casing); 357 return Str; 358 else 359 case Casing is 360 when Lower_Case => 361 return To_Lower (Str); 362 363 when Upper_Case => 364 return To_Upper (Str); 365 366 when Mixed => 367 if Kind in Flat_Attribute_Reference_Kinds | Flat_Pragma_Kinds 368 then 369 -- Handle pragma and attribute names that are special cases 370 -- (some portion should be in ALL CAPS). 371 372 declare 373 Lower : constant W_Str := To_Lower (Str); 374 begin 375 for Special of Special_Case_Names loop 376 if Lower = To_Lower (Special.all) then 377 return Special.all; 378 end if; 379 end loop; 380 end; 381 end if; 382 383 return Capitalize (Str); 384 385 when As_Declared => 386 return Str; 387 end case; 388 end if; 389 end Id_With_Casing; 390 391 package Buffered_Output is new ASIS_UL.Generic_Formatted_Output 392 (W_Char, 393 W_Str, 394 Basic_Put_Char => Put_To_Buffer); 395 396 procedure Indent (Amount : Integer); 397 398 procedure Indent (Amount : Integer) is 399 pragma Assert 400 (abs (Amount) in 401 0 | 402 1 | 403 Options.PP_Indentation | 404 Options.PP_Cont_Line_Indentation); 405 Line_Breaks : Line_Break_Vector renames All_Line_Breaks; 406 begin 407 Cur_Indentation := Cur_Indentation + Amount; 408 409 if abs (Amount) = Options.PP_Indentation then 410 pragma Assert (Point (Out_Buf) = Last_Position (Out_Buf) + 1); 411 if Last_Position (Out_Buf) = 412 Position (Out_Buf, Line_Breaks (Last (Line_Breaks)).Mark) 413 then 414-- pragma Assert (At_Point (Out_Buf, Line_Breaks (Last (Line_Breaks)).Mark)); 415 Line_Breaks (Last (Line_Breaks)).Indentation := Cur_Indentation; 416 end if; 417 end if; 418 end Indent; 419 420 procedure Append_Line_Break 421 (Hard : Boolean; 422 Affects_Comments : Boolean; 423 Level : Nesting_Level; 424 Kind : Ada_Tree_Kind; 425 Template : Name_Id); 426 427 procedure Append_Temp_Line_Break; 428 429 function Max_Nesting_Increment (Temp : Ada_Template) return Nesting_Level; 430 -- If a digit occurs after '@', this is an additional "nesting increment" 431 -- to be added to the nesting level when we recursively process the 432 -- subtree. This is intended to allow some line breaks to have precedence 433 -- over others. If no such digit occurs, the default is zero. This function 434 -- returns the maximum such nesting increment in the template. 435 436 function New_Level 437 (Tree : Ada_Tree; 438 Subtree_Index : Query_Index; 439 Cur_Level : Nesting_Level; 440 Temp : Ada_Template) 441 return Nesting_Level; 442 -- Compute a new nesting level for a subtree. This is usually one more than 443 -- the current level, but we also add in Max_Nesting_Increment. 444 445 procedure If_Statement_Check_1; 446 procedure If_Statement_Check_2 (Level_Of_If : Nesting_Level); 447 -- The above are for a special check related to if_statements, which comes 448 -- in two parts. If_Statement_Check_1 and _2 are called before and after 449 -- calling Subtree_To_Ada on the condition of an 'if'. 450 -- 451 -- The compiler style checks complain if "then" appears by itself on the 452 -- line immediately following "if" (still true???), as in: 453 -- if <condition> 454 -- then 455 -- where <condition> is just long enough to split the line before "then", 456 -- but not long enough to be split itself. To avoid that, we make sure 457 -- at least one line break in <condition> is at the same level as the one 458 -- just before "then", thus ensuring that if the latter is enabled, some 459 -- line break within <condition> will also be enabled. The same goes for 460 -- "elsif". 461 -- 462 -- Part _1 remembers the index of the first line break for the condition. 463 -- Then the condition is walked, possibly inserting some line breaks. Part 464 -- _2 then finds the minimum nested level (i.e. outermost), and patches 465 -- that to equal the level of the 'if'. If there are no line breaks in the 466 -- condition, but it is still long enough to force the "then" onto the next 467 -- line, then there's not much we can do -- the style check will fail in 468 -- that unlikely case. 469 470 procedure Append_Line_Break 471 (Hard : Boolean; 472 Affects_Comments : Boolean; 473 Level : Nesting_Level; 474 Kind : Ada_Tree_Kind; 475 Template : Name_Id) 476 is 477 478 Line_Breaks : Line_Break_Vector renames All_Line_Breaks; 479 480 begin 481 -- If we see two line breaks in a row, we take the least indented one. 482 483 if Hard and then Lookback (Out_Buf) = NL then 484 if Line_Breaks (Last_Index (Line_Breaks)).Indentation > 485 Cur_Indentation 486 then 487 Line_Breaks (Last_Index (Line_Breaks)).Indentation := 488 Cur_Indentation; 489 end if; 490 491 if not Options.Insert_Blank_Lines then 492 return; 493 end if; 494 end if; 495 496 Append 497 (Line_Breaks, 498 Line_Break' 499 (Mark => Mark (Out_Buf, Name => (if Hard then '$' else '@')), 500 Hard => Hard, 501 Affects_Comments => Affects_Comments, 502 Enabled => Hard, 503 Level => Level, 504 Indentation => Cur_Indentation, 505 Length => <>, 506 Kind => Kind, 507 Template => Template, 508 UID => Next_Line_Break_Unique_Id)); 509 Next_Line_Break_Unique_Id := Next_Line_Break_Unique_Id + 1; 510 511 -- A hard line break gets NL 512 513 if Hard then 514 Buffered_Output.Put_Char (NL); 515 end if; 516 end Append_Line_Break; 517 518 procedure Append_Temp_Line_Break is 519 M : Marker; 520 521 begin 522 pragma Assert (Lookback (Out_Buf) /= ' '); -- no trailing blanks 523 Insert_NL (Out_Buf); 524 M := Mark_Previous (Out_Buf, Name => '-'); 525 526 if False then -- Too slow, but we keep it for documentation 527 for L of All_Line_Breaks loop 528 pragma Assert (M /= L.Mark); 529 end loop; 530 end if; 531 532 Append 533 (Temp_Line_Breaks, 534 Line_Break' 535 (Mark => M, 536 Hard => True, 537 Affects_Comments => False, 538 Enabled => True, 539 Level => 0, 540 Indentation => Cur_Indentation, 541 Length => <>, 542 Kind => Not_An_Element, 543 Template => Name_Find ("Insert_Comments_And_Blank_Lines"), 544 UID => Next_Line_Break_Unique_Id)); 545 Next_Line_Break_Unique_Id := Next_Line_Break_Unique_Id + 1; 546 pragma Assert (Char_At (Out_Buf, M) = NL); 547 end Append_Temp_Line_Break; 548 549 function Max_Nesting_Increment (Temp : Ada_Template) return Nesting_Level is 550 J : Positive := Temp'First; 551 C : W_Char; 552 553 begin 554 return Result : Nesting_Level := 0 do 555 while J <= Temp'Last loop 556 C := Temp (J); 557 558 case C is 559 when '@' => 560 declare 561 Digit : W_Char; 562 Increment : Nesting_Level; 563 564 begin 565 if J < Temp'Last and then Temp (J + 1) in '0' .. '9' then 566 J := J + 1; 567 Digit := Temp (J); 568 Increment := Nesting_Level (Char_To_Digit (Digit)); 569 570 else 571 Increment := 0; 572 end if; 573 574 Result := Nesting_Level'Max (Result, Increment); 575 end; 576 577 when others => 578 null; 579 end case; 580 581 J := J + 1; 582 end loop; 583 end return; 584 end Max_Nesting_Increment; 585 586 function New_Level 587 (Tree : Ada_Tree; 588 Subtree_Index : Query_Index; 589 Cur_Level : Nesting_Level; 590 Temp : Ada_Template) 591 return Nesting_Level 592 is 593 begin 594 pragma Assert 595 (if Tree.Kind in An_If_Path | An_Elsif_Path then Subtree_Index = 1); 596 597 return Cur_Level + Max_Nesting_Increment (Temp) + 1; 598 end New_Level; 599 600 First_If_Line_Break : Line_Break_Index; 601 -- Valid only between calls to If_Statement_Check_1 and 602 -- If_Statement_Check_2. Set by _1 to 1 past the end of the table, which 603 -- is where the next line break will be placed. Used by _2 to find the 604 -- first line break (if any) belonging to the condition. 605 606 procedure If_Statement_Check_1 is 607 Line_Breaks : Line_Break_Vector renames All_Line_Breaks; 608 begin 609 First_If_Line_Break := Last_Index (Line_Breaks) + 1; 610 end If_Statement_Check_1; 611 612 procedure If_Statement_Check_2 (Level_Of_If : Nesting_Level) is 613 Line_Breaks : Line_Break_Vector renames All_Line_Breaks; 614 Min : Nesting_Level := Nesting_Level'Last; 615 begin 616 -- Find the minimum level: 617 for J in First_If_Line_Break .. Last_Index (Line_Breaks) loop 618 Min := Nesting_Level'Min (Min, Line_Breaks (J).Level); 619 end loop; 620 621 -- Overwrite all line breaks at the minimum level to the level of the 622 -- 'if': 623 for J in First_If_Line_Break .. Last_Index (Line_Breaks) loop 624 if Line_Breaks (J).Level = Min then 625 Line_Breaks (J).Level := Level_Of_If; 626 end if; 627 end loop; 628 end If_Statement_Check_2; 629 630 Inner_Loop_Count : Natural := 0; 631 632 procedure Split_Lines (First_Time : Boolean); 633 -- Enable soft line breaks as necessary to prevent too-long lines. 634 -- First_Time is for debugging. 635 636 procedure Split_Lines (First_Time : Boolean) is 637 Line_Breaks : Line_Break_Vector renames All_Line_Breaks; 638 639 procedure Remove_Duplicates; 640 -- Remove soft line breaks that have the same Mark as other line 641 -- break(s). This is necessary because we don't want line breaks to 642 -- form blank lines. 643 644 function Line_Length (F, L : Line_Break_Index) return Natural; 645 -- F and L are the first and last index forming a line; returns the 646 -- length of the line, not counting new-lines. F and L must be enabled. 647 648 function Worthwhile_Line_Break (X : Line_Break_Index) return Boolean; 649 -- Called for the first so-far-disabled line break on a line. Returning 650 -- False means don't bother enabling it. 651 652 procedure Assert; 653 -- Assert that the line Length has been set if and only if the line 654 -- break is enabled. 655 656 procedure Assert is 657 begin 658 for X in 1 .. Last_Index (Line_Breaks) loop 659 declare 660 Break : constant Line_Break := Line_Breaks (X); 661 662 begin 663 if X = Last_Index (Line_Breaks) then 664 pragma Assert (Break.Enabled and then Break.Length = 0); 665 666 elsif Break.Enabled then 667 pragma Assert 668 (Break.Length = Line_Length (X, Next_Enabled (X))); 669 pragma Assert 670 (Break.Mark /= Line_Breaks (Next_Enabled (X)).Mark); 671 672 else 673 pragma Assert (Break.Length = Natural'Last); 674 end if; 675 end; 676 end loop; 677 678 Assert_No_Trailing_Blanks (To_W_Str (Out_Buf)); 679 pragma Assert 680 (Position (Out_Buf, All_Line_Breaks (Last (All_Line_Breaks)).Mark) = 681 Last_Position (Out_Buf)); 682 end Assert; 683 684 function Line_Length (F, L : Line_Break_Index) return Natural is 685 First : constant Line_Break := Line_Breaks (F); 686 Last : constant Line_Break := Line_Breaks (L); 687 F_Pos : constant Natural := Position (Out_Buf, First.Mark); 688 L_Pos : constant Natural := Position (Out_Buf, Last.Mark); 689 690 NL_Count : constant Natural := (if First.Hard then 1 else 0); 691 Leading_Blank : constant Natural := 692 (if L_Pos > F_Pos + 1 and then Char_At (Out_Buf, F_Pos) = ' ' then 1 693 else 0); 694 Trailing_Blank : constant Natural := 695 (if 696 L_Pos > F_Pos + 2 and then Char_At (Out_Buf, L_Pos - 1) = ' ' 697 then 698 1 699 else 0); 700 Without_Indent : constant Natural := 701 Position (Out_Buf, Last.Mark) - 702 Position (Out_Buf, First.Mark) - 703 NL_Count - 704 Leading_Blank - 705 Trailing_Blank; 706 -- The length without the indentation is just the difference between the 707 -- two marks, except that if the first one is hard, we don't count the 708 -- NL character. If it's soft, there is no NL character yet. Also, if 709 -- the first or last character is ' ', it doesn't count. 710 711 begin 712 -- If the line is blank, we ignore the indentation; we won't be 713 -- putting blanks in the output. Otherwise, the length is the 714 -- indentation plus the length without the indentation as 715 -- calculated above. 716 717 if Without_Indent = 0 then 718 return 0; 719 720 else 721 return First.Indentation + Without_Indent; 722 end if; 723 end Line_Length; 724 725 procedure Remove_Duplicates is 726 Temp : Line_Break_Vector; 727 -- ???If we have duplicates with different Indentation, should we choose 728 -- the least indented? If we remove a line break for a '[', should we 729 -- remove the corresponding one for ']', and vice-versa? 730 begin 731 Append (Temp, Line_Breaks (1)); 732 733 for X in 2 .. Last_Index (Line_Breaks) loop 734 if Line_Breaks (X).Enabled 735 or else not Is_Empty_Line (X - 1, X) 736 then 737 Append (Temp, Line_Breaks (X)); 738 739 else 740 pragma Assert (not Line_Breaks (X).Hard); 741 end if; 742 end loop; 743 Move (Target => Line_Breaks, Source => Temp); 744 end Remove_Duplicates; 745 746 function Worthwhile_Line_Break (X : Line_Break_Index) return Boolean is 747 This : constant Positive := Position (Out_Buf, Line_Breaks (X).Mark); 748 Prev : Positive := Position (Out_Buf, Line_Breaks (X - 1).Mark); 749 More : constant Boolean := -- more to be enabled to the right 750 X < Last_Index (Line_Breaks) 751 and then not Line_Breaks (X + 1).Enabled; 752 Threshold : constant Positive := 753 (if True then Options.PP_Cont_Line_Indentation -- ???? 754 else Positive'Max (Options.PP_Cont_Line_Indentation - 1, 755 (if More then 6 -- arbitrary 756 else 1))); 757 begin 758 if Line_Breaks (X - 1).Hard then 759 Prev := Prev + 1; -- skip NL 760 end if; 761 762 -- If we have something like: 763 -- P (... 764 -- there's no point in turning it into: 765 -- P 766 -- (... 767 -- assuming PP_Cont_Line_Indentation = 2, because it doesn't shorten 768 -- any lines. If the procedure name is slightly longer than "P": 769 -- Proc (... 770 -- there's _probably_ no point in turning it into: 771 -- Proc 772 -- (... 773 -- because it only saves 3 characters, so we will probably have 774 -- to split up the "..." parameters anyway. 775 776 if This - Prev <= Threshold then 777 return False; 778 end if; 779 return True; 780 end Worthwhile_Line_Break; 781 782 F : Line_Break_Index := 1; 783 L : Line_Break_Index; 784 Len : Natural; 785 786 Level : Nesting_Level; 787 More_Levels : Boolean; 788 789 Again : constant String := 790 (if First_Time then "first time" else " again"); 791 792 -- Start of processing for Split_Lines 793 794 begin 795 pragma Debug (Format_Debug_Output ("before Split_Lines " & Again)); 796 797 Remove_Duplicates; 798 if False then 799 -- ???For debugging, always split at optional newlines 800 for Line_Index in 1 .. Last_Index (Line_Breaks) loop 801 Line_Breaks (Line_Index).Enabled := True; 802 end loop; 803 return; 804 end if; 805 806 while F /= Last_Index (Line_Breaks) loop 807 Level := 0; 808 More_Levels := True; 809 810 loop -- through levels 811 L := Next_Enabled (F); 812 Len := Line_Length (F, L); 813 exit when Len <= Options.Max_Line_Length; -- short enough 814 exit when not More_Levels; -- no more line breaks to enable 815 816 More_Levels := False; 817 818 for X in F + 1 .. L - 1 loop 819 if Line_Breaks (X).Level > Level then 820 More_Levels := True; 821 822 elsif Line_Breaks (X).Level = Level then 823 Inner_Loop_Count := Inner_Loop_Count + 1; 824 825 -- Don't enable the first one, unless it's "worthwhile" 826 -- according to the heuristic. 827 if X = F + 1 and then not Worthwhile_Line_Break (X) then 828 null; 829 830 -- We don't want soft line breaks to form blank lines, so 831 -- don't enable this one if the previous one is already 832 -- enabled. 833 834 else 835 pragma Assert 836 (not Line_Breaks (X - 1).Enabled 837 or else not Is_Empty_Line (X - 1, X)); 838 pragma Assert 839 (if 840 Line_Breaks (X - 1).Enabled 841 then 842 Line_Breaks (X - 1).Mark /= Line_Breaks (X).Mark); 843 if True -- ???? 844 or else L = Last_Index (Line_Breaks) 845 or else 846 Line_Length (F, L + 1) >= Options.Max_Line_Length 847 then 848 Line_Breaks (X).Enabled := True; 849 end if; 850 end if; 851 end if; 852 end loop; 853 854 Level := Level + 1; 855 end loop; -- through levels 856 857 Line_Breaks (F).Length := Len; 858 F := L; 859 end loop; -- through line breaks 860 861 Line_Breaks (F).Length := 0; -- last line 862 863 pragma Debug (Format_Debug_Output ("after Split_Lines" & Again)); 864 pragma Debug (Assert); 865 end Split_Lines; 866 867 procedure Insert_NLs_And_Indentation; 868 869 procedure Insert_NLs_And_Indentation is 870 -- We loop through Out_Buf, and for each character, take care of 871 -- the Line_Break at that character, if any. The Line_Breaks are in 872 -- Enabled_Line_Breaks. Enabled_Line_Breaks cannot have duplicates (two 873 -- elements at the same Mark), because hard line breaks take up space in 874 -- Out_Buf (there is an NL), and we never enable two soft line breaks in 875 -- a row. 876 877 At_Line_Start : Boolean := True; 878 Indentation : Natural := 0; 879 880 Cur_Line : Line_Break_Index := 1; 881 Line_Breaks : Line_Break_Vector renames Enabled_Line_Breaks; 882 883 begin 884 Collect_Enabled_Line_Breaks (Syntax_Also => False); 885 886 Char_Loop : loop 887 pragma Assert 888 (Position (Out_Buf, Last_Element (Tabs).Mark) = 889 Last_Position (Out_Buf) + 1); 890 891 pragma Assert 892 (Point (Out_Buf) <= 893 Position (Out_Buf, Line_Breaks (Cur_Line).Mark)); 894-- if At_Point (Out_Buf, Line_Breaks (Cur_Line).Mark) then 895-- Dbg_Out.Put ("\n"); 896-- end if; 897 898 -- Even though Enabled_Line_Breaks cannot have duplicates, we still 899 -- need 'while' (not 'if'), because in one case we Move_Forward 900 -- below. 901 902 while At_Point (Out_Buf, Line_Breaks (Cur_Line).Mark) loop 903 pragma Assert 904 (Point (Out_Buf) = 905 Position (Out_Buf, Line_Breaks (Cur_Line).Mark)); 906-- Dbg_Out.Put ("Point = \1, break = ", Image (Point (Out_Buf))); 907-- Dump_Marker (Out_Buf, Line_Breaks (Cur_Line).Mark); 908 909 At_Line_Start := True; 910 911 -- A hard line break already has NL; for a soft one, we need to 912 -- add NL 913 914 if Line_Breaks (Cur_Line).Hard then 915-- Dbg_Out.Put 916-- ("\1: hard line break\n", 917-- Image (Integer (Cur_Line))); 918 pragma Assert (Cur (Out_Buf) = NL); 919 Move_Forward (Out_Buf); 920 921 else 922 -- A soft line break can be preceded or followed by a blank, 923 -- but never both, and never more than one. If there is a 924 -- blank, we replace it with NL, otherwise we insert NL. 925 926 if Lookback (Out_Buf) = ' ' then 927-- Dbg_Out.Put 928-- ("\1: soft line break Replace_Previous\n", 929-- Image (Integer (Cur_Line))); 930 pragma Assert (Cur (Out_Buf) /= ' '); 931 Replace_Previous (Out_Buf, NL); 932 pragma Assert 933 (not At_Point (Out_Buf, Line_Breaks (Cur_Line + 1).Mark)); 934 935 elsif Cur (Out_Buf) = ' ' then 936-- Dbg_Out.Put 937-- ("\1: soft line break Replace_Cur\n", 938-- Image (Integer (Cur_Line))); 939 Replace_Cur (Out_Buf, NL); 940 pragma Assert 941 (not At_Point (Out_Buf, Line_Breaks (Cur_Line + 1).Mark)); 942 Move_Forward (Out_Buf); 943 944 else 945-- Dbg_Out.Put 946-- ("\1: soft line break insert\n", 947-- Image (Integer (Cur_Line))); 948 Insert_NL (Out_Buf); 949 pragma Assert 950 (not At_Point (Out_Buf, Line_Breaks (Cur_Line + 1).Mark)); 951 end if; 952 end if; 953 Indentation := Line_Breaks (Cur_Line).Indentation; 954 955 pragma Assert 956 (At_End (Out_Buf) = (Cur_Line = Last_Index (Line_Breaks))); 957 exit Char_Loop when Cur_Line = Last_Index (Line_Breaks); 958 959 Cur_Line := Cur_Line + 1; 960-- Dbg_Out.Put 961-- (" point = \1, next break = ", 962-- Image (Point (Out_Buf))); 963-- Dump_Marker (Out_Buf, Line_Breaks (Cur_Line).Mark); 964-- Dbg_Out.Put ("\n"); 965 pragma Assert 966 (Point (Out_Buf) <= 967 Position (Out_Buf, Line_Breaks (Cur_Line).Mark)); 968 end loop; -- through Line_Breaks table 969 970 -- We can't be At_End, because we would have done "exit Char_Loop" 971 -- above. 972 973 pragma Assert (not At_End (Out_Buf)); 974 pragma Assert (Cur (Out_Buf) not in NL | W_NUL); 975 976 if At_Line_Start then 977 for J in 1 .. Indentation loop 978 Insert (Out_Buf, ' '); 979 end loop; 980 At_Line_Start := False; 981 end if; 982 983 Move_Forward (Out_Buf); 984 end loop Char_Loop; 985 986 pragma Assert (At_End (Out_Buf)); 987 pragma Assert (Cur_Line = Last_Index (Line_Breaks)); 988 Reset (Out_Buf); 989 pragma Debug (Assert_No_Trailing_Blanks (To_W_Str (Out_Buf))); 990 end Insert_NLs_And_Indentation; 991 992 function Remove_Extra_Line_Breaks return Char_Vector; 993 -- Removes extra NL's. The result has exactly one NL at the beginning, and 994 -- exactly one at the end. Also, if Preserve_Blank_Lines is False, we 995 -- collapse 3 or more NL's in a row down to 2. ???It would be cleaner if 996 -- we didn't put multiple blank lines in in the first place. 997 -- 998 -- This also converts LF to CRLF if appropriate. 999 1000 -- Wide_Text_IO accepts a Form parameter that inserts CR's on windows, but 1001 -- it doesn't do that on unix, so we insert CR's by hand. 1002 1003 function Remove_Extra_Line_Breaks return Char_Vector is 1004 Is_Windows : constant Boolean := GNAT.OS_Lib.Directory_Separator = '\'; 1005 Add_CR : constant Boolean := 1006 (case Output.Out_File_Format is 1007 when Output.Default => (if Is_Windows then True else False), 1008 when Output.CRLF => True, 1009 when Output.LF => False); 1010 -- True if we should convert LF to CRLF -- if it was requested on the 1011 -- command line, or if we're on windows an nothing was requested. 1012 1013 begin 1014 -- Optimize the case where we're not changing anything. The reason 1015 -- Remove_Extra_Line_Breaks keeps the initial NL is that this 1016 -- optimization wouldn't work otherwise. 1017 1018 if Options.Preserve_Blank_Lines and then not Add_CR then 1019 return To_Vector (Out_Buf); 1020 end if; 1021 1022 declare 1023 Result : Char_Vector; 1024 begin 1025 while Cur (Out_Buf) = NL loop 1026 Move_Forward (Out_Buf); 1027 end loop; 1028 Append (Result, W_LF); 1029 -- We don't want a CR here; caller skips the one LF character 1030 1031 loop 1032 declare 1033 NL_Count : Natural := 0; 1034 begin 1035 while Cur (Out_Buf) = NL loop 1036 Move_Forward (Out_Buf); 1037 NL_Count := NL_Count + 1; 1038 end loop; 1039 1040 exit when At_End (Out_Buf); 1041 1042 if not Options.Preserve_Blank_Lines and then NL_Count > 2 then 1043 NL_Count := 2; 1044 end if; 1045 1046 for J in 1 .. NL_Count loop 1047 if Add_CR then 1048 Append (Result, W_CR); 1049 end if; 1050 Append (Result, W_LF); 1051 end loop; 1052 end; 1053 1054 pragma Assert (Cur (Out_Buf) /= NL); 1055 Append (Result, Cur (Out_Buf)); 1056 Move_Forward (Out_Buf); 1057 end loop; 1058 1059 if Add_CR then 1060 Append (Result, W_CR); 1061 end if; 1062 Append (Result, W_LF); 1063 Reset (Out_Buf); 1064 pragma Assert (Result (1) = NL); 1065 pragma Assert (Result (2) /= NL); 1066 if not Add_CR then 1067 pragma Assert (Result (Last_Index (Result) - 1) /= NL); 1068 pragma Assert (Result (Last_Index (Result)) = NL); 1069 end if; 1070 return Result; 1071 end; 1072 end Remove_Extra_Line_Breaks; 1073 1074 procedure Write_Str (Out_Elems : W_Str); 1075 procedure Write_Out_Buf; 1076 procedure Write_Src_Buf; 1077 -- Write_Out_Buf writes Out_Buf to the output. This is the normal 1078 -- case. Write_Src_Buf writes the Src_Buf to the output. Write_Str is the 1079 -- code common to both Write_Out_Buf and Write_Src_Buf. 1080 1081 procedure Write_Str (Out_Elems : W_Str) is 1082 use Wide_Text_IO; 1083 Out_File : File_Type; 1084 begin 1085 if False then -- ???Messes up the diff's. 1086 Formatted_Output.Put 1087 ("-- ???Inner_Loop_Count = \1\n", 1088 Image (Inner_Loop_Count)); 1089 end if; 1090 1091 Output_Written := True; 1092 if Output_Name /= "" then 1093 -- If Output_Name = "", leave Current_Output pointing to standard 1094 -- output; otherwise point it to the file. 1095 Create (Out_File, Name => Output_Name, 1096 Form => Form_String & ",Text_Translation=NO"); 1097 Set_Output (Out_File); 1098 end if; 1099 1100 -- If a BOM (byte order mark) was found in the input, we want to put it 1101 -- in the output. 1102 1103 if Write_BOM then 1104 if Options.Output_Encoding /= System.WCh_Con.WCEM_UTF8 then 1105 raise Program_Error; 1106 end if; 1107 Put (W_Char'Val (16#FEFF#)); -- BOM as a wide character 1108 end if; 1109 1110 -- We must call New_Line for LF's (at least for the last one in the 1111 -- Out_Elems), because otherwise Wide_Text_IO adds an annoying blank 1112 -- line to the end of the file. It would probably be better to avoid 1113 -- Wide_Text_IO altogether, but we're currently using it to do Unicode 1114 -- encoding transformations. Note that Put(CR) is not guaranteed to work 1115 -- by the Ada standard, but the GNAT implementation won't molest it. 1116 1117 for C of Out_Elems loop 1118 if C = W_LF then 1119 New_Line; 1120 else 1121 Put (C); 1122 end if; 1123 end loop; 1124 1125 if Output_Name /= "" then 1126 Close (Out_File); 1127 Set_Output (Ada.Wide_Text_IO.Standard_Output); 1128 end if; 1129 end Write_Str; 1130 1131 procedure Write_Out_Buf is 1132 pragma Assert (Point (Out_Buf) = 1); 1133 Normalized : constant Char_Vector := Remove_Extra_Line_Breaks; 1134 Out_Elems : W_Str renames Elems (Normalized) 1135 (2 .. Last_Index (Normalized)); -- 2 to skip initial NL 1136 begin 1137 -- In Do_Diff mode, don't write the output if it is identical to the 1138 -- input. 1139 1140 if Do_Diff then 1141 declare 1142 Src_Elems : W_Str renames Elements (Src_Buf) 1143 (1 .. Last_Position (Src_Buf)); 1144 begin 1145 if Out_Elems = Src_Elems then 1146 Output_Written := False; 1147 return; 1148 end if; 1149 end; 1150 end if; 1151 1152 Write_Str (Out_Elems); 1153 end Write_Out_Buf; 1154 1155 procedure Write_Src_Buf is 1156 Out_Elems : W_Str renames Elements (Src_Buf) 1157 (1 .. Last_Position (Src_Buf)); 1158 begin 1159 Write_Str (Out_Elems); 1160 end Write_Src_Buf; 1161 1162 procedure Subtree_To_Ada 1163 (Tree : Ada_Tree; 1164 Cur_Level : Nesting_Level; 1165 Index_In_Parent : Query_Index); 1166 -- We recursively walk the tree, and for most nodes, take the template 1167 -- from Template_Table, and pass it to Interpret_Template. Some nodes 1168 -- need special casing, and bypass the Template_Table. Subtree_To_Ada is 1169 -- directly recursive, and also mutually recursive with Interpret_Template. 1170 1171 procedure Convert_Tree_To_Ada (Tree : Ada_Tree); 1172 -- Subtree_To_Ada with initial values for Cur_Level and Index_In_Parent, 1173 -- along with some fix-ups. In particular, we add a sentinel Line_Break 1174 -- at the beginning, and a sentinel Tab at the end. 1175 1176 type Tree_Stack_Index is new Positive; 1177 type Tree_Array is array (Tree_Stack_Index range <>) of Ada_Tree; 1178 package Tree_Stacks is new ASIS_UL.Vectors 1179 (Tree_Stack_Index, 1180 Ada_Tree, 1181 Tree_Array); 1182 use Tree_Stacks; 1183 -- use all type Tree_Stacks.Vector; 1184 1185 Tree_Stack : Tree_Stacks.Vector; 1186 -- Stack of trees that we're in the process of traversing. Pushed and 1187 -- popped at the beginning and end of Subtree_To_Ada. 1188 1189 function Ancestor_Tree 1190 (N : Tree_Stack_Index) 1191 return Ada_Tree; 1192 -- Returns the N'th ancestor of the current tree. Ancestor (0) is the 1193 -- current tree, Ancestor (1) is the parent of the current tree, Ancestor 1194 -- (2) is the grandparent of the current tree, and so on. Nil if the tree 1195 -- isn't deep enough. 1196 1197 function Ancestor_Tree 1198 (N : Tree_Stack_Index) 1199 return Ada_Tree is 1200 begin 1201 if Last_Index (Tree_Stack) <= N then 1202 return Nil; 1203 else 1204 return Tree_Stack (Last_Index (Tree_Stack) - N); 1205 end if; 1206 end Ancestor_Tree; 1207 1208 function Parent_Tree return Ada_Tree is (Ancestor_Tree (1)); 1209 1210 Implicit_Null_Statement_Seen : Boolean := False; 1211 -- See the comments about labels under "when A_Null_Statement =>" below for 1212 -- an explanation of this. 1213 1214 function Munge_Template 1215 (T : Ada_Template; 1216 Kind : Ada_Tree_Kind) 1217 return Ada_Template; 1218 -- Modify the template in certain ways based on command-line options and 1219 -- the like. 1220 1221 function Subp_Decl_With_Hard_Breaks 1222 (Tree : Ada_Tree; 1223 Is_Function, Is_Body : Boolean) 1224 return Ada_Template; 1225 -- For implementing Par_Specs_Threshold. This replaces the soft line break 1226 -- between parameters with a hard line break. If Is_Function is True, put 1227 -- a hard line break before "return". If Is_Body is True, put a hard line 1228 -- break before "is". 1229 1230 function Munge_Template 1231 (T : Ada_Template; 1232 Kind : Ada_Tree_Kind) 1233 return Ada_Template 1234 is 1235 begin 1236 if not Options.RM_Style_Spacing then 1237 return T; 1238 end if; 1239 declare 1240 Result : Bounded_W_Str (Max_Length => T'Length * 2); 1241 X : Natural := T'First; 1242 function C return W_Char is (T (X)); 1243 function Match 1244 (S : Ada_Template) 1245 return Boolean is 1246 (T (X .. Natural'Min (T'Last, X + S'Length - 1)) = S); 1247 begin 1248 while X <= T'Last loop 1249 if Options.RM_Style_Spacing then 1250 if Match (" (") or else Match (" @(") then 1251 X := X + 1; -- skip ' ' before '(' 1252 elsif Match (" ^:") and then not Match (" ^:=") then 1253 X := X + 1; -- skip ' ' before ':' 1254 elsif Kind in 1255 A_Loop_Statement | 1256 A_While_Loop_Statement | 1257 A_For_Loop_Statement | 1258 A_Block_Statement 1259 and then Match (" :") 1260 then 1261 X := X + 1; -- skip ' ' before ':' for statement name 1262 end if; 1263 end if; 1264 1265 Append (Result, C); 1266 X := X + 1; 1267 end loop; 1268 1269 return Ada_Template (To_String (Result)); 1270 end; 1271 end Munge_Template; 1272 1273 function Subp_Decl_With_Hard_Breaks 1274 (Tree : Ada_Tree; 1275 Is_Function, Is_Body : Boolean) 1276 return Ada_Template 1277 is 1278 T : Ada_Template renames Template_Table (Tree.Kind).all; 1279 T1 : constant W_Str := 1280 (if Options.RM_Style_Spacing 1281 then Must_Replace (W_Str (T), "[@(~;@ ~)]", "[$(~;$~)]") 1282 else Must_Replace (W_Str (T), "[@ (~;@ ~)]", "[$(~;$~)]")); 1283 T2 : constant W_Str := 1284 (if Is_Function 1285 then Must_Replace (T1, "@1 return", "$ return") 1286 else T1); 1287 T3 : constant W_Str := 1288 (if Is_Body and then Options.Separate_Line_For_IS 1289 then Must_Replace (T2, "@ is$", "$is$") 1290 else T2); 1291 begin 1292 return Result : constant Ada_Template := Ada_Template (T3) do 1293 if Assert_Enabled then 1294 if Result = T then 1295 Self_Rep.Stdo; 1296 Self_Rep.Put_Ada_Tree (Tree); 1297 Wide_Text_IO.Put_Line ("T = " & W_Str (T)); 1298 Wide_Text_IO.Put_Line ("Result = " & W_Str (Result)); 1299 end if; 1300 pragma Assert (Result /= T); 1301 end if; 1302 end return; 1303 end Subp_Decl_With_Hard_Breaks; 1304 1305 package Alternative_Templates is 1306 1307 -- Some templates that are used instead of the ones in Template_Table 1308 1309 Prefix_Notation_Call_Alt_Templ_1 : constant Ada_Template := 1310 Munge_Template (" @(", A_Function_Call); 1311 1312 Prefix_Notation_Call_Alt_Templ_2 : constant Ada_Template := 1313 Munge_Template ("[$(", A_Function_Call); 1314 1315 Accept_Statement_Alt_Templ : constant Ada_Template := 1316 Munge_Template 1317 (Labels & "accept !? @(~~)~?[ @(~;@ ~)]~!!", 1318 An_Accept_Statement); 1319 -- The last "!!" generates nothing, but satisfies the requirement that 1320 -- we use all the subtrees. 1321 1322 -- ???Is the following correct for multi-dim arrays (only some indices 1323 -- need "range")? 1324 Constrained_Array_Definition_Alt_Templ_1 : constant Ada_Template := 1325 Munge_Template 1326 ("array @(?range ~, range ~~) of !", 1327 A_Constrained_Array_Definition); 1328 1329 Constrained_Array_Definition_Alt_Templ_2 : constant Ada_Template := 1330 Munge_Template 1331 ("array @(?~, ~~) of !", 1332 A_Constrained_Array_Definition); 1333 1334 Pragma_Alt_Templ : constant Ada_Template := 1335 Munge_Template ("?[ @(~,@ ~)]~", Flat_Pragma_Kinds'First); 1336 1337 Parameter_Specification_Alt_Templ : constant Ada_Template := 1338 Munge_Template (" ^: ", A_Parameter_Specification); 1339 1340 Block_Statement_Alt_Templ_1 : constant Ada_Template := 1341 Munge_Template 1342 (Labels & "?~~ : ~!" & Handled_Seq_2, 1343 A_Block_Statement); 1344 1345 Block_Statement_Alt_Templ_2 : constant Ada_Template := 1346 Munge_Template 1347 (Labels & "?~~ : ~?declare$" & "{~;$~;$$}~" & Handled_Seq_2, 1348 A_Block_Statement); 1349 1350 Extended_Return_Statement_Alt_Templ : constant Ada_Template := 1351 Munge_Template (Labels & "return !!!", An_Extended_Return_Statement); 1352 -- The last "!!" generates nothing, but satisfies the requirement that 1353 -- we use all the subtrees. 1354 1355 end Alternative_Templates; 1356 1357 procedure Subtree_To_Ada 1358 (Tree : Ada_Tree; 1359 Cur_Level : Nesting_Level; 1360 Index_In_Parent : Query_Index) 1361 is 1362 pragma Unreferenced (Index_In_Parent); -- ???Needed? 1363 1364 Line_Breaks : Line_Break_Vector renames All_Line_Breaks; 1365 1366 procedure Subtrees_To_Ada 1367 (Tree : Ada_Tree; 1368 Pre, Between, Post : Ada_Template); 1369 1370 procedure Interpret_Template 1371 (T : Ada_Template := Template_Table (Tree.Kind).all; 1372 Subtrees : Ada_Tree_Array := Tree.Subtrees; 1373 Cur_Level : Nesting_Level := Subtree_To_Ada.Cur_Level; 1374 Kind : Ada_Tree_Kind := Tree.Kind); 1375 -- Interpret the template, printing literal characters, and recursively 1376 -- calling Subtree_To_Ada when the template calls for a subnode. Kind is 1377 -- for debugging. 1378 1379 procedure Prefix_Notation_Call (Label_Names, Callee, Actuals : Ada_Tree); 1380 -- This is called for A_Function_Call and A_Procedure_Call_Statement 1381 -- when the Is_Prefix_Notation subtree is True. Prefix notation calls 1382 -- have special visibility rules, so we don't want to turn X.F(Y) into 1383 -- F(X, Y). Label_Names is always empty for function calls. 1384 1385 procedure Append_Tab 1386 (Parent, Tree : Ada_Tree_Base; 1387 T : Ada_Template; 1388 Token_Text : Name_Id; 1389 Index_In_Line : Tab_Index_In_Line; 1390 Is_Insertion_Point : Boolean); 1391 -- Append a Tab_Rec onto Tabs. If Token is Name_Empty, get the token 1392 -- from the template T. 1393 -- 1394 -- Handling of "fake tabs": 1395 -- Fake tabs are used to deal with situations like this: 1396 -- 1397 -- A_Long_Var_Name : T := 123; 1398 -- X : A_Long_Type_Name; 1399 -- A_Long_Constant_Name : constant T := 123; 1400 -- 1401 -- where we wish to align the ":" and ":=" tokens. But the 1402 -- Insert_Alignment algorithm doesn't align things unless subsequent 1403 -- lines "match", which includes having the same number of tabs. But X 1404 -- has no ":=", so we add a fake tab so it will match the preceding and 1405 -- following lines. 1406 -- 1407 -- Append_Tab inserts a fake tab after each ":" tab. If there is no 1408 -- ":=" following, the fake tab remains. If there IS a ":=", a real 1409 -- tab replaces the fake one. 1410 -- 1411 -- Fake tabs initially have the same position as the preceding ":" tab. 1412 -- When Insert_Alignment calculates Max_Col, it ignores the fake ones, 1413 -- so they won't push anything further to the right. It sets the Col of 1414 -- the fake ones to Max_Col; hence Num_Blanks will be zero, so fake tabs 1415 -- won't insert any blanks. 1416 -- 1417 -- Context clauses are handled in a similar manner: 1418 -- 1419 -- with Ada.Characters.Handling; use Ada.Characters.Handling; 1420 -- with Ada.Exceptions; 1421 -- with Ada.Strings; use Ada.Strings; 1422 1423 procedure Append_Tab 1424 (Parent, Tree : Ada_Tree_Base; 1425 T : Ada_Template; 1426 Token_Text : Name_Id; 1427 Index_In_Line : Tab_Index_In_Line; 1428 Is_Insertion_Point : Boolean) 1429 is 1430 Text : Name_Id; 1431 Pa : Ada_Tree_Base := Parent; 1432 Tr : Ada_Tree_Base := Tree; 1433 1434 procedure Maybe_Replace_Fake_Tab; 1435 -- Replace a fake tab with a real one, if appropriate. In particular, 1436 -- if the last tab is fake, and the current one has the same 1437 -- Index_In_Line, Tree, and Parent, then the current one replaces the 1438 -- fake one. 1439 1440 function Tab_Token (T : Ada_Template) return Name_Id; 1441 -- Returns the text of the token at the beginning of T, which is the 1442 -- portion of an Ada_Template immediately following "^". 1443 1444 procedure Maybe_Replace_Fake_Tab is 1445 begin 1446 if Is_Empty (Tabs) then 1447 return; 1448 end if; 1449 1450 declare 1451 Tb : constant Tab_Rec := Last_Element (Tabs); 1452 begin 1453 if Tb.Is_Fake 1454 and then Tb.Index_In_Line = Index_In_Line 1455 and then Tb.Tree = Tr 1456 and then Tb.Parent = Pa 1457 then 1458 pragma Assert (Tb.Token = Text); 1459 pragma Assert 1460 ((Text = Name_Assign and then Index_In_Line in 2 | 4) 1461 or else 1462 (Text = Snames.Name_Use and then Index_In_Line = 2)); 1463 pragma Assert (not Is_Insertion_Point); 1464 Delete_Last (Tabs); -- replace fake tab with this real one 1465 end if; 1466 end; 1467 end Maybe_Replace_Fake_Tab; 1468 1469 function Tab_Token (T : Ada_Template) return Name_Id is 1470 -- There is a limited number of possibilities, and we take 1471 -- advantage of that for efficiency. Currently, the only tokens 1472 -- that can follow "^" in templates are as shown below. This needs 1473 -- to be changed if we add more tabbing to templates. 1474 Tok : Scanner.Token; 1475 Text : Name_Id; 1476 begin 1477 if T = "" then 1478 pragma Assert 1479 (Tree.Kind in 1480 A_Parameter_Specification | A_Formal_Object_Declaration); 1481 Text := Name_Tab_In_Out; 1482 else 1483 case T (T'First) is 1484 when ':' => 1485 if Has_Prefix (W_Str (T), Prefix => ":=") then 1486 Text := Name_Assign; 1487 else 1488 Text := Name_Colon; 1489 end if; 1490 when '|' => 1491 Text := Name_Bar; 1492 when '=' => 1493 pragma Assert (Has_Prefix (W_Str (T), Prefix => "=>")); 1494 Text := Name_Arrow; 1495 when 'a' => 1496 pragma Assert (Has_Prefix (W_Str (T), Prefix => "at")); 1497 Text := Snames.Name_At; 1498 when 'r' => 1499 pragma Assert (Has_Prefix (W_Str (T), Prefix => "range")); 1500 Text := Snames.Name_Range; 1501 when '.' => 1502 pragma Assert (Tree.Kind in A_Component_Clause); 1503 pragma Assert (Has_Prefix (W_Str (T), Prefix => "..")); 1504 Text := Name_Dot_Dot; 1505 when ']' => 1506 pragma Assert (Tree.Kind in A_Component_Clause); 1507 Text := Name_R_Sq; 1508 goto Skip_Assertion; -- ']' is not a legal token 1509 when others => 1510 pragma Assert (False); 1511 end case; 1512 if Assert_Enabled then 1513 Tok := Scanner.Get_Token (W_Str (T)); 1514 pragma Assert (Text = Tok.Normalized); 1515 pragma Assert (Tok.Sloc.First = 1); 1516 end if; 1517 <<Skip_Assertion>> 1518 end if; 1519 pragma Assert 1520 (Text in 1521 Name_Tab_In_Out | 1522 Name_Assign | 1523 Name_Colon | 1524 Name_Arrow | 1525 Name_Bar | 1526 Snames.Name_At | 1527 Snames.Name_Range | 1528 Name_Dot_Dot | 1529 Name_R_Sq); 1530 return Text; 1531 end Tab_Token; 1532 1533 -- Start of processing for Append_Tab 1534 1535 begin 1536 if not Alignment_Enabled then 1537 return; 1538 end if; 1539 1540 if Tree /= null and then Tree.Kind = A_With_Clause then 1541 if Is_Nil (Get (Tree, Has_Limited)) 1542 and then Is_Nil (Get (Tree, Has_Private)) 1543 then 1544 Pa := null; 1545 Tr := null; 1546 Text := Snames.Name_With; 1547 else 1548 return; -- ignore "limited with" and "private with" 1549 end if; 1550 elsif Token_Text = Name_Empty then 1551 if Is_Insertion_Point then 1552 Text := Name_Tab_Insertion_Point; 1553 else 1554 Text := Tab_Token (T); 1555 end if; 1556 else 1557 Text := Token_Text; 1558 end if; 1559 1560 Maybe_Replace_Fake_Tab; 1561 1562 pragma Assert 1563 (Point (Out_Buf) = 1564 Last_Position (Out_Buf) + 1); -- ???Do we need Last_Position? 1565 Append 1566 (Tabs, 1567 Tab_Rec' 1568 (Pa, 1569 Tr, 1570 Token => Text, 1571 Mark => Mark (Out_Buf, '^'), 1572 Index_In_Line => Index_In_Line, 1573 Col => <>, 1574 Num_Blanks => <>, 1575 Is_Fake => False, 1576 Is_Insertion_Point => Is_Insertion_Point)); 1577 pragma Assert 1578 (Position (Out_Buf, Last_Element (Tabs).Mark) = 1579 Last_Position (Out_Buf) + 1); 1580 1581 -- Append a fake tab if appropriate 1582 1583 if Tree /= null and then not Is_Insertion_Point then 1584 case Tree.Kind is 1585 when A_Variable_Declaration | 1586 A_Constant_Declaration | 1587 An_Integer_Number_Declaration | 1588 A_Real_Number_Declaration | 1589 A_Discriminant_Specification | 1590 A_Component_Declaration | 1591 A_Return_Variable_Specification => 1592 if Index_In_Line = 1 then 1593 pragma Assert (Text = Name_Colon); 1594 Append 1595 (Tabs, 1596 Tab_Rec' 1597 (Parent => Pa, 1598 Tree => Tr, 1599 Token => Name_Assign, 1600 Mark => Mark (Out_Buf, '^'), 1601 Index_In_Line => 2, 1602 Col => <>, 1603 Num_Blanks => <>, 1604 Is_Fake => True, 1605 Is_Insertion_Point => False)); 1606 end if; 1607 1608 when A_Parameter_Specification | A_Formal_Object_Declaration => 1609 if Index_In_Line = 3 then 1610 pragma Assert (Text = Name_Tab_In_Out); 1611 Append 1612 (Tabs, 1613 Tab_Rec' 1614 (Parent => Pa, 1615 Tree => Tr, 1616 Token => Name_Assign, 1617 Mark => Mark (Out_Buf, '^'), 1618 Index_In_Line => 4, 1619 Col => <>, 1620 Num_Blanks => <>, 1621 Is_Fake => True, 1622 Is_Insertion_Point => False)); 1623 end if; 1624 1625 when A_With_Clause => 1626 if Index_In_Line = 1 then 1627 pragma Assert (Text = Snames.Name_With); 1628 Append 1629 (Tabs, 1630 Tab_Rec' 1631 (Parent => Pa, 1632 Tree => Tr, 1633 Token => Snames.Name_Use, 1634 Mark => Mark (Out_Buf, '^'), 1635 Index_In_Line => 2, 1636 Col => <>, 1637 Num_Blanks => <>, 1638 Is_Fake => True, 1639 Is_Insertion_Point => False)); 1640 end if; 1641 1642 when A_Variant | 1643 An_Aspect_Specification | 1644 A_For_All_Quantified_Expression | 1645 A_For_Some_Quantified_Expression | 1646 An_Assignment_Statement | 1647 A_Case_Path | 1648 A_Select_Path | 1649 An_Or_Path | 1650 A_Case_Expression_Path | 1651 A_Component_Clause | 1652 An_Exception_Handler => 1653 null; 1654 1655 when A_Pragma_Argument_Association | 1656 A_Discriminant_Association | 1657 A_Record_Component_Association | 1658 An_Array_Component_Association | 1659 A_Parameter_Association | 1660 A_Generic_Association => 1661 null; 1662 1663 when others => 1664 -- No other tree kinds have tabs 1665 pragma Assert (False); 1666 end case; 1667 end if; 1668 end Append_Tab; 1669 1670 procedure Subtrees_To_Ada 1671 (Tree : Ada_Tree; 1672 Pre, Between, Post : Ada_Template) 1673 is 1674 procedure Check_Between; 1675 -- Assert that Between doesn't contain any indentation or similar, so 1676 -- we don't need special processing as for Keep_Indentation. 1677 1678 function Keep_Indentation (Post : Ada_Template) return Ada_Template; 1679 -- Remove everything from Post except for indentation commands 1680 1681 procedure Check_Between is 1682 begin 1683 for X of Between loop 1684 if X in '{' | '}' | '[' | ']' | '(' | ')' | '&' | 1685 '!' | '?' | '~' 1686 then 1687 Self_Rep.Stdo; 1688 Self_Rep.Put_Ada_Tree (Tree); 1689 Wide_Text_IO.Put_Line 1690 ("Incorrect Between string: " & W_Str (Between)); 1691 pragma Assert (False); 1692 end if; 1693 end loop; 1694 end Check_Between; 1695 1696 pragma Debug (Check_Between); 1697 1698 function Keep_Indentation (Post : Ada_Template) return Ada_Template is 1699 Result : Bounded_W_Str (Max_Length => Post'Length); 1700 begin 1701 for X of Post loop 1702 pragma Assert (X not in '(' | ')'); 1703 if X in '{' | '}' | '[' | ']' then 1704 Append (Result, X); 1705 end if; 1706 end loop; 1707 return Ada_Template (To_String (Result)); 1708 end Keep_Indentation; 1709 1710 pragma Assert (Tree.Kind in Flat_List_Kinds); 1711 Prev_With : Ada_Tree_Base := null; 1712 -- See Use_Same_Line below 1713 1714 begin 1715 if Tree.Subtree_Count = 0 then 1716 return; 1717 end if; 1718 1719 Interpret_Template (Pre, Subtrees => Empty_Tree_Array); 1720 1721 for Index in 1 .. Tree.Subtree_Count loop 1722 declare 1723 Subtree : constant Ada_Tree := Tree.Subtrees (Index); 1724 1725 function Use_Same_Line return Boolean; 1726 -- Special case for use_package_clauses: We want to print "with 1727 -- A.B; use A.B;" on one line. Also, things like "with A.B; use 1728 -- A; use A.B;". This returns True in these cases. We don't do 1729 -- this special processing for use type clauses. 1730 1731 function Has_Prefix (X, Y : Ada_Tree) return Boolean with 1732 Pre => X.Kind in Usage_Names | A_Selected_Component 1733 and then Y.Kind in Usage_Names | A_Selected_Component; 1734 -- True if X contains Y, as in "A.B.C.D" contains "A.B". 1735 -- I.e. if Y is a prefix of X. 1736 1737 function Has_Prefix (X, Y : Ada_Tree) return Boolean is 1738 begin 1739 if Ref (X) = Ref (Y) then 1740 return True; 1741 elsif X.Kind in Usage_Names then 1742 return False; 1743 else 1744 pragma Assert (X.Kind = A_Selected_Component); 1745 return Has_Prefix (X.Subtrees (1), Y); 1746 end if; 1747 end Has_Prefix; 1748 1749 function Use_Same_Line return Boolean is 1750 begin 1751 -- For a with clause followed by one or more use package 1752 -- clauses, Prev_With will be the with clause when 1753 -- processing the use clauses. Otherwise, Prev_With is null. 1754 1755 if Prev_With = null 1756 or else Options.Separate_Line_For_USE 1757 then 1758 return False; -- usual case 1759 end if; 1760 1761 declare 1762 pragma Assert (Prev_With.Kind = A_With_Clause); 1763 With_Names : constant Ada_Tree := Prev_With.Subtrees (3); 1764 Next_Subtree : constant Ada_Tree := 1765 Tree.Subtrees (Index + 1); 1766 begin 1767 if Next_Subtree.Kind = A_Use_Package_Clause 1768 and then Next_Subtree.Subtrees (1).Subtree_Count = 1 1769 and then With_Names.Subtree_Count = 1 1770 then 1771 declare 1772 W : constant Ada_Tree := With_Names.Subtrees (1); 1773 U : constant Ada_Tree := 1774 Next_Subtree.Subtrees (1).Subtrees (1); 1775 begin 1776 if Has_Prefix (W, U) or else Has_Prefix (U, W) then 1777 return True; 1778 end if; 1779 end; 1780 end if; 1781 end; 1782 1783 return False; -- usual case 1784 end Use_Same_Line; 1785 1786 begin 1787 pragma Assert (Tree.Kind not in An_If_Path | An_Elsif_Path); 1788 -- No need for If_Statement_Check here 1789 Subtree_To_Ada 1790 (Subtree, 1791 New_Level (Tree, Index, Cur_Level, Pre & Between & Post), 1792 Index); 1793 -- ???Shouldn't this use the entire template? 1794 1795 case Subtree.Kind is 1796 when A_With_Clause => 1797 if Is_Nil (Get (Subtree, Has_Limited)) 1798 and then Is_Nil (Get (Subtree, Has_Private)) 1799 then 1800 Prev_With := Subtree; 1801 else 1802 -- ignore "limited with" and "private with" 1803 Prev_With := null; 1804 end if; 1805 when A_Use_Package_Clause => 1806 null; -- Leave Prev_With alone 1807 when others => 1808 Prev_With := null; 1809 end case; 1810 1811 if Index < Tree.Subtree_Count then 1812 declare 1813 Same_Line : constant Boolean := Use_Same_Line; 1814 pragma Assert (if Same_Line then Between = ";$"); 1815 Tween : constant Ada_Template := 1816 (if 1817 Same_Line 1818 then 1819 (if Prev_With = Tree.Subtrees (Index) then ";@ " 1820 else ";$") 1821 else -- else ";@1 "??? 1822 Between); 1823 begin 1824 if Subtree.Kind /= A_Comment then 1825 Interpret_Template 1826 (Tween, Subtrees => Empty_Tree_Array); 1827 end if; 1828 if Same_Line then 1829 Append_Tab 1830 (Parent => null, 1831 Tree => null, 1832 T => "", 1833 Token_Text => Snames.Name_Use, 1834 Index_In_Line => 2, 1835 Is_Insertion_Point => False); 1836 end if; 1837 end; 1838 1839 else 1840 pragma Assert (Index = Tree.Subtree_Count); 1841 if Subtree.Kind = A_Comment then 1842 Interpret_Template 1843 (Keep_Indentation (Post), Subtrees => Empty_Tree_Array); 1844 else 1845 Interpret_Template (Post, Subtrees => Empty_Tree_Array); 1846 end if; 1847 end if; 1848 end; 1849 end loop; 1850 end Subtrees_To_Ada; 1851 1852 procedure Interpret_Template 1853 (T : Ada_Template := Template_Table (Tree.Kind).all; 1854 Subtrees : Ada_Tree_Array := Tree.Subtrees; 1855 Cur_Level : Nesting_Level := Subtree_To_Ada.Cur_Level; 1856 Kind : Ada_Tree_Kind := Tree.Kind) 1857 is 1858 1859 pragma Assert (T = Munge_Template (T, Kind)); 1860 J : Positive := T'First; 1861 subtype Subtrees_Index is Query_Index range 1 .. Subtrees'Last; 1862 Used : array (Subtrees_Index) of Boolean := (others => False); 1863 Cur_Subtree_Index : Query_Count := 0; 1864 Numeric_Arg : Boolean; 1865 C : W_Char; 1866 1867 function Debug_Template return Name_Id; 1868 1869 function Debug_Template return Name_Id is 1870 begin 1871 if False then 1872 return W_Name_Find 1873 ("X" & W_Str (T) & "X [" & From_UTF8 (Image (J)) & "]"); 1874 else 1875 return Name_Empty; 1876 end if; 1877 end Debug_Template; 1878 1879 Nesting_Increment : Nesting_Level; 1880 1881 -- Start of processing for Interpret_Template 1882 1883 begin 1884 while J <= T'Last loop 1885 Numeric_Arg := False; 1886 C := T (J); 1887 1888 case C is 1889 -- The following characters are not currently used in templates 1890 -- (as literal text, or as the initial character of a special 1891 -- character sequence); reserved for future use. 1892 1893 when '0' .. '9' | 1894 '~' | 1895 '#' | 1896 '*' | 1897 '_' | 1898 '"' | 1899 '\' | 1900 '/' => 1901 raise Program_Error with "Illegal template character"; 1902 1903 when '$' | '%' => 1904 Append_Line_Break 1905 (Hard => True, 1906 Affects_Comments => C = '$', 1907 Level => Cur_Level, 1908 Kind => Kind, 1909 Template => Debug_Template); 1910 when '@' => 1911 if J < T'Last and then T (J + 1) in '0' .. '9' then 1912 J := J + 1; 1913 Nesting_Increment := 1914 Nesting_Level (Char_To_Digit (T (J))); 1915 else 1916 Nesting_Increment := 0; 1917 end if; 1918 Append_Line_Break 1919 (Hard => False, 1920 Affects_Comments => False, 1921 Level => Cur_Level + Nesting_Increment, 1922 Kind => Kind, 1923 Template => Debug_Template); 1924 1925 when '{' => 1926 Indent (Options.PP_Indentation); 1927 when '}' => 1928 Indent (-Options.PP_Indentation); 1929 1930 when '[' => 1931 Indent (Options.PP_Cont_Line_Indentation); 1932 when ']' => 1933 Indent (-Options.PP_Cont_Line_Indentation); 1934 1935 when '(' => 1936 Buffered_Output.Put_Char (C); 1937 Indent (1); -- extra indentation 1938 when ')' => 1939 Buffered_Output.Put_Char (C); 1940 Indent (-1); 1941 1942 when '^' | '&' => 1943 declare 1944 Index_In_Line : Tab_Index_In_Line; 1945 Par : Ada_Tree := Parent_Tree; 1946 begin 1947 if J < T'Last and then T (J + 1) in '0' .. '9' then 1948 J := J + 1; 1949 Index_In_Line := 1950 Tab_Index_In_Line (Char_To_Digit (T (J))); 1951 1952 else 1953 Index_In_Line := 1; 1954 end if; 1955 if Par = Tree then 1956 Par := Ancestor_Tree (2); -- up one more level 1957 end if; 1958 Append_Tab 1959 (Par, 1960 Tree, 1961 T (J + 1 .. T'Last), 1962 Name_Empty, 1963 Index_In_Line => Index_In_Line, 1964 Is_Insertion_Point => C = '&'); 1965 end; 1966 1967 when '!' | '?' => 1968 if J < T'Last and then T (J + 1) in '0' .. '9' then 1969 Numeric_Arg := True; 1970 J := J + 1; 1971 1972 else 1973 Cur_Subtree_Index := Cur_Subtree_Index + 1; 1974 end if; 1975 1976 declare 1977 Subtree_Index : Query_Index; 1978 1979 begin 1980 if Numeric_Arg then 1981 Subtree_Index := Query_Index (Char_To_Digit (T (J))); 1982 1983 else 1984 Subtree_Index := Cur_Subtree_Index; 1985 end if; 1986 pragma Assert (Subtree_Index in Subtrees_Index); 1987 -- Put ("Subtree_Index = \1, not in \2..\3 <<\4>>\n", 1988 -- Image (Subtree_Index), Image (Subtrees'First), Image 1989 -- (Subtrees'Last), "???Image (Tr.Kind)"); 1990 1991 declare 1992 Subtree : constant Ada_Tree := 1993 Subtrees (Subtree_Index); 1994 1995 begin 1996 Used (Subtree_Index) := True; 1997 if C = '!' then 1998 if Tree.Kind in An_If_Path | An_Elsif_Path then 1999 pragma Assert (Subtree_Index = 1); 2000 If_Statement_Check_1; 2001 end if; 2002 2003 Subtree_To_Ada 2004 (Subtree, 2005 New_Level (Tree, Subtree_Index, Cur_Level, T), 2006 Subtree_Index); 2007 2008 if Tree.Kind in An_If_Path | An_Elsif_Path then 2009 If_Statement_Check_2 (Cur_Level); 2010 end if; 2011 2012 else 2013 pragma Assert (C = '?'); 2014 2015 declare 2016 function Scan_To_Tilde return Positive; 2017 2018 function Scan_To_Tilde return Positive is 2019 begin 2020 loop 2021 J := J + 1; 2022 exit when T (J) = '~'; 2023 end loop; 2024 return J - 1; 2025 end Scan_To_Tilde; 2026 2027 Pre_First : constant Positive := J + 1; 2028 Pre_Last : constant Positive := Scan_To_Tilde; 2029 pragma Assert (T (J) = '~'); 2030 2031 Between_First : constant Positive := J + 1; 2032 Between_Last : constant Positive := 2033 Scan_To_Tilde; 2034 pragma Assert (T (J) = '~'); 2035 2036 Post_First : constant Positive := J + 1; 2037 Post_Last : constant Positive := Scan_To_Tilde; 2038 pragma Assert (T (J) = '~'); 2039 2040 begin 2041 Used (Subtree_Index) := True; 2042 -- ???The following could use some cleanup 2043 case Subtree.Kind is 2044 when Flat_List_Kinds => 2045 Append (Tree_Stack, Subtree); -- push 2046 Subtrees_To_Ada 2047 (Subtree, 2048 T (Pre_First .. Pre_Last), 2049 T (Between_First .. Between_Last), 2050 T (Post_First .. Post_Last)); 2051 Delete_Last (Tree_Stack); -- pop 2052 2053 when Not_An_Element => 2054 null; 2055 2056 when others => 2057 Interpret_Template 2058 (T (Pre_First .. Pre_Last), 2059 Subtrees => Empty_Tree_Array); 2060 -- ??? 2061 -- if False and then Between /= "" then 2062 -- Put ("\1, \2: ???Between = <<\3>>, " & 2063 -- "T = <<\4>>\n", "???Image (Tr.Kind)", 2064 -- Image (Subtree.Kind), String (Between), 2065 -- String (T)); pragma Assert (Between = 2066 -- ""); end if; 2067 pragma Assert 2068 (Kind not in An_If_Path | An_Elsif_Path); 2069 -- No need for If_Statement_Check here 2070 Subtree_To_Ada 2071 (Subtree, 2072 New_Level 2073 (Tree, 2074 Subtree_Index, 2075 Cur_Level, 2076 T), 2077 Subtree_Index); 2078 Interpret_Template 2079 (T (Post_First .. Post_Last), 2080 Subtrees => Empty_Tree_Array); 2081 end case; 2082 end; 2083 end if; 2084 end; 2085 end; 2086 2087 when ';' => 2088 if Implicit_Null_Statement_Seen then 2089 Implicit_Null_Statement_Seen := False; 2090 2091 else 2092 Buffered_Output.Put_Char (C); 2093 end if; 2094 2095 when others => 2096 Buffered_Output.Put_Char (C); 2097 2098 end case; 2099 2100 J := J + 1; 2101 end loop; 2102 2103 if Used /= (Subtrees_Index => True) then -- ??? 2104 Buffered_Output.Put ("???Not all used: \1", "???Image (Tr.Kind)"); 2105 end if; 2106 -- ???pragma Assert (Used = (Subtrees_Index => True)); 2107 end Interpret_Template; 2108 2109 use Alternative_Templates; 2110 2111 function Past_Call_Threshold (Actuals : Ada_Tree) return Boolean is 2112 (Natural (Actuals.Subtree_Count) > 2113 Options.Par_Associations_Threshold 2114 and then 2115 (for some Assoc of Actuals.Subtrees => 2116 Assoc.Subtrees (1).Kind /= Not_An_Element)); 2117 -- True if there are more parameter associations than the threshold, 2118 -- and at least one of them is named. 2119 2120 function Hard_Breaks_For_Call (Kind : Ada_Tree_Kind) return Ada_Template 2121 is (Ada_Template (Must_Replace 2122 (W_Str (Template_Table (Kind).all), 2123 "@ (~,@ ~)", "%(~,%~)"))); 2124 -- We use % instead of $ here, so that the indentation of these will not 2125 -- affect following comments. 2126 2127 procedure Prefix_Notation_Call 2128 (Label_Names, Callee, Actuals : Ada_Tree) 2129 is 2130 2131 -- For X.F(Y,Z), which is shorthand for F(X,Y,Z), First is X and Rest 2132 -- is Y,Z. 2133 2134 First : constant Ada_Tree := Actuals.Subtrees (1); 2135 2136 The_Rest : aliased Ada_Tree_Rec := 2137 (Kind => An_Association_List, 2138 Checks => Asis.Extensions.Empty_Check_Set, 2139 Subtree_Count => Actuals.Subtree_Count - 1, 2140 Sloc => Asis.Text.Nil_Span, 2141 Subtrees => Actuals.Subtrees (2 .. Actuals.Subtree_Count)); 2142 Rest : constant Ada_Tree := The_Rest'Unchecked_Access; 2143 Past : constant Boolean := Past_Call_Threshold (Rest); 2144 2145 begin 2146 if Label_Names.Subtree_Count /= 0 then 2147 raise Program_Error 2148 with "labeled prefix calls not yet implemented"; 2149 end if; 2150 2151 -- ???Work around possible bug in Function_Call_Parameters. Not sure 2152 -- why Callee would be A_Selected_Component. 2153 2154 if Callee.Kind /= A_Selected_Component then 2155 Subtree_To_Ada (First, Cur_Level + 1, Index_In_Parent => 1); 2156 Buffered_Output.Put ("."); 2157 end if; 2158 Subtree_To_Ada (Callee, Cur_Level + 1, Index_In_Parent => 2); 2159 Subtrees_To_Ada 2160 (Rest, 2161 Pre => 2162 (if Past 2163 then Prefix_Notation_Call_Alt_Templ_2 2164 else Prefix_Notation_Call_Alt_Templ_1), 2165 Between => (if Past then ",$" else ", "), 2166 Post => (if Past then ")]" else ")")); 2167 end Prefix_Notation_Call; 2168 2169 procedure Maybe_Blank_Line; 2170 2171 procedure Maybe_Blank_Line is 2172 Insert_Blank_Line_Before : Boolean := False; 2173 begin 2174 if not Options.Insert_Blank_Lines then 2175 return; 2176 end if; 2177 2178 if Tree.Kind = A_Compilation_Unit then 2179 Insert_Blank_Line_Before := True; 2180 end if; 2181 2182 if Tree.Kind in 2183 An_Ordinary_Type_Declaration | 2184 -- ???(if rec etc)A_Record_Type_Definition 2185 -- A_Derived_Record_Extension_Definition 2186 2187 A_Task_Type_Declaration | 2188 A_Protected_Type_Declaration | 2189 A_Single_Task_Declaration | 2190 A_Single_Protected_Declaration | 2191 A_Procedure_Body_Declaration | 2192 A_Function_Body_Declaration | 2193 A_Package_Declaration | -- ???(non lib unit) 2194 A_Package_Body_Declaration | 2195 A_Task_Body_Declaration | 2196 A_Protected_Body_Declaration | 2197 An_Entry_Body_Declaration | 2198 A_Generic_Procedure_Declaration | 2199 A_Generic_Function_Declaration | 2200 A_Generic_Package_Declaration | 2201 An_Enumeration_Type_Definition | --???(if big) 2202 A_Loop_Statement | 2203 A_While_Loop_Statement | 2204 A_For_Loop_Statement | 2205 A_Block_Statement | 2206 An_Extended_Return_Statement | 2207 An_Accept_Statement | 2208 A_Selective_Accept_Statement | 2209 A_Timed_Entry_Call_Statement | 2210 A_Conditional_Entry_Call_Statement | 2211 An_Asynchronous_Select_Statement | 2212 An_If_Path | --???look up to If_Statement, then up to list. 2213 An_Elsif_Path | 2214 An_Else_Path | 2215 A_Case_Path | 2216 A_Record_Representation_Clause 2217-- An_Exception_Handler |??? 2218 2219 then 2220 declare 2221 Parent : constant Ada_Tree := Parent_Tree; 2222 begin 2223 if Parent.Kind in Flat_List_Kinds then 2224 if Parent.Subtrees (1) /= Tree then 2225 Insert_Blank_Line_Before := True; 2226 end if; 2227 end if; 2228 end; 2229 end if; 2230 2231 if Insert_Blank_Line_Before then 2232 pragma Assert (Line_Breaks (Last (Line_Breaks)).Hard); 2233 pragma Assert 2234 (Point (Out_Buf) = 2235 Last_Position (Out_Buf) + 1); -- ???Do we need Last_Position? 2236 pragma Assert 2237 (Position (Out_Buf, Line_Breaks (Last (Line_Breaks)).Mark) = 2238 Last_Position (Out_Buf)); 2239 pragma Assert (Lookback (Out_Buf) = NL); 2240 -- There should already be a hard line break here; we're about to 2241 -- add another one. 2242 2243 Append_Line_Break 2244 (Hard => True, 2245 Affects_Comments => False, 2246 Level => 0, 2247 Kind => Tree.Kind, 2248 Template => Name_Find ("Maybe_Blank_Line")); 2249 end if; 2250 end Maybe_Blank_Line; 2251 2252 use Asis; 2253 Index : Query_Index := 1; 2254 2255 -- Procedures for formatting the various kinds of node that are not 2256 -- fully covered by Template_Table: 2257 2258 procedure Do_Accept_Statement; 2259 procedure Do_Array_Aggregate; 2260 procedure Do_Association; 2261 procedure Do_Attribute_Reference; 2262 procedure Do_Block_Statement; 2263 procedure Do_Compilation_Unit; 2264 procedure Do_Comment; 2265 procedure Do_Case_Path; 2266 procedure Do_Case_Statement; 2267 procedure Do_Component_Clause; 2268 procedure Do_Constrained_Array_Definition; -- also generic formal 2269 procedure Do_Def_Name; 2270 procedure Do_Extended_Return_Statement; 2271 procedure Do_Extension_Aggregate; 2272 procedure Do_Function_Call; 2273 procedure Do_List; 2274 procedure Do_Literal; 2275 procedure Do_Null_Statement; 2276 procedure Do_Ordinary_Type_Declaration; 2277 procedure Do_Parameter_Specification; -- also Formal_Object_Declaration 2278 procedure Do_Pragma; 2279 procedure Do_Procedure_Call_Statement; -- also Entry_Call_Statement 2280 procedure Do_Qualified_Expression; 2281 procedure Do_Record_Aggregate; 2282 procedure Do_Single_Task_Declaration; 2283 procedure Do_Subp_Decl -- subprograms and the like 2284 (Is_Function, Is_Body : Boolean; 2285 Params_Query : Structural_Queries); 2286 procedure Do_Subtype_Indication; 2287 procedure Do_Task_Type_Declaration; 2288 procedure Do_Usage_Name; 2289 2290 procedure Do_Others; -- anything not listed above 2291 2292 procedure Do_Accept_Statement is 2293 begin 2294 -- If there are no statements or exception handlers, use short form 2295 2296 if Tree.Subtrees (5).Subtree_Count = 0 2297 and then Tree.Subtrees (6).Subtree_Count = 0 2298 then 2299 Interpret_Template (Accept_Statement_Alt_Templ); 2300 else 2301 Interpret_Template; 2302 end if; 2303 end Do_Accept_Statement; 2304 2305 procedure Do_Array_Aggregate is 2306 begin 2307 if Parent_Tree.Kind = An_Enumeration_Representation_Clause then 2308 Interpret_Template ("?[@(~,@ ~)]~"); 2309 else 2310 Interpret_Template; 2311 end if; 2312 end Do_Array_Aggregate; 2313 2314 procedure Do_Association is 2315 -- Some have a single name before the "=>", and some have a list 2316 -- separated by "|". Single_Name_Only is True in the former case. 2317 -- Positional_Notation is True if there are no names (no "=>"). 2318 -- Single_Name is True if there is a single name before "=>", 2319 -- regardless of whether a list is allowed. 2320 Single_Name_Only : constant Boolean := 2321 (case Tree.Kind is 2322 when A_Pragma_Argument_Association | 2323 A_Parameter_Association | 2324 A_Generic_Association => 2325 True, 2326 when A_Discriminant_Association | 2327 A_Record_Component_Association | 2328 An_Array_Component_Association => 2329 False, 2330 when others => False); -- Can't happen 2331 Positional_Notation : constant Boolean := 2332 (if Single_Name_Only then Tree.Subtrees (1).Kind = Not_An_Element 2333 else Tree.Subtrees (1).Subtree_Count = 0 -- list length 0? 2334 ); 2335 begin 2336 if Positional_Notation then 2337 Interpret_Template ("?~~~!"); 2338 -- The "?~~~" generates nothing. 2339 2340 else 2341 declare 2342 Single_Name : constant Boolean := 2343 Single_Name_Only or else Tree.Subtrees (1).Subtree_Count = 1; 2344 begin 2345 -- This is needed because the "[]" is not properly nested with 2346 -- the "?~~~". 2347 if Single_Name then 2348 Interpret_Template ("?~~ ^=>[@ ~!]"); 2349 else 2350 Interpret_Template ("?~ ^|@ ~ ^=>[@ ~!]"); 2351 end if; 2352 end; 2353 end if; 2354 end Do_Association; 2355 2356 procedure Do_Attribute_Reference is 2357 Attribute_Designator_Id : constant String := 2358 To_Lower (Get_Name_String (Tree.Subtrees (2).Ref_Name)); 2359 begin 2360 -- If the Attribute_Designator_Identifier is "Update", then we need 2361 -- to avoid generating an extra pair of parentheses, because ASIS 2362 -- represents X'Update(X => Y) as an attribute reference whose 2363 -- Attribute_Designator_Expressions is a list containing the 2364 -- aggregate (X => Y), so it would otherwise come out as 2365 -- X'Update((X => Y)). 2366 2367 if Attribute_Designator_Id = "update" then 2368 pragma Assert (Tree.Kind = An_Implementation_Defined_Attribute); 2369 Interpret_Template ("!'[@!? @~, ~~]"); 2370 else 2371 Interpret_Template; 2372 end if; 2373 end Do_Attribute_Reference; 2374 2375 procedure Do_Block_Statement is 2376 begin 2377 -- If Block_Declarative_Items is empty, leave off the "declare" 2378 2379 if Tree.Subtrees (3).Subtree_Count = 0 then 2380 Interpret_Template (Block_Statement_Alt_Templ_1); 2381 else 2382 Interpret_Template (Block_Statement_Alt_Templ_2); 2383 end if; 2384 end Do_Block_Statement; 2385 2386 use Buffered_Output; 2387 2388 procedure Do_Compilation_Unit is 2389 begin 2390-- Put ("-- \1 = \2", "Unit_Kind", Capitalize (Tree.Unit_Kind'Img)); 2391-- Interpret_Template ("$", Subtrees => Empty_Tree_Array); 2392-- Put 2393-- ("-- \1 = \2", 2394-- "Unit_Class", 2395-- Capitalize (Tree.Unit_Class'Img)); 2396-- Interpret_Template ("$", Subtrees => Empty_Tree_Array); 2397-- Put 2398-- ("-- \1 = \2", 2399-- "Unit_Origin", 2400-- Capitalize (Tree.Unit_Origin'Img)); 2401-- Interpret_Template ("$", Subtrees => Empty_Tree_Array); 2402-- Interpret_Template ("$", Subtrees => Empty_Tree_Array); 2403 Subtrees_To_Ada 2404 (Tree.Subtrees (1), 2405 Pre => "", 2406 Between => ";$", 2407 Post => ";$$"); 2408 -- If it's a subunit, we need "separate (Parent.Name)" 2409 2410 if Tree.Unit_Kind in A_Subunit then 2411 declare 2412 N : constant W_Str := Get_Name_String (Tree.Unit_Full_Name); 2413 Last : Positive := N'Last; 2414 2415 begin 2416 -- Determine parent name by searching for the last '.' 2417 2418 while N (Last) /= '.' loop 2419 Last := Last - 1; 2420 end loop; 2421 Last := Last - 1; 2422 2423 Put 2424 ("separate\1(\2)", 2425 (if Options.RM_Style_Spacing then "" else " "), 2426 N (1 .. Last)); 2427 Interpret_Template ("$", Subtrees => Empty_Tree_Array); 2428 end; 2429 end if; 2430 2431 case Tree.Unit_Class is 2432 when A_Private_Declaration => 2433 Put ("private "); 2434 2435 when A_Public_Declaration | 2436 A_Public_Body | 2437 A_Public_Declaration_And_Body | 2438 A_Private_Body | 2439 A_Separate_Body => 2440 null; 2441 2442 when Not_A_Class => 2443 raise Program_Error; 2444 end case; 2445 2446 Subtree_To_Ada 2447 (Tree.Subtrees (2), 2448 Cur_Level + 1, 2449 Index_In_Parent => 2); 2450 Put (";"); 2451 Interpret_Template ("$", Subtrees => Empty_Tree_Array); 2452 Subtrees_To_Ada 2453 (Tree.Subtrees (3), 2454 Pre => "", 2455 Between => ";$", 2456 Post => ";$"); 2457 end Do_Compilation_Unit; 2458 2459 procedure Do_Comment is 2460 S : constant W_Str := Get_Name_String (Tree.Text); 2461 pragma Assert (S in Scanner.Gen_Plus | Scanner.Gen_Minus); 2462 -- These are the only ones used, for now. 2463 Gen_Indent : constant Natural := 2464 Good_Column (Options.Max_Line_Length - Cur_Indentation - S'Length); 2465 pragma Assert ((Gen_Indent mod Options.PP_Indentation) = 0); 2466 begin 2467 pragma Assert (Check_Whitespace); 2468 Check_Whitespace := False; 2469 Interpret_Template 2470 ((1 .. Gen_Indent => ' '), 2471 Subtrees => Empty_Tree_Array); 2472 Interpret_Template 2473 (Ada_Template (S), 2474 Subtrees => Empty_Tree_Array); 2475 Check_Whitespace := True; 2476 Interpret_Template ("$", Subtrees => Empty_Tree_Array); 2477 if S = Scanner.Gen_Minus then 2478 Interpret_Template ("$", Subtrees => Empty_Tree_Array); 2479 end if; 2480 end Do_Comment; 2481 2482 procedure Do_Case_Path is 2483 Stms : constant Ada_Tree := Tree.Subtrees (2); 2484 2485 begin 2486 -- If the statement list is a single block statement that starts on 2487 -- the same line as the "when", then we assume the user wants to keep 2488 -- it that way. For example: 2489 -- 2490 -- when Upper_Case => Upper_Case_Case : begin 2491 2492 if Stms.Subtree_Count = 1 2493 and then Stms.Subtrees (1).Kind = A_Block_Statement 2494 and then Stms.Subtrees (1).Sloc.First_Line = Tree.Sloc.First_Line 2495 then 2496 Interpret_Template ("when ?[@~ |@ ~]~ => " & "?~~;$~"); 2497 2498 else 2499 Interpret_Template; 2500 end if; 2501 end Do_Case_Path; 2502 2503 procedure Do_Case_Statement is 2504 -- If all the "when"s appear in the same column as "case", then we 2505 -- assume that's what the user intended, and avoid indenting the 2506 -- "when"s. ???But the old gnatpp doesn't do that, so disable it 2507 -- for now. 2508 2509 Case_Col : constant Positive := Tree.Sloc.First_Column; 2510 -- Column in which "case" appears 2511 Whens_Col : Positive := 2512 Tree.Subtrees (3).Subtrees (1).Sloc.First_Column; 2513 -- Column in which all the "when"s appear, if they're all the same 2514 2515 begin 2516 for W of Tree.Subtrees (3).Subtrees loop 2517 if W.Sloc.First_Column /= Whens_Col then 2518 Whens_Col := Positive'Last; -- not all the same 2519 end if; 2520 end loop; 2521 2522 Whens_Col := Positive'Last; -- ???disable for now 2523 if Case_Col = Whens_Col and then Case_Col /= 1 then 2524 Interpret_Template (Labels & "case[@ !]@ is$" & "!" & "end case"); 2525 2526 else 2527 Interpret_Template; 2528 end if; 2529 end Do_Case_Statement; 2530 2531 procedure Do_Component_Clause is 2532 -- We use "&" to right-justify the three expressions X, Y, and Z in 2533 -- "at X range Y .. Z". We need to lift the Y and Z expressions up so 2534 -- they appear at the same level as X, so the Tree and Parent of the 2535 -- "&" will match that of the following "^". The Index_In_Lines must 2536 -- also match. The end result will be something like: 2537 -- Thing at 0 range 0 .. 127; 2538 -- Thing_2 at 0 range 128 .. 1023; 2539 2540 pragma Assert 2541 (Tree.Subtrees (3).Kind = A_Discrete_Simple_Expression_Range); 2542 Subtrees : constant Ada_Tree_Array := 2543 Tree.Subtrees (1 .. 2) & Tree.Subtrees (3).Subtrees; 2544 pragma Assert (Subtrees'Last = 4); 2545 Cc_Templ : constant Ada_Template := 2546 "! ^at &2! ^2range [@&3! ^3..[@ &4!^4]]"; 2547 begin 2548 Interpret_Template (Cc_Templ, Subtrees); 2549 end Do_Component_Clause; 2550 2551 procedure Do_Constrained_Array_Definition is 2552 begin 2553 case Tree.Subtrees (1).Subtrees (1).Kind is 2554 when A_Range_Attribute_Reference | A_Simple_Expression_Range => 2555 Interpret_Template (Constrained_Array_Definition_Alt_Templ_1); 2556 when others => 2557 Interpret_Template (Constrained_Array_Definition_Alt_Templ_2); 2558 end case; 2559 end Do_Constrained_Array_Definition; 2560 2561 procedure Do_Def_Name is 2562 Kind : Ada_Tree_Kind; 2563 begin 2564 if Tree.Kind = A_Defining_Expanded_Name then 2565 Interpret_Template ("![@.!]"); 2566 else 2567 -- Odd special case for task and protected bodies: If we have 2568 -- "task body T is...", what casing rule should be used for "T"? 2569 -- If the spec is a task type declaration, we should use the rule 2570 -- for types, but if it's a single task declaration, we should use 2571 -- the rule for other names. This is only relevant if 2572 -- PP_Type_Casing /= PP_Name_Casing, which is hardly ever the 2573 -- case. 2574 2575 if Decl_Of_Def (Symtab, Tree).Kind in 2576 A_Task_Body_Declaration | A_Protected_Body_Declaration 2577 then 2578 Kind := Decl_Of_Def_Kind (Symtab, Spec_Of_Body (Symtab, Tree)); 2579 else 2580 Kind := Decl_Of_Def_Kind (Symtab, Tree); 2581 end if; 2582 2583 Put ("\1", 2584 Id_With_Casing (Tree.Def_Name, Kind, Is_Predef => False)); 2585 end if; 2586 end Do_Def_Name; 2587 2588 procedure Do_Extended_Return_Statement is 2589 begin 2590 -- If there are no statements or exception handlers, use short form 2591 2592 if Tree.Subtrees (3).Subtree_Count = 0 2593 and then Tree.Subtrees (4).Subtree_Count = 0 2594 then 2595 Interpret_Template (Extended_Return_Statement_Alt_Templ); 2596 else 2597 Interpret_Template; 2598 end if; 2599 end Do_Extended_Return_Statement; 2600 2601 procedure Do_Extension_Aggregate is 2602 begin 2603 if Tree.Subtrees (2).Subtree_Count = 0 then 2604 Interpret_Template ("@(! with @" & "null record)!"); 2605 2606 else 2607 Interpret_Template; 2608 end if; 2609 end Do_Extension_Aggregate; 2610 2611 type Precedence_Level is range 1 .. 7; 2612 function Precedence (Expr : Ada_Tree) return Precedence_Level; 2613 2614 function Precedence (Expr : Ada_Tree) return Precedence_Level is 2615 begin 2616 case Expr.Kind is 2617-- ???Don't treat membership tests as operators, for now 2618-- when An_In_Membership_Test | A_Not_In_Membership_Test => 2619-- return 1; 2620 when An_And_Then_Short_Circuit | An_Or_Else_Short_Circuit => 2621 return 2; 2622 2623 when A_Function_Call => 2624 -- Binary operator using operator notation 2625 2626 if Expr.Subtrees (3).Kind /= An_Is_Prefix_Call 2627 and then Expr.Subtrees (2).Subtree_Count /= 1 2628 then 2629 pragma Assert 2630 (Expr.Subtrees (4).Kind /= An_Is_Prefix_Notation); 2631 pragma Assert (Expr.Subtrees (2).Subtree_Count = 2); 2632 case Expr.Subtrees (1).Kind is 2633 when An_And_Operator | An_Or_Operator | An_Xor_Operator => 2634 return 2; -- same as 'and then' and 'or else' 2635 2636 when An_Equal_Operator | 2637 A_Not_Equal_Operator | 2638 A_Less_Than_Operator | 2639 A_Less_Than_Or_Equal_Operator | 2640 A_Greater_Than_Operator | 2641 A_Greater_Than_Or_Equal_Operator => 2642 return 3; 2643 2644 when A_Plus_Operator | 2645 A_Minus_Operator | 2646 A_Concatenate_Operator => 2647 return 4; 2648 2649 when A_Multiply_Operator | 2650 A_Divide_Operator | 2651 A_Mod_Operator | 2652 A_Rem_Operator => 2653 return 5; 2654 2655 when An_Exponentiate_Operator => 2656 return 6; 2657 2658 when others => 2659 raise Program_Error; 2660 end case; 2661 2662 -- Unary operator or normal function-call notation 2663 2664 else 2665 return 7; 2666 end if; 2667 2668 -- Assume anything else is a primary (highest precedence) 2669 2670 when others => 2671 return 7; 2672 end case; 2673 end Precedence; 2674 2675 function Get_Arg (Expr : Ada_Tree; N : Query_Index) return Ada_Tree; 2676 2677 function Get_Arg (Expr : Ada_Tree; N : Query_Index) return Ada_Tree is 2678 Assoc : constant Ada_Tree := Expr.Subtrees (2).Subtrees (N); 2679 pragma Assert (Assoc.Kind = A_Parameter_Association); 2680 function Is_Positional 2681 (Assoc : Ada_Tree) 2682 return Boolean is 2683 (Assoc.Subtrees (1).Kind = Not_An_Element); 2684 pragma Assert (Is_Positional (Assoc)); 2685 2686 begin 2687 return Assoc.Subtrees (2); 2688 end Get_Arg; 2689 2690 function Make_Op (Expr : Ada_Tree) return Ada_Tree; 2691 -- Create operator node. This is a separate function to reduce stack 2692 -- usage (for example long strings of "&" can cause deep recursion). 2693 2694 function Make_Op (Expr : Ada_Tree) return Ada_Tree is 2695 begin 2696 return Result : constant Ada_Tree := Make (An_Identifier) do 2697 case Expr.Kind is 2698 when A_Function_Call => 2699 declare 2700 Q_Op_Sym : constant String := 2701 To_Lower (Get_Name_String (Expr.Subtrees (1).Ref_Name)); 2702 Un_Q : constant String (1 .. Q_Op_Sym'Length - 2) := 2703 Q_Op_Sym (2 .. Q_Op_Sym'Last - 1); 2704 -- Strip off quotes 2705 begin 2706 Result.Ref := Name_Find (Un_Q); 2707 end; 2708 2709 when An_And_Then_Short_Circuit => 2710 Result.Ref := Name_And_Then; 2711 2712 when An_Or_Else_Short_Circuit => 2713 Result.Ref := Name_Or_Else; 2714 2715 when others => 2716 raise Program_Error; 2717 end case; 2718 Result.Ref_Name := Result.Ref; 2719 end return; 2720 end Make_Op; 2721 2722 procedure Do_Unary_Operator (Expr : Ada_Tree); 2723 2724 procedure Do_Binary_Operator 2725 (Expr : Ada_Tree; 2726 Is_Right : Boolean; 2727 Cur_Level : Nesting_Level); 2728 -- Also handles some things that look like operators, like "and then". 2729 -- Is_Right is True if Expr is the right-hand argument of an outer 2730 -- binary operator. Otherwise (Expr is the left-hand argument, or Expr's 2731 -- parent is something else, like a parenthesized expression), Is_Right 2732 -- is False. 2733 2734 function Is_Bin_Op (Expr : Ada_Tree) return Boolean; 2735 2736 procedure Do_Unary_Operator (Expr : Ada_Tree) is 2737 Op : constant Ada_Tree := Make_Op (Expr); 2738 Arg1 : constant Ada_Tree := Get_Arg (Expr, 1); 2739 begin 2740 -- First we have a special case for the Depends aspect specification. 2741 -- We want to pretend that "=>+" is an operator, so we print: 2742 -- "Depends => (A =>+ B)" instead of "Depends => (A => +B)". 2743 -- We don't bother with this for pragma Depends, because that's 2744 -- mainly for the compiler's implementation of the aspect, so we 2745 -- don't expect it to be used much. 2746 2747 if Ancestor_Tree (4).Kind = An_Aspect_Specification 2748 and then Ancestor_Tree (4).Subtrees (1).Ref_Name = Name_Depends 2749 then 2750 pragma Assert (Expr.Subtrees (1).Kind = A_Unary_Plus_Operator); 2751 pragma Assert 2752 (Slice (Out_Buf, Point (Out_Buf) - 4, Point (Out_Buf) - 1) 2753 = " => "); 2754 declare 2755 Subtrees : constant Ada_Tree_Array := (1 => Arg1); 2756 begin 2757 Replace_Previous (Out_Buf, '+'); 2758 Interpret_Template (" !", Subtrees); 2759 end; 2760 2761 -- No special "Depends" case. Put a space after the operator, 2762 -- except for "+" and "-". 2763 2764 else 2765 declare 2766 Subtrees : constant Ada_Tree_Array := (Op, Arg1); 2767 begin 2768 if Expr.Subtrees (1).Kind in 2769 A_Unary_Plus_Operator | A_Unary_Minus_Operator 2770 then 2771 Interpret_Template ("!!", Subtrees); 2772 else 2773 Interpret_Template ("! !", Subtrees); 2774 end if; 2775 end; 2776 end if; 2777 end Do_Unary_Operator; 2778 2779 function Is_Bin_Op (Expr : Ada_Tree) return Boolean is 2780 begin 2781 case Expr.Kind is 2782 when A_Function_Call => 2783 return Expr.Subtrees (3).Kind /= An_Is_Prefix_Call 2784 and then Expr.Subtrees (2).Subtree_Count = 2; 2785 2786 when An_And_Then_Short_Circuit | An_Or_Else_Short_Circuit => 2787 return True; 2788 2789 when others => 2790 return False; 2791 end case; 2792 end Is_Bin_Op; 2793 2794 procedure Do_Binary_Operator 2795 (Expr : Ada_Tree; 2796 Is_Right : Boolean; 2797 Cur_Level : Nesting_Level) 2798 is 2799 Is_Short_C : constant Boolean := 2800 Expr.Kind in An_And_Then_Short_Circuit | An_Or_Else_Short_Circuit; 2801 Is_Expon : constant Boolean := -- True for "**" 2802 (Expr.Kind in A_Function_Call 2803 and then Expr.Subtrees (1).Kind = An_Exponentiate_Operator); 2804 Op : constant Ada_Tree := Make_Op (Expr); 2805 Arg1, Arg2 : Ada_Tree; 2806 Arg1_Higher : Boolean; -- Arg1 is higher precedence than Expr 2807 2808 -- Calculate template fragments for the args (Arg1/2_T), that indent 2809 -- if the arg is a higher precedence binary operator than the whole 2810 -- expression. 2811 2812 -- Start of processing for Do_Binary_Operator 2813 2814 begin 2815 if Is_Short_C then 2816 Arg1 := Expr.Subtrees (1); 2817 Arg2 := Expr.Subtrees (2); 2818 2819 else -- function call 2820 Arg1 := Get_Arg (Expr, 1); 2821 Arg2 := Get_Arg (Expr, 2); 2822 end if; 2823 2824 -- The arguments can't have lower precedence than the expression as 2825 -- a whole; that's what precedence means -- you need parens to put 2826 -- a "+" inside a "*". The right-hand argument can't have equal 2827 -- precedence, because Ada has no right-associative binary operators. 2828 2829 pragma Assert (Precedence (Arg1) >= Precedence (Expr)); 2830 pragma Assert (Precedence (Arg2) > Precedence (Expr)); 2831 2832 Arg1_Higher := Precedence (Arg1) > Precedence (Expr); 2833 2834 -- The recursive calls to Do_Binary_Operator below bypass the 2835 -- normal recursion via Subtree_To_Ada, so we need to pass along the 2836 -- Cur_Level to Interpret_Template. When we reach something that's 2837 -- not a binary op, we switch back to the normal recursion via 2838 -- Interpret_Template on the Arg. We split lines after the 2839 -- operator symbol, as in: 2840 -- Some_Long_Thing + 2841 -- Some_Other_Long_Thing 2842 -- except in the case of short circuits: 2843 -- Some_Long_Thing 2844 -- and then Some_Other_Long_Thing 2845 -- The --split-line-before-op switch causes all operators to be 2846 -- treated like short circuits in this regard. 2847 -- 2848 -- All operators are surrounded by blanks, except for "**": 2849 -- Max : constant := 2**31 - 1; 2850 2851 if Is_Bin_Op (Arg1) then 2852 if Is_Right and then Arg1_Higher then 2853 Interpret_Template ("[@", Empty_Tree_Array, Cur_Level); 2854 end if; 2855 Do_Binary_Operator 2856 (Arg1, 2857 Is_Right => Is_Right, 2858 Cur_Level => Cur_Level + (if Arg1_Higher then 1 else 0)); 2859 if Is_Right and then Arg1_Higher then 2860 Interpret_Template ("]", Empty_Tree_Array, Cur_Level); 2861 end if; 2862 2863 else 2864 Interpret_Template 2865 ("!", 2866 Subtrees => (1 => Arg1), 2867 Cur_Level => Cur_Level); 2868 end if; 2869 2870 if Is_Short_C or Options.Split_Line_Before_Op then 2871 Interpret_Template ("@", Empty_Tree_Array, Cur_Level); 2872 end if; 2873 Interpret_Template 2874 ((if Is_Expon then "!" else " ! "), -- no blanks for "**" 2875 Subtrees => (1 => Op), 2876 Cur_Level => Cur_Level); 2877 if not (Is_Short_C or Options.Split_Line_Before_Op) then 2878 Interpret_Template ("@", Empty_Tree_Array, Cur_Level); 2879 end if; 2880 2881 if Is_Bin_Op (Arg2) then 2882 Interpret_Template ("[@", Empty_Tree_Array, Cur_Level + 1); 2883 Do_Binary_Operator 2884 (Arg2, 2885 Is_Right => True, 2886 Cur_Level => Cur_Level + 1); 2887 Interpret_Template ("]", Empty_Tree_Array, Cur_Level + 1); 2888 2889 else 2890 Interpret_Template 2891 ("!", 2892 Subtrees => (1 => Arg2), 2893 Cur_Level => Cur_Level + 1); 2894 end if; 2895 end Do_Binary_Operator; 2896 2897 procedure Do_Function_Call is 2898 begin 2899 -- Note: Is_Prefix_Notation is for Object.Operation(...) notation, 2900 -- whereas Is_Prefix_Call is for anything that's not an operator 2901 -- notation call. Thus Is_Prefix_Call is True for "&"(X, Y), and 2902 -- False for X&Y. 2903 2904 if Tree.Subtrees (4).Kind = An_Is_Prefix_Notation then 2905 pragma Assert (Tree.Subtrees (3).Kind = An_Is_Prefix_Call); 2906 Prefix_Notation_Call 2907 (Label_Names => Empty (A_Defining_Name_List), 2908 Callee => Tree.Subtrees (1), 2909 Actuals => Tree.Subtrees (2)); 2910 2911 -- Determine whether to use operator notation, like X+Y instead of 2912 -- "+"(X,Y). We can use operator notation if it's an operator call, 2913 -- and the argument(s) are in positional notation (not named). ???We 2914 -- must use operator notation for "/=", to work around compiler bug. 2915 -- In some cases, "/="(X, Y) doesn't work (on access types?), so we 2916 -- generate (X /= Y) instead. 2917 2918 -- We don't want to translate "&" (STRING'("AB"), STRING'("CDEF"))(5) 2919 -- /= CHARACTER'('E') into ((STRING'("AB") & STRING'("CDEF"))(5) 2920 -- /= CHARACTER'('E')) because an operator-notation call is not a 2921 -- name, and therefore cannot be used as the prefix of an indexed 2922 -- component. 2923 2924 elsif Tree.Subtrees (3).Kind = An_Is_Prefix_Call then 2925 if Past_Call_Threshold (Tree.Subtrees (2)) then 2926 Interpret_Template (Hard_Breaks_For_Call (Tree.Kind)); 2927 else 2928 Interpret_Template; -- normal "F (X)" notation 2929 end if; 2930 2931 -- Operator notation: 2932 2933 else 2934 pragma Assert 2935 (Tree.Subtrees (1).Kind in Flat_Operator_Symbol_Kinds); 2936 pragma Assert (Tree.Subtrees (2).Subtree_Count in 1 .. 2); 2937 2938 -- Unary operator 2939 2940 if Tree.Subtrees (2).Subtree_Count = 1 then 2941 Do_Unary_Operator (Tree); 2942 2943 -- Binary operator 2944 2945 else 2946 Do_Binary_Operator 2947 (Tree, 2948 Is_Right => False, 2949 Cur_Level => Cur_Level); 2950 end if; 2951 end if; 2952 end Do_Function_Call; 2953 2954 procedure Do_List is 2955 -- This formats the list elements with a hard line break in between. It 2956 -- is called when a "!" in a template refers to a list subtree. If you 2957 -- don't want this formatting, you must use "?" instead of "!". See, 2958 -- for example, the template for An_If_Expression, where we want soft 2959 -- line breaks in between paths. Sometimes this is called for a list 2960 -- of one element, in which case the Between doesn't matter (e.g. 2961 -- Defining_Name_List, where there is only one). 2962 begin 2963 Subtrees_To_Ada (Tree, Pre => "", Between => "$", Post => ""); 2964 end Do_List; 2965 2966 procedure Do_Literal is 2967 S : constant W_Str := Get_Name_String (Tree.Lit_Val); 2968 2969 function Last_Digit 2970 (First : Positive; Based : Boolean) return Positive; 2971 -- Returns the index of the last digit in S starting at 2972 -- First 2973 2974 procedure Put_With_Underscores 2975 (Part : W_Str; Grouping : Positive; Int : Boolean); 2976 -- Part is the integer part (before the '.', if any) or the 2977 -- fractional part (after the '.'). Int is True for the integer part. 2978 -- For example, for "16#12345.67890#e2", this will be called for Part 2979 -- = "12345" and Int = True, then for Part = "67890" and Int = False. 2980 -- We want to get "16#1_2345.6789_0#e2" (assuming Grouping = 4). 2981 2982 procedure Put_With_Underscores 2983 (Part : W_Str; Grouping : Positive; Int : Boolean) 2984 is 2985 Count : Natural := (if Int then Part'Length else 0); 2986 Inc : constant Integer := (if Int then -1 else 1); 2987 -- For the integer part, we count downward from the Length; for 2988 -- the fractional part, we count upward from zero. If Count is 2989 -- divisible by Grouping, the next character should be preceded by 2990 -- an underscore, except there is never a leading underscore. 2991 begin 2992 for J in Part'Range loop 2993 if J /= Part'First and then Count mod Grouping = 0 then 2994 Put_Char ('_'); 2995 end if; 2996 Put_Char (Part (J)); 2997 Count := Count + Inc; 2998 end loop; 2999 end Put_With_Underscores; 3000 3001 function Last_Digit 3002 (First : Positive; Based : Boolean) return Positive 3003 is 3004 begin 3005 for J in First .. S'Last loop 3006 if Is_Digit (S (J)) then 3007 null; 3008 elsif Based and then Is_Letter (S (J)) then 3009 null; 3010 else 3011 return J - 1; 3012 end if; 3013 end loop; 3014 return S'Last; 3015 end Last_Digit; 3016 3017 -- Start of processing for Do_Literal 3018 3019 begin 3020 pragma Assert (Check_Whitespace); 3021 Check_Whitespace := False; 3022 3023 -- In most cases, we simply print out S. All of the complicated code 3024 -- below is for the --decimal-grouping and --based-grouping 3025 -- switches. If --decimal-grouping was used to specify a nonzero 3026 -- value, and we have a numeric literal without a base, and that 3027 -- literal contains no underscores, we insert underscores. Similarly 3028 -- for --based-grouping. A based literal is one containing "#" or 3029 -- ":"; note that "10#...#" is considered based, not decimal. 3030 3031 case Tree.Kind is 3032 when A_String_Literal => 3033 Put ("\1", S); 3034 3035 when An_Integer_Literal | A_Real_Literal => 3036 if Options.Decimal_Grouping = 0 3037 and then Options.Based_Grouping = 0 3038 then 3039 Put ("\1", S); 3040 else 3041 declare 3042 Sharp : constant Natural := 3043 (if Find (S, "#") /= 0 then Find (S, "#") 3044 else Find (S, ":")); 3045 Underscore : constant Natural := Find (S, "_"); 3046 3047 Grouping : constant Natural := 3048 (if Underscore /= 0 then 0 3049 elsif Sharp = 0 then Options.Decimal_Grouping 3050 else Options.Based_Grouping); 3051 3052 Int_First, Int_Last, Frac_First, Frac_Last : Natural; 3053 -- These point to the slices of the literal that should 3054 -- have underscores inserted. For example: 3055 -- For 12345 or 12345E6: 3056 -- S (Int_First .. Int_Last) = "12345" 3057 -- For 12345.6789 or 16#12345.6789#E-3: 3058 -- S (Int_First .. Int_Last) = "12345", and 3059 -- S (Frac_First .. Frac_Last) = "6789" 3060 begin 3061 if Grouping = 0 then 3062 Put ("\1", S); 3063 else 3064 Int_First := Sharp + 1; 3065 Int_Last := 3066 Last_Digit (Int_First, Based => Sharp /= 0); 3067 Put ("\1", S (1 .. Sharp)); 3068 Put_With_Underscores 3069 (S (Int_First .. Int_Last), 3070 Grouping, Int => True); 3071 if Tree.Kind = An_Integer_Literal then 3072 Put ("\1", S (Int_Last + 1 .. S'Last)); 3073 else 3074 Frac_First := Int_Last + 2; -- skip '.' 3075 Frac_Last := Last_Digit 3076 (Frac_First, Based => Sharp /= 0); 3077 pragma Assert 3078 (S (Int_Last + 1 .. Frac_First - 1) = "."); 3079 Put_Char ('.'); 3080 Put_With_Underscores 3081 (S (Frac_First .. Frac_Last), 3082 Grouping, Int => False); 3083 Put ("\1", S (Frac_Last + 1 .. S'Last)); 3084 end if; 3085 end if; 3086 end; 3087 end if; 3088 3089 when others => raise Program_Error; 3090 end case; 3091 3092 Check_Whitespace := True; 3093 end Do_Literal; 3094 3095 procedure Do_Null_Statement is 3096 begin 3097 -- If a label comes at the end of a statement list, as allowed in Ada 3098 -- 2012, ASIS inserts an extra implicit null statement to hang the 3099 -- label off of. We don't want to print that statement, because 3100 -- it wasn't in the source code. We can detect such implicit null 3101 -- statements by checking for a nil Sloc. We also need to suppress 3102 -- the ";" that comes after the implicit 'null', which is the purpose 3103 -- of Implicit_Null_Statement_Seen. We set that flag True here, and 3104 -- the very next template character seen by Interpret_Template will 3105 -- be that ";", so Interpret_Template will suppress the ";" and reset 3106 -- Implicit_Null_Statement_Seen to False. 3107 3108 if Tree.Subtrees (1).Subtree_Count /= 0 3109 and then Asis.Text.Is_Nil (Tree.Sloc) 3110 then 3111 Interpret_Template (Labels); 3112 Implicit_Null_Statement_Seen := True; 3113 3114 else 3115 Interpret_Template; 3116 end if; 3117 end Do_Null_Statement; 3118 3119 procedure Do_Ordinary_Type_Declaration is 3120 begin 3121 if Tree.Subtrees (3).Kind in 3122 A_Derived_Record_Extension_Definition | 3123 A_Record_Type_Definition | 3124 A_Tagged_Record_Type_Definition | 3125 An_Access_To_Procedure | 3126 An_Access_To_Protected_Procedure | 3127 An_Access_To_Function | 3128 An_Access_To_Protected_Function 3129 then 3130 Interpret_Template ("type !! is !" & Aspects); 3131 -- Record_Definition or other subtree will take care of new lines. 3132 -- ???It might be better to have a *weak* newline, though. 3133 else 3134 Interpret_Template; 3135 end if; 3136 end Do_Ordinary_Type_Declaration; 3137 3138 procedure Do_Others is 3139 begin 3140 if Template_Table (Tree.Kind) = null then 3141-- Put ("null templ:\1", Image (Tree.Kind)); 3142 Subtrees_To_Ada (Tree, Pre => "{", Between => "|", Post => "}"); 3143 raise Program_Error; 3144 else 3145 Interpret_Template; 3146 end if; 3147 end Do_Others; 3148 3149 procedure Do_Parameter_Specification is 3150 begin 3151 Subtrees_To_Ada 3152 (Tree.Subtrees (Index), 3153 Pre => "", 3154 Between => ",@ ", 3155 Post => ""); 3156 Interpret_Template 3157 (Parameter_Specification_Alt_Templ, 3158 Subtrees => Empty_Tree_Array); 3159 3160 case Tree.Kind is 3161 when A_Parameter_Specification => 3162 Index := Index + 1; 3163 3164 if Tree.Subtrees (Index).Kind /= 3165 Not_An_Element 3166 then -- "aliased" 3167 Subtree_To_Ada (Tree.Subtrees (Index), Cur_Level + 1, Index); 3168 Put (" "); 3169 end if; 3170 3171 when A_Formal_Object_Declaration => 3172 null; -- A_Formal_Object_Declaration doesn't have "aliased" 3173 3174 when others => 3175 raise Program_Error; 3176 end case; 3177 3178 if Tree.Mode in An_In_Mode | An_In_Out_Mode then 3179 Put ("in "); 3180 end if; 3181 Interpret_Template ("^2", Subtrees => Empty_Tree_Array); 3182 if Tree.Mode in An_Out_Mode | An_In_Out_Mode then 3183 Put ("out "); 3184 end if; 3185 Interpret_Template ("^3", Subtrees => Empty_Tree_Array); 3186 3187 Index := Index + 1; 3188 3189 if Tree.Subtrees (Index).Kind /= Not_An_Element then -- "not null" 3190 Subtree_To_Ada (Tree.Subtrees (Index), Cur_Level + 1, Index); 3191 Put (" "); 3192 end if; 3193 3194 Index := Index + 1; 3195 Subtree_To_Ada (Tree.Subtrees (Index), Cur_Level + 1, Index); 3196 3197 Index := Index + 1; 3198 if Tree.Subtrees (Index).Kind /= Not_An_Element then 3199 Interpret_Template 3200 (" ^4:=[@ !]", 3201 Subtrees => (1 => Tree.Subtrees (Index))); 3202 end if; 3203 end Do_Parameter_Specification; 3204 3205 procedure Do_Pragma is 3206 begin 3207 Put 3208 ("pragma \1", 3209 Id_With_Casing (Tree.Pragma_Name, Tree.Kind, Is_Predef => False)); 3210 Interpret_Template (Pragma_Alt_Templ); 3211 end Do_Pragma; 3212 3213 procedure Do_Procedure_Call_Statement is 3214 begin 3215 if Tree.Kind = A_Procedure_Call_Statement 3216 and then Tree.Subtrees (4).Kind = An_Is_Prefix_Notation 3217 then 3218 Prefix_Notation_Call 3219 (Label_Names => Tree.Subtrees (1), 3220 Callee => Tree.Subtrees (2), 3221 Actuals => Tree.Subtrees (3)); 3222 elsif Past_Call_Threshold (Tree.Subtrees (3)) then 3223 Interpret_Template (Hard_Breaks_For_Call (Tree.Kind)); 3224 else 3225 Interpret_Template; 3226 end if; 3227 end Do_Procedure_Call_Statement; 3228 3229 procedure Do_Qualified_Expression is 3230 begin 3231 if Tree.Subtrees (2).Kind in 3232 A_Record_Aggregate | 3233 An_Extension_Aggregate | 3234 A_Positional_Array_Aggregate | 3235 A_Named_Array_Aggregate 3236 then 3237 Interpret_Template ("!'[@!]"); 3238 -- If the thing after the ' is an aggregate, we leave out the 3239 -- parentheses here, because the aggregate will insert them. We 3240 -- want T'(X, Y, Z), not T'((X, Y, Z)). 3241 3242 else 3243 Interpret_Template; 3244 end if; 3245 end Do_Qualified_Expression; 3246 3247 procedure Do_Record_Aggregate is 3248 begin 3249 if Tree.Subtrees (1).Subtree_Count = 0 then 3250 Interpret_Template ("@(null record)!"); 3251 else 3252 Interpret_Template; 3253 end if; 3254 end Do_Record_Aggregate; 3255 3256 procedure Do_Single_Task_Declaration is 3257 begin 3258 -- For single task declarations, use short form if 3259 -- Object_Declaration_View is Nil 3260 3261 if Is_Nil (Tree.Subtrees (4)) then 3262 Interpret_Template ("task !" & Aspects & "!!"); 3263 3264 else 3265 Interpret_Template; 3266 end if; 3267 end Do_Single_Task_Declaration; 3268 3269 procedure Do_Subp_Decl 3270 (Is_Function, Is_Body : Boolean; 3271 Params_Query : Structural_Queries) 3272 -- Params_Query is the query for getting the formal parameters 3273 is 3274 -- This is for subprogram declarations and the like -- everything 3275 -- that has a formal parameter list. 3276 3277 Param_Count : constant Query_Count := 3278 Get (Tree, Params_Query).Subtree_Count + 3279 Boolean'Pos (Is_Function); -- Add one extra for function result 3280 begin 3281 if Param_Count > Query_Count (Options.Par_Specs_Threshold) then 3282 Interpret_Template 3283 (Subp_Decl_With_Hard_Breaks 3284 (Tree, 3285 Is_Function, 3286 Is_Body)); 3287 else 3288 Interpret_Template; 3289 end if; 3290 end Do_Subp_Decl; 3291 3292 procedure Do_Subtype_Indication is 3293 begin 3294 if Tree.Subtrees (4).Kind in 3295 A_Range_Attribute_Reference | 3296 A_Simple_Expression_Range 3297 then 3298 Interpret_Template ("?~~ ~?~~ ~!? range ~~~"); 3299 elsif Options.RM_Style_Spacing 3300 and then Tree.Subtrees (4).Kind = An_Index_Constraint 3301 then 3302 Interpret_Template ("?~~ ~?~~ ~!?~~~"); 3303 else 3304 Interpret_Template ("?~~ ~?~~ ~!? ~~~"); 3305 end if; 3306 end Do_Subtype_Indication; 3307 3308 procedure Do_Task_Type_Declaration is 3309 begin 3310 -- For task type declarations, use short form if 3311 -- Type_Declaration_View is Nil 3312 3313 if Is_Nil (Tree.Subtrees (5)) then 3314 Interpret_Template ("task type !!" & Aspects & "!!"); 3315 3316 else 3317 Interpret_Template; 3318 end if; 3319 end Do_Task_Type_Declaration; 3320 3321 procedure Do_Usage_Name is 3322 -- The following works around a compiler limitation related to 3323 -- 'Elab_Spec and 'Elab_Body attributes. For something like 3324 -- "Ada.Text_IO'Elab_Spec", the compiler does not analyze the prefix 3325 -- "Ada.Text_IO", so it looks like a name that doesn't denote 3326 -- anything, like an identifier specific to a pragma. Setting 3327 -- Elab_Spec_Seen to True tells Id_With_Casing to treat it like a 3328 -- normal name (it really DOES denote something). 3329 Elab_Spec_Seen : Boolean := False; 3330 N : Tree_Stack_Index := Last_Index (Tree_Stack); 3331 P : Ada_Tree_Base; 3332 A : Name_Id; 3333 begin 3334 while N > 1 and then Tree_Stack (N - 1).Kind = A_Selected_Component 3335 loop 3336 N := N - 1; 3337 end loop; 3338 if N > 1 then 3339 P := Tree_Stack (N - 1); 3340 if P.Kind = An_Implementation_Defined_Attribute then 3341 A := P.Subtrees (2).Ref_Name; 3342 if 3343 (A = Name_Find ("Elab_Spec") 3344 or else A = Name_Find ("Elab_Body")) 3345 and then P.Subtrees (1) = Tree_Stack (N) 3346 then 3347 Elab_Spec_Seen := True; 3348 end if; 3349 end if; 3350 end if; 3351 -- End special handling for 'Elab_Spec and 'Elab_Body 3352 3353 Put 3354 ("\1", 3355 Id_With_Casing 3356 (Tree.Ref_Name, 3357 Tree.Decl_Kind, 3358 Tree.Is_Predef, 3359 Use_Name_Casing_For_Nils => Elab_Spec_Seen)); 3360 end Do_Usage_Name; 3361 3362 -- Start of processing for Subtree_To_Ada 3363 3364 begin 3365 Append (Tree_Stack, Tree); -- push 3366 3367 Maybe_Blank_Line; 3368 3369 case Tree.Kind is 3370 when A_Compilation_Unit => 3371 Do_Compilation_Unit; 3372 3373 when A_Comment => 3374 Do_Comment; 3375 3376 when Def_Names => 3377 Do_Def_Name; 3378 3379 when Usage_Names => 3380 Do_Usage_Name; 3381 3382 when An_Integer_Literal | A_Real_Literal | A_String_Literal => 3383 Do_Literal; 3384 3385 when Flat_Pragma_Kinds => 3386 Do_Pragma; 3387 3388 when A_Null_Statement => 3389 Do_Null_Statement; 3390 3391 when An_Ordinary_Type_Declaration => 3392 Do_Ordinary_Type_Declaration; 3393 3394 when A_Procedure_Call_Statement | An_Entry_Call_Statement => 3395 Do_Procedure_Call_Statement; 3396 3397 when A_Function_Call => 3398 Do_Function_Call; 3399 3400 when An_And_Then_Short_Circuit | An_Or_Else_Short_Circuit => 3401 Do_Binary_Operator 3402 (Tree, 3403 Is_Right => False, 3404 Cur_Level => Cur_Level); 3405 3406 when A_Task_Type_Declaration => 3407 Do_Task_Type_Declaration; 3408 3409 when A_Single_Task_Declaration => 3410 Do_Single_Task_Declaration; 3411 3412 when A_Pragma_Argument_Association | 3413 A_Discriminant_Association | 3414 A_Record_Component_Association | 3415 An_Array_Component_Association | 3416 A_Parameter_Association | 3417 A_Generic_Association => 3418 Do_Association; 3419 3420 when Flat_Attribute_Reference_Kinds => 3421 Do_Attribute_Reference; 3422 3423 when A_Block_Statement => 3424 Do_Block_Statement; 3425 3426 when A_Subtype_Indication => 3427 Do_Subtype_Indication; 3428 3429 when A_Case_Path => 3430 Do_Case_Path; 3431 3432 when A_Case_Statement => 3433 Do_Case_Statement; 3434 3435 when A_Component_Clause => 3436 Do_Component_Clause; 3437 3438 when A_Constrained_Array_Definition | 3439 A_Formal_Constrained_Array_Definition => 3440 Do_Constrained_Array_Definition; 3441 3442 when An_Extended_Return_Statement => 3443 Do_Extended_Return_Statement; 3444 3445 when An_Accept_Statement => 3446 Do_Accept_Statement; 3447 3448 when A_Positional_Array_Aggregate | 3449 A_Named_Array_Aggregate => 3450 Do_Array_Aggregate; 3451 3452 when A_Qualified_Expression => 3453 Do_Qualified_Expression; 3454 3455 when A_Record_Aggregate => 3456 Do_Record_Aggregate; 3457 3458 when An_Extension_Aggregate => 3459 Do_Extension_Aggregate; 3460 3461 when A_Parameter_Specification | A_Formal_Object_Declaration => 3462 Do_Parameter_Specification; 3463 3464 when A_Procedure_Declaration | 3465 A_Null_Procedure_Declaration | 3466 A_Procedure_Renaming_Declaration | 3467 An_Entry_Declaration | 3468 A_Generic_Procedure_Declaration | 3469 A_Formal_Procedure_Declaration | 3470 A_Procedure_Body_Stub => 3471 -- An_Accept_Statement goes through Do_Accept_Statement 3472 Do_Subp_Decl 3473 (Is_Function => False, 3474 Is_Body => False, 3475 Params_Query => Parameter_Profile); 3476 3477 when A_Procedure_Body_Declaration | 3478 An_Entry_Body_Declaration => 3479 Do_Subp_Decl 3480 (Is_Function => False, 3481 Is_Body => True, 3482 Params_Query => Parameter_Profile); 3483 3484 when An_Access_To_Procedure | 3485 An_Access_To_Protected_Procedure | 3486 An_Anonymous_Access_To_Procedure | 3487 An_Anonymous_Access_To_Protected_Procedure | 3488 A_Formal_Access_To_Procedure | 3489 A_Formal_Access_To_Protected_Procedure => 3490 Do_Subp_Decl 3491 (Is_Function => False, 3492 Is_Body => False, 3493 Params_Query => Access_To_Subprogram_Parameter_Profile); 3494 3495 when A_Function_Declaration | 3496 An_Expression_Function_Declaration | 3497 A_Function_Renaming_Declaration | 3498 A_Generic_Function_Declaration | 3499 A_Formal_Function_Declaration | 3500 A_Function_Body_Stub => 3501 Do_Subp_Decl 3502 (Is_Function => True, 3503 Is_Body => False, 3504 Params_Query => Parameter_Profile); 3505 3506 when A_Function_Body_Declaration => 3507 Do_Subp_Decl 3508 (Is_Function => True, 3509 Is_Body => True, 3510 Params_Query => Parameter_Profile); 3511 3512 when An_Access_To_Function | 3513 An_Access_To_Protected_Function | 3514 An_Anonymous_Access_To_Function | 3515 An_Anonymous_Access_To_Protected_Function | 3516 A_Formal_Access_To_Function | 3517 A_Formal_Access_To_Protected_Function => 3518 Do_Subp_Decl 3519 (Is_Function => True, 3520 Is_Body => False, 3521 Params_Query => Access_To_Subprogram_Parameter_Profile); 3522 3523 when Flat_List_Kinds => 3524 Do_List; 3525 3526 when others => 3527 Do_Others; 3528 end case; 3529 3530 Delete_Last (Tree_Stack); -- pop 3531 end Subtree_To_Ada; 3532 3533 procedure Convert_Tree_To_Ada (Tree : Ada_Tree) is 3534 begin 3535 Append_Line_Break 3536 (Hard => True, 3537 Affects_Comments => True, 3538 Level => 0, 3539 Kind => Not_An_Element, 3540 Template => Name_Empty); 3541 pragma Assert (Check_Whitespace); 3542 Subtree_To_Ada (Tree, Cur_Level => 0, Index_In_Parent => 1); 3543 pragma Debug (Assert_No_Trailing_Blanks (To_W_Str (Out_Buf))); 3544 Append 3545 (Tabs, 3546 Tab_Rec' 3547 (Parent | Tree => null, Mark => Mark (Out_Buf, '$'), others => <>)); 3548 -- Append a sentinel tab, whose Position is greater than any actual 3549 -- position. This ensures that as we step through Tabs, there is 3550 -- always one more. 3551 pragma Assert (Is_Empty (Tree_Stack)); 3552 Reset (Out_Buf); 3553 pragma Assert (Cur_Indentation = 0); 3554 end Convert_Tree_To_Ada; 3555 3556 procedure Insert_Comments_And_Blank_Lines; 3557 -- Src_Tokens is the tokens from the original source file. Out_Tokens 3558 -- is the newly-generated tokens. Out_Buf contains the corresponding 3559 -- characters to Out_Tokens. Out_[Tokens|Buf] doesn't contain any 3560 -- comments; they are inserted into the output from Src_Tokens. 3561 -- 3562 -- This procedure also does some work in preparation for 3563 -- Copy_Pp_Off_Regions. In particular, it checks that OFF/ON commands are 3564 -- in the proper sequence, and it sets the Pp_Off_Present flag. 3565 3566 procedure Final_Check_Helper; 3567 procedure Final_Check; 3568 -- Final pass: check that we have not damaged the input source text. 3569 -- Parameters and Out_Buf are as for Insert_Comments_And_Blank_Lines, 3570 -- except that comments are now included in Out_[Tokens|Buf], and this 3571 -- checks that they match the ones in Src_Tokens. Final_Check simply 3572 -- calls Final_Check_Helper, plus asserts that Out_Buf wasn't modified. 3573 3574 -- The code in Final_Check[_Helper] is parallel to the code in 3575 -- Insert_Comments_And_Blank_Lines, so there's a bit of code duplication. 3576 -- It is worth it to keep Final_Check[_Helper] as simple as possible. If 3577 -- you make changes to one, consider making similar changes to the other. 3578 3579 procedure Raise_Token_Mismatch 3580 (Message : String; 3581 Src_Index, Out_Index : Scanner.Token_Index; 3582 Src_Tok, Out_Tok : Scanner.Token); 3583 -- Called when either Insert_Comments_And_Blank_Lines or Final_Check finds 3584 -- a mismatch. Prints debugging information and raises Token_Mismatch. 3585 3586 procedure Insert_Comment_Text (Comment_Tok : Scanner.Token); 3587 -- Insert the text of the comment into Out_Buf, including the initial 3588 -- "--" and leading blanks. 3589 3590 procedure Insert_Comment_Text (Comment_Tok : Scanner.Token) is 3591 use Scanner; 3592 3593 function Filled_Text 3594 (Comment_Tok : Token; 3595 Leading_Blanks : Natural) 3596 return W_Str; 3597 -- Returns the text of the comment after filling (see 3598 -- GNATCOLL.Paragraph_Filling). 3599 3600 function Filled_Text 3601 (Comment_Tok : Token; 3602 Leading_Blanks : Natural) 3603 return W_Str 3604 is 3605 use GNATCOLL.Paragraph_Filling, Ada.Strings.Unbounded; 3606 S1 : constant String := Namet.Get_Name_String (Comment_Tok.Text); 3607 S2 : constant String := 3608 To_String 3609 (Pretty_Fill 3610 (S1, 3611 Max_Line_Length => 3612 Options.Max_Line_Length - 3613 (Cur_Indentation + String'("--")'Length + Leading_Blanks))); 3614 pragma Debug (Assert_No_Trailing_Blanks (From_UTF8 (S2))); 3615 begin 3616 return From_UTF8 (S2); 3617 end Filled_Text; 3618 3619 -- GNAT_Comment_Start causes the comment to start with at least 2 3620 -- blanks. 3621 3622 Leading_Blanks : constant Natural := 3623 (if 3624 Options.GNAT_Comment_Start and Comment_Tok.Is_Fillable_Comment 3625 then 3626 Natural'Max (Comment_Tok.Leading_Blanks, 2) 3627 else Comment_Tok.Leading_Blanks); 3628 -- In Comments_Only mode, we need to indent "by hand" here. In normal 3629 -- mode, Cur_Indentation will be heeded by the line breaks. 3630 Indentation : constant W_Str := 3631 (if Options.Comments_Only 3632 then (1 .. Cur_Indentation => ' ') 3633 else ""); 3634 Prelude : constant W_Str := 3635 Indentation & "--" & (1 .. Leading_Blanks => ' '); 3636 Do_Filling : constant Boolean := 3637 Comment_Filling_Enabled and then Comment_Tok.Is_Fillable_Comment; 3638 Text : constant W_Str := 3639 (if Do_Filling then Filled_Text (Comment_Tok, Leading_Blanks) 3640 else Get_Name_String (Comment_Tok.Text)); 3641 3642 -- Start of processing for Insert_Comment_Text 3643 3644 begin 3645 Insert (Out_Buf, Prelude); 3646 3647 pragma Assert (Text (Text'Last) = NL); 3648 for X in Text'First .. Text'Last - 1 loop -- skip last NL 3649 if Text (X) = NL then 3650 Append_Temp_Line_Break; 3651 Insert (Out_Buf, Prelude); 3652 else 3653 Insert (Out_Buf, Text (X)); 3654 end if; 3655 end loop; 3656 end Insert_Comment_Text; 3657 3658 procedure Raise_Token_Mismatch 3659 (Message : String; 3660 Src_Index, Out_Index : Scanner.Token_Index; 3661 Src_Tok, Out_Tok : Scanner.Token) 3662 is 3663 begin 3664 if Enable_Token_Mismatch then 3665 declare 3666 use Scanner; 3667 Num_Toks : constant Token_Index := 8; 3668 -- Number of tokens before and after the mismatch to print 3669 First_Src_Index : constant Token_Index := 3670 Token_Index'Max (Src_Index - Num_Toks, 1); 3671 Last_Src_Index : constant Token_Index := 3672 Token_Index'Min (Src_Index + Num_Toks, Last_Index (Src_Tokens)); 3673 First_Out_Index : constant Token_Index := 3674 Token_Index'Max (Out_Index - Num_Toks, 1); 3675 Last_Out_Index : constant Token_Index := 3676 Token_Index'Min (Out_Index + Num_Toks, Last_Index (Out_Tokens)); 3677 begin 3678 ASIS_UL.Dbg_Out.Output_Enabled := True; 3679 Text_IO.Put_Line ("Src_Buf:"); 3680 Dump_Buf (Src_Buf); 3681 Text_IO.Put_Line ("Out_Buf:"); 3682 Dump_Buf (Out_Buf); 3683 3684 Text_IO.Put_Line 3685 (Text_IO.Standard_Output, 3686 Message & 3687 ": Token mismatch: " & 3688 Get_Name_String (Src_Tok.Text) & 3689 " --> " & 3690 Get_Name_String (Out_Tok.Text)); 3691 Text_IO.Put_Line (Text_IO.Standard_Output, "Src tokens:"); 3692 Put_Tokens 3693 (Src_Tokens, 3694 First => First_Src_Index, 3695 Last => Last_Src_Index, 3696 Highlight => Src_Index); 3697 Text_IO.Put_Line 3698 (Text_IO.Standard_Output, 3699 "========================================"); 3700 Text_IO.Put_Line (Text_IO.Standard_Output, "Out tokens:"); 3701 Put_Tokens 3702 (Out_Tokens, 3703 First => First_Out_Index, 3704 Last => Last_Out_Index, 3705 Highlight => Out_Index); 3706 3707 Text_IO.Put_Line (Text_IO.Standard_Output, "Src text:"); 3708 Wide_Text_IO.Put 3709 (Wide_Text_IO.Standard_Output, Slice (Src_Buf, 3710 Src_Tokens (First_Src_Index).Sloc.First, 3711 Src_Tokens (Last_Src_Index).Sloc.Last, 3712 Lines => True)); 3713 Text_IO.Put_Line (Text_IO.Standard_Output, "Out text:"); 3714 Wide_Text_IO.Put 3715 (Wide_Text_IO.Standard_Output, Slice (Out_Buf, 3716 Out_Tokens (First_Out_Index).Sloc.First, 3717 Out_Tokens (Last_Out_Index).Sloc.Last, 3718 Lines => True)); 3719 end; 3720 end if; 3721 raise Token_Mismatch; 3722 end Raise_Token_Mismatch; 3723 3724 Pp_Off_Present : Boolean := False; 3725 -- True if there is at least one Pp_Off_Comment. We don't care about 3726 -- Pp_On_Comments, because it's an error to have a Pp_On_Comment without a 3727 -- preceding Pp_Off_Comment. Set True if appropriate by 3728 -- Insert_Comments_And_Blank_Lines. This allows us to skip the 3729 -- Copy_Pp_Off_Regions pass as an optimization. 3730 3731 procedure Insert_Comments_And_Blank_Lines is 3732 use Scanner; 3733 -- use all type Token_Vector; 3734 3735 function Match (Tok1, Tok2 : Token) return Boolean; 3736 -- True if the tokens have the same kind and same text, except that the 3737 -- matching is case insensitive for identifiers, reserved words, and 3738 -- string literals that could be operator symbols. The source locations 3739 -- are ignored. 3740 3741 procedure Move_Past_Char; 3742 procedure Move_Past_Out_Tok; 3743 procedure Move_Past_Src_Tok; 3744 3745 procedure Insert_End_Of_Line_Comment; 3746 -- Found an End_Of_Line_Comment comment; copy it to the buffer. If it 3747 -- is too long to fit on the line, turn it into a Whole_Line_Comment, 3748 -- taking care to indent. 3749 3750 -- Note that the Subtree_To_Ada pass already inserted indentation, so we 3751 -- mostly keep the indentation level at zero. The exception is comments, 3752 -- which Subtree_To_Ada didn't see. For comments, we temporarily set the 3753 -- indentation to that of the surrounding code. 3754 3755 procedure Insert_Whole_Line_Comment; 3756 -- Found a Whole_Line_Comment; copy it to the buffer, taking care to 3757 -- indent, except that if the comment starts in column 1, we assume 3758 -- the user wants to keep it that way. 3759 3760 procedure Insert_Declare_Or_Private (Declare_Or_Private : W_Str) with 3761 Pre => Declare_Or_Private in "declare" | "private"; 3762 -- If a block statement has no declarations, the earlier passes 3763 -- don't insert "declare", whether or not it was in the source code. 3764 -- If Do_Inserts is True, and there is a comment, this re-inserts 3765 -- "declare" before the comment, to avoid messing up the formatting. 3766 -- Similarly for "private [possible comment] end". 3767 3768 function Extra_Blank_On_Return return Boolean; 3769 -- This is to deal with something like: 3770 -- function Some_Function 3771 -- (A_Parameter : A_Parameter_Type; 3772 -- Another_Parameter : Another_Parameter_Type) 3773 -- return Result_Type; 3774 -- ^ Need to insert an extra blank there. 3775 -- Returns true if done. 3776 3777 function Match (Tok1, Tok2 : Token) return Boolean is 3778 begin 3779 if Tok1.Kind = Tok2.Kind then 3780 case Tok1.Kind is 3781 when Nil | End_Of_Line | Comment_Kind => 3782 pragma Assert (False); 3783 3784 when Start_Of_Input | End_Of_Input | Blank_Line => 3785 pragma Assert (Tok1.Normalized = Tok2.Normalized); 3786 return True; 3787 3788 when Lexeme | Identifier | Reserved_Word => 3789 return Tok1.Normalized = Tok2.Normalized; 3790 3791 when Numeric_Literal => 3792 if Tok1.Text = Tok2.Text then 3793 return True; 3794 end if; 3795 declare 3796 Tok1_Text : constant W_Str := Get_Name_String (Tok1.Text); 3797 Tok2_Text : constant W_Str := Get_Name_String (Tok2.Text); 3798 begin 3799 if (Options.Decimal_Grouping = 0 3800 and then Options.Based_Grouping = 0) 3801 or else Find (Tok1_Text, "_") /= 0 3802 then 3803 return False; 3804 else 3805 return Tok1_Text = Replace_All (Tok2_Text, "_", ""); 3806 end if; 3807 end; 3808 3809 when String_Literal => 3810 if Is_Op_Sym_With_Letters (Tok1.Normalized) then 3811 return Tok1.Normalized = Tok2.Normalized; 3812 3813 else 3814 return Tok1.Text = Tok2.Text; 3815 end if; 3816 end case; 3817 end if; 3818 3819 return False; 3820 end Match; 3821 3822 Src_Index, Out_Index : Token_Index := 2; 3823 -- Skip the first Start_Of_Input token, which is just a sentinel 3824 3825 Src_Tok, Out_Tok : Token; 3826 3827 Line_Breaks : Line_Break_Vector renames Syntax_Line_Breaks; 3828 -- Line breaks used for indenting whole-line comments 3829 3830 -- ??? 3831 EOL_Line_Breaks : Line_Break_Vector renames Enabled_Line_Breaks; 3832-- EOL_Line_Breaks : Line_Break_Vector renames Nonblank_Line_Breaks; Line 3833-- breaks used for indenting end-of-line comments 3834 3835 Cur_Line : Line_Break_Index := 2; 3836 EOL_Cur_Line : Line_Break_Index := 2; -- for end-of-line comments 3837 3838 procedure Move_Past_Char is 3839 begin 3840 pragma Assert 3841 (Point (Out_Buf) <= 3842 Position (Out_Buf, Line_Breaks (Cur_Line).Mark)); 3843 3844 -- Step past Line_Breaks at the current position 3845 3846 while Cur_Line <= Last_Index (Line_Breaks) 3847 and then At_Point (Out_Buf, Line_Breaks (Cur_Line).Mark) 3848 loop 3849 Cur_Line := Cur_Line + 1; 3850 end loop; 3851 3852 -- Step past EOL_Line_Breaks at the current position 3853 3854 while EOL_Cur_Line <= Last_Index (EOL_Line_Breaks) 3855 and then At_Point (Out_Buf, EOL_Line_Breaks (EOL_Cur_Line).Mark) 3856 loop 3857 EOL_Cur_Line := EOL_Cur_Line + 1; 3858 end loop; 3859 3860 -- Step past character 3861 3862 Move_Forward (Out_Buf); 3863 end Move_Past_Char; 3864 3865 procedure Move_Past_Out_Tok is 3866 begin 3867 loop 3868 Move_Past_Char; 3869 exit when At_Point (Out_Buf, Out_Tok.Sloc.Lastx); 3870 end loop; 3871 end Move_Past_Out_Tok; 3872 3873 procedure Move_Past_Src_Tok is 3874 begin 3875 loop 3876 Move_Forward (Src_Buf); 3877 exit when At_Point (Src_Buf, Src_Tok.Sloc.Lastx); 3878 end loop; 3879 end Move_Past_Src_Tok; 3880 3881 function Extra_Blank_On_Return return Boolean is 3882 begin 3883 if Out_Tok.Normalized = Snames.Name_Return then 3884 declare 3885 Paren : constant Token := Out_Tokens (Out_Index - 1); 3886 LB : constant Line_Break := EOL_Line_Breaks (EOL_Cur_Line); 3887 begin 3888 -- If the function has no parameters, or if this is the 3889 -- "return" of a return_statement, then there will be no ")", 3890 -- and we won't do anything. If there is a comment between ")" 3891 -- and "return", we do nothing. 3892 if Paren.Normalized = Name_R_Paren then 3893 if not LB.Hard -- will be hard if comment present 3894 and then LB.Enabled 3895 and then At_Point (Out_Buf, LB.Mark) 3896 then 3897 pragma Assert (Cur (Out_Buf) = ' '); 3898 Move_Past_Char; 3899 pragma Assert (To_Lower (Cur (Out_Buf)) = 'r'); 3900 Insert (Out_Buf, ' '); -- before "return" 3901 Move_Past_Out_Tok; 3902 -- No need to insert ' ' after "return" 3903 return True; 3904 end if; 3905 end if; 3906 end; 3907 end if; 3908 return False; 3909 end Extra_Blank_On_Return; 3910 3911 Prev_EOL_Comment_Src_Col : Natural := 0; 3912 -- If the previous line had an end-of-line comment, this is its column 3913 -- in the original source; otherwise 0. 3914 Prev_EOL_Comment_Out_Col : Natural := 0; 3915 -- If the previous line had an end-of-line comment, this is its column 3916 -- in the output; otherwise 0. 3917 3918 procedure Insert_End_Of_Line_Comment is 3919 Indentation : Natural := 0; 3920 Prev_Src_Tok : constant Token := Src_Tokens (Src_Index - 1); 3921 pragma Assert (Src_Tok.Sloc.Line = Prev_Src_Tok.Sloc.Line); 3922 Preceding_Blanks : Natural := 3923 First_Pos (Src_Buf, Src_Tok.Sloc) - 3924 Last_Pos (Src_Buf, Prev_Src_Tok.Sloc) - 3925 1; 3926 -- Number of blanks between the previous token and this comment. Note 3927 -- that tabs have been expanded in Src_Buf. 3928 begin 3929 pragma Assert (EOL_Cur_Line > 1); 3930 Indentation := EOL_Line_Breaks (EOL_Cur_Line - 1).Indentation; 3931 3932 -- If we're just before a blank followed by NL, move past the blank, 3933 -- so we won't add a new NL below. 3934 3935 if not At_Point (Out_Buf, EOL_Line_Breaks (EOL_Cur_Line).Mark) 3936 and then Cur (Out_Buf) = ' ' 3937 then 3938 Move_Past_Char; 3939 pragma Assert (Cur (Out_Buf) /= ' '); 3940 if Preceding_Blanks > 0 then 3941 Preceding_Blanks := Preceding_Blanks - 1; 3942 end if; 3943 end if; 3944 3945 -- If this comment is lined up with one on the previous line in the 3946 -- source, then line it up in the output. Otherwise, just preserve 3947 -- Preceding_Blanks. ???Disabled for now. 3948 3949 if False and then Src_Tok.Sloc.Col = Prev_EOL_Comment_Src_Col then 3950 while Cur_Column (Out_Buf) < Prev_EOL_Comment_Out_Col loop 3951 Insert (Out_Buf, ' '); 3952 end loop; 3953 else 3954 for J in 1 .. Preceding_Blanks loop 3955 Insert (Out_Buf, ' '); -- Avoid making line too long??? 3956 end loop; 3957 end if; 3958 if False then -- ???Disabled for now. 3959 -- This doesn't work, because Cur_Column is wrong, because Out_Buf 3960 -- does not yet contain any NLs. Also, we presumably need to reset 3961 -- these variables to 0 when we see a line without a comment. 3962 Prev_EOL_Comment_Src_Col := Src_Tok.Sloc.Col; 3963 Prev_EOL_Comment_Out_Col := Cur_Column (Out_Buf); 3964 end if; 3965 Insert_Comment_Text (Src_Tok); 3966 3967 -- In the usual case, the end-of-line comment is at a natural line 3968 -- break, like this: 3969 -- X := X + 1; -- Increment X 3970 -- so we don't need another one. But if the original was: 3971 -- X := -- Increment X 3972 -- X + 1; 3973 -- we need to add a line break after the comment. 3974 3975 if not At_Point (Out_Buf, EOL_Line_Breaks (EOL_Cur_Line).Mark) then 3976 pragma Assert (Cur (Out_Buf) /= NL); 3977 Cur_Indentation := Indentation; 3978 Append_Temp_Line_Break; 3979 Cur_Indentation := 0; 3980 end if; 3981 Src_Index := Src_Index + 1; 3982 end Insert_End_Of_Line_Comment; 3983 3984 Pp_On : Boolean := True; 3985 -- True initially, and if the most recently encountered Pp_Off_Comment 3986 -- or Pp_On_Comment was Pp_On_Comment. 3987 Last_Pp_Off_On : Token_Index := 1; 3988 -- If > 1, this is the index in Src_Tokens of the most recently 3989 -- encountered Pp_Off_Comment or Pp_On_Comment. Used to check for 3990 -- errors; they must alternate, OFF, ON, OFF, .... 3991 3992 procedure Insert_Whole_Line_Comment is 3993 function Look_Before return Boolean; 3994 -- True if we should look before the current location to determine 3995 -- indentation level for the comment. If the next lexeme is "begin", 3996 -- for example, we want to indent to the level of "begin", even 3997 -- though there is probably previous code more deeply indented. 3998 3999 procedure Set_Cur_Indent; 4000 -- Set Cur_Indentation as appropriate 4001 4002 function Before_Indentation return Natural; 4003 -- Same as "Line_Breaks (Cur_Line - 1).Indentation", except we skip 4004 -- Line_Breaks with Affects_Comments = False. In other words, this is 4005 -- the previous line-breaks indentation which should affect comments. 4006 function After_Indentation return Natural; 4007 -- Same as "Line_Breaks (Cur_Line).Indentation", except we skip 4008 -- Line_Breaks with Affects_Comments = False.In other words, this is 4009 -- the current/next line-breaks indentation which should affect 4010 -- comments. 4011 4012 function Look_Before return Boolean is 4013 begin 4014 if Out_Tok.Kind = End_Of_Input then 4015 return True; 4016 end if; 4017 4018 -- Should the following list include "exception"??? 4019 return not 4020 (Out_Tok.Normalized = Snames.Name_Begin 4021 or else Out_Tok.Normalized = Snames.Name_When 4022 or else Out_Tok.Normalized = Snames.Name_Elsif 4023 or else Out_Tok.Normalized = Snames.Name_Else); 4024 end Look_Before; 4025 4026 Indentation : Natural; 4027 4028 procedure Set_Cur_Indent is 4029 begin 4030 if Src_Tok.Sloc.Col = 1 4031 or else Src_Tok.Is_Special_Comment 4032 or else not Options.Format_Comments 4033 then 4034 Cur_Indentation := Src_Tok.Sloc.Col - 1; -- Keep as in input 4035 4036 else 4037 Cur_Indentation := Indentation; 4038 4039 -- Try to make comment fit on line. If we're filling it, then 4040 -- rely on that to make it fit. If Cur_Indentation pushes 4041 -- it past Max_Line_Length, and the comment would fit if 4042 -- not indented, then reduce the indentation. 4043 4044 if 4045 (not Comment_Filling_Enabled 4046 or else not Src_Tok.Is_Fillable_Comment) 4047 and then 4048 Cur_Indentation + Src_Tok.Width > 4049 Options.Max_Line_Length 4050 and then Src_Tok.Width <= Options.Max_Line_Length 4051 then 4052 Cur_Indentation := 4053 Good_Column (Options.Max_Line_Length - Src_Tok.Width); 4054 pragma Assert 4055 ((Cur_Indentation mod Options.PP_Indentation) = 0); 4056 end if; 4057 end if; 4058 end Set_Cur_Indent; 4059 4060 function Before_Indentation return Natural is 4061 X : Line_Break_Index := Cur_Line - 1; 4062 begin 4063 while X > 1 and then not Line_Breaks (X).Affects_Comments loop 4064 X := X - 1; 4065 end loop; 4066 return Line_Breaks (X).Indentation; 4067 end Before_Indentation; 4068 4069 function After_Indentation return Natural is 4070 X : Line_Break_Index := Cur_Line; 4071 begin 4072 while X < Last_Index (Line_Breaks) 4073 and then not Line_Breaks (X).Affects_Comments 4074 loop 4075 X := X + 1; 4076 end loop; 4077 return Line_Breaks (X).Indentation; 4078 end After_Indentation; 4079 4080 -- Start of processing for Insert_Whole_Line_Comment 4081 4082 begin 4083 -- Processing in preparation for Copy_Pp_Off_Regions. That depends on 4084 -- an alternating sequence: OFF, ON, OFF, ON, .... So we check that 4085 -- here, and abort processing if it's not true. 4086 4087 case Whole_Line_Comment'(Src_Tok.Kind) is 4088 when Pp_Off_Comment => 4089 if Pp_On then 4090 Pp_On := False; 4091 Last_Pp_Off_On := Src_Index; 4092 pragma Assert (Last_Pp_Off_On /= 1); 4093 else 4094 Output.Error_No_Tool_Name 4095 (Message_Image (Root, Src_Tok.Sloc) & 4096 ": pretty printing already disabled at " & 4097 Message_Image (Src_Tokens (Last_Pp_Off_On).Sloc)); 4098 raise Common.Fatal_Error; 4099 end if; 4100 when Pp_On_Comment => 4101 if Pp_On then 4102 Output.Error_No_Tool_Name 4103 (Message_Image (Root, Src_Tok.Sloc) & 4104 ": pretty printing already enabled at " & 4105 Message_Image (Src_Tokens (Last_Pp_Off_On).Sloc)); 4106 raise Common.Fatal_Error; 4107 else 4108 Pp_On := True; 4109 Last_Pp_Off_On := Src_Index; 4110 pragma Assert (Last_Pp_Off_On /= 1); 4111 end if; 4112 when Other_Whole_Line_Comment => null; 4113 end case; 4114 4115 -- Comments at the beginning are not indented. The "2" is to skip the 4116 -- initial sentinel NL. 4117 4118 if Point (Out_Buf) = 2 then 4119 Indentation := 0; 4120 4121 -- Otherwise, we indent as for the max of the preceding and following 4122 -- line breaks, except when Look_Before is False (as it is for this 4123 -- comment, which is followed by "else"). 4124 4125 else 4126 Indentation := After_Indentation; 4127 4128 if Look_Before then 4129 Indentation := Natural'Max (Indentation, Before_Indentation); 4130 end if; 4131 end if; 4132 4133 -- Make sure Indentation is a multiple of PP_Indentation; otherwise 4134 -- style checking complains "(style) bad column". 4135 4136 Indentation := 4137 (Indentation / Options.PP_Indentation) * Options.PP_Indentation; 4138 pragma Assert ((Indentation mod Options.PP_Indentation) = 0); 4139 4140 Set_Cur_Indent; 4141 if Src_Tokens (Src_Index - 1).Kind = Blank_Line 4142 or else Lookback (Out_Buf) /= NL 4143 then 4144 Append_Temp_Line_Break; 4145 end if; 4146 4147 loop 4148 -- ???Handle blank lines here, too? 4149 Insert_Comment_Text (Src_Tok); 4150 Src_Index := Src_Index + 1; 4151 Src_Tok := Src_Tokens (Src_Index); 4152 exit when Src_Tok.Kind not in Other_Whole_Line_Comment; 4153 Set_Cur_Indent; 4154 Append_Temp_Line_Break; 4155 end loop; 4156 4157 -- If we don't have an enabled line break here, we need to add one. 4158 4159 if not Options.Insert_Blank_Lines 4160 and then not Options.Preserve_Blank_Lines 4161 then 4162 pragma Assert 4163 ((Cur (Out_Buf) = NL) = 4164 (At_Point (Out_Buf, Line_Breaks (Cur_Line).Mark))); 4165 pragma Assert 4166 (if 4167 Cur (Out_Buf) = NL 4168 then 4169 At_Point (Out_Buf, EOL_Line_Breaks (EOL_Cur_Line).Mark)); 4170 end if; 4171 declare 4172 LB_Pos : constant Positive := 4173 Position (Out_Buf, EOL_Line_Breaks (EOL_Cur_Line).Mark); 4174 P : constant Positive := Point (Out_Buf); 4175 begin 4176 if LB_Pos = P then 4177 null; 4178 elsif Cur (Out_Buf) = ' ' and then LB_Pos = P + 1 then 4179 null; 4180 else 4181 Cur_Indentation := Indentation; 4182 Append_Temp_Line_Break; 4183 end if; 4184 end; 4185 4186 Cur_Indentation := 0; 4187 end Insert_Whole_Line_Comment; 4188 4189 procedure Insert_Declare_Or_Private (Declare_Or_Private : W_Str) is 4190 Out_Tok_Pos : constant Positive := 4191 Position (Out_Buf, Out_Tok.Sloc.Firstx); 4192 LB_Pos : constant Positive := 4193 Position (Out_Buf, Line_Breaks (Cur_Line).Mark); 4194 Prev_LB_Pos : constant Positive := 4195 Position (Out_Buf, Line_Breaks (Cur_Line - 1).Mark); 4196 4197 begin 4198 -- Either the current or previous line break is just before "begin" 4199 -- or "end"; that's the indentation we want for "declare" or 4200 -- "private", respectively. There is one exception: a named block 4201 -- of the form "Name : begin", we want to insert the declare before 4202 -- "begin", and we don't care about indentation. ???Better would be 4203 -- to use indentation of "Name". 4204 4205 if LB_Pos = Out_Tok_Pos - 1 then 4206 Cur_Indentation := Line_Breaks (Cur_Line).Indentation; 4207 4208 elsif Prev_LB_Pos = Out_Tok_Pos - 1 then 4209 Cur_Indentation := Line_Breaks (Cur_Line - 1).Indentation; 4210 4211 -- The "one exception" mentioned above 4212 4213 else 4214 pragma Assert 4215 (Declare_Or_Private = "declare" 4216 and then Out_Tokens (Out_Index - 1).Text = Name_Colon 4217 and then Out_Tokens (Out_Index - 2).Kind = Identifier); 4218 end if; 4219 4220 Append_Temp_Line_Break; 4221 Insert (Out_Buf, Declare_Or_Private); 4222 Cur_Indentation := 0; 4223 4224 Src_Index := Src_Index + 1; 4225 end Insert_Declare_Or_Private; 4226 4227 Qual_Nesting : Natural := 0; 4228 -- Count the nesting level of qualified expressions containing aggregates 4229 -- with extra parentheses. 4230 4231 -- Start of processing for Insert_Comments_And_Blank_Lines 4232 4233 begin 4234 pragma Debug 4235 (Format_Debug_Output ("before Insert_Comments_And_Blank_Lines")); 4236 Get_Tokens (Out_Buf, Out_Tokens, Pp_Off_On_Delimiters); 4237 -- ???At this point, we might need another pass to insert hard line 4238 -- breaks after end-of-line comments, so they will be indented properly. 4239 -- Or better yet, insert the EOL comments, with tabs and soft line break 4240 -- before, hard line break after. 4241 pragma Assert (Cur (Out_Buf) = NL); 4242 Move_Forward (Out_Buf); -- skip sentinel 4243 Collect_Enabled_Line_Breaks (Syntax_Also => True); 4244 Clear (Temp_Line_Breaks); 4245 4246 -- The two sequences Src_Tokens and Out_Tokens should be identical, 4247 -- with some exceptions where mismatches are possible. The code below 4248 -- to insert comments depends on this fact. We step through the two 4249 -- sequences, copying text into Buffer, and detect any token mismatch. 4250 -- The allowed mismatches are: 4251 -- 4252 -- The Out sequence has no comments, so when we detect a mismatch and 4253 -- the source one is a comment, that's where we insert the comment. 4254 -- 4255 -- The sequences may have blank lines in different places. 4256 -- 4257 -- We normalize "end;" to "end Some_Name;" 4258 -- 4259 -- We normalize by removing "declare" from a block statement with no 4260 -- declarative items. We put the "declare" back in here. 4261 -- 4262 -- We normalize by removing "private" from a package (etc) when there 4263 -- is nothing in the private part. We put the "private" back in here. 4264 -- 4265 -- We normalize a qualified expression with unnecessary parentheses 4266 -- containing an aggregate. That is "T'((X, Y, Z))" is normalized to 4267 -- "T'(X, Y, Z)", where "(X, Y, Z)" is an aggregate. We pretty-much 4268 -- have to do that, because ASIS provides no way to distinguish these 4269 -- two forms. 4270 -- 4271 -- We normalize "X : in T" to "X : T" (currently disabled to match 4272 -- the old gnatpp). 4273 -- 4274 -- There is a mode in which we insert underscores in numeric 4275 -- literals, as in 12_345_678. 4276 -- 4277 -- Allowed Replacements of Characters (see RM-J.2). We normalize "!" 4278 -- to "|" when used as a delimiter. The other allowed replacements 4279 -- (: for # and % for ") are not normalized. 4280 -- 4281 -- Any other mismatch is considered to be a bug. 4282 4283 loop 4284 Src_Tok := Src_Tokens (Src_Index); 4285 Out_Tok := Out_Tokens (Out_Index); 4286 4287 pragma Assert (Out_Tok.Kind not in Comment_Kind); 4288 4289 -- Move into comment area??? 4290 pragma Assert 4291 (Prev_Lexeme (Out_Tokens, Out_Index).Kind not in 4292 Blank_Line | 4293 Comment_Kind); 4294 4295 -- The order of the if/elsif's below is important in some 4296 -- cases. Blank lines must be handled late, even if they match. 4297 -- End_Of_Line_Comments must be handled before blank lines, 4298 -- because they need to appear at the end of the preceding line. 4299 -- Whole_Line_Comments must be handled after blank lines, because 4300 -- the blank line should precede the comment. 4301 4302 if Src_Tok.Kind /= Blank_Line 4303 and then 4304 (Match (Src_Tok, Out_Tok) 4305 or else 4306 (Src_Tok.Normalized = Name_Bang 4307 and then Out_Tok.Normalized = Name_Bar)) 4308 then 4309 exit when Src_Tok.Kind = End_Of_Input; 4310 -- i.e. exit when both Src and Out are at end of input 4311 4312 if Extra_Blank_On_Return then 4313 null; -- Extra_Blank_On_Return took care of it 4314 else 4315 Move_Past_Out_Tok; 4316 end if; 4317 4318 Src_Index := Src_Index + 1; 4319 Out_Index := Out_Index + 1; 4320 4321 else 4322 -- Check for "end;" --> "end Some_Name;" case 4323 4324 if Src_Tok.Text = Name_Semicolon 4325 and then 4326 Prev_Lexeme (Src_Tokens, Src_Index).Normalized = 4327 Snames.Name_End 4328 and then Out_Tok.Kind in Identifier | String_Literal 4329 then 4330 loop -- could be "end A.B.C;" 4331 Move_Past_Out_Tok; 4332 Out_Index := Out_Index + 1; 4333 Out_Tok := Out_Tokens (Out_Index); 4334 -- ???Shouldn't have to set Out_Tok here. Either write a 4335 -- procedure that sets it every time Out_Index changes, 4336 -- or make Out_Tok a function. 4337 4338 exit when Out_Tok.Normalized /= Name_Dot; 4339 4340 Move_Past_Out_Tok; 4341 Out_Index := Out_Index + 1; 4342 Out_Tok := Out_Tokens (Out_Index); 4343 pragma Assert (Out_Tok.Kind in Identifier | String_Literal); 4344 end loop; 4345 pragma Assert (Out_Tok.Normalized = Name_Semicolon); 4346 4347 -- Check for "end Some_Name;" --> "end;" case. This only happens 4348 -- when the --no-end-id switch was given. Here, the name was 4349 -- present in the source, so we insert it. 4350 4351 elsif not Options.End_Id 4352 and then Out_Tok.Text = Name_Semicolon 4353 and then 4354 Prev_Lexeme (Out_Tokens, Out_Index).Normalized = 4355 Snames.Name_End 4356 and then Src_Tok.Kind in Identifier | String_Literal 4357 then 4358 Insert (Out_Buf, " "); 4359 loop -- could be "end A.B.C;" 4360 Insert (Out_Buf, Get_Name_String (Src_Tok.Text)); 4361 Move_Past_Src_Tok; 4362 Src_Index := Src_Index + 1; 4363 Src_Tok := Src_Tokens (Src_Index); 4364 4365 exit when Src_Tok.Normalized /= Name_Dot; 4366 4367 Insert (Out_Buf, Get_Name_String (Src_Tok.Text)); 4368 Move_Past_Src_Tok; 4369 Src_Index := Src_Index + 1; 4370 Src_Tok := Src_Tokens (Src_Index); 4371 pragma Assert (Src_Tok.Kind in Identifier | String_Literal); 4372 end loop; 4373 pragma Assert (Src_Tok.Normalized = Name_Semicolon); 4374 4375 -- Check for "declare begin" --> "begin" case, with a possible 4376 -- comment between "declare" and "begin". 4377 4378 elsif Src_Tok.Normalized = Snames.Name_Declare 4379 and then Out_Tok.Normalized = Snames.Name_Begin 4380 then 4381 pragma Assert 4382 (Next_Lexeme (Src_Tokens, Src_Index).Normalized = 4383 Snames.Name_Begin); 4384 Insert_Declare_Or_Private ("declare"); 4385 4386 -- Check for "private end" --> "end" case. 4387 4388 elsif Src_Tok.Normalized = Snames.Name_Private 4389 and then Out_Tok.Normalized = Snames.Name_End 4390 then 4391 pragma Assert 4392 (Next_Lexeme (Src_Tokens, Src_Index).Normalized = 4393 Snames.Name_End); 4394 Insert_Declare_Or_Private ("private"); 4395 4396 -- Check for "T'((X, Y, Z))" --> "T'(X, Y, Z)" case 4397 4398 elsif Src_Tok.Text = Name_L_Paren 4399 and then Prev_Lexeme (Src_Tokens, Src_Index).Text = Name_L_Paren 4400 --???Also check that the one before that is a tick! 4401 then 4402 Qual_Nesting := Qual_Nesting + 1; 4403 Insert (Out_Buf, '('); 4404 Src_Index := Src_Index + 1; 4405 elsif Qual_Nesting > 0 4406 and then Src_Tok.Text = Name_R_Paren 4407 and then Prev_Lexeme (Src_Tokens, Src_Index).Text = Name_R_Paren 4408 then 4409 Qual_Nesting := Qual_Nesting - 1; 4410 Insert (Out_Buf, ')'); 4411 Src_Index := Src_Index + 1; 4412 4413 -- Check for "X : in T" --> "X : T" case 4414 4415 elsif False -- Deletion of "in" is currently disabled 4416 and then Src_Tok.Normalized = Snames.Name_In 4417 and then Prev_Lexeme (Src_Tokens, Src_Index).Text = Name_Colon 4418 4419 then 4420 Src_Index := Src_Index + 1; 4421 4422 elsif Src_Tok.Kind = End_Of_Line_Comment then 4423 Insert_End_Of_Line_Comment; 4424 4425 -- If the source has a blank line at this point, send it to the 4426 -- output, but avoid multiple blank lines (unless 4427 -- Preserve_Blank_Lines is True) and blank lines just before 4428 -- End_Of_Input. 4429 4430 elsif Src_Tok.Kind = Blank_Line then 4431 loop 4432 Src_Index := Src_Index + 1; 4433 Src_Tok := Src_Tokens (Src_Index); 4434 exit when Src_Tok.Kind /= Blank_Line 4435 or else Options.Preserve_Blank_Lines; 4436 end loop; 4437 if Src_Tok.Kind /= End_Of_Input 4438 or else Options.Preserve_Blank_Lines 4439 then 4440 Append_Temp_Line_Break; 4441 end if; 4442 4443 elsif Src_Tok.Kind in Whole_Line_Comment then 4444 Insert_Whole_Line_Comment; 4445 4446 elsif Out_Tok.Kind = Blank_Line then 4447 Move_Past_Out_Tok; 4448 Out_Index := Out_Index + 1; 4449 4450 -- Else print out debugging information and crash. This avoids 4451 -- damaging the source code in case of bugs. 4452 4453 else 4454 Raise_Token_Mismatch 4455 ("Inserting", 4456 Src_Index, 4457 Out_Index, 4458 Src_Tok, 4459 Out_Tok); 4460 end if; 4461 end if; 4462 end loop; 4463 4464 if Last_Pp_Off_On > 1 then 4465 Pp_Off_Present := True; 4466 end if; 4467 4468 pragma Assert 4469 (if not Options.Comments_Only then 4470 Point (Out_Buf) = Last_Position (Out_Buf)); 4471 pragma Assert (Cur (Out_Buf) = NL); 4472 Move_Past_Out_Tok; 4473 4474 pragma Assert (Cur_Indentation = 0); 4475 4476 pragma Assert (Src_Index = Last_Index (Src_Tokens)); 4477 pragma Assert (Out_Index = Last_Index (Out_Tokens)); 4478 pragma Assert (At_End (Out_Buf) and then Lookback (Out_Buf) = NL); 4479 pragma Assert (Cur_Line = Last_Index (Line_Breaks) + 1); 4480 pragma Assert (EOL_Cur_Line = Last_Index (EOL_Line_Breaks) + 1); 4481 4482 pragma Assert (Line_Break_Sorting.Is_Sorted (All_Line_Breaks)); 4483 pragma Assert (Line_Break_Sorting.Is_Sorted (Temp_Line_Breaks)); 4484 Line_Break_Sorting.Merge 4485 (Target => All_Line_Breaks, 4486 Source => Temp_Line_Breaks); 4487 pragma Assert (Is_Empty (Temp_Line_Breaks)); 4488 pragma Assert (Line_Break_Sorting.Is_Sorted (All_Line_Breaks)); 4489 pragma Assert (Qual_Nesting = 0); 4490 pragma Debug (Assert_No_Trailing_Blanks (To_W_Str (Out_Buf))); 4491 Reset (Out_Buf); 4492 Clear (Out_Tokens); 4493 end Insert_Comments_And_Blank_Lines; 4494 4495 procedure Final_Check_Helper is 4496 use Scanner; 4497 -- use all type Token_Vector; 4498 4499 function Match (Tok1, Tok2 : Token) return Boolean; 4500 -- Similar to Match in Insert_Comments_And_Blank_Lines, but here we need 4501 -- to deal with comments. 4502 4503 procedure Move_Past_Char; 4504 procedure Move_Past_Out_Tok; 4505 -- These are similar to the procedures in 4506 -- Insert_Comments_And_Blank_Lines, but here we don't need to keep 4507 -- track of line breaks. 4508 4509 procedure Collect_Comments 4510 (Tokens : Token_Vector; 4511 Index : in out Token_Index; 4512 Tok : in out Token; 4513 Result : in out Char_Vector; 4514 Is_Out : Boolean); 4515 -- Collect up all the text of a sequence of Whole_Line_Comments, 4516 -- ignoring changes made by paragraph filling. Paragraph_Filling might 4517 -- have changed blank to NL and vice versa, and it turns a series of 4518 -- blanks into a single one. Similarly needed if GNAT_Comment_Start is 4519 -- True. 4520 4521 function Match (Tok1, Tok2 : Token) return Boolean is 4522 begin 4523 if Tok1.Kind = Tok2.Kind then 4524 case Tok1.Kind is 4525 when Nil | End_Of_Line => 4526 raise Program_Error; 4527 4528 when Start_Of_Input | End_Of_Input | Blank_Line => 4529 pragma Assert (Tok1.Normalized = Tok2.Normalized); 4530 return True; 4531 4532 when Comment_Kind => 4533 return 4534 (Options.GNAT_Comment_Start 4535 or else Tok1.Leading_Blanks = Tok2.Leading_Blanks) 4536 and then Tok1.Text = Tok2.Text; 4537 4538 when Lexeme | Identifier | Reserved_Word => 4539 return Tok1.Normalized = Tok2.Normalized; 4540 4541 when Numeric_Literal => 4542 if Tok1.Text = Tok2.Text then 4543 return True; 4544 end if; 4545 declare 4546 Tok1_Text : constant W_Str := Get_Name_String (Tok1.Text); 4547 Tok2_Text : constant W_Str := Get_Name_String (Tok2.Text); 4548 begin 4549 if (Options.Decimal_Grouping = 0 4550 and then Options.Based_Grouping = 0) 4551 or else Find (Tok1_Text, "_") /= 0 4552 then 4553 return False; 4554 else 4555 return Tok1_Text = Replace_All (Tok2_Text, "_", ""); 4556 end if; 4557 end; 4558 4559 when String_Literal => 4560 if True or else Is_Op_Sym_With_Letters (Tok1.Normalized) then 4561 return Tok1.Normalized = Tok2.Normalized; 4562 4563 else 4564 return Tok1.Text = Tok2.Text; 4565 end if; 4566 end case; 4567 4568 elsif Tok1.Kind = End_Of_Line_Comment 4569 and then Tok2.Kind in Whole_Line_Comment 4570 then 4571 return Tok1.Text = Tok2.Text 4572 and then 4573 (if 4574 not Options.GNAT_Comment_Start 4575 then 4576 Tok1.Leading_Blanks = Tok2.Leading_Blanks); 4577 -- ???This case will be needed if/when we turn end-of-line 4578 -- comments that don't fit into whole-line comments. That 4579 -- transformation seems questionable, because it would damage 4580 -- idempotency: first run of gnatpp turns an end-of-line comment 4581 -- into a whole-line-comment, and then a second run considers it 4582 -- part of a comment paragraph and fills it. 4583 end if; 4584 4585 return False; 4586 end Match; 4587 4588 Src_Index, Out_Index : Token_Index := 2; 4589 -- Skip the first Start_Of_Input token, which is just a sentinel 4590 4591 Src_Tok, Out_Tok : Token; 4592 4593 procedure Move_Past_Char is 4594 begin 4595 -- Step past character 4596 4597 Move_Forward (Out_Buf); 4598 end Move_Past_Char; 4599 4600 procedure Move_Past_Out_Tok is 4601 begin 4602 -- ???Make sure we're not moving past multiple tokens here. Move past 4603 -- whitespace, then assert we're at token start, then move to end. Or 4604 -- something like that. 4605 loop 4606 Move_Past_Char; 4607 exit when At_Point (Out_Buf, Out_Tok.Sloc.Lastx); 4608 end loop; 4609 end Move_Past_Out_Tok; 4610 4611 procedure Collect_Comments 4612 (Tokens : Token_Vector; 4613 Index : in out Token_Index; 4614 Tok : in out Token; 4615 Result : in out Char_Vector; 4616 Is_Out : Boolean) 4617 is 4618 begin 4619 while Tok.Kind in Whole_Line_Comment loop 4620 declare 4621 Text : constant W_Str := Get_Name_String (Tok.Text); 4622 function White 4623 (X : Positive) 4624 return Boolean is 4625 (X <= Text'Last 4626 and then 4627 (Is_Space (Text (X)) or else Is_Line_Terminator (Text (X)))); 4628 -- True if X points to a space or NL character 4629 4630 pragma Assert 4631 (Text'First = 1 4632 and then Text'Last >= 1 4633 and then (if Text'Last > 1 then not White (1)) 4634 and then White (Text'Last)); 4635 X : Positive := 1; 4636 begin 4637 while X <= Text'Last loop 4638 if White (X) then 4639 Append (Result, ' '); 4640 while White (X) loop 4641 X := X + 1; 4642 end loop; 4643 else 4644 Append (Result, Text (X)); 4645 X := X + 1; 4646 end if; 4647 end loop; 4648 end; 4649 4650 if Is_Out then 4651 Move_Past_Out_Tok; 4652 end if; 4653 Index := Index + 1; 4654 Tok := Tokens (Index); 4655 end loop; 4656 end Collect_Comments; 4657 4658 -- Start of processing for Final_Check_Helper 4659 4660 begin 4661 Get_Tokens (Out_Buf, Out_Tokens, Pp_Off_On_Delimiters); 4662 pragma Assert (Cur (Out_Buf) = NL); 4663 Move_Forward (Out_Buf); -- skip sentinel 4664 4665 loop 4666 Src_Tok := Src_Tokens (Src_Index); 4667 Out_Tok := Out_Tokens (Out_Index); 4668 4669 if Src_Index > 5 and then Simulate_Token_Mismatch then 4670 -- Simulate a token mismatch, for testing 4671 Raise_Token_Mismatch 4672 ("Final_Check 0", 4673 Src_Index, 4674 Out_Index, 4675 Src_Tok, 4676 Out_Tok); 4677 end if; 4678 4679 if Src_Tok.Kind /= Blank_Line 4680 and then 4681 (Match (Src_Tok, Out_Tok) 4682 or else 4683 (Src_Tok.Normalized = Name_Bang 4684 and then Out_Tok.Normalized = Name_Bar)) 4685 then 4686 exit when Src_Tok.Kind = End_Of_Input; 4687 -- i.e. exit when both Src and Out are at end of input 4688 4689 Move_Past_Out_Tok; 4690 4691 Src_Index := Src_Index + 1; 4692 Out_Index := Out_Index + 1; 4693 4694 else 4695 -- If we're filling comments, then the comments might not match 4696 -- up. For example, a line break could be added such that the 4697 -- first line is too short to be considered part of a fillable 4698 -- comment paragraph, thus turning one comment into two. So 4699 -- we collect them all together and check that their text 4700 -- more-or-less matches. 4701 -- 4702 -- Similarly, we do this if GNAT_Comment_Start. For example, if 4703 -- one comment starts with a single blank and the next starts with 4704 -- two, then they will not look like a single paragraph during 4705 -- Insert_Comments_And_Blank_Lines, but here they will, because an 4706 -- extra blank has been added to the first. 4707 -- 4708 -- Actually, we need to do this in any case: if two comments in 4709 -- the input are not indented the same, they will be indented the 4710 -- same in the output, and thus appear to be a fillable paragraph. 4711 4712 if Src_Tok.Kind in Whole_Line_Comment 4713 and then Out_Tok.Kind in Whole_Line_Comment 4714 then 4715 declare 4716 Src_Comments : Char_Vector; 4717 Out_Comments : Char_Vector; 4718 begin 4719 Collect_Comments 4720 (Src_Tokens, 4721 Src_Index, 4722 Src_Tok, 4723 Src_Comments, 4724 Is_Out => False); 4725 Collect_Comments 4726 (Out_Tokens, 4727 Out_Index, 4728 Out_Tok, 4729 Out_Comments, 4730 Is_Out => True); 4731 if Src_Comments /= Out_Comments then 4732 Text_IO.Put_Line 4733 (Text_IO.Standard_Output, 4734 To_UTF8 (To_Array (Src_Comments)) & 4735 " --> " & 4736 To_UTF8 (To_Array (Out_Comments))); 4737 Raise_Token_Mismatch 4738 ("Final_Check 1", 4739 Src_Index, 4740 Out_Index, 4741 Src_Tok, 4742 Out_Tok); 4743 end if; 4744 end; 4745 4746 -- Check for "end;" --> "end Some_Name;" case 4747--???Check next Out token is ";" 4748 elsif Src_Tok.Text = Name_Semicolon 4749 and then 4750 Prev_Lexeme (Src_Tokens, Src_Index).Normalized = 4751 Snames.Name_End 4752 and then Out_Tok.Kind in Identifier | String_Literal 4753 then 4754 loop -- could be "end A.B.C;" 4755 Move_Past_Out_Tok; 4756 Out_Index := Out_Index + 1; 4757 Out_Tok := Out_Tokens (Out_Index); 4758 -- ???Shouldn't have to set Out_Tok here. Either write a 4759 -- procedure that sets it every time Out_Index changes, 4760 -- or make Out_Tok a function. 4761 4762 exit when Out_Tok.Normalized /= Name_Dot; 4763 4764 Move_Past_Out_Tok; 4765 Out_Index := Out_Index + 1; 4766 Out_Tok := Out_Tokens (Out_Index); 4767 if Out_Tok.Kind not in Identifier | String_Literal then 4768 Raise_Token_Mismatch 4769 ("Final_Check 2", 4770 Src_Index, 4771 Out_Index, 4772 Src_Tok, 4773 Out_Tok); 4774 end if; 4775 end loop; 4776 4777 -- Check for "X : in T" --> "X : T" case 4778 4779 elsif False -- Deletion of "in" is currently disabled 4780 and then Src_Tok.Normalized = Snames.Name_In 4781 and then Prev_Lexeme (Src_Tokens, Src_Index).Text = Name_Colon 4782 --???Check prev&next ids match??? 4783 4784 then 4785 Src_Index := Src_Index + 1; 4786 4787 elsif Src_Tok.Kind = Blank_Line then 4788 Src_Index := Src_Index + 1; 4789 Src_Tok := Src_Tokens (Src_Index); 4790 4791 elsif Out_Tok.Kind = Blank_Line then 4792 Move_Past_Out_Tok; 4793 Out_Index := Out_Index + 1; 4794 4795 -- Else print out debugging information and crash. This avoids 4796 -- damaging the source code in case of bugs. 4797 4798 else 4799 Raise_Token_Mismatch 4800 ("Final_Check 3", 4801 Src_Index, 4802 Out_Index, 4803 Src_Tok, 4804 Out_Tok); 4805 end if; 4806 end if; 4807 end loop; 4808 4809 if not Options.Comments_Only 4810 and then not Options.Preserve_Blank_Lines 4811 then 4812 if Point (Out_Buf) /= Last_Position (Out_Buf) then 4813 Raise_Token_Mismatch 4814 ("Final_Check 4", 4815 Src_Index, 4816 Out_Index, 4817 Src_Tok, 4818 Out_Tok); 4819 end if; 4820 end if; 4821 while not At_End (Out_Buf) loop 4822 if not Is_Line_Terminator (Cur (Out_Buf)) then 4823 Raise_Token_Mismatch 4824 ("Final_Check 5", 4825 Src_Index, 4826 Out_Index, 4827 Src_Tok, 4828 Out_Tok); 4829 end if; 4830 4831 Move_Forward (Out_Buf); 4832 end loop; 4833 4834 Reset (Out_Buf); 4835 4836 if Src_Index /= Last_Index (Src_Tokens) 4837 or else Out_Index /= Last_Index (Out_Tokens) 4838 then 4839 Raise_Token_Mismatch 4840 ("Final_Check 6", 4841 Src_Index, 4842 Out_Index, 4843 Src_Tok, 4844 Out_Tok); 4845 end if; 4846 end Final_Check_Helper; 4847 4848 procedure Final_Check is 4849 begin 4850 if Disable_Final_Check then 4851 return; 4852 end if; 4853 if Enable_Token_Mismatch then 4854 declare 4855 Old_Out_Buf : constant Char_Vector := To_Vector (Out_Buf); 4856 begin 4857 Final_Check_Helper; 4858 pragma Assert (To_Vector (Out_Buf) = Old_Out_Buf); 4859 pragma Debug (Assert_No_Trailing_Blanks (To_W_Str (Out_Buf))); 4860 end; 4861 else 4862 Final_Check_Helper; 4863 end if; 4864 end Final_Check; 4865 4866 procedure Insert_Alignment (Tokens : Scanner.Token_Vector); 4867 -- Expand tabs as necessary to align things 4868 4869 procedure Insert_Alignment (Tokens : Scanner.Token_Vector) is 4870 4871 procedure Calculate_Num_Blanks; 4872 4873 procedure Calculate_Num_Blanks is 4874 use Scanner; 4875 -- use all type Token_Vector; 4876 4877 -- Note on Col and Num_Blanks components of Tab_Rec: Col is 4878 -- initialized to a bogus value, and Num_Blanks to 0. Process_Line 4879 -- sets Col to the correct value. Flush_Para uses Col, and possibly 4880 -- changes Num_Blanks to some positive value. After the call to 4881 -- Calculate_Num_Blanks, Num_Blanks is used to insert the correct 4882 -- number of ' ' characters. Thus, Col is temporary, used only within 4883 -- Calculate_Num_Blanks, to communicate information from Process_Line 4884 -- to Flush_Para. 4885 4886 Paragraph_Tabs : Tab_In_Line_Vector_Vectors.Vector; 4887 -- One Tab_In_Line_Vector for each line in the current paragraph 4888 4889 procedure Put_Paragraph_Tabs; 4890 4891 procedure Flush_Para; 4892 -- Called at the end of a "tabbing paragraph", i.e. a group of one or 4893 -- more lines that each represents similar constructs that should be 4894 -- treated together for alignment purposes. 4895 4896 procedure Flush_Para is 4897 Num_Lines : constant Tab_In_Line_Vector_Index'Base := 4898 Last_Index (Paragraph_Tabs); 4899 begin 4900 -- Here we have Paragraph_Tabs set to a sequence of lines (or the 4901 -- tabs in those lines, really). For example, if the input text 4902 -- was (*1): 4903 -- 4904 -- package P is 4905 -- 4906 -- X : T := 1; 4907 -- A_Long_Variable_Name : T := 2; 4908 -- Y : A_Long_Type_Name := 3; 4909 -- 4910 -- end P; 4911 -- ^ 4912 -- | 4913 -- column 1 4914 -- 4915 -- then previous passes will have turned that into (*2): 4916 -- 4917 -- package P is 4918 -- 4919 -- X ^1: T ^2:= 1; 4920 -- A_Long_Variable_Name ^1: T ^2:= 2; 4921 -- Y ^1: A_Long_Type_Name ^2:= 3; 4922 -- 4923 -- end P; 4924 -- 4925 -- The tabs are shown as ^1 and ^2 in (*2) above, although they 4926 -- are really kept in a separate data structure (Tabs) rather than 4927 -- in the text itself, and take up zero columns in the buffer. 4928 -- The "paragraph" we're talking about consists of the three 4929 -- variable-declaration lines. Note that the alignment from the 4930 -- input has been forgotten; we would get the same thing if the 4931 -- input were unaligned. Our job is to align the ":" and ":=" 4932 -- symbols, whether or not they were originally aligned. 4933 -- 4934 -- ^1 means Index_In_Line = 1; ^2 means Index_In_Line = 2 (see 4935 -- type Tab_Rec). The Col of each tab is currently set to the 4936 -- column in which it appears in (*2), and the Num_Blanks is 4937 -- currently set to 0. The following code sets the Col of each tab 4938 -- to the column in which it WILL appear, and the Num_Blanks to 4939 -- the number of blanks to expand the tab to in order to achieve 4940 -- that. 4941 -- 4942 -- We first loop through all the ^1 tabs, and calculate the max 4943 -- Col, which will be the ":" of the A_Long_Variable_Name line. 4944 -- We then loop through those again, and set the Num_Blanks to be 4945 -- the number of blanks needed to reach that max column. For each 4946 -- such ^1 tab, we loop from that ^1, through ^2 and ^3 and so 4947 -- on (we have no ^3... in this example), adjusting their Col 4948 -- accordingly. 4949 -- 4950 -- Then we loop through all the ^2 tabs in the same way, and so on 4951 -- for ^3, etc. 4952 -- 4953 -- So in this example, we loop down through the ^1 tabs to 4954 -- calculate where to put the ":"'s. Then down through the ^1 tabs 4955 -- again to adjust the Num_Blanks for the ^1 tabs, and loop across 4956 -- to adjust the Col for the ^1 and ^2 tabs. Then down through the 4957 -- ^2 tabs to calculate where to put the ":="'s. Then down through 4958 -- the ^2 tabs to adjust the Num_Blanks for the ^2 tabs, and loop 4959 -- across to adjust the Col for the ^2 tabs. Note that adjusting 4960 -- the Col for the ":"'s affects where we're going to put the 4961 -- ":="'s -- that's the reason for the "loop across" part. 4962 -- 4963 -- The end result is to calculate the Num_Blanks so that when 4964 -- we expand the tabs, (*2) above will be turned (back) into 4965 -- the (*1). 4966 4967 -- We must not process a zero-line paragraph. For efficiency, we 4968 -- can avoid processing a one-line paragraph (leaving all tabs, if 4969 -- any with Num_Blanks = 0). Multi-line paragraphs always have at 4970 -- least one tab per line, and all lines have the same number of 4971 -- tabs. 4972 4973 if Num_Lines = 0 then 4974 return; 4975 end if; 4976 4977 if Num_Lines = 1 then 4978 Clear (Paragraph_Tabs); 4979 return; 4980 end if; 4981 pragma Debug (Put_Paragraph_Tabs); 4982 pragma Assert (Last_Index (Paragraph_Tabs (1)) /= 0); 4983 4984 for Index_In_Line in 1 .. Last_Index (Paragraph_Tabs (1)) loop 4985 declare 4986 Max_Col : Positive := 1; 4987 begin 4988 for Line of Paragraph_Tabs loop 4989 declare 4990 Tab_I : constant Tab_Index := Line (Index_In_Line); 4991 Tab : Tab_Rec renames Tabs (Tab_I); 4992 begin 4993 Max_Col := Positive'Max (Max_Col, Tab.Col); 4994 end; 4995 end loop; 4996 4997 for Line of Paragraph_Tabs loop 4998 declare 4999 Tab_I : constant Tab_Index := Line (Index_In_Line); 5000 Tab : Tab_Rec renames Tabs (Tab_I); 5001 begin 5002 if Tab.Is_Fake then 5003 Tab.Col := Max_Col; 5004 end if; 5005 Tab.Num_Blanks := Max_Col - Tab.Col; 5006 pragma Assert (if Tab.Is_Fake then Tab.Num_Blanks = 0); 5007 5008 for X_In_Line in Index_In_Line .. Last_Index (Line) 5009 loop 5010 declare 5011 Tab_J : constant Tab_Index := Line (X_In_Line); 5012 Tab_2 : Tab_Rec renames Tabs (Tab_J); 5013 begin 5014 Tab_2.Col := Tab_2.Col + Tab.Num_Blanks; 5015 end; 5016 end loop; 5017 pragma Assert (Tab.Col = Max_Col); 5018 5019 pragma Assert 5020 (if Num_Lines = 1 then Tab.Num_Blanks = 0); 5021 -- Because of that fact, we can skip all this for 5022 -- 1-line paragraphs. 5023 end; 5024 end loop; 5025 end; 5026 end loop; 5027 pragma Debug (Put_Paragraph_Tabs); 5028 5029 Clear (Paragraph_Tabs); 5030 end Flush_Para; 5031 5032 Cur_Token_Index : Token_Index := 1; 5033 function Cur_Tok return Token is (Tokens (Cur_Token_Index)); 5034 Cur_Tab_Index : Tab_Index := 1; 5035 function Cur_Tab return Tab_Rec is (Tabs (Cur_Tab_Index)); 5036 5037 First_Line_Tabs, Cur_Line_Tabs : Tab_In_Line_Vector; 5038 -- Tabs for first line of paragraph and for current line. 5039 5040 procedure Process_Line; 5041 -- Process a single line in Out_Buf. Collect together all relevant 5042 -- tabs in Cur_Line_Tabs. All tabs in Cur_Line_Tabs must have the 5043 -- same Tree (that of the first tab on the line). Other tabs (for 5044 -- more nested constructs) are skipped. So for example: 5045 -- X : T (Discrim => 123) := (This | That => 345); 5046 -- we collect two tabs for ':' and ':=', which have the same Tree 5047 -- (a variable declaration tree). The '|' and '=>' characters in 5048 -- the discriminant constraint and the aggregate also have tabs, but 5049 -- these are skipped, because their Tree is different (more nested). 5050 -- If there are no tabs on the line, then of course Cur_Line_Tabs 5051 -- will be empty. In addition, if we have something like: 5052 -- A := (1 | 2 | 3 => ...); 5053 -- the '|' and '=>' tabs will have the same Index_In_Line, in which 5054 -- case we give up (set Tab_Mismatch to True, and set Cur_Line_Tabs 5055 -- to empty). Those tabs are only of use if we end up enabling line 5056 -- breaks after the '|'s. 5057 -- 5058 -- Handling of "insertion points". 5059 -- 5060 -- Let's pretend the template for assignment_statement is 5061 -- 5062 -- ! ^:= ! 5063 -- 5064 -- which means insert the left-hand side, followed by " := ", 5065 -- followed by the right-hand side. (It's actually more complicated; 5066 -- this is just an example.) There is a tab before ":=", so multiple 5067 -- assignment_statements line up like this: 5068 -- 5069 -- Long_Name := 1; 5070 -- X := 10_000; 5071 -- Even_Longer_Name := 1_000_000; 5072 -- 5073 -- If we add a tab at the end (just before the ";"): "! ^:= !^2", we 5074 -- get this: 5075 -- 5076 -- Long_Name := 1 ; 5077 -- X := 10_000 ; 5078 -- Even_Longer_Name := 1_000_000; 5079 -- 5080 -- If in addition we add an insertion point before the right-hand 5081 -- side, so the template is: "! ^:= &2!^2", then the blanks are 5082 -- inserted before the right-hand side, resulting in right-justified 5083 -- expressions: 5084 -- 5085 -- Long_Name := 1; 5086 -- X := 10_000; 5087 -- Even_Longer_Name := 1_000_000; 5088 -- 5089 -- (We currently do not right-justify those expressions; this is just 5090 -- an example to show how "&" works. "&" is actually used in 5091 -- Do_Component_Clause.) 5092 5093 procedure Process_Line is 5094 Tab_Mismatch : Boolean := False; 5095 First_Time : Boolean := True; 5096 Tree : Ada_Tree_Base; 5097 Insertion_Point : Marker; 5098 Have_Insertion_Point : Boolean := False; 5099 IP_Index_In_Line : Tab_Index_In_Line; 5100 begin 5101 while Cur_Tok.Kind not in End_Of_Input | End_Of_Line | Blank_Line 5102 loop 5103 pragma Assert 5104 (Cur_Tok.Sloc.First <= Position (Out_Buf, Cur_Tab.Mark)); 5105 -- We can have two tabs at the same place if the second one is 5106 -- fake. Also for implicit 'in' mode, etc. Hence 'while', not 5107 -- 'if' here: 5108 while Cur_Tok.Sloc.Firstx = Cur_Tab.Mark loop 5109 if First_Time then 5110 pragma Assert (Is_Empty (Cur_Line_Tabs)); 5111 First_Time := False; 5112 Tree := Cur_Tab.Tree; 5113 end if; 5114 if Cur_Tab.Tree = Tree then 5115 if Cur_Tab.Is_Insertion_Point then 5116 pragma Assert (not Have_Insertion_Point); 5117 Have_Insertion_Point := True; 5118 Insertion_Point := Cur_Tab.Mark; 5119 IP_Index_In_Line := Cur_Tab.Index_In_Line; 5120 else 5121 Append (Cur_Line_Tabs, Cur_Tab_Index); 5122 if Cur_Tab.Index_In_Line /= 5123 Last_Index (Cur_Line_Tabs) 5124 then 5125 Tab_Mismatch := True; 5126 end if; 5127 5128 Tabs (Cur_Tab_Index).Col := Cur_Tok.Sloc.Col; 5129 if Have_Insertion_Point then 5130 Have_Insertion_Point := False; 5131 pragma Assert 5132 (Cur_Tab.Index_In_Line = IP_Index_In_Line); 5133 Tabs (Cur_Tab_Index).Mark := Insertion_Point; 5134 end if; 5135 end if; 5136 end if; 5137 5138 Cur_Tab_Index := Cur_Tab_Index + 1; 5139 end loop; 5140 5141 Cur_Token_Index := Cur_Token_Index + 1; 5142 end loop; 5143 5144 if Tab_Mismatch then 5145 Clear (Cur_Line_Tabs); 5146 end if; 5147 end Process_Line; 5148 5149 procedure Check_Tokens_Match (X, Y : Tab_In_Line_Vector); 5150 -- If two lines come from the same construct, then the tokens should 5151 -- match. Raise an exception if they don't. 5152 5153 procedure Check_Tokens_Match (X, Y : Tab_In_Line_Vector) is 5154 begin 5155 pragma Assert (not Is_Empty (X) and then not Is_Empty (Y)); 5156 for J in 1 .. Last_Index (X) loop 5157 declare 5158 XX : constant Tab_Index := X (J); 5159 YY : constant Tab_Index := Y (J); 5160 XT : constant Name_Id := Tabs (XX).Token; 5161 YT : constant Name_Id := Tabs (YY).Token; 5162 begin 5163 if XT /= YT then 5164 -- "=>" matches a preceding "|" 5165 if XT = Name_Arrow and then YT = Name_Bar then 5166 null; 5167 else 5168 raise Program_Error; 5169 end if; 5170 end if; 5171 end; 5172 end loop; 5173 end Check_Tokens_Match; 5174 5175 procedure Put_Tab_In_Line_Vector 5176 (Name : String; 5177 X : Tab_In_Line_Vector); 5178 5179 procedure Put_Tab_In_Line_Vector 5180 (Name : String; 5181 X : Tab_In_Line_Vector) 5182 is 5183 begin 5184 if Is_Empty (X) then 5185 return; 5186 end if; 5187 5188 Dbg_Out.Put ("\1: \t", Name); 5189 5190 for J in 1 .. Last_Index (X) loop 5191 if J /= 1 then 5192 Dbg_Out.Put ("; "); 5193 end if; 5194 Dbg_Out.Put ("\1", Tab_Image (X (J))); 5195 end loop; 5196 Dbg_Out.Put ("\n"); 5197 end Put_Tab_In_Line_Vector; 5198 5199 procedure Put_Paragraph_Tabs is 5200 begin 5201 Dbg_Out.Put 5202 ("\1 Paragraph_Tabs\n", 5203 Image (Integer (Last_Index (Paragraph_Tabs)))); 5204 5205 for X of Paragraph_Tabs loop 5206 Put_Tab_In_Line_Vector ("", X); 5207 end loop; 5208 Dbg_Out.Put ("end Paragraph_Tabs\n"); 5209 end Put_Paragraph_Tabs; 5210 5211 F_Tab, C_Tab : Tab_Rec; 5212 5213 -- Start of processing for Calculate_Num_Blanks 5214 5215 begin 5216-- Debug printouts commented out for efficiency 5217 while Cur_Tok.Kind /= End_Of_Input loop 5218 declare 5219-- First_Char_In_Line : constant Natural := 5220-- Cur_Tok.Sloc.First - Cur_Tok.Sloc.Col + 1; 5221 begin 5222 Process_Line; 5223 5224-- Dbg_Out.Put ("<<"); 5225-- 5226-- for X in First_Char_In_Line .. Cur_Tok.Sloc.First - 1 loop 5227-- for Tab of Cur_Line_Tabs loop 5228-- if X = Position (Out_Buf, Tabs (Tab).Mark) then 5229-- Dbg_Out.Put ("^"); 5230-- end if; 5231-- end loop; 5232-- Dbg_Out.Put ("\1", To_UTF8 ((1 => Char_At (Out_Buf, X)))); 5233-- end loop; 5234-- Dbg_Out.Put (">>\n"); 5235-- Put_Tab_In_Line_Vector ("First", First_Line_Tabs); 5236-- Put_Tab_In_Line_Vector ("Cur", Cur_Line_Tabs); 5237 5238 Cur_Token_Index := Cur_Token_Index + 1; 5239 -- Consume the newline 5240 5241 if Is_Empty (Cur_Line_Tabs) then 5242-- Dbg_Out.Put ("Flush_Para -- no tabs\n"); 5243 Flush_Para; 5244 -- Leave tabs from this line with Num_Blanks = 0. 5245 Clear (First_Line_Tabs); 5246 5247 else 5248 if Is_Empty (First_Line_Tabs) then 5249 First_Line_Tabs := Cur_Line_Tabs; 5250 else 5251 -- If the Parents don't match, we're at the end of a 5252 -- paragraph. We also end the paragraph if the line-tab 5253 -- arrays are of different length, which can only 5254 -- happen if a comment occurs in the middle of a 5255 -- tabable construct (e.g. before ":=" in a variable 5256 -- declaration), thus forcing a tab onto the next line. 5257 5258 F_Tab := Element (Tabs, First_Line_Tabs (1)); 5259 C_Tab := Element (Tabs, Cur_Line_Tabs (1)); 5260 5261 if C_Tab.Parent = F_Tab.Parent 5262 and then 5263 Last_Index (Cur_Line_Tabs) = 5264 Last_Index (First_Line_Tabs) 5265 then 5266 pragma Debug 5267 (Check_Tokens_Match 5268 (Cur_Line_Tabs, 5269 First_Line_Tabs)); 5270 else 5271-- Dbg_Out.Put ("Flush_Para -- parent mismatch\n"); 5272 Flush_Para; 5273 First_Line_Tabs := Cur_Line_Tabs; 5274 end if; 5275 F_Tab := (others => <>); 5276 C_Tab := (others => <>); 5277 end if; 5278 Append (Paragraph_Tabs, Cur_Line_Tabs); 5279 Clear (Cur_Line_Tabs); 5280 end if; 5281 end; 5282-- Dbg_Out.Put ("\n"); 5283 end loop; 5284 5285 pragma Assert (Cur_Tab_Index = Last_Index (Tabs)); 5286 end Calculate_Num_Blanks; 5287 5288 -- Start of processing for Insert_Alignment 5289 5290 begin 5291 if not Alignment_Enabled then 5292 return; 5293 end if; 5294 5295 Clear (Out_Buf_Line_Ends); 5296 Scanner.Get_Tokens 5297 (Out_Buf, 5298 Out_Tokens, Pp_Off_On_Delimiters, 5299 Ignore_Single_Line_Breaks => False, 5300 Line_Ends => Out_Buf_Line_Ends'Access); 5301 5302 -- First go through the tabs and set their Num_Blanks field to the 5303 -- appropriate value. Tabs that are not expanded at all will have 5304 -- Num_Blanks left equal to zero. 5305 5306 pragma Debug (Format_Debug_Output ("before Calculate_Num_Blanks")); 5307 Calculate_Num_Blanks; 5308 pragma Debug (Format_Debug_Output ("after Calculate_Num_Blanks")); 5309 5310 -- Now go through the buffer, inserting blanks for tabs that should be 5311 -- expanded. Don't expand a tab if it would make the line too long. 5312 5313 declare 5314 Cur_Tab_Index : Tab_Index := 1; 5315 Cur_Tab : Tab_Rec := Tabs (Cur_Tab_Index); 5316 Cur_Line_Num : Positive := 1; 5317 5318 begin 5319 while not At_End (Out_Buf) loop 5320 pragma Assert 5321 (Point (Out_Buf) <= Position (Out_Buf, Cur_Tab.Mark)); 5322 5323 while At_Point (Out_Buf, Cur_Tab.Mark) loop 5324 if Scanner.Line_Length 5325 (Out_Buf, 5326 Out_Buf_Line_Ends, 5327 Cur_Line_Num) + 5328 Cur_Tab.Num_Blanks <= 5329 Options.Max_Line_Length 5330 then 5331 for J in 1 .. Cur_Tab.Num_Blanks loop 5332 Insert (Out_Buf, ' '); 5333 end loop; 5334 end if; 5335 Cur_Tab_Index := Cur_Tab_Index + 1; 5336 Cur_Tab := Tabs (Cur_Tab_Index); 5337 end loop; 5338 if Cur (Out_Buf) = NL then 5339 Cur_Line_Num := Cur_Line_Num + 1; 5340 end if; 5341 Move_Forward (Out_Buf); 5342 end loop; 5343 pragma Assert (Cur_Tab_Index = Last_Index (Tabs)); 5344 end; 5345 5346 Reset (Out_Buf); 5347 pragma Debug (Assert_No_Trailing_Blanks (To_W_Str (Out_Buf))); 5348 end Insert_Alignment; 5349 5350 procedure Keyword_Casing; 5351 -- Convert reserved words to lower/upper case based on command-line 5352 -- options. 5353 5354 procedure Keyword_Casing is 5355 -- The usual case is Lower_Case, in which case there's nothing to do, 5356 -- because all of the Ada_Templates have reserved words in lower case. 5357 -- If it's Upper_Case, we loop through the tokens, converting reserved 5358 -- words to upper case. 5359 use Scanner; 5360 -- use all type Token_Vector; 5361 Out_Tok : Token; 5362 begin 5363 case Options.PP_Keyword_Casing is 5364 when Lower_Case => 5365 null; 5366 5367 when Upper_Case => 5368 Scanner.Get_Tokens (Out_Buf, Out_Tokens, Pp_Off_On_Delimiters); 5369 for Out_Index in 2 .. Last_Index (Out_Tokens) loop 5370 Out_Tok := Out_Tokens (Out_Index); 5371 loop 5372 if Out_Tok.Kind = Reserved_Word then 5373 Replace_Cur (Out_Buf, To_Upper (Cur (Out_Buf))); 5374 end if; 5375 Move_Forward (Out_Buf); 5376 exit when At_Point (Out_Buf, Out_Tok.Sloc.Lastx); 5377 end loop; 5378 end loop; 5379 Reset (Out_Buf); 5380 end case; 5381 end Keyword_Casing; 5382 5383 procedure Insert_Form_Feeds; 5384 -- Insert FF after "pragma Page;" if -ff switch was given. It might seem 5385 -- silly to have a whole extra pass for this little feature, but it's a 5386 -- rarely used feature, so we don't care if it's a little slower, and this 5387 -- seems cleanest. We could have put this processing in some other 5388 -- unrelated pass. Note that it would not be easy to do this in 5389 -- Convert_Tree_To_Ada, because the FF goes after the ";", and the ";" is 5390 -- not printed as part of the pragma -- it goes BETWEEN the pragma and 5391 -- whatever comes next. Furthermore, we want to do this last so the FF 5392 -- doesn't get turned back into NL. 5393 5394 procedure Insert_Form_Feeds is 5395 use Scanner; 5396 -- use all type Token_Vector; 5397 Out_Tok, Prev_Tok, Prev_Prev_Tok : Token; 5398 begin 5399 if not Options.Add_FF then 5400 return; 5401 end if; 5402 5403 Scanner.Get_Tokens (Out_Buf, Out_Tokens, Pp_Off_On_Delimiters); 5404 for Out_Index in 2 + 3 - 1 .. Last_Index (Out_Tokens) loop 5405 -- Skip sentinel and first 3 tokens 5406 5407 Out_Tok := Out_Tokens (Out_Index); 5408 Prev_Tok := Out_Tokens (Out_Index - 1); 5409 Prev_Prev_Tok := Out_Tokens (Out_Index - 2); 5410 loop 5411 Move_Forward (Out_Buf); 5412 exit when At_Point (Out_Buf, Out_Tok.Sloc.Lastx); 5413 end loop; 5414 5415 if Out_Tok.Text = Name_Semicolon 5416 and then Prev_Tok.Normalized = Snames.Name_Page 5417 and then Prev_Prev_Tok.Normalized = Snames.Name_Pragma 5418 then 5419 Insert_Any (Out_Buf, W_FF); 5420 end if; 5421 end loop; 5422 Reset (Out_Buf); 5423 end Insert_Form_Feeds; 5424 5425 procedure Copy_Pp_Off_Regions; 5426 -- Out_Buf is fully formatted at this point, including regions where pretty 5427 -- printing is supposed to be turned off. This replaces those regions of 5428 -- Out_Buf with the corresponding regions of Src_Buf. 5429 -- Note that this destroys any markers that might be pointing to Out_Buf 5430 5431 procedure Copy_Pp_Off_Regions is 5432 -- The Src_Buf contains a sequence of zero or more OFF and ON 5433 -- commands. The first must be OFF, then ON, then OFF and so on, 5434 -- alternating. If that weren't true, we would have gotten an error in 5435 -- Insert_Comments_And_Blank_Lines, in which case we don't get here. 5436 -- The final End_Of_Input acts as an ON or OFF as appropriate. 5437 -- The Out_Buf contains a corresponding sequence with the same 5438 -- number of OFF's and ON's. 5439 5440 -- Pretty printing is ON between the beginning and the first OFF, then 5441 -- OFF until the next ON, and so on. 5442 5443 use Scanner; 5444 5445 New_Buf : Buffer; 5446 -- Buffers don't support deletion, so we need to build up a whole new 5447 -- Buffer. This will be moved into Out_Buf when we are done. 5448 5449 procedure Get_Next_Off_On 5450 (Tokens : Token_Vector; 5451 Index : in out Token_Index; 5452 Tok, Prev_Tok : out Token; 5453 Expect : Pp_Off_On_Comment); 5454 -- Get the next OFF or ON (or End_Of_Input). The index of that token in 5455 -- Tokens is returned in Index. The token itself is returned in Tok. The 5456 -- token before Tok is Prev_Tok, which is necessarily an End_Of_Line or 5457 -- New_Line. Expect is purely for assertions; it alternates between OFF 5458 -- and ON; Tok must be as expected (or End_Of_Input). 5459 5460 procedure Copy (Buf : in out Buffer; Up_To : Marker); 5461 -- Copy from Buf to New_Buf, up to the given marker. 5462 5463 procedure Skip (Buf : in out Buffer; Up_To : Marker); 5464 -- Move forward in Buf, up to the given marker, ignoring the characters. 5465 5466 procedure Get_Next_Off_On 5467 (Tokens : Token_Vector; 5468 Index : in out Token_Index; 5469 Tok, Prev_Tok : out Token; 5470 Expect : Pp_Off_On_Comment) is 5471 begin 5472 loop 5473 Index := Index + 1; 5474 Tok := Tokens (Index); 5475 exit when Tok.Kind in Pp_Off_On_Comment | End_Of_Input; 5476 end loop; 5477 Prev_Tok := Tokens (Index - 1); 5478 pragma Assert (Tok.Kind in Expect | End_Of_Input); 5479 pragma Assert 5480 (Prev_Tok.Kind in Start_Of_Input | End_Of_Line | Blank_Line); 5481 end Get_Next_Off_On; 5482 5483 procedure Copy (Buf : in out Buffer; Up_To : Marker) is 5484 begin 5485 while not At_Point (Buf, Up_To) loop 5486 Insert_Any (New_Buf, Cur (Buf)); 5487 Move_Forward (Buf); 5488 end loop; 5489 end Copy; 5490 5491 procedure Skip (Buf : in out Buffer; Up_To : Marker) is 5492 begin 5493 while not At_Point (Buf, Up_To) loop 5494 Move_Forward (Buf); 5495 end loop; 5496 end Skip; 5497 5498 Src_Index, Out_Index : Token_Index := 1; 5499 5500 Src_Tok, Out_Tok, Prev_Tok : Token; 5501 5502 Src_Toks : Token_Vector; 5503 -- Note that we don't use Src_Tokens (the one in Ada_Trees.Formatting). 5504 -- We don't want to destroy that one with Ignore_Single_Line_Breaks => 5505 -- False. 5506 5507 -- Start of processing for Copy_Pp_Off_Regions 5508 5509 begin 5510 -- Optimize by skipping this phase if there are no Pp_Off_Comments 5511 if not Pp_Off_Present then 5512 return; 5513 end if; 5514 5515 -- We need to see End_Of_Line tokens, because when we see an OFF, we 5516 -- want to copy/ignore starting at the beginning of the line on which 5517 -- the OFF appears. For an ON, we ignore the Prev_Tok. 5518 5519 Get_Tokens (Src_Buf, Src_Toks, Pp_Off_On_Delimiters, 5520 Ignore_Single_Line_Breaks => False); 5521 Get_Tokens (Out_Buf, Out_Tokens, Pp_Off_On_Delimiters, 5522 Ignore_Single_Line_Breaks => False); 5523 if Debug_Mode then 5524 Dbg_Out.Put ("Copy_Pp_Off_Regions: Src_Toks:\n"); 5525 Put_Tokens (Src_Toks); 5526 Dbg_Out.Put ("end Src_Toks:\n"); 5527 Dbg_Out.Put ("Copy_Pp_Off_Regions: Out_Tokens:\n"); 5528 Put_Tokens (Out_Tokens); 5529 Dbg_Out.Put ("end Out_Tokens:\n"); 5530 end if; 5531 5532 -- The following loop repeatedly copies an ON region from Out_Buf to 5533 -- New_Buf (ignoring the corresponding region of Src_Buf), then copies 5534 -- an OFF region from Src_Buf to New_Buf (ignoring the corresponding 5535 -- region of Out_Buf). 5536 5537 loop 5538 Get_Next_Off_On 5539 (Out_Tokens, Out_Index, Out_Tok, Prev_Tok => Prev_Tok, 5540 Expect => Pp_Off_Comment); 5541 Copy (Out_Buf, Up_To => Prev_Tok.Sloc.Lastx); 5542 Get_Next_Off_On (Src_Toks, Src_Index, Src_Tok, Prev_Tok, 5543 Expect => Pp_Off_Comment); 5544 Skip (Src_Buf, Up_To => Prev_Tok.Sloc.Lastx); 5545 5546 pragma Assert 5547 ((Out_Tok.Kind = End_Of_Input) = (Src_Tok.Kind = End_Of_Input)); 5548 exit when Out_Tok.Kind = End_Of_Input; 5549 5550 Get_Next_Off_On (Src_Toks, Src_Index, Src_Tok, Prev_Tok, 5551 Expect => Pp_On_Comment); 5552 Copy (Src_Buf, Up_To => Src_Tok.Sloc.Lastx); 5553 Get_Next_Off_On (Out_Tokens, Out_Index, Out_Tok, Prev_Tok, 5554 Expect => Pp_On_Comment); 5555 Skip (Out_Buf, Up_To => Out_Tok.Sloc.Lastx); 5556 5557 pragma Assert 5558 ((Out_Tok.Kind = End_Of_Input) = (Src_Tok.Kind = End_Of_Input)); 5559 exit when Out_Tok.Kind = End_Of_Input; 5560 end loop; 5561 5562 Reset (Src_Buf); 5563 Reset (Out_Buf); 5564 Reset (New_Buf); 5565 5566 Move (Target => Out_Buf, Source => New_Buf); 5567 end Copy_Pp_Off_Regions; 5568 5569 procedure Assert_No_Trailing_Blanks (S : W_Str) is 5570 begin 5571 pragma Assert (S'First = 1); 5572 for X in 2 .. S'Last loop 5573 pragma Assert (if S (X) /= ' ' then not Is_Space (S (X))); 5574 if S (X) = NL then 5575 pragma Assert (S (X - 1) /= ' '); 5576 end if; 5577 end loop; 5578 pragma Assert (S (S'Last) = NL); 5579 end Assert_No_Trailing_Blanks; 5580 5581 function Replacements (T : Ada_Template) return Ada_Template; 5582 5583 function Replacements (T : Ada_Template) return Ada_Template is 5584 Temp : W_Str_Access := new W_Str'(W_Str (T)); 5585 begin 5586 -- Replacements inserting soft line breaks 5587 5588 Temp := Replace_All (Temp, "? @(~; ~)~", "?[@ (~;@ ~)]~"); 5589 Temp := Replace_All (Temp, "? @(~, ~)~", "?[@ (~,@ ~)]~"); 5590 Temp := Replace_All (Temp, "? := ~~~", "? :=[@ ~~]~"); 5591 Temp := Replace_All (Temp, " renames !", " renames[@ !]"); 5592 -- ???Should be a weaker @, at least for function renamings. 5593 Temp := Replace_All (Temp, "? and ~ and ~~", "? and[@ ~ and@ ~]~"); 5594 Temp := Replace_All (Temp, " => !", " =>[@ !]"); 5595 5596 -- Replacements inserting tabs 5597 5598 Temp := Replace_All (Temp, "=>", "^=>"); 5599 Temp := 5600 Replace_All 5601 (Temp, 5602 "?~, ~~ :? ~~~ !? :=[@ ~~]~", 5603 "?~, ~~ ^:? ~~~ !? ^2:=[@ ~~]~"); 5604 Temp := 5605 Replace_All 5606 (Temp, 5607 "?~, ~~ :? ~~~ constant !? :=[@ ~~]~", 5608 "?~, ~~ ^:? ~~~ constant !? ^2:=[@ ~~]~"); 5609 -- This doesn't cover A_Parameter_Specification, which is handled 5610 -- specially by Do_Parameter_Specification. 5611 5612 -- Replacements inserting soft line breaks in comma-separated lists of 5613 -- defining identifiers. 5614 5615 Temp := Replace_All (Temp, "?~, ~~ ^:", "?~,@ ~~ ^:"); 5616 -- Note @ without [] 5617 5618 -- Replacements for --no-separate-is 5619 5620 if not Options.Separate_Line_For_IS then 5621 Temp := Replace_All (Temp, "@ is", " is"); 5622 end if; 5623 5624 -- If the --no-end-id switch was given, do not insert names after "end" 5625 -- during the Convert_Tree_To_Ada pass. Instead, insert them during 5626 -- Insert_Comments_And_Blank_Lines, and only if they are present in the 5627 -- source. 5628 5629 if not Options.End_Id then 5630 Temp := Replace_All (Temp, "end !1", "end"); 5631 Temp := Replace_All (Temp, "end !2", "end"); 5632 Temp := Replace_All (Temp, "end?1 ~~~", "end"); 5633 Temp := Replace_All (Temp, "end?2 ~~~", "end"); 5634 Temp := Replace_All (Temp, "end?3 ~~~", "end"); 5635 end if; 5636 5637 return Result : constant Ada_Template := Ada_Template (Temp.all) do 5638 Free (Temp); 5639 end return; 5640 end Replacements; 5641 5642 procedure Free is new Unchecked_Deallocation 5643 (Ada_Template, Ada_Template_Ptr); 5644 5645 procedure Replace_One (Kind : Ada_Tree_Kind; From, To : W_Str); 5646 -- Replace From with To in the template for Kind 5647 5648 procedure Replace_One (Kind : Ada_Tree_Kind; From, To : W_Str) is 5649 Temp : Ada_Template_Ptr := Template_Table (Kind); 5650 begin 5651 Template_Table (Kind) := 5652 new Ada_Template'(Ada_Template 5653 (Must_Replace (W_Str (Temp.all), From, To))); 5654 Free (Temp); 5655 end Replace_One; 5656 5657 procedure Init_Template_Table is 5658 begin 5659 pragma Assert (not Template_Table_Initialized); 5660 Template_Table_Initialized := True; 5661 5662 -- We can't initialize Template_Table with an aggregate, because we 5663 -- refer to the Kind. The following case-within-loop construction may 5664 -- look odd, but it accomplishes two goals: the 'case' requires full 5665 -- coverage, so the items left null are done so explicitly, and the 5666 -- 'for' provides the Kind value to each sub-case that needs it. 5667 -- The 'case' we're talking about is in Template_For_Kind. 5668 5669 for Kind in Ada_Tree_Kind loop 5670 declare 5671 Temp : Ada_Template_Ptr := Template_For_Kind (Kind); 5672 begin 5673 if Temp = null then 5674 Template_Table (Kind) := null; 5675 else 5676 Template_Table (Kind) := 5677 new Ada_Template' 5678 (Munge_Template (Replacements (Temp.all), Kind)); 5679 Free (Temp); 5680 end if; 5681 end; 5682 end loop; 5683 5684 -- Some more-specific replacements 5685 5686 -- For Separate_Line_For_THEN_and_LOOP, we want a hard line break before 5687 -- "then" and "loop". 5688 5689 if Options.Separate_Line_For_THEN_and_LOOP then 5690 Replace_One (An_If_Path, "@ then$", "$then$"); 5691 Replace_One (An_Elsif_Path, "@ then$", "$then$"); 5692 Replace_One (A_While_Loop_Statement, "@ loop$", "$loop$"); 5693 Replace_One (A_For_Loop_Statement, "@ loop$", "$loop$"); 5694 5695 -- For No_Separate_Line_For_THEN_and_LOOP, we remove the soft line break 5696 -- before "then" and "loop". 5697 5698 elsif Options.No_Separate_Line_For_THEN_and_LOOP then 5699 Replace_One (An_If_Path, "@ then$", " then$"); 5700 Replace_One (An_Elsif_Path, "@ then$", " then$"); 5701 Replace_One (A_While_Loop_Statement, "@ loop$", " loop$"); 5702 Replace_One (A_For_Loop_Statement, "@ loop$", " loop$"); 5703 end if; 5704 5705 -- Now do some validity checking on the templates 5706 5707 for Kind in Ada_Tree_Kind loop 5708 declare 5709 T : constant Ada_Template_Ptr := Template_Table (Kind); 5710 5711 begin 5712 if T /= null then 5713 declare 5714 subtype Constrained_Query_Count is 5715 Query_Count range 0 .. Num_Queries (Kind); 5716 Subtree_Count : Query_Count := 0; 5717 5718 begin 5719 for J in T'Range loop 5720 case T (J) is 5721 when '!' | '?' => 5722 if J < T'Last and then T (J + 1) in '1' .. '9' then 5723 pragma Assert 5724 (Query_Index (Char_To_Digit (T (J + 1))) in 5725 Constrained_Query_Count); 5726 5727 else 5728 Subtree_Count := Subtree_Count + 1; 5729 end if; 5730 5731 -- ??? "{" is always preceded by "$"; we might want a 5732 -- short-hand for "${". 5733 5734 when '{' => 5735 pragma Assert (T (J - 1) = '$'); 5736 5737 when others => 5738 null; 5739 end case; 5740 end loop; 5741 5742 if Subtree_Count /= Constrained_Query_Count'Last then 5743 raise Program_Error 5744 with "Wrong Subtree_Count: " & Kind'Img; 5745 end if; 5746 end; 5747 end if; 5748 end; 5749 end loop; 5750 5751 if Debug_Mode then 5752 Put_Ada_Templates; 5753 end if; 5754 end Init_Template_Table; 5755 5756 procedure Init_Pp_Off_And_On is 5757 use Scanner; 5758 begin 5759 if Options.Pp_Off_String /= null then 5760 pragma Assert (Options.Pp_Off_String.all /= ""); 5761 Pp_Off_On_Delimiters.Off := new W_Str' 5762 ("--" & To_Wide_String (Options.Pp_Off_String.all)); 5763 end if; 5764 if Options.Pp_On_String /= null then 5765 pragma Assert (Options.Pp_On_String.all /= ""); 5766 Pp_Off_On_Delimiters.On := new W_Str' 5767 ("--" & To_Wide_String (Options.Pp_On_String.all)); 5768 end if; 5769 end Init_Pp_Off_And_On; 5770 5771 procedure Do_Comments_Only; 5772 -- Implement the --comments-only switch. This skips most of the usual 5773 -- pretty-printing passes, and just formats comments. 5774 5775 procedure Do_Comments_Only is 5776 use Scanner; 5777 Src_Toks : Token_Vector; 5778 Cur_Token_Index : Token_Index := 2; -- skip sentinel 5779 function Cur_Tok return Token is (Src_Toks (Cur_Token_Index)); 5780 5781 procedure Assert; 5782 -- If Comments_Only is True, but Comment_Filling_Enabled and 5783 -- GNAT_Comment_Start are both False, then the input and output should 5784 -- be identical. So assert. 5785 5786 procedure Assert is 5787 begin 5788 if Comment_Filling_Enabled or else Options.GNAT_Comment_Start then 5789 return; 5790 end if; 5791 5792 -- Slice removes the extra leading NL 5793 5794 if Slice (Out_Buf, 2, Last_Position (Out_Buf)) /= 5795 To_W_Str (Src_Buf) 5796 then 5797 ASIS_UL.Dbg_Out.Output_Enabled := True; 5798 Text_IO.Put_Line ("Src_Buf:"); 5799 Dump_Buf (Src_Buf); 5800 Text_IO.Put_Line ("Out_Buf:"); 5801 Dump_Buf (Out_Buf); 5802 pragma Assert (False); 5803 end if; 5804 end Assert; 5805 5806 -- Start of processing for Do_Comments_Only 5807 5808 begin 5809 Get_Tokens (Src_Buf, Src_Toks, Pp_Off_On_Delimiters, 5810 Ignore_Single_Line_Breaks => False); 5811 Insert_NL (Out_Buf); 5812 5813 while Cur_Tok.Kind /= End_Of_Input loop 5814 if Cur_Tok.Kind in Comment_Kind then 5815 -- Set Cur_Indentation to the number of spaces to be inserted 5816 -- before "--". For whole-line comments, that's one less than the 5817 -- starting column. For end-of-line comments, it's the number of 5818 -- blanks between the last character of the previous token to the 5819 -- first character of this (comment) token. 5820 5821 case Comment_Kind'(Cur_Tok.Kind) is 5822 when Whole_Line_Comment => 5823 Cur_Indentation := Cur_Tok.Sloc.Col - 1; 5824 when End_Of_Line_Comment => 5825 Cur_Indentation := 5826 Cur_Tok.Sloc.First - 5827 Src_Toks (Cur_Token_Index - 1).Sloc.Last - 5828 1; 5829 when others => null; 5830 end case; 5831 5832 Insert_Comment_Text (Cur_Tok); 5833 Cur_Indentation := 0; 5834 end if; 5835 5836 loop 5837 if Cur_Tok.Kind not in Comment_Kind then 5838 Insert_Any (Out_Buf, Cur (Src_Buf)); 5839 end if; 5840 Move_Forward (Src_Buf); 5841 exit when At_Point (Src_Buf, Cur_Tok.Sloc.Lastx); 5842 end loop; 5843 5844 Cur_Token_Index := Cur_Token_Index + 1; 5845 end loop; 5846 5847 pragma Assert (At_End (Src_Buf)); 5848 Reset (Src_Buf); 5849 Reset (Out_Buf); 5850 5851 pragma Debug (Assert); 5852 Final_Check; 5853 5854 Write_Out_Buf; 5855 end Do_Comments_Only; 5856 5857 use Scanner; 5858-- use all type Token_Vector; 5859 5860-- Start of processing for Tree_To_Ada 5861 5862begin 5863 if Debug_Mode then 5864 ASIS_UL.Dbg_Out.Output_Enabled := True; 5865 end if; 5866 5867 if not Template_Table_Initialized then 5868 Init_Template_Table; 5869 Init_Pp_Off_And_On; 5870 end if; 5871 5872 -- Note that if we're processing multiple files, we will get here multiple 5873 -- times, so we need to clear out data structures left over from last time. 5874 5875 pragma Assert (Cur_Indentation = 0); 5876 Clear (All_Line_Breaks); 5877 Clear (Tabs); 5878 5879 Get_Tokens (Src_Buf, Src_Tokens, Pp_Off_On_Delimiters); 5880 if Debug_Mode then 5881 Dbg_Out.Put ("Src_Tokens:\n"); 5882 Put_Tokens (Src_Tokens); 5883 Dbg_Out.Put ("end Src_Tokens:\n"); 5884 end if; 5885 5886 Clear (Out_Buf); 5887 5888 -- If --comments-only was specified, format the comments and quit 5889 5890 if Options.Comments_Only then 5891 Do_Comments_Only; 5892 return; 5893 end if; 5894 5895 -- The major passes: 5896 5897 Convert_Tree_To_Ada (Root); 5898 5899 Split_Lines (First_Time => True); 5900 5901 Insert_Comments_And_Blank_Lines; 5902 5903 Split_Lines (First_Time => False); 5904 5905 Insert_NLs_And_Indentation; 5906 5907 Insert_Alignment (Tokens => Out_Tokens); 5908 5909 Keyword_Casing; 5910 5911 Insert_Form_Feeds; 5912 5913 Copy_Pp_Off_Regions; 5914 5915 -- The following pass doesn't modify anything; it just checks that the 5916 -- sequence of tokens we have constructed matches the original source 5917 -- code (with some allowed exceptions). 5918 5919 Final_Check; 5920 5921 -- Finally, print out the result to Current_Output 5922 5923 Write_Out_Buf; 5924 5925exception 5926 -- If we got an error, don't produce output 5927 5928 when Common.Fatal_Error => 5929 raise; 5930 5931 when others => 5932 -- In order to avoid damaging the user's source code, if there is a bug 5933 -- (like a token mismatch in Final_Check), we avoid writing the output 5934 -- file in Do_Diff mode; otherwise, we write the input to the output 5935 -- unchanged. This happens only in production builds. 5936 5937 if Enable_Token_Mismatch then 5938 raise; 5939 else 5940 if Do_Diff then 5941 Output_Written := False; 5942 else 5943 if not At_Beginning (Src_Buf) then 5944 while not At_End (Src_Buf) loop 5945 Move_Forward (Src_Buf); 5946 end loop; 5947 Reset (Src_Buf); 5948 end if; 5949 5950 Write_Src_Buf; 5951 end if; 5952 end if; 5953end Tree_To_Ada; 5954