← Back to branch summary

~ubuntu-branches/ubuntu/jaunty/adacontrol/jaunty

« back to all changes in this revision

Viewing changes to src/units_list.adb

  • Committer: Bazaar Package Importer
  • Author(s): Ludovic Brenta
  • Date: 2006-10-12 19:17:22 UTC
  • mfrom: (1.1.1 upstream)
  • Revision ID: james.westby@ubuntu.com-20061012191722-fo5bcn4k5r0iubgd
Tags: 1.5r24-1

* New upstream release.
* debian/control (Depends): add gnat-4.1.
  (Enhances): add gnat-gps.
* debian/adacontrol.gpr: build pfni.
* debian/rules: install the new gnat-gps plug-in, and pfni.
* debian/pfni.1: new.
* patches/gps-integration.patch: new.

Show diffs side-by-side

added added

removed removed

Lines of Context:
src/units_list.adb
41
41
  Ada.Wide_Text_IO;
42
42
 
43
43
with   -- ASIS components
 
44
  Asis.Clauses,
44
45
  Asis.Compilation_Units,
45
46
  Asis.Elements,
46
 
  Asis.Expressions,
47
 
  Asis.Iterator;
48
 
pragma Elaborate_All (Asis.Iterator);
 
47
  Asis.Expressions;
49
48
 
50
49
with   -- Reusable components
51
50
  A4G_Bugs,
64
63
 
65
64
   type WS_Access is access Wide_String;
66
65
 
67
 
   type Info is null record;
68
 
 
69
66
   type Node;
70
67
   type Link is access Node;
71
68
   type Node (Length : Positive) is
78
75
   -- Global variables --
79
76
   ----------------------
80
77
 
81
 
   Head     : Link;
82
 
   Cursor   : Link;
83
 
   Previous : Link;
 
78
   Head        : Link;
 
79
   Cursor      : Link;
 
80
   Previous    : Link;
 
81
   List_Length : Natural := 0;
84
82
 
85
83
   ---------
86
84
   -- Add --
94
92
      Current    : Link := Head;
95
93
   begin
96
94
      if Current = null then
97
 
         Head     := new Node'(Upper_Unit'Length, Upper_Unit, null);
98
 
         Cursor   := Head;
99
 
         Previous := null;
 
95
         Head        := new Node'(Upper_Unit'Length, Upper_Unit, null);
 
96
         Cursor      := Head;
 
97
         Previous    := null;
 
98
         List_Length := 1;
100
99
         return;
101
100
      end if;
102
101
 
111
110
      -- Not found
112
111
      -- Current still points to the last node
113
112
      Current.Next := new Node'(Upper_Unit'Length, Upper_Unit, null);
 
113
      List_Length := List_Length + 1;
114
114
      if Cursor = null then
115
115
         Cursor   := Current.Next;
116
116
         Previous := Current;
117
117
      end if;
118
118
   end Add;
119
119
 
120
 
   -----------
121
 
   -- Error --
122
 
   -----------
123
 
 
124
 
   procedure Raise_Specification_Error (Mess : String) is
125
 
      use Ada.Exceptions;
126
 
   begin
127
 
      Raise_Exception (Specification_Error'Identity, Mess);
128
 
   end Raise_Specification_Error;
129
 
   pragma No_Return (Raise_Specification_Error);
130
 
 
131
 
   ----------
132
 
   -- Free --
133
 
   ----------
134
 
   procedure Free is new Ada.Unchecked_Deallocation (Node, Link);
135
 
 
136
 
   --------------------
137
 
   -- Post_Procedure --
138
 
   --------------------
139
 
 
140
 
   procedure Post_Procedure (Element : in     Asis.Element;
141
 
                             Control : in out Asis.Traverse_Control;
142
 
                             State   : in out Info)
143
 
   is
144
 
      pragma Unreferenced (Element);
145
 
      pragma Unreferenced (Control);
146
 
      pragma Unreferenced (State);
147
 
  begin
148
 
      null;
149
 
   end Post_Procedure;
150
 
 
151
 
   ------------------------
152
 
   -- Pre_Procedure_With --
153
 
   ------------------------
154
 
 
155
 
   procedure Pre_Procedure_With (Element : in     Asis.Element;
156
 
                                 Control : in out Asis.Traverse_Control;
157
 
                                 State   : in out Info)
158
 
   is
159
 
      pragma Unreferenced (State);
160
 
      use Asis, Asis.Elements, Asis.Expressions, Asis.Compilation_Units;
161
 
      use Thick_Queries;
162
 
 
163
 
   begin
164
 
      Control := Continue;
165
 
 
166
 
      case Element_Kind (Element) is
167
 
         when A_Clause =>                 ------------ Clause ------------
168
 
            case Clause_Kind (Element) is
169
 
               when A_With_Clause =>
170
 
                  -- Let recurse into children
171
 
                  null;
172
 
               when others =>
173
 
                  -- Not interested
174
 
                  Control := Abandon_Children;
175
 
            end case;
176
 
         when An_Expression =>                 ------------ Expression ------------
177
 
            case Expression_Kind (Element) is
178
 
               when An_Identifier =>
179
 
                  -- Only identifiers from with clauses come here
180
 
                  -- However, we do not add predefined units
181
 
                  if Unit_Origin (Enclosing_Compilation_Unit
182
 
                                    (Corresponding_Name_Definition (Element))) =
183
 
                    An_Application_Unit
184
 
                  then
185
 
                     Add (Full_Name_Image (Corresponding_Name_Definition (Element)));
186
 
                  end if;
187
 
               when others =>
188
 
                  null;
189
 
            end case;
190
 
 
191
 
         when others =>
192
 
            -- Not interested
193
 
            Control := Abandon_Children;
194
 
      end case;
195
 
 
196
 
   exception
197
 
      when others =>
198
 
         Trace ("Exception in Pre-proc of Units_List ", Element); --## rule line off no_trace
199
 
         raise;
200
 
   end Pre_Procedure_With;
201
 
 
202
 
   -------------------
203
 
   -- Traverse_With --
204
 
   -------------------
205
 
 
206
 
   procedure Traverse_With is new Asis.Iterator.Traverse_Element
207
 
     (Info, Pre_Procedure_With, Post_Procedure);
208
120
 
209
121
   ----------------------------------------------------------------
210
122
   --                 Exported subprograms                       --
224
136
   --------------------
225
137
 
226
138
   procedure Delete_Current is
 
139
      procedure Free is new Ada.Unchecked_Deallocation (Node, Link);
227
140
      To_Free : Link := Cursor;
228
141
   begin
229
142
      if Previous = null then
231
144
      else
232
145
         Previous.Next := Cursor.Next;
233
146
      end if;
234
 
      Cursor := Cursor.Next;
 
147
      Cursor      := Cursor.Next;
 
148
      List_Length := List_Length - 1;
235
149
      Free (To_Free);
236
150
   end Delete_Current;
237
151
 
244
158
      return Cursor = null;
245
159
   end Is_Exhausted;
246
160
 
 
161
   ------------
 
162
   -- Length --
 
163
   ------------
 
164
 
 
165
   function Length return Integer is
 
166
   begin
 
167
      return List_Length;
 
168
   end Length;
 
169
 
247
170
   --------------
248
171
   -- Register --
249
172
   --------------
255
178
   is
256
179
      use Asis, Asis.Compilation_Units, Asis.Elements, Ada.Strings.Wide_Fixed, Ada.Strings.Wide_Maps;
257
180
 
258
 
      procedure Free is new Ada.Unchecked_Deallocation (Wide_String, WS_Access);
259
 
 
260
181
      Ignored_Units : array (1 .. Count (Unit_Spec, "-")    ) of WS_Access;
261
182
      Ignored_Inx   : Natural := 0;
262
183
      Separators    : constant Wide_Character_Set := To_Set ("+-");
263
184
 
 
185
      procedure Free is new Ada.Unchecked_Deallocation (Wide_String, WS_Access);
 
186
 
 
187
      procedure Raise_Specification_Error (Mess : String) is
 
188
         use Ada.Exceptions;
 
189
      begin
 
190
         Raise_Exception (Specification_Error'Identity, Mess);
 
191
      end Raise_Specification_Error;
 
192
      pragma No_Return (Raise_Specification_Error);
 
193
 
264
194
      function Must_Ignore (Name : Wide_String) return Boolean is
265
195
         -- Check if unit name is either ignored, or a child (or a subunit) of an ignored unit
266
196
      begin
277
207
      end Must_Ignore;
278
208
 
279
209
      procedure Do_Process_With (My_Unit : Compilation_Unit) is
280
 
         The_Control : Traverse_Control := Continue;
281
 
         The_Info    : Info;
282
 
 
 
210
         use Asis.Clauses;
 
211
 
 
212
         procedure Add_Withed_Unit (Withed_Name : Asis.Expression) is
 
213
            use Asis.Expressions;
 
214
            use Thick_Queries;
 
215
            Unit_Name : Asis.Expression;
 
216
         begin
 
217
            if Expression_Kind (Withed_Name) = A_Selected_Component then
 
218
               -- Must add all units in the prefix
 
219
               Add_Withed_Unit (Prefix (Withed_Name));
 
220
 
 
221
               -- Treat this one
 
222
               Unit_Name := Selector (Withed_Name);
 
223
            else
 
224
               Unit_Name := Withed_Name;
 
225
            end if;
 
226
 
 
227
            declare
 
228
               Name_Def : constant Asis.Definition := Corresponding_Name_Definition (Unit_Name);
 
229
            begin
 
230
               if Unit_Origin (Enclosing_Compilation_Unit (Name_Def)) = An_Application_Unit then
 
231
                  Add (Full_Name_Image (Name_Def));
 
232
               end if;
 
233
            end;
 
234
         end Add_Withed_Unit;
283
235
      begin
284
236
         if Is_Nil (My_Unit) then
285
237
            return;
286
238
         end if;
287
239
 
288
240
         declare
289
 
            My_CC_List : constant Context_Clause_List
290
 
              := Context_Clause_Elements (Compilation_Unit => My_Unit,
291
 
                                          Include_Pragmas  => True) ;
 
241
            My_CC_List : constant Context_Clause_List := Context_Clause_Elements (My_Unit) ;
292
242
         begin
293
243
            for I in My_CC_List'Range loop
294
 
               Traverse_With (My_CC_List (I), The_Control, The_Info);
 
244
               if Clause_Kind (My_CC_List (I)) = A_With_Clause then
 
245
                   declare
 
246
                      Withed_Units : constant Asis.Name_List := Clause_Names (My_CC_List (I));
 
247
                   begin
 
248
                      for J in Withed_Units'Range loop
 
249
                         Add_Withed_Unit (Withed_Units (J));
 
250
                      end loop;
 
251
                   end;
 
252
               end if;
295
253
            end loop;
296
254
         end;
297
255
      end Do_Process_With;
312
270
            My_CU_List : constant Compilation_Unit_List := A4G_Bugs.Subunits (My_Unit);
313
271
         begin
314
272
            for I in My_CU_List'Range loop
315
 
               -- We do not add stubs is Add_Stubs is false, but we still need to
316
 
               -- add units that are withed by the stub
 
273
               -- We do not add stubs if Add_Stubs is false, but if recursive, we still need
 
274
               -- to add units that are withed by the stub
317
275
               if Add_Stubs then
318
276
                  Add (Unit_Full_Name (My_CU_List (I)));
319
277
               end if;
320
 
               Do_Process_With (My_CU_List (I));
 
278
 
 
279
               if Recursive then
 
280
                  Do_Process_With (My_CU_List (I));
 
281
               end if;
321
282
            end loop;
322
283
         end;
323
284
      end Do_Process_Stub;
324
285
 
325
 
      -- Forward declaration:
326
 
      procedure Process_Unit_Spec (Unit_Spec : Wide_String);
327
 
 
328
 
      procedure Process_Indirect_File (Name : String) is
329
 
         use Ada.Wide_Text_IO, Ada.Strings,Ada.Strings.Wide_Fixed;
330
 
 
331
 
         Units_File : Ada.Wide_Text_IO.File_Type;
332
 
 
333
 
         function Read_Line return Wide_String is
334
 
            Buffer : Wide_String (1..250);
335
 
            Last   : Natural;
336
 
         begin
337
 
            Get_Line (Units_File, Buffer, Last);
338
 
            if Last = Buffer'Last then
339
 
               return Buffer & Read_Line;
340
 
            else
341
 
               return Buffer (1 .. Last);
342
 
            end if;
343
 
         end Read_Line;
344
 
      begin
345
 
         Open (Units_File, In_File, Name);
346
 
 
347
 
         -- Exit on End_Error
348
 
         -- This is the simplest way to deal with improperly formed files
349
 
         loop
350
 
            declare
351
 
               Line : constant Wide_String := Trim (Read_Line, Both);
 
286
      procedure Process_Unit_Spec (Spec : Wide_String) is
 
287
         use Ada.Characters.Handling;
 
288
 
 
289
         procedure Process_Indirect_File (Name : String) is
 
290
            use Ada.Wide_Text_IO, Ada.Strings;
 
291
 
 
292
            Units_File : Ada.Wide_Text_IO.File_Type;
 
293
 
 
294
            function Read_Line return Wide_String is
 
295
               Buffer : Wide_String (1..250);
 
296
               Last   : Natural;
352
297
            begin
353
 
               if Line /= "" and then Line (1) /= '#' then
354
 
                  Process_Unit_Spec (Line);
 
298
               Get_Line (Units_File, Buffer, Last);
 
299
               if Last = Buffer'Last then
 
300
                  return Buffer & Read_Line;
 
301
               else
 
302
                  return Buffer (1 .. Last);
355
303
               end if;
356
 
            end;
357
 
         end loop;
358
 
 
359
 
         Close (Units_File);
360
 
      exception
361
 
         when Name_Error =>
362
 
            Raise_Specification_Error ("Missing units file: " & Name);
363
 
         when others =>  -- Including End_Error
364
 
            if Is_Open (Units_File) then
 
304
            end Read_Line;
 
305
         begin
 
306
            Open (Units_File, In_File, Name);
 
307
 
 
308
            -- Exit on End_Error
 
309
            -- This is the simplest way to deal with improperly formed files
 
310
            loop
 
311
               declare
 
312
                  Line : constant Wide_String := Trim (Read_Line, Both);
 
313
               begin
 
314
                  if Line /= "" and then Line (1) /= '#' then
 
315
                     Process_Unit_Spec (Line);
 
316
                  end if;
 
317
               end;
 
318
            end loop;
 
319
 
 
320
            Close (Units_File);
 
321
         exception
 
322
            when Name_Error =>
 
323
               Raise_Specification_Error ("Missing units file: " & Name);
 
324
            when others =>  -- Including End_Error
 
325
               if Is_Open (Units_File) then
365
326
               Close (Units_File);
366
 
            end if;
367
 
      end Process_Indirect_File;
368
 
 
369
 
      procedure Process_Unit_Spec (Unit_Spec : Wide_String) is
370
 
         use Ada.Characters.Handling;
 
327
               end if;
 
328
         end Process_Indirect_File;
371
329
 
372
330
         Start : Positive;
373
331
         Stop  : Natural;
374
 
      begin
 
332
      begin  -- Process_Unit_Spec
375
333
         --
376
334
         -- Get rid of case of indirect file:
377
335
         --
378
 
         if Unit_Spec (Unit_Spec'First) = '@' then
379
 
            if Unit_Spec'Length = 1 then
 
336
         if Spec (Spec'First) = '@' then
 
337
            if Spec'Length = 1 then
380
338
               -- '@' alone
381
339
               Raise_Specification_Error ("Missing file name after @");
382
340
            else
383
 
               Process_Indirect_File (To_String (Unit_Spec (Unit_Spec'First+1 .. Unit_Spec'Last)));
 
341
               Process_Indirect_File (To_String (Spec (Spec'First+1 .. Spec'Last)));
384
342
               return;
385
343
            end if;
386
344
         end if;
389
347
         -- Extract unit names and ignored units from unit spec.
390
348
         --
391
349
 
392
 
         -- If Unit_spec starts with '-', our count is wrong...
 
350
         -- If Spec starts with '-', our count is wrong...
393
351
         -- let's forbid this case
394
 
         if Unit_Spec (Unit_Spec'First) = '-' then
395
 
            Raise_Specification_Error ("Wrong unit specification: " & To_String (Unit_Spec));
 
352
         if Spec (Spec'First) = '-' then
 
353
            Raise_Specification_Error ("Wrong unit specification: " & To_String (Spec));
396
354
         end if;
397
355
 
398
 
         if Unit_Spec (Unit_Spec'First) = '+' then
399
 
            Start := Unit_Spec'First + 1;
 
356
         if Spec (Spec'First) = '+' then
 
357
            Start := Spec'First + 1;
400
358
         else
401
 
            Start := Unit_Spec'First;
 
359
            Start := Spec'First;
402
360
         end if;
403
361
         loop
404
 
            Stop := Index (Unit_Spec (Start .. Unit_Spec'Last), Separators);
 
362
            Stop := Index (Spec (Start .. Spec'Last), Separators);
405
363
            if Stop = 0 then
406
 
               Stop := Unit_Spec'Last;
 
364
               Stop := Spec'Last;
407
365
            elsif Stop = Start then   -- "--" or "+-" or "-+" or "++" ...
408
366
               Raise_Specification_Error ("No unit name after '-' or '+'");
409
367
            else
410
368
               Stop := Stop - 1;
411
369
            end if;
412
 
            if Start = Unit_Spec'First or else Unit_Spec (Start-1) = '+' then
413
 
               Add (To_Upper(Unit_Spec (Start .. Stop)));
 
370
            if Start = Spec'First or else Spec (Start-1) = '+' then
 
371
               Add (To_Upper(Spec (Start .. Stop)));
414
372
            else
415
373
               Ignored_Inx                 := Ignored_Inx + 1;
416
 
               Ignored_Units (Ignored_Inx) := new Wide_String'(To_Upper(Unit_Spec (Start .. Stop)));
 
374
               Ignored_Units (Ignored_Inx) := new Wide_String'(To_Upper(Spec (Start .. Stop)));
417
375
            end if;
418
 
            exit when Stop = Unit_Spec'Last;
 
376
            exit when Stop = Spec'Last;
419
377
            Start := Stop + 2;
420
378
         end loop;
421
379
      end Process_Unit_Spec;
450
408
 
451
409
                  -- Analyze with clauses
452
410
                  Do_Process_With (Library_Unit_Declaration (One_Unit, My_Context));
453
 
                  Do_Process_With (Compilation_Unit_Body (One_Unit, My_Context));
 
411
                  Do_Process_With (Compilation_Unit_Body    (One_Unit, My_Context));
454
412
               end if;
455
413
               Skip;
456
414
            end if;