1------------------------------------------------------------------------------- 2-- 3-- This file is part of AdaBrowse. 4-- 5-- <STRONG>Copyright (c) 2002 by Thomas Wolf.</STRONG> 6-- <BLOCKQUOTE> 7-- AdaBrowse is free software; you can redistribute it and/or modify it 8-- under the terms of the GNU General Public License as published by the 9-- Free Software Foundation; either version 2, or (at your option) any 10-- later version. AdaBrowse is distributed in the hope that it will be 11-- useful, but <EM>without any warranty</EM>; without even the implied 12-- warranty of <EM>merchantability or fitness for a particular purpose.</EM> 13-- See the GNU General Public License for more details. You should have 14-- received a copy of the GNU General Public License with this distribution, 15-- see file "<A HREF="GPL.txt">GPL.txt</A>". If not, write to the Free 16-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, 17-- USA. 18-- </BLOCKQUOTE> 19-- 20-- <DL><DT><STRONG> 21-- Author:</STRONG><DD> 22-- Thomas Wolf (TW) 23-- <ADDRESS><A HREF="mailto:twolf@acm.org">twolf@acm.org</A></ADDRESS></DL> 24-- 25-- <DL><DT><STRONG> 26-- Purpose:</STRONG><DD> 27-- Traversal of the ASIS tree and HTML generation.</DL> 28-- 29-- <!-- 30-- Revision History 31-- 32-- 02-FEB-2002 TW First release. 33-- 07-FEB-2002 TW Finally got the renaming unwinding for renamed 34-- exceptions to work. It appears that ASIS-for-GNAT 3.14p 35-- has another bug in 'Corresponding_Base_Entity', which 36-- makes it not work across generic instantiations. 37-- 12-FEB-2002 TW First version completely taking apart the source, i.e., 38-- it splits everything into a sequence of items and 39-- then processes that instead of just traversing the 40-- whole tree and writing out everything plus everything 41-- between the last source chunk written and the current 42-- source chunk. 43-- 17-FEB-2002 TW Added indices and grouping together of items. AdaBrowse 44-- now writes any rep clauses or pragmas right after the 45-- item they refer to. 46-- 18-FEB-2002 TW Corrected a rather nasty and hard-to-find bug in the 47-- generation of cross-refs for entities within formal 48-- packages. 49-- 20-FEB-2002 TW Moved all the 'Write*' procedures to new package 50-- AD.Writers. 51-- 26-FEB-2002 TW Added handling for incomplete type declarations in 52-- writing the type summary. Also added the cross-ref from 53-- the incomplete declaration to the full declaration. 54-- 04-MAR-2002 TW Added another work-around for a bug in ASIS-for-GNAT, 55-- which sometimes returns only the last name component 56-- for child units that are subprogram instantiations. 57-- 03-APR-2002 TW Makes now entries for type and procedure indices. 58-- 26-APR-2002 TW Work-around for ASIS-for-GNAT bug in generic parameter 59-- associations. 60-- 30-APR-2002 TW Uses new AD.Format to emit formatted comments now. 61-- 22-NOV-2002 TW Added support for AD.Options.Private_Too. 62-- 30-MAY-2003 TW Added handling of private library units. (Until now, the 63-- "private" was missing in the output!) 64-- 04-JUN-2003 TW Regularized handling of private parts. (The "-private" 65-- option now applies to task and protected types, too.) 66-- 30-JUN-2003 TW New index management. 67-- 08-JUL-2003 TW Added support for special crossrefs and indices to 68-- pragmas and rep clauses. 69-- --> 70------------------------------------------------------------------------------- 71 72pragma License (GPL); 73 74with Ada.Exceptions; 75with Ada.Strings.Wide_Unbounded; 76 77with Asis.Iterator; 78pragma Elaborate_All (Asis.Iterator); 79with Asis.Compilation_Units; 80with Asis.Declarations; 81with Asis.Elements; 82with Asis.Expressions; 83with Asis.Text; 84 85with Asis2.Container_Elements; 86with Asis2.Declarations; 87with Asis2.Naming; 88with Asis2.Spans; 89with Asis2.Text; 90 91with AD.Crossrefs; 92with AD.Descriptions; 93with AD.Filters; 94with AD.Indices; 95with AD.Item_Lists; 96with AD.Messages.Inline; 97with AD.Options; 98with AD.Predicates; 99with AD.Queries; 100with AD.Text_Utilities; 101with AD.Writers; 102 103with GAL.Sorting; 104with GAL.Support; 105 106package body AD.Scanner is 107 108 package A_D renames Asis.Declarations; 109 package A_T renames Asis.Text; 110 111 package WASU renames Ada.Strings.Wide_Unbounded; 112 113 use AD.Descriptions; 114 use AD.Item_Lists; 115 use AD.Printers; 116 use AD.Text_Utilities; 117 use AD.Writers; 118 119 use Asis; 120 use Asis.Compilation_Units; 121 use Asis.Declarations; 122 use Asis.Elements; 123 use Asis.Expressions; 124 use Asis.Text; 125 126 use Asis2.Naming; 127 use Asis2.Spans; 128 129 ---------------------------------------------------------------------------- 130 131 function Smaller_Name 132 (Left, Right : in Asis.Declaration) 133 return Boolean 134 is 135 L : constant Defining_Name := Get_Name (Left); 136 R : constant Defining_Name := Get_Name (Right); 137 138 L_S : constant Wide_String := 139 Asis2.Text.To_Lower (Name_Definition_Image (L)); 140 R_S : constant Wide_String := 141 Asis2.Text.To_Lower (Name_Definition_Image (R)); 142 143 begin 144 if L_S = R_S then 145 -- Sort by position! 146 return Start (Get_Span (L)) < Start (Get_Span (R)); 147 else 148 return L_S < R_S; 149 end if; 150 end Smaller_Name; 151 152 ---------------------------------------------------------------------------- 153 154 type Scan_State is new AD.Writers.Write_State with 155 record 156 Reporter : aliased AD.Messages.Inline.Error_Reporter; 157 Traverse_Top : Asis.Element := Nil_Element; 158 -- The top element in a traversal. We use this in 'Post_Visit' to 159 -- omit a newline on the very last line of an element. This helps 160 -- avoid unnecessary empty lines between an items. 161 end record; 162 163 -- Note: originally, I had a 'Traverse_Level : Natural' component that 164 -- counted the nesting depth within 'Traverse' (Inc in 'Pre', dec in 165 -- 'Post'). However, this turned out to fail for ASIS-for-GNAT 3.14p: in 166 -- a declaration, it would call only 'Pre' for the defining name, but 167 -- never call 'Post', with the result that I ended up with a nesting 168 -- depth of 1 at the very end, and thus couldn't reliably determine when 169 -- to omit that dreaded newline. Hence the above approach with storing the 170 -- whole element: if in 'Post' the current element equals 'Traverse_Top', 171 -- we're at the end. 172 -- 173 -- Note that the ASIS behavior of not calling 'Post' is not an error, it 174 -- is the defined behavior of Asis.Iterator.Traverse_Element! 'Pre' 175 -- handles the defining name by calling 'Handle_Defining_Name', which 176 -- sets the control to 'Abandon_Children', and in such a case, the 177 -- standard iterator doesn't call the corresponding 'Post'... I think this 178 -- is a lousy spec, but if it's the standard, I can't change it. 179 180 ---------------------------------------------------------------------------- 181 182 procedure Write_Comment 183 (Element : in Asis.Element; 184 Span : in A_T.Span; 185 State : in out Scan_State) 186 is 187 -- 'Span' comprises all comment lines. Starts at column 1 and ends 188 -- at the end of the last line. 189 begin 190 if Is_Nil (Span) then return; end if; 191 begin 192 AD.Printers.Write_Comment 193 (State.The_Printer, A_T.Lines (Element, Span)); 194 exception 195 when E : AD.Filters.Recursive_Expansion => 196 Ada.Exceptions.Raise_Exception 197 (AD.Filters.Recursive_Expansion'Identity, 198 Ada.Exceptions.Exception_Message (E) & 199 " (in comment from lines" & 200 Asis.Text.Line_Number'Image (Span.First_Line) & " to" & 201 Asis.Text.Line_Number'Image (Span.Last_Line) & ") in unit " & 202 To_String 203 (Full_Unit_Name 204 (Enclosing_Compilation_Unit (State.Unit)))); 205 end; 206 end Write_Comment; 207 208 procedure Write_Comments 209 (Element : in Asis.Element; 210 List : in Comment_Ptr; 211 State : in out Scan_State) 212 is 213 P : Comment_Ptr := List; 214 begin 215 while P /= null loop 216 Write_Comment (Element, P.Span, State); 217 P := P.Next; 218 end loop; 219 end Write_Comments; 220 221 ---------------------------------------------------------------------------- 222 223 procedure Handle_Defining_Name 224 (Element : in Declaration; 225 Control : in out Traverse_Control; 226 State : in out Scan_State; 227 Do_Anchor : in Boolean := True); 228 229 ---------------------------------------------------------------------------- 230 231 procedure Post_Visit 232 (Element : in Asis.Element; 233 Control : in out Traverse_Control; 234 State : in out Scan_State) 235 is 236 -- Write anything of that element that hasn't been written yet. 237 begin 238 if Control = Terminate_Immediately then null; end if; 239 -- The above if serves only to silence GNAT -gnatwa. 'Control' can never 240 -- be Terminate_Immediately here! 241 Write (Element, State); 242 if not Is_Equal (State.Traverse_Top, Element) then 243 Terminate_Line (State); 244 end if; 245 end Post_Visit; 246 247 procedure Pre_Visit 248 (Element : in Asis.Element; 249 Control : in out Traverse_Control; 250 State : in out Scan_State); 251 252 procedure Traverse is 253 new Asis.Iterator.Traverse_Element (Scan_State, Pre_Visit, Post_Visit); 254 -- Our main traversal routine, which does most of the job. We just handle 255 -- a few elements specially (anything that might deserve a cross-reference 256 -- or an anchor), the rest is just skipped. Note that we never see a 257 -- declaration in 'Traverse', these are handled explicitly in procedure 258 -- 'Handle_Declaration' below. We just use 'Traverse' to traverse and 259 -- crossref the contents of a declaration (or a pragma) itself. 260 261 procedure Pre_Visit 262 (Element : in Asis.Element; 263 Control : in out Traverse_Control; 264 State : in out Scan_State) 265 is 266 -- Handle anything that needs handling; just keep traversing for all 267 -- other elements. They'll be written eventually when the stuff before 268 -- some element we're handling is written (see AD.Writers), or in 269 -- 'Post_Visit' above. 270 begin 271 case Element_Kind (Element) is 272 when An_Expression => 273 case Expression_Kind (Element) is 274 when An_Identifier => 275 -- Only generate a cross-ref if it isn't the selector name 276 -- of a named parameter association. 277 declare 278 Cont : constant Asis.Element := 279 Enclosing_Element (Element); 280 begin 281 if Element_Kind (Cont) /= An_Association 282 or else 283 Association_Kind (Cont) /= A_Parameter_Association 284 or else 285 not Is_Equal (Element, Formal_Parameter (Cont)) 286 then 287 Write_Reference (Element, State); 288 Terminate_Line (State); 289 end if; 290 -- else don't do anything, it'll be written as part of 291 -- some 'Write_Before' call later on. 292 end; 293 294 when An_Operator_Symbol | 295 An_Enumeration_Literal => 296 Write_Reference (Element, State); 297 Terminate_Line (State); 298 299 when An_Attribute_Reference => 300 -- Needs to be handled separately because the attribute is 301 -- to be formatted specially. 302 Control := Continue; 303 Traverse (Prefix (Element), Control, State); 304 Write_Attribute 305 (Attribute_Designator_Identifier (Element), State); 306 Terminate_Line (State); 307 Control := Abandon_Children; 308 309 when A_Function_Call => 310 -- Need to handle function calls of dyadic operators that 311 -- are inlined (as in "A + B") specially. We traverse first 312 -- the function name ("+", in this case), and then the 313 -- parameters. But this screws up the text sequence! 314 if not Is_Prefix_Call (Element) and then 315 Expression_Kind (Prefix (Element)) = An_Operator_Symbol 316 then 317 -- Attention: In ASIS-for-GNAT 3.14p, Is_Prefix_Call 318 -- returns False for a unary operator as in "(- A)", 319 -- although that always is a prefix call! 320 -- 321 -- We therefore need to check the number of parameters 322 -- below, even though it should be clear that any 323 -- non-prefix call must have exactly two parameters! 324 declare 325 Params : constant Association_List := 326 Function_Call_Parameters (Element); 327 begin 328 if Params'Last = Params'First + 1 then 329 -- We have exactly two parameters! (And it can't 330 -- be a named notation, se we need only care about 331 -- the actual parameters.) 332 Control := Continue; 333 Traverse 334 (Actual_Parameter (Params (Params'First)), 335 Control, State); 336 Control := Continue; 337 Traverse (Prefix (Element), Control, State); 338 Control := Continue; 339 Traverse 340 (Actual_Parameter (Params (Params'First + 1)), 341 Control, State); 342 Control := Abandon_Children; 343 end if; 344 end; 345 end if; 346 347 when others => 348 null; 349 350 end case; 351 352 when A_Defining_Name => 353 -- Only generate an anchor if the defining name is not a 354 -- parameter name of some subprogram or entry! 355 declare 356 Decl : constant Asis.Element := 357 Asis2.Declarations.Enclosing_Declaration (Element); 358 begin 359 Handle_Defining_Name 360 (Element, Control, State, 361 Declaration_Kind (Decl) /= A_Parameter_Specification); 362 Terminate_Line (State); 363 end; 364 365 when An_Association => 366 case Association_Kind (Element) is 367 when A_Generic_Association => 368 -- Work-around for another ASIS-for-GNAT 3.14p bug: if 369 -- we let 'Traverse_Element' handle this itself, it 370 -- crashes sometimes!! So far observed only for one case 371 -- where the formal was an operator symbol, but just to be 372 -- on the safe side, we also guard the actual parameter. 373 Control := Continue; 374 declare 375 Formal : Asis.Element; 376 begin 377 begin 378 Formal := Formal_Parameter (Element); 379 exception 380 when others => 381 AD.Printers.Inline_Error 382 (State.The_Printer, 383 "ASIS crash on generic formal parameter!"); 384 Formal := Nil_Element; 385 end; 386 if not Is_Nil (Formal) then 387 Traverse (Formal, Control, State); 388 end if; 389 end; 390 Control := Continue; 391 declare 392 Actual : Asis.Expression; 393 begin 394 begin 395 Actual := Actual_Parameter (Element); 396 exception 397 when others => 398 AD.Printers.Inline_Error 399 (State.The_Printer, 400 "ASIS crash on generic actual parameter!"); 401 Actual := Nil_Element; 402 end; 403 if not Is_Nil (Actual) then 404 Traverse (Actual, Control, State); 405 end if; 406 end; 407 -- Note: even if ASIS crashes and we don't traverse part 408 -- of the association, its program text will still be 409 -- written in 'Post_Visit'. It just won't have cross- 410 -- references. 411 Control := Abandon_Children; 412 413 when others => 414 -- Nothing to do. 415 null; 416 end case; 417 418 when A_Pragma => 419 -- Generate an anchor... 420 Write_Special_Anchor (Element, State); 421 -- ...and then just continue... 422 423 when A_Clause => 424 case Representation_Clause_Kind (Element) is 425 when An_Attribute_Definition_Clause | 426 An_Enumeration_Representation_Clause | 427 A_Record_Representation_Clause => 428 Write_Special_Anchor (Element, State); 429 when others => 430 null; 431 end case; 432 433 when others => 434 -- Nothing to do. 435 null; 436 437 end case; 438 end Pre_Visit; 439 440 ---------------------------------------------------------------------------- 441 442 procedure Add_To_Index 443 (State : in out Scan_State; 444 Element : in Asis.Element; 445 Is_Private : in Boolean) 446 is 447 begin 448 case Element_Kind (Element) is 449 when A_Declaration => 450 if not Is_Private or else AD.Options.Private_Too then 451 -- Special cases for types. There can be some funny cases: 452 -- (1) An incomplete type declaration: if there's a full 453 -- declaration for it, don't do anything: we'll process 454 -- the full declaration later. If there's no full decl, 455 -- (implies 'Is_Private'), then do it. 456 -- (2) Is_Private is True and there's a public view of the 457 -- type: don't generate an index entry, we'll have one 458 -- for the public view already! 459 if Declaration_Kind (Element) = An_Incomplete_Type_Declaration 460 and then 461 not Is_Nil (Corresponding_Type_Declaration (Element)) 462 then 463 -- We have an incomplete type declaration, and there is 464 -- a full type declaration. Note that both the incomplete 465 -- and the full decl are either in the public or in the 466 -- private part. There cannot be an incomplete decl in 467 -- the public part, and the corresponding full decl in 468 -- the private part. 469 return; 470 elsif Is_Private and then AD.Predicates.Is_Type (Element) then 471 declare 472 Other : constant Declaration := 473 Corresponding_Type_Declaration (Element); 474 begin 475 if not Is_Nil (Other) and then 476 Declaration_Kind (Other) /= 477 An_Incomplete_Type_Declaration 478 then 479 -- We're in the private part, and there exists a 480 -- public view of the type. 481 return; 482 end if; 483 end; 484 end if; 485 declare 486 Names : constant Asis.Name_List := A_D.Names (Element); 487 XRef : AD.Crossrefs.Cross_Reference; 488 begin 489 for I in Names'Range loop 490 declare 491 Name : Asis.Defining_Name := Names (I); 492 begin 493 -- Special case for constants: if there is a 494 -- corresponding deferred constant declaration, 495 -- we'll already have an entry for that one, and we 496 -- thus skip this name. Note that we need to be in 497 -- the private part for all this to be true. 498 if Is_Private and then 499 Declaration_Kind (Element) = A_Constant_Declaration 500 and then 501 not Is_Nil 502 (Corresponding_Constant_Declaration (Name)) 503 then 504 -- Skip it! 505 null; 506 else 507 if Defining_Name_Kind (Name) = 508 A_Defining_Expanded_Name 509 then 510 Name := Defining_Selector (Name); 511 end if; 512 XRef := 513 AD.Crossrefs.Crossref_Name 514 (Name, State.Unit, State.Reporter'Access); 515 if XRef.Is_Top_Unit then 516 XRef.Image := XRef.Full_Unit_Name; 517 end if; 518 AD.Indices.Add (Name, XRef, Is_Private); 519 end if; 520 end; 521 end loop; 522 end; 523 end if; 524 when A_Pragma => 525 -- Why did I ever have the funny idea that somebody might want 526 -- a pragma index? 527 declare 528 XRef : AD.Crossrefs.Cross_Reference := 529 AD.Crossrefs.Crossref_Special (Element, State.Unit); 530 begin 531 AD.Indices.Add (Element, XRef, Is_Private); 532 end; 533 when A_Clause => 534 case Representation_Clause_Kind (Element) is 535 when An_Attribute_Definition_Clause | 536 An_Enumeration_Representation_Clause | 537 A_Record_Representation_Clause => 538 declare 539 XRef : AD.Crossrefs.Cross_Reference := 540 AD.Crossrefs.Crossref_Special (Element, State.Unit); 541 begin 542 AD.Indices.Add (Element, XRef, Is_Private); 543 end; 544 when others => 545 null; 546 end case; 547 when others => 548 null; 549 end case; 550 end Add_To_Index; 551 552 procedure Write_Item 553 (Items : in Item_Table; 554 Current : in Natural; 555 State : in out Scan_State; 556 Top_Level : in Boolean := False) 557 is 558 Null_Items : Item_Table (2 .. 1); 559 Index : Index_Table := 560 (1 => Current) & 561 Collect_Subordinates (Items, Null_Items, Items (Current).Sub); 562 Ctrl : Traverse_Control; 563 564 procedure XRef_Other_Decl 565 (Other : in Declaration; 566 State : in out Scan_State; 567 Text : in String) 568 is 569 begin 570 if not Is_Nil (Other) then 571 AD.Printers.Other_Declaration 572 (State.The_Printer, 573 AD.Crossrefs.Crossref_Name 574 (Get_Name (Other), State.Unit, State.Reporter'Access), 575 Text); 576 end if; 577 end XRef_Other_Decl; 578 579 begin 580 Sort_Subordinates (Index (Index'First + 1 .. Index'Last), 581 Items, Null_Items); 582 -- First the rep clauses, then the pragmas, both ordered by name. 583 AD.Printers.Open_Section (State.The_Printer, Snippet_Section); 584 for I in Index'Range loop 585 declare 586 Pos : Position := 587 Start (Get_Span (Items (Index (I)).Element)); 588 begin 589 if Pos.Line = 1 then Pos.Column := 1; end if; 590 State.Write_From := Pos; 591 State.Last_Written := (Pos.Line, Pos.Column - 1); 592 State.Indent := Pos.Column - 1; 593 end; 594 if I > Index'First then 595 -- Ok, the main item has been written. What follows are pragmas 596 -- and rep clauses, which we still need to add to the indices! 597 Add_To_Index 598 (State, 599 Items (Index (I)).Element, 600 Items (Index (Index'First)).Is_Private); 601 -- Yes, we take the 'Is_Private' flag from the main item! 602 end if; 603 -- if Top_Level then 604 -- Check_Private_Unit (State, Items (Index (I)).Element); 605 -- end if; 606 Ctrl := Continue; 607 State.Traverse_Top := Items (Index (I)).Element; 608 Traverse (Items (Index (I)).Element, Ctrl, State); 609 -- Try to generate a cross-reference to the full type declaration. 610 -- Note: if the element is not a declaration at all (but a pragma 611 -- or a rep clause), 'Declaration_Kind' will simply return 612 -- 'Not_A_Declaration' and *not* raise an exception. 613 case Declaration_Kind (Items (Index (I)).Element) is 614 when An_Incomplete_Type_Declaration => 615 XRef_Other_Decl 616 (Corresponding_Type_Declaration (Items (Index (I)).Element), 617 State, "Full declaration"); 618 619 when A_Private_Type_Declaration | 620 A_Private_Extension_Declaration => 621 if AD.Options.Private_Too then 622 XRef_Other_Decl 623 (Corresponding_Type_Declaration 624 (Items (Index (I)).Element), 625 State, "Full declaration"); 626 end if; 627 628 when An_Ordinary_Type_Declaration | 629 A_Task_Type_Declaration | 630 A_Protected_Type_Declaration => 631 declare 632 Other : constant Declaration := 633 Corresponding_Type_Declaration (Items (Index (I)).Element); 634 begin 635 if not Is_Nil (Other) then 636 if Declaration_Kind (Other) = 637 An_Incomplete_Type_Declaration 638 then 639 XRef_Other_Decl 640 (Other, State, "Incomplete declaration"); 641 elsif Items (Index (I)).Is_Private then 642 -- Actually, if it's not an incomplete declaration, 643 -- we should always be processing a full decl in the 644 -- private part! 645 XRef_Other_Decl 646 (Other, State, "Public view"); 647 end if; 648 end if; 649 end; 650 651 when others => 652 null; 653 654 end case; 655 if I < Index'Last then New_Line (State.The_Printer); end if; 656 end loop; 657 AD.Printers.Close_Section (State.The_Printer, Snippet_Section); 658 -- Then write any comments of these items: 659 declare 660 Have_Comments : Boolean := False; 661 From : Natural; 662 begin 663 if Top_Level then 664 From := Index'First + 1; 665 else 666 From := Index'First; 667 end if; 668 for I in From .. Index'Last loop 669 if Items (Index (I)).List /= null then 670 Have_Comments := True; exit; 671 end if; 672 end loop; 673 if Have_Comments then 674 AD.Printers.Open_Section (State.The_Printer, Description_Section); 675 for I in From .. Index'Last loop 676 Write_Comments 677 (Items (Index (I)).Element, 678 Items (Index (I)).List, State); 679 end loop; 680 AD.Printers.Close_Section (State.The_Printer, Description_Section); 681 end if; 682 end; 683 end Write_Item; 684 685 ---------------------------------------------------------------------------- 686 687 generic 688 with function Matches (Kind : in Declaration_Kinds) return Boolean; 689 function Extract_Declarations 690 (From : in Declarative_Item_List; 691 Sorted : in Boolean) 692 return Declarative_Item_List; 693 694 -- generic 695 -- with function Matches (Kind : in Declaration_Kinds) return Boolean; 696 function Extract_Declarations 697 (From : in Declarative_Item_List; 698 Sorted : in Boolean) 699 return Declarative_Item_List 700 is 701 Result : Declarative_Item_List (From'Range); 702 N : Natural := Result'First - 1; 703 704 procedure Sort is 705 new GAL.Sorting.Sort_G 706 (List_Index, Asis.Element, Declarative_Item_List, Smaller_Name); 707 708 begin 709 for I in From'Range loop 710 if Matches (Declaration_Kind (From (I))) then 711 N := N + 1; 712 Result (N) := From (I); 713 end if; 714 end loop; 715 if N > Result'First and then Sorted then 716 Sort (Result (Result'First .. N)); 717 end if; 718 return Result (Result'First .. N); 719 end Extract_Declarations; 720 721 ---------------------------------------------------------------------------- 722 723 procedure Handle_Children 724 (The_Unit : in Compilation_Unit; 725 State : in out Scan_State; 726 Table_Opened : in out Boolean) 727 is 728 -- Build and output an index of known child units of the top-level 729 -- libarary unit. 730 731 Children : Compilation_Unit_List := 732 Corresponding_Children (The_Unit); 733 734 function Smaller 735 (Left, Right : in Compilation_Unit) 736 return Boolean 737 is 738 begin 739 return Asis2.Text.To_Lower (Full_Unit_Name (Left)) < 740 Asis2.Text.To_Lower (Full_Unit_Name (Right)); 741 end Smaller; 742 743 procedure Sort is 744 new GAL.Sorting.Sort_G 745 (List_Index, Compilation_Unit, Compilation_Unit_List, Smaller); 746 747 procedure Swap is 748 new GAL.Support.Swap (Compilation_Unit); 749 750 N : Natural := 0; 751 I : Natural := 0; 752 753 begin -- Handle_Children 754 if Children'Last >= Children'First then 755 -- Attention, we have both specs and bodies here! First throw out the 756 -- bodies! 757 N := Children'Last; I := Children'First; 758 while I <= N loop 759 case Declaration_Kind (Unit_Declaration (Children (I))) is 760 when A_Package_Body_Declaration | 761 A_Procedure_Body_Declaration | 762 A_Function_Body_Declaration => 763 if I < N then 764 Swap (Children (I), Children (N)); 765 end if; 766 N := N - 1; 767 when others => 768 I := I + 1; 769 end case; 770 end loop; 771 -- If we had *only* bodies, give up. 772 if N < Children'First then return; end if; 773 -- The index is to be sorted alphabetically! 774 Sort (Children (Children'First .. N)); 775 if not Table_Opened then 776 AD.Printers.Open_Section (State.The_Printer, Content_Section); 777 Table_Opened := True; 778 end if; 779 AD.Printers.Open_Section (State.The_Printer, Children_Section); 780 for I in Children'First .. N loop 781 declare 782 Name : constant Defining_Name := 783 Get_Name (Unit_Declaration (Children (I))); 784 -- They're children, so they all are defining expanded names! 785 XRef : AD.Crossrefs.Cross_Reference := 786 AD.Crossrefs.Crossref_Name 787 (Defining_Selector (Name), 788 State.Unit, State.Reporter'Access); 789 begin 790 XRef.Image := 791 WASU.To_Unbounded_Wide_String (Name_Definition_Image (Name)); 792 AD.Printers.Add_Child 793 (State.The_Printer, 794 Get_Item_Kind (Unit_Declaration (Children (I))), 795 Unit_Class (Children (I)) = A_Private_Declaration, 796 XRef); 797 end; 798 end loop; 799 AD.Printers.Close_Section (State.The_Printer, Children_Section); 800 end if; 801 end Handle_Children; 802 803 ---------------------------------------------------------------------------- 804 805 procedure Handle_Clauses 806 (The_Unit : in Compilation_Unit; 807 State : in out Scan_State; 808 Item : in Item_Desc) 809 is 810 -- Write the context clauses in their own section. 811 812 Clauses : constant Context_Clause_List := 813 Context_Clause_Elements (The_Unit, True); 814 815 begin 816 if Clauses'Last < Clauses'First then return; end if; 817 AD.Printers.Open_Section (State.The_Printer, Dependencies_Section); 818 AD.Printers.Open_Section (State.The_Printer, Snippet_Section); 819 for I in Clauses'Range loop 820 declare 821 Ctrl : Traverse_Control := Continue; 822 begin 823 -- Never suppress any newlines: 824 State.Traverse_Top := Nil_Element; 825 Traverse (Clauses (I), Ctrl, State); 826 end; 827 end loop; 828 AD.Printers.Close_Section (State.The_Printer, Snippet_Section); 829 if Item.List /= null then 830 AD.Printers.Open_Section (State.The_Printer, Description_Section); 831 Write_Comments (Item.Element, Item.List, State); 832 AD.Printers.Close_Section (State.The_Printer, Description_Section); 833 end if; 834 AD.Printers.Close_Section (State.The_Printer, Dependencies_Section); 835 end Handle_Clauses; 836 837 ---------------------------------------------------------------------------- 838 -- Produce a cross-ref table of all objects of a given class declared in 839 -- the package. 840 841 procedure Handle_Objects 842 (Items : in out Item_Table; 843 Index : in out Index_Table; 844 Current : in out Natural; 845 State : in out Scan_State; 846 Class : in Item_Classes) 847 is 848 849 procedure Write_Object 850 (Items : in Item_Table; 851 Current : in Natural; 852 State : in out Scan_State) 853 is 854 Original : Scan_State := State; 855 begin 856 AD.Printers.Open_Item 857 (State.The_Printer, 858 AD.Crossrefs.Null_Crossref, 859 AD.Printers.Get_Item_Kind (Items (Current).Element)); 860 Write_Item (Items, Current, State); 861 AD.Printers.Close_Item (State.The_Printer); 862 State := Original; 863 end Write_Object; 864 865 N : Natural; 866 867 begin 868 N := Current; 869 while N <= Index'Last and then 870 Items (Index (N)).Class = Class and then 871 not Items (Index (N)).Is_Private 872 loop 873 N := N + 1; 874 end loop; 875 N := N - 1; 876 if N >= Current then 877 Sort_By_Name (Items, Index (Current .. N)); 878 if Class = Item_Constant then 879 AD.Printers.Open_Section (State.The_Printer, Constants_Section); 880 else 881 AD.Printers.Open_Section (State.The_Printer, Variables_Section); 882 end if; 883 for I in Current .. N loop 884 Add_To_Index 885 (State, 886 Items (Index (I)).Element, Items (Index (I)).Is_Private); 887 Write_Object (Items, Index (I), State); 888 Items (Index (I)).Done := True; 889 end loop; 890 if Class = Item_Constant then 891 AD.Printers.Close_Section (State.The_Printer, Constants_Section); 892 else 893 AD.Printers.Close_Section (State.The_Printer, Variables_Section); 894 end if; 895 Current := N + 1; 896 end if; 897 end Handle_Objects; 898 899 ---------------------------------------------------------------------------- 900 -- Produce a cross-ref table of all exceptions declared in the package. 901 902 procedure Handle_Exceptions 903 (Items : in out Item_Table; 904 Index : in out Index_Table; 905 Current : in out Natural; 906 State : in out Scan_State) 907 is 908 909 procedure Write_Exception 910 (Exc : in Item_Desc; 911 State : in out Scan_State) 912 is 913 914 function Unwind_Renames 915 (Decl : in Declaration) 916 return Asis.Element 917 is 918 -- Corresponding_Base_Entity sometimes returns an expression in 919 -- an implicit spec due to an instantiation, in which case things 920 -- get pretty hairy (see comment below). This routine never 921 -- returns implicit things, but always the expression from the 922 -- template. 923 D : Asis.Element := Decl; 924 B : Asis.Element; 925 begin 926 loop 927 B := Renamed_Entity (D); 928 D := Asis2.Declarations.Name_Definition (B); 929 if Is_Part_Of_Instance (D) then 930 -- Get the name in the template! 931 D := 932 Asis2.Declarations.Enclosing_Declaration 933 (AD.Queries.Expand_Generic (D, State.Reporter'Access)); 934 end if; 935 exit when 936 Declaration_Kind (D) /= An_Exception_Renaming_Declaration; 937 end loop; 938 return B; 939 end Unwind_Renames; 940 941 Original : Scan_State := State; 942 943 begin 944 AD.Printers.Open_Section (State.The_Printer, Exception_Section); 945 declare 946 Names : constant Name_List := A_D.Names (Exc.Element); 947 begin 948 for I in Names'Range loop 949 AD.Printers.Add_Exception 950 (State.The_Printer, 951 AD.Crossrefs.Crossref_Name 952 (Names (I), State.Unit, State.Reporter'Access)); 953 end loop; 954 end; 955 if Declaration_Kind (Exc.Element) = 956 An_Exception_Renaming_Declaration 957 then 958 declare 959 Direct_Rename : constant Asis.Expression := 960 Renamed_Entity (Exc.Element); 961 Ctrl : Traverse_Control := Continue; 962 begin 963 State.Write_From := 964 Start (Get_Span (Direct_Rename)); 965 if not Is_Nil (State.Write_From) then 966 State.Last_Written := 967 (State.Write_From.Line, 968 State.Write_From.Column - 1); 969 AD.Printers.Open_Section 970 (State.The_Printer, Exception_Rename_Section); 971 -- Never generate a newline: 972 State.Traverse_Top := Direct_Rename; 973 Traverse (Direct_Rename, Ctrl, State); 974 AD.Printers.Close_Section 975 (State.The_Printer, Exception_Rename_Section); 976 declare 977 Ultimately : constant Asis.Element := 978 Unwind_Renames (Exc.Element); 979 -- Corresponding_Base_Entity may return an expression 980 -- in an implicit generic spec due to an instantiation, 981 -- and to get the true element from the generic template, 982 -- we'd have to go out of our way an first find the 983 -- declaration containing the expression, and then do 984 -- Renamed_Entity (Enclosing_Declaration 985 -- (Expand_Generic (Get_Name (Decl)))). 986 -- It took me a while to figure that one out, and in the 987 -- meantime, I already had 'Unwind_Renames' written, so 988 -- I prefer to stick with my own routine. 989 begin 990 if not Is_Equal (Ultimately, Direct_Rename) then 991 State.Write_From := 992 Start (Get_Span (Ultimately)); 993 if not Is_Nil (State.Write_From) then 994 State.Last_Written := 995 (State.Write_From.Line, 996 State.Write_From.Column - 1); 997 -- The text may be in some other unit! 998 State.Unit := 999 Unit_Declaration 1000 (Enclosing_Compilation_Unit (Ultimately)); 1001 AD.Printers.Open_Section 1002 (State.The_Printer, Ultimate_Exception_Section); 1003 Ctrl := Continue; 1004 -- Never generate a newline: 1005 State.Traverse_Top := Ultimately; 1006 Traverse (Ultimately, Ctrl, State); 1007 AD.Printers.Close_Section 1008 (State.The_Printer, Ultimate_Exception_Section); 1009 end if; 1010 end if; 1011 end; 1012 end if; 1013 end; 1014 end if; 1015 State := Original; 1016 if Exc.List /= null then 1017 AD.Printers.Open_Section (State.The_Printer, Description_Section); 1018 Write_Comments (Exc.Element, Exc.List, State); 1019 AD.Printers.Close_Section (State.The_Printer, Description_Section); 1020 end if; 1021 AD.Printers.Close_Section (State.The_Printer, Exception_Section); 1022 State := Original; 1023 end Write_Exception; 1024 1025 N : Natural; 1026 1027 begin 1028 N := Current; 1029 while N <= Index'Last and then 1030 Items (Index (N)).Class = Item_Exception and then 1031 not Items (Index (N)).Is_Private 1032 loop 1033 N := N + 1; 1034 end loop; 1035 -- Only visible ones! 1036 N := N - 1; 1037 if N >= Current then 1038 Sort_By_Name (Items, Index (Current .. N)); 1039 AD.Printers.Open_Section (State.The_Printer, Exceptions_Section); 1040 for I in Current .. N loop 1041 Add_To_Index 1042 (State, 1043 Items (Index (I)).Element, Items (Index (I)).Is_Private); 1044 Write_Exception (Items (Index (I)), State); 1045 Items (Index (I)).Done := True; 1046 end loop; 1047 AD.Printers.Close_Section (State.The_Printer, Exceptions_Section); 1048 Current := N + 1; 1049 end if; 1050 end Handle_Exceptions; 1051 1052 ---------------------------------------------------------------------------- 1053 -- Produce a cross-ref table of all types declared in the package. 1054 1055 Translation : constant array (AD.Queries.Operation_Kind) of 1056 AD.Printers.Operation_Kind := 1057 (AD.Queries.Overridden_Operation => 1058 AD.Printers.Overridden_Operation, 1059 AD.Queries.New_Operation => 1060 AD.Printers.Own_Operation, 1061 AD.Queries.Inherited_Operation => 1062 AD.Printers.Inherited_Operation, 1063 AD.Queries.Inherited_Original_Operation => 1064 AD.Printers.Inherited_Original_Operation 1065 ); 1066 1067 procedure Handle_Types 1068 (Element : in Asis.Element; 1069 State : in out Scan_State) 1070 is 1071 -- Generate a cross-referenced table of all types and their primitive 1072 -- operations. 'Element' is a top-level package declaration. Note: we 1073 -- only include the visible types, and we also do not include subtype 1074 -- declarations in the per-unit type index. 1075 1076 procedure Write_Type 1077 (Decl : in Declaration; 1078 State : in out Scan_State) 1079 is 1080 1081 use type AD.Queries.Operation_Kind; 1082 1083 procedure Write 1084 (Ops : in AD.Queries.Operation_List; 1085 I : in out Natural; 1086 Kind : in AD.Queries.Operation_Kind; 1087 State : in out Scan_State) 1088 is 1089 Header_Written : Boolean := False; 1090 begin 1091 while I <= Ops'Last and then Ops (I).Kind = Kind loop 1092 if not Header_Written then 1093 AD.Printers.Open_Operation_List 1094 (State.The_Printer, Translation (Kind)); 1095 Header_Written := True; 1096 end if; 1097 AD.Printers.Add_Type_Operation 1098 (State.The_Printer, 1099 AD.Crossrefs.Crossref_Name 1100 (Get_Name (Ops (I).Decl), State.Unit, 1101 State.Reporter'Access)); 1102 I := I + 1; 1103 end loop; 1104 if Header_Written then 1105 AD.Printers.Close_Operation_List (State.The_Printer); 1106 end if; 1107 end Write; 1108 1109 function Smaller 1110 (Left, Right : in AD.Queries.Operation_Description) 1111 return Boolean 1112 is 1113 begin 1114 if Left.Kind /= Right.Kind then 1115 return Left.Kind < Right.Kind; 1116 else 1117 return Smaller_Name (Left.Decl, Right.Decl); 1118 end if; 1119 end Smaller; 1120 1121 procedure Sort is 1122 new GAL.Sorting.Sort_G 1123 (Positive, 1124 AD.Queries.Operation_Description, 1125 AD.Queries.Operation_List, 1126 Smaller); 1127 1128 procedure Purge 1129 (Ops : in out AD.Queries.Operation_List; 1130 Last : out Natural) 1131 is 1132 -- Remove all 'Inherited_Original_Operation's that are not in an 1133 -- application defined unit. Change all others to simple 1134 -- 'Inherited_Operations'. Set 'Last' to reflect the last index 1135 -- still containing a valid operation. 1136 I : Natural; 1137 1138 procedure Swap is 1139 new GAL.Support.Swap (AD.Queries.Operation_Description); 1140 1141 begin 1142 Last := Ops'Last; 1143 I := Ops'First; 1144 while I <= Last loop 1145 if Ops (I).Kind = AD.Queries.Inherited_Original_Operation then 1146 -- if Unit_Origin 1147 -- (Enclosing_Compilation_Unit (Ops (I).Decl)) /= 1148 -- An_Application_Unit 1149 if not AD.Crossrefs.Crossref_To_Unit 1150 (Enclosing_Compilation_Unit (Ops (I).Decl)) 1151 then 1152 if I < Last then 1153 Swap (Ops (I), Ops (Last)); 1154 end if; 1155 Last := Last - 1; 1156 else 1157 Ops (I).Kind := AD.Queries.Inherited_Operation; 1158 I := I + 1; 1159 end if; 1160 else 1161 I := I + 1; 1162 end if; 1163 end loop; 1164 end Purge; 1165 1166 begin -- Write_Type 1167 declare 1168 XRef : AD.Crossrefs.Cross_Reference := 1169 AD.Crossrefs.Crossref_Name 1170 (Get_Name (Decl), State.Unit, State.Reporter'Access); 1171 begin 1172 AD.Printers.Open_Section (State.The_Printer, Type_Section); 1173 AD.Printers.Type_Name (State.The_Printer, XRef); 1174 end; 1175 case Declaration_Kind (Decl) is 1176 when A_Task_Type_Declaration => 1177 AD.Printers.Type_Kind (State.The_Printer, "task type"); 1178 when A_Protected_Type_Declaration => 1179 AD.Printers.Type_Kind (State.The_Printer, "protected type"); 1180 when An_Incomplete_Type_Declaration => 1181 -- Actually this shouldn't ever happen. We can have an 1182 -- incomplete type here only if we're in the private part of 1183 -- a package spec, but we don't traverse those anyway. 1184 AD.Printers.Type_Kind (State.The_Printer, "incomplete type"); 1185 AD.Printers.Close_Section (State.The_Printer, Type_Section); 1186 return; 1187 when others => 1188 case Trait_Kind (Decl) is 1189 when A_Limited_Trait | 1190 A_Limited_Private_Trait => 1191 AD.Printers.Type_Kind (State.The_Printer, "limited type"); 1192 when An_Abstract_Trait | 1193 An_Abstract_Private_Trait => 1194 AD.Printers.Type_Kind 1195 (State.The_Printer, "abstract type"); 1196 when An_Abstract_Limited_Trait | 1197 An_Abstract_Limited_Private_Trait => 1198 AD.Printers.Type_Kind 1199 (State.The_Printer, "abstract limited type"); 1200 when others => 1201 null; 1202 end case; 1203 end case; 1204 declare 1205 Parent : constant Declaration := 1206 AD.Queries.Ancestor_Type (Decl); 1207 Primitives : AD.Queries.Operation_List := 1208 AD.Queries.Primitive_Operations (Decl); 1209 I : Natural; 1210 Last : Natural; 1211 begin 1212 if not Is_Nil (Parent) then 1213 AD.Printers.Parent_Type 1214 (State.The_Printer, 1215 AD.Crossrefs.Crossref_Name 1216 (Get_Name (Parent), State.Unit, State.Reporter'Access)); 1217 end if; 1218 if Primitives'Last >= Primitives'First then 1219 Purge (Primitives, Last); 1220 if Last >= Primitives'First then 1221 Sort (Primitives (Primitives'First .. Last)); 1222 I := Primitives'First; 1223 AD.Printers.Open_Section 1224 (State.The_Printer, Operations_Section); 1225 for Kind in AD.Queries.Operation_Kind loop 1226 Write 1227 (Primitives (Primitives'First .. Last), I, Kind, State); 1228 end loop; 1229 AD.Printers.Close_Section 1230 (State.The_Printer, Operations_Section); 1231 end if; 1232 end if; 1233 end; 1234 AD.Printers.Close_Section (State.The_Printer, Type_Section); 1235 end Write_Type; 1236 1237 function Is_A_Type_Declaration 1238 (Kind : in Declaration_Kinds) 1239 return Boolean 1240 is 1241 begin 1242 return Kind in A_Type_Declaration; 1243 -- This does *not* include subtypes! 1244 end Is_A_Type_Declaration; 1245 1246 function Extract_Types is 1247 new Extract_Declarations (Is_A_Type_Declaration); 1248 1249 Types : constant Declarative_Item_List := 1250 Extract_Types (Visible_Part_Declarative_Items (Element, False), True); 1251 -- Collects all the types from the visible declarations. 1252 1253 begin 1254 if Types'Last >= Types'First then 1255 AD.Printers.Open_Section (State.The_Printer, Type_Summary_Section); 1256 for I in Types'Range loop 1257 if 1258 Declaration_Kind (Types (I)) = An_Incomplete_Type_Declaration 1259 then 1260 -- The next one *must* be the full type declaration. Hence 1261 -- just skip the incomplete type decl. 1262 if I = Types'Last or else 1263 not Is_Equal (Types (I + 1), 1264 Corresponding_Type_Declaration (Types (I))) 1265 then 1266 -- Actually, we shouldn't ever get here, because incomplete 1267 -- types without completion are allowed in the private part 1268 -- of a package spec only, and we don't traverse that in 1269 -- the first place. 1270 Write_Type (Types (I), State); 1271 end if; 1272 else 1273 Write_Type (Types (I), State); 1274 end if; 1275 end loop; 1276 AD.Printers.Close_Section (State.The_Printer, Type_Summary_Section); 1277 end if; 1278 end Handle_Types; 1279 1280 ---------------------------------------------------------------------------- 1281 1282 procedure Handle_Declaration 1283 (Items : in Item_Table; 1284 Current : in Natural; 1285 State : in out Scan_State; 1286 Is_Last : in Boolean; 1287 Top_Level : in Boolean := False) 1288 is 1289 1290 procedure Write_Generic_Formals 1291 (Decl : in Declaration; 1292 State : in out Scan_State) 1293 is 1294 -- Write the generic formals, if any. 1295 begin 1296 case Declaration_Kind (Decl) is 1297 when A_Generic_Package_Declaration | 1298 A_Generic_Function_Declaration | 1299 A_Generic_Procedure_Declaration => 1300 declare 1301 Ctrl : Traverse_Control; 1302 Generic_Formals : constant Element_List := 1303 Generic_Formal_Part (Decl, True); 1304 begin 1305 for I in Generic_Formals'Range loop 1306 Ctrl := Continue; 1307 -- Never suppress any newlines: 1308 State.Traverse_Top := Nil_Element; 1309 Traverse (Generic_Formals (I), Ctrl, State); 1310 end loop; 1311 end; 1312 1313 when others => 1314 null; 1315 1316 end case; 1317 end Write_Generic_Formals; 1318 1319 procedure Write_Container 1320 (Items : in Item_Table; 1321 Current : in Natural; 1322 State : in out Scan_State; 1323 Is_Last : in Boolean; 1324 Top_Level : in Boolean) 1325 is 1326 Old_Indent : constant Character_Position := State.Indent; 1327 Kind : constant Declaration_Kinds := 1328 Declaration_Kind (Items (Current).Element); 1329 Table_Opened : Boolean := False; 1330 Contained_Items : Item_Table := 1331 Find_Items (Items (Current).Element); 1332 For_Container : Natural; 1333 begin 1334 Group_Items (Contained_Items, For_Container); 1335 Add_To_Index 1336 (State, Items (Current).Element, Items (Current).Is_Private); 1337 declare 1338 Name : Defining_Name := Get_Name (Items (Current).Element); 1339 begin 1340 if Defining_Name_Kind (Name) = A_Defining_Expanded_Name then 1341 Name := Defining_Selector (Name); 1342 end if; 1343 AD.Printers.Open_Container 1344 (State.The_Printer, 1345 AD.Crossrefs.Crossref_Name 1346 (Name, State.Unit, State.Reporter'Access), 1347 Get_Item_Kind (Items (Current).Element), 1348 Get_Single_Name (Items (Current).Element)); 1349 end; 1350 AD.Printers.Open_Section (State.The_Printer, Header_Section); 1351 declare 1352 Pos : Position := 1353 Start (Get_Span (Items (Current).Element)); 1354 begin 1355 if Pos.Line = 1 then Pos.Column := 1; end if; 1356 State.Write_From := Pos; 1357 State.Last_Written := (Pos.Line, Pos.Column - 1); 1358 State.Indent := Pos.Column - 1; 1359 end; 1360 Write_Generic_Formals (Items (Current).Element, State); 1361 -- Complete the header: write everything up to and including the 1362 -- defining name, then write everything up to and including the 1363 -- "is", and then write all following items belonging to this one. 1364 -- Finally, write the comments for all items (excluding the current 1365 -- item (and the context clauses) if we're on top level. 1366 declare 1367 Name : constant Defining_Name := 1368 Get_Name (Items (Current).Element); 1369 Ctrl : Traverse_Control := Continue; 1370 begin 1371 State.Traverse_Top := Nil_Element; 1372 Handle_Defining_Name (Name, Ctrl, State); 1373 Terminate_Line (State); 1374 -- If it's a task or protected type, it may have discriminants 1375 -- here... 1376 if Kind = A_Task_Type_Declaration or else 1377 Kind = A_Protected_Type_Declaration 1378 then 1379 declare 1380 Discriminants : constant Asis.Element := 1381 Discriminant_Part (Items (Current).Element); 1382 Ctrl : Traverse_Control := Continue; 1383 begin 1384 if not Is_Nil (Discriminants) then 1385 -- Never suppress any newlines: 1386 State.Traverse_Top := Nil_Element; 1387 Traverse (Discriminants, Ctrl, State); 1388 end if; 1389 end; 1390 end if; 1391 -- Find the 'is' and write it. 1392 declare 1393 To_Write : A_T.Span := 1394 Through (State.Unit, 1395 "is", From => State.Last_Written); 1396 begin 1397 Set_Start (To_Write, State.Write_From); 1398 Write_Span (To_Write, State); 1399 New_Line (State.The_Printer); 1400 end; 1401 end; 1402 AD.Printers.Close_Section (State.The_Printer, Header_Section); 1403 -- Now write any object belonging to this one (rep clauses, pragmas), 1404 -- and then write the comments, if any. 1405 declare 1406 Index : Index_Table := 1407 (1 => Current) & 1408 Collect_Subordinates (Items, Contained_Items, 1409 Items (Current).Sub, For_Container); 1410 Ctrl : Traverse_Control; 1411 begin 1412 if Index'Last > Index'First then 1413 AD.Printers.Open_Section (State.The_Printer, Content_Section); 1414 AD.Printers.Open_Section (State.The_Printer, Top_Item_Section); 1415 AD.Printers.Open_Section (State.The_Printer, Snippet_Section); 1416 Table_Opened := True; 1417 Sort_Subordinates (Index (Index'First + 1 .. Index'Last), 1418 Items, Contained_Items); 1419 for I in Index'First + 1 .. Index'Last loop 1420 declare 1421 This : Asis.Element; 1422 begin 1423 if Index (I) < 0 then 1424 This := Contained_Items (-Index (I)).Element; 1425 else 1426 This := Items (Index (I)).Element; 1427 end if; 1428 -- TBD: Produce anchor; add to index 1429 declare 1430 Pos : Position := Start (Get_Span (This)); 1431 begin 1432 if Pos.Line = 1 then Pos.Column := 1; end if; 1433 State.Write_From := Pos; 1434 State.Last_Written := 1435 (Pos.Line, Pos.Column - 1); 1436 State.Indent := Pos.Column - 1; 1437 end; 1438 Ctrl := Continue; 1439 State.Traverse_Top := This; 1440 Traverse (This, Ctrl, State); 1441 end; 1442 if I < Index'Last then New_Line (State.The_Printer); end if; 1443 end loop; 1444 AD.Printers.Close_Section (State.The_Printer, Snippet_Section); 1445 end if; 1446 -- First check that we do have comments: 1447 declare 1448 Have_Comments : Boolean := False; 1449 From : Natural; 1450 begin 1451 if Top_Level then 1452 From := Index'First + 1; 1453 else 1454 From := Index'First; 1455 end if; 1456 for I in From .. Index'Last loop 1457 if (Index (I) > 0 and then 1458 Items (Index (I)).List /= null) 1459 or else 1460 (Index (I) < 0 and then 1461 Contained_Items (-Index (I)).List /= null) 1462 then 1463 Have_Comments := True; exit; 1464 end if; 1465 end loop; 1466 if Have_Comments then 1467 if not Table_Opened then 1468 AD.Printers.Open_Section 1469 (State.The_Printer, Content_Section); 1470 AD.Printers.Open_Section 1471 (State.The_Printer, Top_Item_Section); 1472 Table_Opened := True; 1473 end if; 1474 AD.Printers.Open_Section 1475 (State.The_Printer, Description_Section); 1476 for I in From .. Index'Last loop 1477 if Index (I) > 0 then 1478 Write_Comments 1479 (Items (Index (I)).Element, 1480 Items (Index (I)).List, State); 1481 else 1482 Write_Comments 1483 (Contained_Items (-Index (I)).Element, 1484 Contained_Items (-Index (I)).List, State); 1485 end if; 1486 end loop; 1487 AD.Printers.Close_Section 1488 (State.The_Printer, Description_Section); 1489 end if; 1490 end; 1491 end; 1492 if Table_Opened then 1493 AD.Printers.Close_Section (State.The_Printer, Top_Item_Section); 1494 end if; 1495 -- And now go into it: 1496 1497 declare 1498 Curr : Natural; 1499 In_Private : Boolean := False; 1500 Is_Package : constant Boolean := 1501 Kind = A_Generic_Package_Declaration or else 1502 Kind = A_Package_Declaration; 1503 Contained_Index : Index_Table := 1504 Build_Index (Contained_Items); 1505 begin 1506 if Is_Package and then Top_Level then 1507 Handle_Children 1508 (Enclosing_Compilation_Unit (Items (Current).Element), 1509 State, Table_Opened); 1510 end if; 1511 if Contained_Index'Last >= Contained_Index'First then 1512 if not Table_Opened then 1513 AD.Printers.Open_Section 1514 (State.The_Printer, Content_Section); 1515 Table_Opened := True; 1516 end if; 1517 Sort_Index (Contained_Items, Contained_Index); 1518 Curr := Contained_Index'First; 1519 if Is_Package then 1520 Handle_Exceptions (Contained_Items, Contained_Index, Curr, 1521 State); 1522 Handle_Types (Items (Current).Element, State); 1523 Handle_Objects (Contained_Items, Contained_Index, Curr, 1524 State, 1525 Item_Constant); 1526 Handle_Objects (Contained_Items, Contained_Index, Curr, 1527 State, 1528 Item_Object); 1529 end if; 1530 if Curr <= Contained_Index'Last then 1531 AD.Printers.Open_Section (State.The_Printer, Others_Section); 1532 while Curr <= Contained_Index'Last loop 1533 if 1534 Contained_Items (Contained_Index (Curr)).Is_Private 1535 then 1536 if not In_Private then 1537 AD.Printers.Add_Private (State.The_Printer, False); 1538 end if; 1539 In_Private := True; 1540 end if; 1541 Handle_Declaration 1542 (Contained_Items, Contained_Index (Curr), 1543 State, Curr = Contained_Index'Last); 1544 Curr := Curr + 1; 1545 end loop; 1546 AD.Printers.Close_Section 1547 (State.The_Printer, Others_Section); 1548 end if; 1549 Clear_Table (Contained_Items); 1550 end if; 1551 if not AD.Options.Private_Too and then 1552 Asis2.Container_Elements.Has_Private (Items (Current).Element) 1553 then 1554 if not Table_Opened then 1555 AD.Printers.Open_Section 1556 (State.The_Printer, Content_Section); 1557 Table_Opened := True; 1558 end if; 1559 AD.Printers.Add_Private (State.The_Printer, True); 1560 end if; 1561 if Table_Opened then 1562 AD.Printers.Close_Section (State.The_Printer, Content_Section); 1563 end if; 1564 end; 1565 1566 -- Find the closing 'end': 1567 AD.Printers.Open_Section (State.The_Printer, Footer_Section); 1568 AD.Printers.Dump (State.The_Printer, "end "); 1569 -- Now write the name again (even if it didn't appear in the 1570 -- source!) 1571 declare 1572 Names : constant Name_List := 1573 A_D.Names (Items (Current).Element); 1574 Span : constant A_T.Span := Get_Span (Names (Names'First)); 1575 Ctrl : Traverse_Control := Continue; 1576 begin 1577 -- Now be careful to pretend that we're at the beginning, 1578 -- and that we have written everything on that same line 1579 -- before the name itself. 1580 State.Write_From := Start (Span); 1581 State.Last_Written := 1582 (State.Write_From.Line, 1583 State.Write_From.Column - 1); 1584 Handle_Defining_Name (Names (Names'First), Ctrl, State, False); 1585 AD.Printers.Dump (State.The_Printer, ";"); 1586 end; 1587 AD.Printers.Close_Section (State.The_Printer, Footer_Section); 1588 AD.Printers.Close_Container 1589 (State.The_Printer, Is_Last and then not Top_Level); 1590 State.Indent := Old_Indent; 1591 end Write_Container; 1592 1593 procedure Write_Item 1594 (Items : in Item_Table; 1595 Current : in Natural; 1596 State : in out Scan_State; 1597 Is_Last : in Boolean; 1598 Top_Level : in Boolean) 1599 is 1600 Old_Indent : constant Character_Position := State.Indent; 1601 Kind : constant AD.Printers.Item_Kind := 1602 AD.Printers.Get_Item_Kind (Items (Current).Element); 1603 use type AD.Printers.Item_Kind; 1604 1605 begin 1606 if Kind not in AD.Printers.Declaration_Item_Kind then 1607 AD.Printers.Open_Item 1608 (State.The_Printer, AD.Crossrefs.Null_Crossref, Kind); 1609 -- TBD: Produce anchor, add to indices. 1610 else 1611 Add_To_Index 1612 (State, Items (Current).Element, Items (Current).Is_Private); 1613 declare 1614 Name : Defining_Name := Get_Name (Items (Current).Element); 1615 begin 1616 if Defining_Name_Kind (Name) = A_Defining_Expanded_Name then 1617 Name := Defining_Selector (Name); 1618 end if; 1619 AD.Printers.Open_Item 1620 (State.The_Printer, 1621 AD.Crossrefs.Crossref_Name 1622 (Name, State.Unit, State.Reporter'Access), 1623 Kind, 1624 Get_Single_Name (Items (Current).Element)); 1625 end; 1626 end if; 1627 Write_Item (Items, Current, State, Top_Level); 1628 AD.Printers.Close_Item (State.The_Printer, Is_Last); 1629 State.Indent := Old_Indent; 1630 end Write_Item; 1631 1632 begin 1633 if Top_Level then 1634 if Items (Current).List /= null then 1635 AD.Printers.Open_Section (State.The_Printer, Description_Section); 1636 Write_Comments (State.Unit, Items (Current).List, State); 1637 AD.Printers.Close_Section (State.The_Printer, Description_Section); 1638 end if; 1639 end if; 1640 if Is_Container (Items (Current).Class) then 1641 Write_Container (Items, Current, State, Is_Last, Top_Level); 1642 else 1643 Write_Item (Items, Current, State, Is_Last, Top_Level); 1644 end if; 1645 end Handle_Declaration; 1646 1647 ---------------------------------------------------------------------------- 1648 1649 procedure Handle_Defining_Name 1650 (Element : in Defining_Name; 1651 Control : in out Traverse_Control; 1652 State : in out Scan_State; 1653 Do_Anchor : in Boolean := True) 1654 is 1655 -- Generate an anchor for a defining name, so that it can be cross- 1656 -- referenced. 1657 1658 Name : Defining_Name := Element; 1659 begin 1660 if Defining_Name_Kind (Name) = A_Defining_Expanded_Name then 1661 -- Try to generate cross-references for the prefix! (Fails some- 1662 -- times on Asis 2.0.R for GNAT 3.13p; the failure is handled in 1663 -- 'AD.Writers.Write_Reference'). 1664 Traverse (Defining_Prefix (Name), Control, State); 1665 Name := Defining_Selector (Name); 1666 end if; 1667 if Do_Anchor then 1668 Write_Name (Name, State); 1669 else 1670 Write (Name, State); 1671 end if; 1672 Control := Abandon_Children; 1673 end Handle_Defining_Name; 1674 1675 ---------------------------------------------------------------------------- 1676 -- The only exported routine. 1677 1678 procedure Scan 1679 (The_Unit : in Compilation_Unit; 1680 The_Printer : in AD.Printers.Printer_Ref) 1681 is 1682 -- Produce an HTML rendering of the given compilation unit. 1683 1684 State : Scan_State; 1685 1686 begin 1687 State.The_Printer := The_Printer; 1688 State.Reporter.The_Printer := The_Printer; 1689 State.Unit := Unit_Declaration (The_Unit); 1690 State.Write_From := Start (Compilation_Unit_Span (State.Unit)); 1691 -- Asis 2.0.R for GNAT 3.13p has a problem if the unit starts at the 1692 -- very beginning with a clause: the column is set to an arbitrary 1693 -- value. The above therefore sometimes causes some stuff at the very 1694 -- beginning not to be written. Correct that! 1695 -- 1696 -- This error seems to be corrected in the 3.14p version. 1697 if State.Write_From.Line = 1 then 1698 State.Write_From.Column := 1; 1699 end if; 1700 State.Indent := 0; 1701 1702 declare 1703 Name : Defining_Name := Asis2.Naming.Get_Name (State.Unit); 1704 begin 1705 if Defining_Name_Kind (Name) = A_Defining_Expanded_Name then 1706 Name := Defining_Selector (Name); 1707 end if; 1708 AD.Printers.Open_Unit 1709 (State.The_Printer, 1710 AD.Printers.Get_Item_Kind (State.Unit), 1711 Full_Unit_Name (The_Unit), 1712 Unit_Class (The_Unit) = A_Private_Declaration, 1713 AD.Crossrefs.Crossref_Name 1714 (Name, State.Unit, State.Reporter'Access)); 1715 end; 1716 declare 1717 Items : Item_Table := Find_Items (The_Unit); 1718 Curr : Natural; 1719 begin 1720 if Items (Items'First).Is_Clause then 1721 Handle_Clauses (The_Unit, State, Items (Items'First)); 1722 Curr := Items'First + 1; 1723 else 1724 Curr := Items'First; 1725 end if; 1726 declare 1727 Index : constant Index_Table := 1728 Build_Index (Items (Curr .. Items'Last)); 1729 begin 1730 for I in Index'Range loop 1731 Handle_Declaration 1732 (Items, Index (I), State, 1733 Is_Last => I = Index'Last, Top_Level => True); 1734 end loop; 1735 end; 1736 Clear_Table (Items); 1737 Clear_Comments; 1738 end; 1739 AD.Printers.Close_Unit (State.The_Printer); 1740 end Scan; 1741 1742 ---------------------------------------------------------------------------- 1743 1744end AD.Scanner; 1745