← Back to branch summary

~ubuntu-branches/debian/stretch/adabrowse/stretch

« back to all changes in this revision

Viewing changes to ad-descriptions.adb

  • Committer: Bazaar Package Importer
  • Author(s): Ludovic Brenta
  • Date: 2004-02-14 13:22:40 UTC
  • Revision ID: james.westby@ubuntu.com-20040214132240-cqumhiq1677pkvzo
Tags: upstream-4.0.2
Import upstream version 4.0.2

Show diffs side-by-side

added added

removed removed

Lines of Context:
ad-descriptions.adb
 
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
--   Storage of description definitions.</DL>
 
28
--
 
29
-- <!--
 
30
-- Revision History
 
31
--
 
32
--   06-FEB-2002   TW  Initial version.
 
33
--   26-FEB-2002   TW  Added 'A_Component_Declaration' to function
 
34
--                     'Item_Class' (components of protected objs or types).
 
35
--   19-MAR-2002   TW  Added 'An_Object_Renaming_Declaration' to function
 
36
--                     'Item_Class'.
 
37
--   25-MAR-2002   TW  Changed the item class for task (type) declarations
 
38
--                     without content ("task type X;") to Item_Type or
 
39
--                     Item_Object instead of Item_Task.
 
40
--   11-NOV-2002   TW  Added 'Item_Context_Clause'.
 
41
-- -->
 
42
-------------------------------------------------------------------------------
 
43
 
 
44
pragma License (GPL);
 
45
 
 
46
with Ada.Exceptions;
 
47
with Ada.Strings.Maps;
 
48
with Ada.Unchecked_Deallocation;
 
49
 
 
50
with AD.Config;
 
51
with AD.Text_Utilities;
 
52
 
 
53
with Asis;
 
54
with Asis.Declarations;
 
55
with Asis.Elements;
 
56
with Asis.Text;
 
57
 
 
58
with Asis2.Spans;
 
59
 
 
60
with Util.Strings;
 
61
 
 
62
package body AD.Descriptions is
 
63
 
 
64
   package ASM renames Ada.Strings.Maps;
 
65
 
 
66
   use Asis;
 
67
   use Asis.Declarations;
 
68
   use Asis.Elements;
 
69
   use Asis.Text;
 
70
 
 
71
   use Asis2.Spans;
 
72
   use AD.Text_Utilities;
 
73
 
 
74
   use Util.Strings;
 
75
 
 
76
   procedure Free is new
 
77
     Ada.Unchecked_Deallocation (Finders, Finders_Ptr);
 
78
 
 
79
   type Handle is access Finders_Ptr;
 
80
 
 
81
   procedure Free is new
 
82
     Ada.Unchecked_Deallocation (Finders_Ptr, Handle);
 
83
 
 
84
   type Desc is
 
85
      record
 
86
         Is_Default : Boolean;
 
87
         Ptr        : Handle;
 
88
      end record;
 
89
 
 
90
   Comment_Finders : array (Item_Classes) of Desc;
 
91
 
 
92
   subtype Default_Count is Natural range 0 .. 2;
 
93
 
 
94
   type Default_Desc (N : Default_Count := 0) is
 
95
      record
 
96
         Super : Item_Classes;
 
97
         Find  : Finders (1 .. N);
 
98
      end record;
 
99
 
 
100
   Defaults : constant array (Item_Classes) of Default_Desc :=
 
101
     (No_Item_Class =>
 
102
        (0, No_Item_Class, (others => (None, 0))),
 
103
      Item_Context_Clause =>
 
104
        (1, Item_Context_Clause, (1 => (After, 1))),
 
105
      Item_Clause     =>
 
106
        (1, Item_Clause, (1 => (After, 1))),
 
107
      Item_Constant =>
 
108
        (1, Item_Constant, (1 => (After, 1))),
 
109
      Item_Container  =>
 
110
        (2, Item_Container, ((Before, Unlimited), (Inside, Unlimited))),
 
111
      Item_Exception  =>
 
112
        (1, Item_Exception, (1 => (After, 1))),
 
113
      Item_Instantiation =>
 
114
        (1, Item_Subprogram, (1 => (After, 1))),
 
115
      Item_Library    =>
 
116
        (2, Item_Library, ((Before, Unlimited), (After, Unlimited))),
 
117
      Item_Library_Instantiation =>
 
118
        (0, Item_Library, (others => (None, 0))),
 
119
      Item_Library_Package =>
 
120
        (0, Item_Library, (others => (None, 0))),
 
121
      Item_Library_Renaming =>
 
122
        (0, Item_Library, (others => (None, 0))),
 
123
      Item_Library_Subprogram =>
 
124
        (0, Item_Library, (others => (None, 0))),
 
125
      Item_Object =>
 
126
        (1, Item_Object, (1 => (After, 1))),
 
127
      Item_Package =>
 
128
        (0, Item_Container, (others => (None, 0))),
 
129
      Item_Pragma     =>
 
130
        (1, Item_Pragma, (1 => (After, 1))),
 
131
      Item_Protected =>
 
132
        (0, Item_Container, (others => (None, 0))),
 
133
      Item_Renaming =>
 
134
        (1, Item_Subprogram, (1 => (After, 1))),
 
135
      Item_Rep_Clause =>
 
136
        (1, Item_Rep_Clause, (1 => (After, 1))),
 
137
      Item_Subprogram =>
 
138
        (1, Item_Subprogram, (1 => (After, 1))),
 
139
      Item_Task =>
 
140
        (0, Item_Container, (others => (None, 0))),
 
141
      Item_Type       =>
 
142
        (2, Item_Type, ((After, 1), (Before, Unlimited)))
 
143
     );
 
144
 
 
145
   ----------------------------------------------------------------------------
 
146
 
 
147
   procedure Reset
 
148
     (The_Class : in Item_Classes)
 
149
   is
 
150
   begin
 
151
      if Comment_Finders (The_Class).Is_Default then
 
152
         return;
 
153
      end if;
 
154
      if Defaults (The_Class).Super = The_Class then
 
155
         Free (Comment_Finders (The_Class).Ptr.all);
 
156
         Comment_Finders (The_Class).Ptr.all :=
 
157
           new Finders'(Defaults (The_Class).Find);
 
158
      else
 
159
         Free (Comment_Finders (The_Class).Ptr.all);
 
160
         Free (Comment_Finders (The_Class).Ptr);
 
161
         Comment_Finders (The_Class).Ptr :=
 
162
           Comment_Finders (Defaults (The_Class).Super).Ptr;
 
163
      end if;
 
164
      Comment_Finders (The_Class).Is_Default := True;
 
165
   end Reset;
 
166
 
 
167
   procedure Set
 
168
     (The_Class : in Item_Classes;
 
169
      To        : in Finders)
 
170
   is
 
171
   begin
 
172
      if The_Class = No_Item_Class then raise Program_Error; end if;
 
173
      if Comment_Finders (The_Class).Is_Default and then
 
174
         Defaults (The_Class).Super /= The_Class
 
175
      then
 
176
         --  A subclass at its default setting: shares the parent data
 
177
         --  structure. Hence we need to create a new one.
 
178
         Comment_Finders (The_Class).Ptr := new Finders_Ptr;
 
179
      else
 
180
         --  It has its own data structure.
 
181
         Free (Comment_Finders (The_Class).Ptr.all);
 
182
      end if;
 
183
      Comment_Finders (The_Class).Ptr.all    := new Finders'(To);
 
184
      Comment_Finders (The_Class).Is_Default := False;
 
185
   end Set;
 
186
 
 
187
   ----------------------------------------------------------------------------
 
188
 
 
189
   procedure Parse
 
190
     (Selector : in String;
 
191
      Value    : in String)
 
192
   is
 
193
 
 
194
      function Parse_List
 
195
        (Value : in String)
 
196
        return Finders
 
197
      is
 
198
 
 
199
         function Parse_Finder
 
200
           (Value : in String)
 
201
           return Comment_Finder
 
202
         is
 
203
            Result : Comment_Finder := (None, 0);
 
204
            N      : Natural;
 
205
         begin
 
206
            if Is_Prefix (Value, "after") then
 
207
               Result.Where := After; N := 5;
 
208
            elsif Is_Prefix (Value, "before") then
 
209
               Result.Where := Before; N := 6;
 
210
            elsif Is_Prefix (Value, "inside") then
 
211
               Result.Where := Inside; N := 6;
 
212
            elsif Value = "none" then
 
213
               return Result;
 
214
            end if;
 
215
            if Result.Where = None then
 
216
               Ada.Exceptions.Raise_Exception
 
217
                 (AD.Config.Invalid_Config'Identity,
 
218
                  "unknown location """ & Value & '"');
 
219
            end if;
 
220
            if Value'Length = N then
 
221
               Result.How_Far := Unlimited;
 
222
               return Result;
 
223
            end if;
 
224
            --  "(number)" must be following.
 
225
            N := Index (Value (Value'First + N .. Value'Last), '(');
 
226
            if N = 0 then
 
227
               Ada.Exceptions.Raise_Exception
 
228
                 (AD.Config.Invalid_Config'Identity,
 
229
                  "invalid location """ & Value & '"');
 
230
            end if;
 
231
            declare
 
232
               I : constant Natural := N;
 
233
               J : constant Natural :=
 
234
                 Index (Value (N + 1 .. Value'Last), ')');
 
235
               Limit : Integer := -1;
 
236
            begin
 
237
               if J = Value'Last then
 
238
                  begin
 
239
                     Limit := Integer'Value (Value (I + 1 .. J - 1));
 
240
                  exception
 
241
                     when others =>
 
242
                        Limit := -1;
 
243
                  end;
 
244
               end if;
 
245
               if Limit < 0 then
 
246
                  Ada.Exceptions.Raise_Exception
 
247
                    (AD.Config.Invalid_Config'Identity,
 
248
                     "invalid location """ & Value & '"');
 
249
               end if;
 
250
               Result.How_Far := Limit;
 
251
            end;
 
252
            return Result;
 
253
         end Parse_Finder;
 
254
 
 
255
         I, J : Natural;
 
256
 
 
257
      begin --  Parse_List
 
258
         I := Value'First;
 
259
         while I <= Value'Last loop
 
260
            J := Index (Value, ',');
 
261
            if J = 0 then J := Value'Last + 1; end if;
 
262
            declare
 
263
               Item : constant String :=
 
264
                 To_Lower (Trim (Value (I .. J - 1)));
 
265
            begin
 
266
               if Item'Last >= Item'First then
 
267
                  return Parse_Finder (Item) &
 
268
                         Parse_List (Value (J + 1 .. Value'Last));
 
269
               end if;
 
270
            end;
 
271
            I := J + 1;
 
272
         end loop;
 
273
         declare
 
274
            Null_Finders : Finders (2 .. 1);
 
275
         begin
 
276
            return Null_Finders;
 
277
         end;
 
278
      end Parse_List;
 
279
 
 
280
      The_Class : Item_Classes;
 
281
 
 
282
   begin --  Parse
 
283
      begin
 
284
         The_Class := Item_Classes'Value ("ITEM_" & To_Upper (Selector));
 
285
      exception
 
286
         when Constraint_Error =>
 
287
            Ada.Exceptions.Raise_Exception
 
288
              (AD.Config.Invalid_Config'Identity,
 
289
               "unknown selector """ & Selector & '"');
 
290
      end;
 
291
      declare
 
292
         Where : constant Finders := Parse_List (Value);
 
293
      begin
 
294
         if Where'Last < Where'First then
 
295
            Reset (The_Class);
 
296
         else
 
297
            --  Check semantics: only containers and library items can have
 
298
            --  'Inside'!
 
299
            if Defaults (The_Class).Super /= Item_Container and then
 
300
               Defaults (The_Class).Super /= Item_Library
 
301
            then
 
302
               for I in Where'Range loop
 
303
                  if Where (I).Where = Inside then
 
304
                     Ada.Exceptions.Raise_Exception
 
305
                       (AD.Config.Invalid_Config'Identity,
 
306
                        "this description selector cannot have an " &
 
307
                        """Inside"" location");
 
308
                  end if;
 
309
               end loop;
 
310
            end if;
 
311
            --  It's ok.
 
312
            Set (The_Class, Where);
 
313
         end if;
 
314
      end;
 
315
   end Parse;
 
316
 
 
317
   ----------------------------------------------------------------------------
 
318
 
 
319
   function Item_Class
 
320
     (Item : in Asis.Element)
 
321
     return Item_Classes
 
322
   is
 
323
   begin
 
324
      case Element_Kind (Item) is
 
325
         when A_Clause =>
 
326
            case Clause_Kind (Item) is
 
327
               when A_Representation_Clause |
 
328
                    A_Component_Clause =>
 
329
                  return Item_Rep_Clause;
 
330
               when A_With_Clause =>
 
331
                  return Item_Context_Clause;
 
332
               when A_Use_Package_Clause | A_Use_Type_Clause =>
 
333
                  --  It's a context clause if it occurs before the start
 
334
                  --  of that compilation unit's declaration.
 
335
                  declare
 
336
                     Decl : constant Declaration :=
 
337
                       Unit_Declaration (Enclosing_Compilation_Unit (Item));
 
338
                  begin
 
339
                     if Is_Nil (Decl) or else
 
340
                        Start (Get_Span (Decl)) > Stop (Get_Span (Item))
 
341
                     then
 
342
                        return Item_Context_Clause;
 
343
                     end if;
 
344
                     return Item_Clause;
 
345
                  end;
 
346
               when others =>
 
347
                  return Item_Clause;
 
348
            end case;
 
349
 
 
350
         when A_Pragma =>
 
351
            return Item_Pragma;
 
352
 
 
353
         when A_Declaration =>
 
354
            case Declaration_Kind (Item) is
 
355
               when An_Exception_Renaming_Declaration |
 
356
                    An_Exception_Declaration =>
 
357
                  return Item_Exception;
 
358
 
 
359
               when A_Task_Type_Declaration =>
 
360
                  if Is_Nil (Type_Declaration_View (Item)) then
 
361
                     return Item_Type;
 
362
                  else
 
363
                     return Item_Task;
 
364
                  end if;
 
365
 
 
366
               when A_Single_Task_Declaration =>
 
367
                  if Is_Nil (Object_Declaration_View (Item)) then
 
368
                     return Item_Object;
 
369
                  else
 
370
                     return Item_Task;
 
371
                  end if;
 
372
 
 
373
               when A_Protected_Type_Declaration |
 
374
                    A_Single_Protected_Declaration =>
 
375
                  return Item_Protected;
 
376
 
 
377
               when A_Package_Declaration |
 
378
                    A_Generic_Package_Declaration =>
 
379
                  if Is_Equal
 
380
                       (Item,
 
381
                        Unit_Declaration  (Enclosing_Compilation_Unit (Item)))
 
382
                  then
 
383
                     return Item_Library_Package;
 
384
                  else
 
385
                     return Item_Package;
 
386
                  end if;
 
387
 
 
388
               when A_Procedure_Declaration |
 
389
                    A_Function_Declaration |
 
390
                    A_Generic_Procedure_Declaration |
 
391
                    A_Generic_Function_Declaration =>
 
392
                  if Is_Equal
 
393
                       (Item,
 
394
                        Unit_Declaration  (Enclosing_Compilation_Unit (Item)))
 
395
                  then
 
396
                     return Item_Library_Subprogram;
 
397
                  else
 
398
                     return Item_Subprogram;
 
399
                  end if;
 
400
 
 
401
               when A_Procedure_Renaming_Declaration |
 
402
                    A_Function_Renaming_Declaration |
 
403
                    A_Package_Renaming_Declaration |
 
404
                    A_Generic_Procedure_Renaming_Declaration |
 
405
                    A_Generic_Function_Renaming_Declaration |
 
406
                    A_Generic_Package_Renaming_Declaration =>
 
407
                  if Is_Equal
 
408
                       (Item,
 
409
                        Unit_Declaration  (Enclosing_Compilation_Unit (Item)))
 
410
                  then
 
411
                     return Item_Library_Renaming;
 
412
                  else
 
413
                     return Item_Renaming;
 
414
                  end if;
 
415
 
 
416
               when A_Procedure_Instantiation |
 
417
                    A_Function_Instantiation |
 
418
                    A_Package_Instantiation =>
 
419
                  if Is_Equal
 
420
                       (Item,
 
421
                        Unit_Declaration  (Enclosing_Compilation_Unit (Item)))
 
422
                  then
 
423
                     return Item_Library_Instantiation;
 
424
                  else
 
425
                     return Item_Instantiation;
 
426
                  end if;
 
427
 
 
428
               when An_Entry_Declaration =>
 
429
                  return Item_Subprogram;
 
430
 
 
431
               when A_Constant_Declaration |
 
432
                    A_Deferred_Constant_Declaration |
 
433
                    An_Integer_Number_Declaration |
 
434
                    A_Real_Number_Declaration =>
 
435
                  return Item_Constant;
 
436
 
 
437
               when A_Variable_Declaration |
 
438
                    A_Component_Declaration |
 
439
                    An_Object_Renaming_Declaration =>
 
440
                  --  Components can occur as the items in the private part of
 
441
                  --  a protected type or object.
 
442
                  return Item_Object;
 
443
 
 
444
               when others =>
 
445
                  if (Declaration_Kind (Item) in A_Type_Declaration) or else
 
446
                     (Declaration_Kind (Item) = A_Subtype_Declaration)
 
447
                  then
 
448
                     return Item_Type;
 
449
                  end if;
 
450
 
 
451
            end case; --  Declaration_Kind
 
452
 
 
453
         when others =>
 
454
            null;
 
455
 
 
456
      end case; --  Element_Kind
 
457
      return No_Item_Class;
 
458
   end Item_Class;
 
459
 
 
460
   function Is_Container
 
461
     (Class : in Item_Classes)
 
462
     return Boolean
 
463
   is
 
464
   begin
 
465
      return Defaults (Class).Super = Item_Container or else
 
466
             Class = Item_Library_Package;
 
467
   end Is_Container;
 
468
 
 
469
   function Get_Finders
 
470
     (The_Class : in Item_Classes)
 
471
     return Finders_Ptr
 
472
   is
 
473
   begin
 
474
      return Comment_Finders (The_Class).Ptr.all;
 
475
   end Get_Finders;
 
476
 
 
477
   ----------------------------------------------------------------------------
 
478
 
 
479
   type Text_Range;
 
480
   type Range_Ptr is access Text_Range;
 
481
   type Text_Range is
 
482
      record
 
483
         Start : Asis.Text.Line_Number;
 
484
         Stop  : Asis.Text.Line_Number;
 
485
         Next  : Range_Ptr;
 
486
      end record;
 
487
 
 
488
   procedure Free is
 
489
      new Ada.Unchecked_Deallocation (Text_Range, Range_Ptr);
 
490
 
 
491
   Anchor : Range_Ptr;
 
492
 
 
493
   procedure Take
 
494
     (Span : Asis.Text.Span)
 
495
   is
 
496
      P, Q  : Range_Ptr;
 
497
      First : constant Line_Number := Start (Span).Line;
 
498
      Last  : constant Line_Number := Stop (Span).Line;
 
499
   begin
 
500
      P := Anchor;
 
501
      --  There can be no overlaps!
 
502
      while P /= null and then Last < P.Stop loop
 
503
         Q := P; P := P.Next;
 
504
      end loop;
 
505
      if Q = null then
 
506
         Anchor := new Text_Range'(First, Last, P);
 
507
      else
 
508
         Q.Next := new Text_Range'(First, Last, P);
 
509
      end if;
 
510
   end Take;
 
511
 
 
512
   function Is_Taken
 
513
     (Pos : Asis.Text.Line_Number)
 
514
     return Boolean
 
515
   is
 
516
      P : Range_Ptr := Anchor;
 
517
   begin
 
518
      while P /= null and then Pos <= P.Stop loop
 
519
         if Pos >= P.Start then return True; end if;
 
520
         P := P.Next;
 
521
      end loop;
 
522
      return False;
 
523
   end Is_Taken;
 
524
 
 
525
   procedure Clear_Comments
 
526
   is
 
527
      P, Q : Range_Ptr;
 
528
   begin
 
529
      P := Anchor;
 
530
      while P /= null loop
 
531
         Q := P; P := P.Next; Free (Q);
 
532
      end loop;
 
533
      Anchor := null;
 
534
   end Clear_Comments;
 
535
 
 
536
   function Get_Name
 
537
     (Decl : in Asis.Declaration)
 
538
     return Asis.Element
 
539
   is
 
540
      All_Names : constant Name_List := Names (Decl);
 
541
   begin
 
542
      return All_Names (All_Names'First);
 
543
   end Get_Name;
 
544
 
 
545
   procedure Find_Comment
 
546
     (Unit      : in     Asis.Element;
 
547
      From      : in     Position;
 
548
      Limit     : in     Integer;
 
549
      Span      : in out Asis.Text.Span;
 
550
      Direction : in     Ada.Strings.Direction := Ada.Strings.Forward)
 
551
   is
 
552
      --  'Span' is initially nil!
 
553
 
 
554
      use type Ada.Strings.Direction;
 
555
 
 
556
      Comment_Pos : Position;
 
557
 
 
558
   begin
 
559
      if Is_Nil (From) then return; end if;
 
560
      if Direction = Ada.Strings.Backward then
 
561
         Comment_Pos :=
 
562
           Find_Comment (Unit, From.Line, Ada.Strings.Backward);
 
563
         if Is_Nil (Comment_Pos) or else
 
564
            (Limit >= 0 and then
 
565
             Integer (From.Line - Comment_Pos.Line - 1) > Limit) or else
 
566
            Is_Taken (Comment_Pos.Line)
 
567
         then
 
568
            return;
 
569
         end if;
 
570
         Set_Stop (Span, Comment_Pos);
 
571
         Set_Start
 
572
           (Span, Expand_Comment (Unit, Comment_Pos, Ada.Strings.Backward));
 
573
      else
 
574
         Comment_Pos := Find_Comment (Unit, From.Line);
 
575
         if Is_Nil (Comment_Pos) or else
 
576
            (Limit >= 0 and then
 
577
             Integer (Comment_Pos.Line - From.Line - 1) > Limit) or else
 
578
            Is_Taken (Comment_Pos.Line)
 
579
         then
 
580
            return;
 
581
         end if;
 
582
         Set_Start (Span, Comment_Pos);
 
583
         Set_Stop  (Span, Expand_Comment (Unit, Comment_Pos));
 
584
      end if;
 
585
      Comment_Pos := Start (Span);
 
586
      if Comment_Pos.Line = Stop (Span).Line then
 
587
         --  A one-liner... if it is empty after we've stripped out any blanks
 
588
         --  and dashes, it is not a comment after all!
 
589
         declare
 
590
            use type ASM.Character_Set;
 
591
            L : constant Line_List := Asis.Text.Lines (Unit, Span);
 
592
            S : constant String :=
 
593
              Trim (To_String (Comment_Image (L (L'First))),
 
594
                    Blanks or ASM.To_Set ("-"),
 
595
                    Blanks or ASM.To_Set ("-"));
 
596
         begin
 
597
            if S'Last < S'First then
 
598
               Span := Asis.Text.Nil_Span;
 
599
            end if;
 
600
         end;
 
601
      end if;
 
602
   end Find_Comment;
 
603
 
 
604
   procedure Find
 
605
     (Self       : in     Comment_Finder;
 
606
      Item       : in     Asis.Element;
 
607
      Span       :    out Asis.Text.Span;
 
608
      Class      : in     Item_Classes := No_Item_Class)
 
609
   is
 
610
   begin
 
611
      Span  := Asis.Text.Nil_Span;
 
612
      if Self.Where = None then return; end if;
 
613
      declare
 
614
         The_Span : constant Asis.Text.Span := Get_Span (Item);
 
615
      begin
 
616
         Find (Self, Item, Start (The_Span), Stop (The_Span), Span, Class);
 
617
      end;
 
618
   end Find;
 
619
 
 
620
   ----------------------------------------------------------------------------
 
621
 
 
622
   procedure Find
 
623
     (Self  : in     Comment_Finder;
 
624
      Item  : in     Asis.Element;
 
625
      From  : in     Asis2.Spans.Position;
 
626
      To    : in     Asis2.Spans.Position;
 
627
      Span  :    out Asis.Text.Span;
 
628
      Class : in     Item_Classes := No_Item_Class)
 
629
   is
 
630
      The_Class          : Item_Classes := Class;
 
631
      Front, Back, Inner : Position;
 
632
   begin
 
633
      Span  := Asis.Text.Nil_Span;
 
634
      if Self.Where = None then return; end if;
 
635
      Front := From;
 
636
      Back  := To;
 
637
      if The_Class = No_Item_Class then
 
638
         The_Class := Item_Class (Item);
 
639
      end if;
 
640
      if The_Class = No_Item_Class then return; end if;
 
641
      if Defaults (The_Class).Super = Item_Container then
 
642
         --  Find the end of the header
 
643
         case Declaration_Kind (Item) is
 
644
            when A_Task_Type_Declaration |
 
645
                 A_Protected_Type_Declaration =>
 
646
               declare
 
647
                  Before_Is : Asis.Element :=
 
648
                    Discriminant_Part (Item);
 
649
               begin
 
650
                  if Is_Nil (Before_Is) then
 
651
                     Before_Is := Get_Name (Item);
 
652
                  end if;
 
653
                  Inner :=
 
654
                    Stop (Through (Item, "is",
 
655
                                   From => Stop (Get_Span (Before_Is))));
 
656
               end;
 
657
 
 
658
            when A_Single_Task_Declaration |
 
659
                 A_Single_Protected_Declaration |
 
660
                 A_Package_Declaration |
 
661
                 A_Generic_Package_Declaration =>
 
662
               Inner :=
 
663
                 Stop
 
664
                   (Through (Item, "is",
 
665
                             From => Stop (Get_Span (Get_Name (Item)))));
 
666
 
 
667
            when others =>
 
668
               --  Not a container
 
669
               null;
 
670
 
 
671
         end case;
 
672
      elsif Defaults (The_Class).Super = Item_Library then
 
673
         --  Front is before the context clauses; Inner is the beginning of
 
674
         --  the item, Back is the end of the item, or, if it is a package,
 
675
         --  the end of the header.
 
676
         Inner := Front;
 
677
         declare
 
678
            Clauses : constant Context_Clause_List :=
 
679
              Context_Clause_Elements (Enclosing_Compilation_Unit (Item),
 
680
                                       True);
 
681
         begin
 
682
            if Clauses'Last >= Clauses'First then
 
683
               Front := Start (Get_Span (Clauses (Clauses'First)));
 
684
               if Is_Nil (Front) then Front := Inner; end if;
 
685
            end if;
 
686
         end;
 
687
         if The_Class = Item_Library_Package then
 
688
            --  Find the end of the header, i.e. the "is" after the package
 
689
            --  name.
 
690
            Back :=
 
691
              Stop (Through (Item, "is",
 
692
                             From => Stop (Get_Span (Get_Name (Item)))));
 
693
         end if;
 
694
      end if;
 
695
      --  All right, we now have the three positions we (may) need.
 
696
      declare
 
697
         Unit : constant Declaration :=
 
698
           Unit_Declaration (Enclosing_Compilation_Unit (Item));
 
699
      begin
 
700
         case Self.Where is
 
701
            when Before =>
 
702
               Find_Comment
 
703
                 (Unit, Front, Self.How_Far, Span, Ada.Strings.Backward);
 
704
 
 
705
            when Inside =>
 
706
               if Defaults (The_Class).Super = Item_Library then
 
707
                  --  Search backwards; 'Inner' is the beginning of the unit.
 
708
                  Find_Comment
 
709
                    (Unit, Front, Self.How_Far, Span, Ada.Strings.Backward);
 
710
               else
 
711
                  Find_Comment (Unit, Inner, Self.How_Far, Span);
 
712
               end if;
 
713
 
 
714
            when After =>
 
715
               Find_Comment (Unit, Back, Self.How_Far, Span);
 
716
 
 
717
            when None =>
 
718
               raise Program_Error;
 
719
 
 
720
         end case;
 
721
      end;
 
722
      if not Is_Nil (Span) then
 
723
         Take (Span);
 
724
      end if;
 
725
   end Find;
 
726
 
 
727
begin --  AD.Descriptions.BODY
 
728
   for I in Comment_Finders'Range loop
 
729
      if I = No_Item_Class then
 
730
         Comment_Finders (I).Ptr := null;
 
731
      elsif Defaults (I).Super = I then
 
732
         Comment_Finders (I).Ptr     := new Finders_Ptr;
 
733
         Comment_Finders (I).Ptr.all := new Finders'(Defaults (I).Find);
 
734
      end if;
 
735
   end loop;
 
736
   for I in Comment_Finders'Range loop
 
737
      Comment_Finders (I).Is_Default := True;
 
738
      if Defaults (I).Super /= I then
 
739
         Comment_Finders (I).Ptr := Comment_Finders (Defaults (I).Super).Ptr;
 
740
      end if;
 
741
   end loop;
 
742
end AD.Descriptions;
 
743