« back to all changes in this revision
Viewing changes to ad-driver.adb
- browse files at revision 1
- compare with another revision
- download diff
- download tarball
- view history from revision 1
- 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
- files added:
- config
- doc
- simple_test
- xml
added
removed
ad-driver.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
-- Main procedure of AdaBrowse.</DL>
28
--
29
-- <!--
30
-- Revision History
31
--
32
-- 02-FEB-2002 TW V1.0 First release.
33
-- 04-FEB-2002 TW V1.01 Added automatic tree file generation. Improved
34
-- some error messages. Added "-a | -all" option, which
35
-- generates HTML also for all supporters of the given
36
-- unit.
37
-- 06-FEB-2002 TW Added the "-q" and "-x" options, changed behavior of
38
-- all options taking filenames (may be in the next arg,
39
-- or immediately following the option prefix). Changed
40
-- some error handling. Added support for excluding units.
41
-- 07-FEB-2002 TW Added support for "-I" options with directories that
42
-- contain white space. Improved the Asis initialization:
43
-- it also catches inconsistencies reported by Asis now
44
-- and tries to correct them. Improved the command line
45
-- handling (new exception 'Help_Requested').
46
-- 13-MAR-2002 TW V1.3 Changed to handle several units; added "-i" option
47
-- for index creation.
48
-- 14-MAR-2002 TW Added "-is" option for nested index creation; allow
49
-- index generation also if "-all" is given.
50
-- 15-MAR-2002 TW Added an optional file name argument to "-i" and "-is".
51
-- 19-MAR-2002 TW V1.33 Corrected plausibility test of filename in -o
52
-- option: must not be done if name is "-". Minor change in
53
-- 'Recreate': pass not just the file name, but also its
54
-- path! (Allows 'Create_Unit' to automatically add that
55
-- path as a "-I" option to the compile command.)
56
-- Correction in 'Process_One_Unit': if it's *not* a
57
-- src-vs-tree inconsistency, re-raise the exception.
58
-- 26-MAR-2002 TW Added support for krunched file names.
59
-- 28-MAR-2002 TW Added "-t" and "-p" options for type and subprogram
60
-- indices. Same syntax as "-i".
61
-- 03-APR-2002 TW Uses new index package now.
62
-- 24-APR-2002 TW Uses AD.All_Units now to avoid processing the same unit
63
-- multiple times if "-all" in file input mode is given.
64
-- 02-MAY-2002 TW Added the user-defined HTML tags feature.
65
-- 03-JUL-2002 TW Added the "-g" option; added logic such that the
66
-- general context using all tree files is initialized and
67
-- opened only once, and not opened and closed for each
68
-- and every input unit. It appears that ASIS-for-GNAT has
69
-- a rather huge memory leak on closing a context, and
70
-- furthermore, opening a context is slow!
71
-- 20-AUG-2002 TW Added the "-G" option.
72
-- 28-AUG-2002 TW Added the "-l" option.
73
-- 11-NOV-2002 TW Catch Program_Error if it is an "Inconsistent versions
74
-- of GNAT and ASIS" bug, so that we don't get the "report
75
-- this error" message. I couldn't do anything about it
76
-- anyway: you'll have to rebuild AdaBrowse or use the
77
-- same GNAT as was used to build AdaBrowse itself. I know,
78
-- it's a major nuisance, but I'm not responsible for that.
79
-- Complain to ACT, if you like (but I guess they won't
80
-- make their ASIS and their tree files compiler version
81
-- independent).
82
-- 22-NOV-2002 TW Added "-private" option.
83
-- 28-APR-2003 TW Customized ASIS initialization to work around a most
84
-- annoying behavior of ASIS-for-GNAT 3.16a.
85
-- 07-JUN-2003 TW Added support for the GNAT project manager.
86
-- 12-JUN-2003 TW Changed into a package.
87
-- 30-JUN-2003 TW Adapted to new index management.
88
-- 09-JUL-2003 TW Delay processing the -f input until after the project
89
-- file has been processed. Also, don't delete the tree
90
-- files we generated if we're using a project file: in
91
-- that case, the tree directory is ours, and we may well
92
-- leave the files there for future re-use.
93
-- 18-NOV-2003 TW Added -X option for consistency with GNAT's project
94
-- manager.
95
-- 19-NOV-2003 TW Added checks that directories really exist. Additional
96
-- check in exception handling for "not compile-only" tree
97
-- files.
98
-- -->
99
-------------------------------------------------------------------------------
100
101
pragma License (GPL);
102
103
with Ada.Characters.Handling;
104
with Ada.Command_Line;
105
with Ada.Exceptions;
106
with Ada.Text_IO;
107
with Ada.Strings.Unbounded;
108
with Ada.Unchecked_Deallocation;
109
110
with Asis;
111
with Asis.Errors;
112
with Asis.Exceptions;
113
with Asis.Compilation_Units;
114
with Asis.Ada_Environments;
115
with Asis.Implementation;
116
117
with Asis2.Naming;
118
119
with AD.Compiler;
120
with AD.Config;
121
with AD.Crossrefs;
122
with AD.Environment;
123
with AD.Exclusions;
124
with AD.File_Ops;
125
with AD.Filters;
126
with AD.HTML;
127
with AD.Indices.Configuration;
128
with AD.Messages;
129
with AD.Options;
130
with AD.Printers;
131
with AD.Printers.HTML;
132
with AD.Printers.XML;
133
with AD.Projects;
134
with AD.Queries;
135
with AD.Parameters;
136
with AD.Parse;
137
with AD.Scanner;
138
with AD.Setup;
139
with AD.Text_Utilities;
140
with AD.User_Tags;
141
with AD.Version;
142
143
with Util.Pathes;
144
with Util.Strings;
145
146
pragma Elaborate_All (AD.Projects);
147
pragma Elaborate_All (AD.Version);
148
149
package body AD.Driver is
150
151
package ACH renames Ada.Characters.Handling;
152
package ASU renames Ada.Strings.Unbounded;
153
154
package AIC renames AD.Indices.Configuration;
155
156
use Ada.Text_IO;
157
158
use AD.Messages;
159
use AD.Printers;
160
use AD.Text_Utilities;
161
162
use Util.Strings;
163
164
Help_Requested : exception;
165
Command_Line_Error : exception;
166
No_Tree_File : exception;
167
168
Asis_Context : Asis.Context;
169
Asis_Unit : Asis.Compilation_Unit;
170
Tree_Dirs : ASU.Unbounded_String;
171
Src_Dirs : ASU.Unbounded_String;
172
O_Option_Set : Boolean := False;
173
174
Has_Project : Boolean := False;
175
Project_File : ASU.Unbounded_String;
176
177
Pass_On_Options : ASU.Unbounded_String;
178
179
Print_Src_Names : Boolean := False;
180
181
type File_Ptr is access Ada.Text_IO.File_Type;
182
183
Src_Files : File_Ptr;
184
185
Tree_File_Name : ASU.Unbounded_String;
186
187
Transitive_Closure : Boolean := False;
188
Generate_Index : Boolean := False;
189
190
General_Context_Tried : Boolean := False;
191
General_Context_Open : Boolean := False;
192
193
type Printer_Kinds is
194
(HTML_Printer, XML_Printer, DocBook_Printer);
195
196
type Printer_Set is array (Printer_Kinds) of Boolean;
197
198
Enabled_Printers : Printer_Set := (others => False);
199
200
The_Printer : AD.Printers.Printer_Ref := null;
201
202
Version : constant String :=
203
AD.Version.Get_Version & AD.Projects.Project_Version &
204
" (" & AD.Version.Time & " / " & AD.Version.Get_Asis_Version & ')';
205
206
package Handled_Units is
207
208
procedure Add
209
(Name : in String);
210
211
function Exists
212
(Name : in String)
213
return Boolean;
214
215
end Handled_Units;
216
217
package body Handled_Units is separate;
218
219
procedure Handle_Command_Line
220
(Quit : out Boolean)
221
is
222
use Ada.Command_Line;
223
224
procedure Check_Following
225
(Curr, Last : in Natural;
226
Name : in String)
227
is
228
begin
229
if Curr > Last then
230
Error (Name & " option must be followed by something.");
231
raise Command_Line_Error;
232
end if;
233
end Check_Following;
234
235
procedure Set_Index
236
(Idx : in AIC.Index_Type;
237
Last : in Natural;
238
Curr : in out Natural)
239
is
240
begin
241
AIC.Enter_Index (Idx);
242
if Curr < Last then
243
declare
244
Next : constant String := Argument (Curr + 1);
245
begin
246
if Next = "-" or else Next (Next'First) /= '-' then
247
Curr := Curr + 1;
248
AIC.Set_File_Name (Idx, Next);
249
end if;
250
end;
251
end if;
252
end Set_Index;
253
254
function Quote_If_Needed
255
(S : in String)
256
return String
257
is
258
begin
259
if S'Length = 0 or else -- Empty string OR
260
S (S'First) = '"' or else -- Already quoted OR
261
Util.Strings.Next_Blank (S) = 0 -- No blanks
262
then
263
return S;
264
end if;
265
return Util.Strings.Quote (S, '"', '\');
266
end Quote_If_Needed;
267
268
procedure Handle_External_Variable_Assignment
269
(S : in String)
270
is
271
begin
272
if S'Length <= 1 or else
273
S (S'First) /= '"'
274
then
275
AD.Environment.Add (S);
276
else
277
if S (S'Last) /= '"' then
278
-- Missing final quote?
279
Error ("Unterminated quote in -X option: " & S);
280
raise Command_Line_Error;
281
end if;
282
AD.Environment.Add
283
(Util.Strings.Unquote (S (S'First + 1 .. S'Last - 1), '"', '\'));
284
end if;
285
exception
286
when AD.Environment.Invalid_Variable_Assignment =>
287
Error ("Invalid -X option: " & S);
288
raise Command_Line_Error;
289
end Handle_External_Variable_Assignment;
290
291
procedure Add_Directory
292
(Flags : in out ASU.Unbounded_String;
293
Flag : in String;
294
Path : in String;
295
Quoted : in Boolean)
296
is
297
Dir : constant String := Canonical (Path);
298
begin
299
if not AD.File_Ops.Is_Directory (Dir) then
300
Error (Dir & " is an invalid directory (" & Flag & ')');
301
raise Command_Line_Error;
302
end if;
303
if Quoted then
304
ASU.Append (Flags, ' ' & Quote_If_Needed (Flag & Dir));
305
else
306
ASU.Append (Flags, ' ' & Flag & Dir);
307
end if;
308
end Add_Directory;
309
310
F_Input : ASU.Unbounded_String;
311
File_Name_Set : Boolean := False;
312
I : Natural := 1;
313
Print_Version : Boolean := False;
314
315
N : constant Natural := Argument_Count;
316
Max : Natural := N;
317
-- Used to pass to 'Set_Index' in palce of 'Curr' to suppress the
318
-- setting of the file name.
319
320
begin
321
if N = 0 then raise Help_Requested; end if;
322
Quit := False;
323
while I <= N loop
324
declare
325
S : constant String := Argument (I);
326
begin
327
if S = "-h" or else S = "-?" or else
328
S = "-help" or else S = "--help"
329
then
330
raise Help_Requested;
331
elsif S = "-G" then
332
I := I + 1;
333
Check_Following (I, N, S);
334
while I <= N loop
335
declare
336
Next : constant String := To_Lower (Argument (I));
337
begin
338
if Next = "html" then
339
Enabled_Printers (HTML_Printer) := True;
340
elsif Next = "xml" then
341
Enabled_Printers (XML_Printer) := True;
342
-- elsif Next = "docbook" then
343
-- Enabled_Printers (DocBook_Printer) := True;
344
else
345
exit;
346
end if;
347
end;
348
I := I + 1;
349
end loop;
350
I := I - 1;
351
elsif S = "-g" then
352
AD.Crossrefs.Set_Standard_Units (True);
353
elsif S = "-l" then
354
AD.Printers.Set_Line_Only;
355
elsif S = "-v" or else S = "-version" or else S = "--version" then
356
Print_Version := True;
357
elsif S = "-o" then
358
I := I + 1;
359
Check_Following (I, N, S);
360
if O_Option_Set then
361
Error ("only one -o option may be given.");
362
raise Command_Line_Error;
363
end if;
364
AD.Options.Set_Output_Name (Canonical (Argument (I)));
365
O_Option_Set := True;
366
elsif S'Length > 2 and then
367
S (S'First .. S'First + 1) = "-o"
368
then
369
if O_Option_Set then
370
Error ("only one -o option may be given.");
371
raise Command_Line_Error;
372
end if;
373
AD.Options.Set_Output_Name
374
(Canonical (S (S'First + 2 .. S'Last)));
375
O_Option_Set := True;
376
elsif S = "-f" then
377
I := I + 1;
378
Check_Following (I, N, S);
379
if File_Name_Set then
380
Warn ("Input already set; " &
381
"ignoring option: " & S & ' ' & Argument (I));
382
else
383
F_Input :=
384
ASU.To_Unbounded_String
385
(Canonical (Argument (I)));
386
File_Name_Set := True;
387
end if;
388
elsif S'Length > 2 and then
389
S (S'First .. S'First + 1) = "-f"
390
then
391
if File_Name_Set then
392
Warn ("Input already set; ignoring option: " & S);
393
else
394
F_Input :=
395
ASU.To_Unbounded_String
396
(Canonical (S (S'First + 2 .. S'Last)));
397
File_Name_Set := True;
398
end if;
399
elsif S = "-c" then
400
I := I + 1;
401
Check_Following (I, N, S);
402
AD.Config.Configure (Canonical (Argument (I)));
403
elsif S'Length > 2 and then
404
S (S'First .. S'First + 1) = "-c"
405
then
406
AD.Config.Configure (Canonical (S (S'First + 2 .. S'Last)));
407
elsif S = "-q" then
408
AD.Messages.Set_Mode (AD.Messages.Only_Errors);
409
elsif S'Length = 3 and then
410
S (S'First .. S'First + 1) = "-w"
411
then
412
case S (S'First + 2) is
413
when '0' | 'e' =>
414
AD.Messages.Set_Mode (AD.Messages.Only_Errors);
415
when '1' | 'w' =>
416
AD.Messages.Set_Mode (AD.Messages.Errors_And_Warnings);
417
when '2' | 'a' | 'i' =>
418
AD.Messages.Set_Mode (AD.Messages.All_Messages);
419
when 'D' =>
420
AD.Messages.Set_Mode (AD.Messages.Including_Debug);
421
AD.Messages.Debug ("Debug messages activated!");
422
when others =>
423
Error ("unknown warning level on command line.");
424
raise Command_Line_Error;
425
end case;
426
elsif S = "-s" then
427
I := I + 1;
428
Check_Following (I, N, S);
429
AD.HTML.Set_Style_Sheet (Argument (I));
430
elsif S'Length > 2 and then
431
S (S'First .. S'First + 1) = "-s"
432
then
433
AD.HTML.Set_Style_Sheet (S (S'First + 2 .. S'Last));
434
elsif S = "-is" then
435
Set_Index (AIC.Unit_Index, N, I);
436
AIC.Set_Structured (AIC.Unit_Index, True);
437
elsif S'Length > 3 and then
438
S (S'First .. S'First + 2) = "-is"
439
then
440
Set_Index (AIC.Unit_Index, N, Max);
441
AIC.Set_Structured (AIC.Unit_Index, True);
442
AIC.Set_File_Name
443
(AIC.Unit_Index, Canonical (S (S'First + 3 .. S'Last)));
444
elsif S = "-i" then
445
Set_Index (AIC.Unit_Index, N, I);
446
AIC.Set_Structured (AIC.Unit_Index, False);
447
elsif S'Length > 2 and then
448
S (S'First .. S'First + 1) = "-i"
449
then
450
Set_Index (AIC.Unit_Index, N, Max);
451
AIC.Set_Structured (AIC.Unit_Index, False);
452
AIC.Set_File_Name
453
(AIC.Unit_Index, Canonical (S (S'First + 2 .. S'Last)));
454
elsif S = "-t" then
455
Set_Index (AIC.Type_Index, N, I);
456
elsif S'Length > 2 and then
457
S (S'First .. S'First + 1) = "-t"
458
then
459
Set_Index (AIC.Type_Index, N, Max);
460
AIC.Set_File_Name
461
(AIC.Type_Index, Canonical (S (S'First + 2 .. S'Last)));
462
elsif S = "-private" or else S = "--private" then
463
AD.Options.Set_Private_Too (True);
464
elsif S = "-p" then
465
Set_Index (AIC.Subprogram_Index, N, I);
466
elsif S'Length > 2 and then
467
S (S'First .. S'First + 1) = "-p"
468
then
469
Set_Index (AIC.Subprogram_Index, N, Max);
470
AIC.Set_File_Name
471
(AIC.Subprogram_Index, Canonical (S (S'First + 2 .. S'Last)));
472
elsif S = "-P" then
473
I := I + 1;
474
Check_Following (I, N, S);
475
if Has_Project then
476
Error ("only one -P option may be given.");
477
raise Command_Line_Error;
478
end if;
479
Has_Project := True;
480
Project_File :=
481
ASU.To_Unbounded_String (Canonical (Argument (I)));
482
elsif S'Length > 2 and then
483
S (S'First .. S'First + 1) = "-P"
484
then
485
if Has_Project then
486
Error ("only one -P option may be given.");
487
raise Command_Line_Error;
488
end if;
489
Has_Project := True;
490
Project_File :=
491
ASU.To_Unbounded_String
492
(Canonical (S (S'First + 2 .. S'Last)));
493
elsif S = "-X" then
494
-- External variable assignment. Applies to project files
495
-- *and* to AdaBrowse config files subsequently read.
496
-- Syntax: -X name=value or -X "name = value".
497
I := I + 1;
498
Check_Following (I, N, S);
499
Handle_External_Variable_Assignment (Argument (I));
500
ASU.Append (Pass_On_Options, " -X" &
501
Quote_If_Needed (Argument (I)));
502
elsif S'Length > 2 and then
503
S (S'First .. S'First + 1) = "-X"
504
then
505
Handle_External_Variable_Assignment (S (S'First + 2 .. S'Last));
506
ASU.Append (Pass_On_Options, " -X" &
507
Quote_If_Needed (S (S'First + 2 .. S'Last)));
508
elsif S = "-a" or else S = "-all" or else S = "--all" then
509
Transitive_Closure := True;
510
elsif S = "-x" then
511
AD.Options.Set_Overwrite (False);
512
elsif S = "-T" then
513
-- Options for Asis.
514
I := I + 1;
515
Check_Following (I, N, S);
516
if Next_Blank (Argument (I)) /= 0 then
517
Error ("Directories for the -T option must not contain " &
518
"white space; option = " &
519
S & " """ & Argument (I) & '"');
520
raise Command_Line_Error;
521
end if;
522
Add_Directory (Tree_Dirs, "-T", Argument (I), False);
523
elsif S'Length > 2 and then
524
S (S'First .. S'First + 1) = "-T"
525
then
526
-- Options for Asis.
527
if Next_Blank (S) /= 0 then
528
Error ("Directories for the -T option must not contain " &
529
"white space; option = " & S);
530
raise Command_Line_Error;
531
end if;
532
Add_Directory
533
(Tree_Dirs, "-T", S (S'First + 2 .. S'Last), False);
534
elsif S = "-I" then
535
-- Options for Asis.
536
I := I + 1;
537
Check_Following (I, N, S);
538
Add_Directory (Src_Dirs, "-I", Argument (I), True);
539
elsif S'Length > 2 and then
540
S (S'First .. S'First + 1) = "-I"
541
then
542
-- Options for Asis
543
Add_Directory (Src_Dirs, "-I", S (S'First + 2 .. S'Last), True);
544
else
545
Error ("Unknown command-line option: " & S);
546
raise Command_Line_Error;
547
end if;
548
end;
549
I := I + 1;
550
end loop;
551
if Print_Version then
552
Put_Line (Current_Error,
553
"AdaBrowse " & Version &
554
"; Copyright (c) 2002, 2003 by Thomas Wolf");
555
if N = 1 then
556
Quit := True;
557
return;
558
end if;
559
end if;
560
if Has_Project then
561
begin
562
AD.Projects.Handle_Project_File (ASU.To_String (Project_File));
563
exception
564
when E : AD.Projects.Project_Error =>
565
Error (Ada.Exceptions.Exception_Message (E));
566
raise Command_Line_Error;
567
end;
568
end if;
569
Generate_Index := AD.Indices.Has_Indices;
570
if File_Name_Set then
571
AD.Parameters.Set_Input (ASU.To_String (F_Input));
572
else
573
if not Has_Project then
574
Error ("No input file name! " &
575
"(At least one of -f or -P must be given.)");
576
raise Command_Line_Error;
577
else
578
Info ("Processing all sources in project '" &
579
ASU.To_String (Project_File) & ''');
580
Print_Src_Names := True;
581
Src_Files := new Ada.Text_IO.File_Type;
582
Ada.Text_IO.Create (Src_Files.all, Ada.Text_IO.Out_File);
583
AD.Projects.Get_Source_File_List (Src_Files.all);
584
Ada.Text_IO.Reset (Src_Files.all, Ada.Text_IO.In_File);
585
AD.Parameters.Set_Input
586
(Ada.Text_IO.File_Access'(Src_Files.all'Unchecked_Access));
587
-- Actually, I think plain 'Access should work just as well,
588
-- but unfortunately GNAT 3.15p complains.
589
end if;
590
end if;
591
if Has_Project and then not O_Option_Set then
592
declare
593
Target : constant String :=
594
AD.Projects.Get_Output_Directory;
595
begin
596
if Target'Length > 0 then
597
Info ("Output goes to " & Target);
598
if Util.Pathes.Name (Target)'Length > 0 then
599
AD.Options.Set_Output_Name
600
(Target & Util.Pathes.Directory_Separator);
601
else
602
AD.Options.Set_Output_Name (Target);
603
end if;
604
O_Option_Set := True;
605
end if;
606
end;
607
end if;
608
if Generate_Index then
609
if not AD.Parameters.Is_File and then not Transitive_Closure then
610
Warn ("Index generation is only active if AdaBrowse is supposed " &
611
"to process more than one unit. " &
612
"(-f- or -f @file_name or -a or -P project_file)");
613
Generate_Index := False;
614
elsif AD.Options.Output_Name = "-" then
615
Warn ("Index generation turned off because output goes to " &
616
"stdout. (-o- was given.)");
617
Generate_Index := False;
618
end if;
619
end if;
620
-- Find out how many printers are enabled.
621
declare
622
Nof_Printers : Natural := 0;
623
begin
624
for I in Enabled_Printers'Range loop
625
if Enabled_Printers (I) then
626
Nof_Printers := Nof_Printers + 1;
627
end if;
628
end loop;
629
if Nof_Printers = 0 then
630
-- If no "-G" option was given, enable the HTML printer by
631
-- default.
632
Nof_Printers := 1;
633
Enabled_Printers (HTML_Printer) := True;
634
end if;
635
if AD.Options.Output_Name = "-" and then Nof_Printers > 1 then
636
Error ("Output must not go to stdout if more than one output " &
637
"format is enabled (-G option).");
638
raise Command_Line_Error;
639
end if;
640
if AD.Parameters.Is_File or else Nof_Printers > 1 or else
641
Transitive_Closure
642
then
643
AD.Options.Set_Processing_Mode (AD.Options.Multiple_Files);
644
else
645
AD.Options.Set_Processing_Mode (AD.Options.Single_File);
646
end if;
647
end;
648
if Has_Project then
649
declare
650
Prj_Tree_Dir : constant String := AD.Projects.Get_Tree_Directory;
651
begin
652
if Prj_Tree_Dir'Last >= Prj_Tree_Dir'First then
653
ASU.Append (Tree_Dirs, " -T" & Prj_Tree_Dir);
654
end if;
655
AD.Messages.Info
656
("Tree directory is " & Prj_Tree_Dir);
657
end;
658
-- We have to change the compile command to ensure that the project
659
-- file gets passed along and the compiler thus has the environment
660
-- it needs (configuration pragmas, naming schemes, etc.)
661
-- Note: we also pass on -X options!
662
AD.Compiler.Set_Compile_Command
663
("gnat compile -c -gnatc -gnatt -P" &
664
AD.Projects.Get_Project_File_Name &
665
ASU.To_String (Pass_On_Options));
666
end if;
667
exception
668
when Command_Line_Error =>
669
-- Check if there's a help option somewhere. If so, translate this
670
-- into a Help_Requested. (This allows the user to simply re-use a
671
-- command that previously terminated with a Command_Line_Error with
672
-- an additional help option at the end to get the help. I find this
673
-- personally useful because it saves typing; since most command
674
-- shells support a "command history", I can get the help by typing
675
-- <UP-ARROW> -?<RETURN>, which is way faster than having to type
676
-- adabrowse -?<RETURN>.)
677
I := I + 1;
678
-- We failed on argument I, so we only need to check the remaining
679
-- arguments.
680
while I <= N loop
681
declare
682
S : constant String := Argument (I);
683
begin
684
exit when S = "-?" or else S = "-h" or else
685
S = "-help" or else S = "--help";
686
end;
687
I := I + 1;
688
end loop;
689
if I <= N then
690
raise Help_Requested;
691
else
692
raise;
693
end if;
694
end Handle_Command_Line;
695
696
procedure Report
697
(Debug_Only : Boolean := False)
698
is
699
use type AD.Messages.Verbosity;
700
begin
701
if not Debug_Only or else
702
AD.Messages.Get_Mode = AD.Messages.Including_Debug
703
then
704
Put_Line (Current_Error,
705
"*** Please report this error to " &
706
AD.Version.Get_Maintainer &
707
", giving the AdaBrowse version,");
708
Put_Line (Current_Error,
709
"host environment, GNAT version, and all input files" &
710
" (Ada sources, style sheets ");
711
Put_Line (Current_Error,
712
"and configuration files).");
713
Put_Line (Current_Error,
714
"This is AdaBrowse " & Version &
715
"; Copyright (c) 2002, 2003 by Thomas Wolf");
716
end if;
717
end Report;
718
719
procedure Report_No_GNATC
720
(E : in Ada.Exceptions.Exception_Occurrence;
721
Asis_Info : in String)
722
is
723
begin
724
Error ("Fatal ASIS failure. It seems like some tree files have");
725
Error ("been compiled with only ""-gnatt"" (no ""-gnatc"").");
726
Error ("Verify this, and if the error doesn't go away, re-run");
727
Error ("AdaBrowse with the ""-wD"" option to get more information.");
728
Debug (Ada.Exceptions.Exception_Information (E));
729
Debug (Asis_Info);
730
Report (Debug_Only => True);
731
end Report_No_GNATC;
732
733
procedure Recreate
734
is
735
-- Call the compiler (if any) to try to recreate the ASIS-information.
736
-- Raises 'No_Tree' if a compilation command is set, but fails. If
737
-- no compilation command is defined, nothing at all happens. Assumes
738
-- 'Asis_Context' to be closed upon entry and, if compilation was
739
-- successful, tries to open it.
740
-- Hmmm... what happens here if the command reads from stdin, or
741
-- does not return? For the time being, we just assume that compilers
742
-- don't do such nasty things!
743
Ok : Boolean := False;
744
begin
745
if AD.Compiler.Get_Compile_Command /= "" then
746
Info ("Trying to recompile """ & AD.Parameters.Source_Name & """...");
747
AD.Compiler.Create_Unit
748
(Util.Pathes.Concat
749
(AD.Parameters.Path, AD.Parameters.Source_Name),
750
Src_Dirs, Tree_Dirs, Tree_File_Name, Ok);
751
if Ok then
752
Info ("Recompilation of """ & AD.Parameters.Source_Name &
753
""" was successful.");
754
-- Success! Re-open the context and try again.
755
Asis.Ada_Environments.Associate
756
(The_Context => Asis_Context,
757
Name => "AdaBrowse_Context",
758
Parameters => To_Wide_String ("-C1 -FT -SA -T. " &
759
ASU.To_String (Tree_File_Name)));
760
Asis.Ada_Environments.Open (Asis_Context);
761
else
762
raise No_Tree_File;
763
end if;
764
end if;
765
end Recreate;
766
767
procedure Transform_Unit
768
(Unit : in Asis.Compilation_Unit)
769
is
770
begin
771
AD.Scanner.Scan (Unit, The_Printer);
772
AD.User_Tags.Reset_Tags;
773
exception
774
when others =>
775
begin
776
Asis.Ada_Environments.Close (Asis_Context);
777
Asis.Ada_Environments.Dissociate (Asis_Context);
778
Asis.Implementation.Finalize ("");
779
exception
780
when others =>
781
null;
782
end;
783
raise;
784
end Transform_Unit;
785
786
procedure Process_One_Unit
787
is
788
789
procedure Delete_ADT
790
is
791
begin
792
if ASU.Length (Tree_File_Name) > 0 and then not Has_Project then
793
-- We created a tree file: try to delete it!
794
-- (But only if we're not working from a project file: project
795
-- files have a tree directory, and that's ours!)
796
declare
797
ADT_Name : constant String := ASU.To_String (Tree_File_Name);
798
begin
799
AD.File_Ops.Delete (ADT_Name);
800
-- And GNAT also creates a "*.ali" file...
801
AD.File_Ops.Delete
802
(ADT_Name (ADT_Name'First .. ADT_Name'Last - 3) & "ali");
803
end;
804
end if;
805
Tree_File_Name := ASU.Null_Unbounded_String;
806
exception
807
when others =>
808
-- Swallow the exception!
809
Tree_File_Name := ASU.Null_Unbounded_String;
810
end Delete_ADT;
811
812
Skip_Unit : exception;
813
814
use type Ada.Exceptions.Exception_Id;
815
816
begin
817
if Handled_Units.Exists (AD.Parameters.Unit_Name) then return; end if;
818
if Print_Src_Names then
819
Info ("Processing file """ & AD.Parameters.Source_Name & '"');
820
end if;
821
-- Now try to open the Asis context. This is pretty complex. By default,
822
-- we use all tree files, but if ASIS detects an inconsistency, we first
823
-- need to hack around to properly detect that, then try to recompile
824
-- the given file, and finally re-open the context with options telling
825
-- ASIS to use only that new tree file.
826
827
Init_Asis :
828
declare
829
Already_Tried_To_Create : Boolean := False;
830
begin
831
Initially :
832
begin
833
if not General_Context_Tried then
834
General_Context_Tried := True;
835
Asis.Ada_Environments.Associate
836
(The_Context => Asis_Context,
837
Name => "AdaBrowse_Context",
838
Parameters => To_Wide_String
839
("-CA -FT -SA " &
840
ASU.To_String (Tree_Dirs)));
841
-- use "-FM -SA" (generate tree files as needed)?
842
-- use "-I<dir>" (directories to search for sources)
843
-- use "-T<dir>" (directories to search for trees)
844
--
845
-- Default is "-CA -FT -SA" (all tree files found, no automatic
846
-- tree generation, use all sources for consistency checks).
847
--
848
-- Note that "-FM" requires "-SA"! Also note that it is
849
-- absolutely unclear what happens with any generated tree
850
-- files when the context is closed. Neither the ASIS-for-GNAT
851
-- RM nor the UG say whether or not these files are deleted
852
-- once the last context using them is closed... They also
853
-- don't say where these files are created: in the current
854
-- directory, in a directory given by a "-T" option, or in
855
-- the system's temporary directory? Probably in the current
856
-- directory, following the "gcc" command launched internally.
857
--
858
-- Note: for the time being, we do not use "-FM": some ASIS
859
-- queries (e.g. Corresponding_Children) are implemented only
860
-- for "-FT"!
861
862
Asis.Ada_Environments.Open (Asis_Context);
863
General_Context_Open := True;
864
elsif not General_Context_Open then
865
Already_Tried_To_Create := True;
866
Recreate;
867
end if;
868
exception
869
when Asis.Exceptions.ASIS_Failed =>
870
if AD.Compiler.Get_Compile_Command = "" then
871
raise;
872
end if;
873
-- ASIS-for-GNAT specific!
874
declare
875
Msg : constant String :=
876
Trim (To_String (Asis.Implementation.Diagnosis));
877
I : Natural :=
878
Index (Msg, " is inconsistent with a tree file");
879
begin
880
if I = 0 then
881
I := Index (Msg, "does not exist");
882
end if;
883
if I > 0 then
884
-- It *is* indeed a source-vs-tree
885
-- inconsistency!
886
Warn (Msg);
887
-- Close the context again and try to recreate
888
-- the ASIS info and then re-open the context.
889
if Asis.Ada_Environments.Is_Open (Asis_Context) then
890
Asis.Ada_Environments.Close (Asis_Context);
891
end if;
892
Asis.Ada_Environments.Dissociate (Asis_Context);
893
General_Context_Open := False;
894
Already_Tried_To_Create := True;
895
Recreate;
896
else
897
raise;
898
end if;
899
end;
900
end Initially;
901
902
Asis_Unit :=
903
Asis.Compilation_Units.Library_Unit_Declaration
904
(To_Wide_String (AD.Parameters.Unit_Name), Asis_Context);
905
906
if Asis.Compilation_Units.Is_Nil (Asis_Unit) then
907
-- Hmmm... might be a krunched file name: try to find the source
908
-- file, and extract the unit name from the source!
909
declare
910
Full_Name : constant String :=
911
AD.File_Ops.Find
912
(Util.Pathes.Concat
913
(AD.Parameters.Path, AD.Parameters.Source_Name),
914
Src_Dirs);
915
begin
916
if Full_Name'Last >= Full_Name'First then
917
declare
918
True_Name : constant String :=
919
AD.Parse.Get_Unit_Name (Full_Name);
920
begin
921
if True_Name'Last >= True_Name'First and then
922
To_Lower (True_Name) /=
923
To_Lower (AD.Parameters.Unit_Name)
924
then
925
if Handled_Units.Exists (True_Name) then
926
raise Skip_Unit;
927
end if;
928
Info ("File """ & Full_Name &
929
""" contains a unit named """ & True_Name & '"');
930
AD.Parameters.Set_Unit_Name (True_Name);
931
Asis_Unit :=
932
Asis.Compilation_Units.Library_Unit_Declaration
933
(To_Wide_String (True_Name), Asis_Context);
934
end if;
935
end;
936
end if;
937
end;
938
end if;
939
940
if Asis.Compilation_Units.Is_Nil (Asis_Unit) and then
941
not (Already_Tried_To_Create) and then
942
AD.Compiler.Get_Compile_Command /= ""
943
then
944
-- Not found: Close the context again and then try to generate the
945
-- tree and re-open the context.
946
Asis.Ada_Environments.Close (Asis_Context);
947
Asis.Ada_Environments.Dissociate (Asis_Context);
948
Warn ("Couldn't find unit """ & AD.Parameters.Unit_Name &
949
""" in the library.");
950
General_Context_Open := False;
951
Recreate;
952
-- Try again.
953
Asis_Unit :=
954
Asis.Compilation_Units.Library_Unit_Declaration
955
(To_Wide_String (AD.Parameters.Unit_Name), Asis_Context);
956
end if;
957
end Init_Asis;
958
959
if Asis.Compilation_Units.Is_Nil (Asis_Unit) then
960
-- Still not found: abandon!
961
Asis.Ada_Environments.Close (Asis_Context);
962
Asis.Ada_Environments.Dissociate (Asis_Context);
963
raise Asis.Exceptions.ASIS_Inappropriate_Compilation_Unit;
964
end if;
965
966
Generate_Main :
967
declare
968
Unit_Name : constant String :=
969
To_String (Asis2.Naming.Full_Unit_Name (Asis_Unit));
970
begin
971
if not Handled_Units.Exists (Unit_Name) then
972
Handled_Units.Add (Unit_Name);
973
if AD.Exclusions.Is_Excluded (To_Lower (Unit_Name)) then
974
Info
975
("There's an EXCLUDE key in some configuration file for " &
976
"the given unit """ & Unit_Name & """. Unit is skipped.");
977
raise Skip_Unit;
978
else
979
Transform_Unit (Asis_Unit);
980
end if;
981
else
982
if AD.Exclusions.Is_Excluded (To_Lower (Unit_Name)) then
983
raise Skip_Unit;
984
end if;
985
end if;
986
end Generate_Main;
987
988
if Transitive_Closure then
989
Generate_Closure :
990
declare
991
All_Units : constant Asis.Compilation_Unit_List :=
992
AD.Queries.Get_Dependents (Asis_Unit);
993
begin
994
for I in All_Units'Range loop
995
if
996
not Asis.Compilation_Units.Is_Equal (All_Units (I), Asis_Unit)
997
then
998
-- The "if" is just paranoia; I suppose we should never get
999
-- back the unit itself.
1000
declare
1001
Unit_Name : constant String :=
1002
To_String (Asis2.Naming.Full_Unit_Name (All_Units (I)));
1003
begin
1004
if not Handled_Units.Exists (Unit_Name) then
1005
Handled_Units.Add (Unit_Name);
1006
if AD.Exclusions.Skip (To_Lower (Unit_Name)) then
1007
Info
1008
("The unit """ & Unit_Name & """ is excluded" &
1009
" by an EXCLUDE or NO_XREF key in some" &
1010
" configuration file.");
1011
else
1012
Transform_Unit (All_Units (I));
1013
end if;
1014
end if;
1015
end;
1016
end if;
1017
end loop;
1018
end Generate_Closure;
1019
end if;
1020
1021
-- No exception: successful termination
1022
1023
if not General_Context_Open and then
1024
Asis.Ada_Environments.Is_Open (Asis_Context)
1025
then
1026
Asis.Ada_Environments.Close (Asis_Context);
1027
Asis.Ada_Environments.Dissociate (Asis_Context);
1028
end if;
1029
Delete_ADT;
1030
1031
exception
1032
when E : others =>
1033
if not General_Context_Open and then
1034
Asis.Ada_Environments.Is_Open (Asis_Context)
1035
then
1036
Asis.Ada_Environments.Close (Asis_Context);
1037
Asis.Ada_Environments.Dissociate (Asis_Context);
1038
end if;
1039
Delete_ADT;
1040
if Ada.Exceptions.Exception_Identity (E) /= Skip_Unit'Identity then
1041
raise;
1042
end if;
1043
end Process_One_Unit;
1044
1045
procedure Init_Asis
1046
is
1047
ASIS_Version : constant String := AD.Version.Get_Asis_Version;
1048
Pattern_GNAT : constant String := "for GNAT";
1049
Pattern_Pro : constant String := "Pro";
1050
I : Natural;
1051
begin
1052
-- Search for "for GNAT", then skip blanks, then get a sequence of
1053
-- digits and periods.
1054
I := Util.Strings.First_Index (ASIS_Version, Pattern_GNAT);
1055
if I = 0 then
1056
-- Not an ASIS-for-GNAT?
1057
Asis.Implementation.Initialize (Parameters => "");
1058
else
1059
I :=
1060
Next_Non_Blank
1061
(ASIS_Version (I + Pattern_GNAT'Length .. ASIS_Version'Last));
1062
-- Some GNAT versions may have a version string "for GNAT Pro x.yy"!
1063
if I /= 0 and then
1064
Is_Prefix (ASIS_Version (I .. ASIS_Version'Last), Pattern_Pro)
1065
then
1066
I :=
1067
Next_Non_Blank
1068
(ASIS_Version (I + Pattern_Pro'Length .. ASIS_Version'Last));
1069
end if;
1070
declare
1071
Major_Version : Natural := 3;
1072
Minor_Version : Natural := 15;
1073
begin
1074
if I /= 0 and then ACH.Is_Digit (ASIS_Version (I)) then
1075
Major_Version := Natural (Character'Pos (ASIS_Version (I)) -
1076
Character'Pos ('0'));
1077
I := I + 1;
1078
if I <= ASIS_Version'Last and then ASIS_Version (I) = '.' then
1079
declare
1080
J : Natural := I + 1;
1081
begin
1082
while J <= ASIS_Version'Last and then
1083
ACH.Is_Digit (ASIS_Version (J))
1084
loop
1085
J := J + 1;
1086
end loop;
1087
if J > I + 1 then
1088
Minor_Version :=
1089
Natural'Value (ASIS_Version (I + 1 .. J - 1));
1090
end if;
1091
end;
1092
end if;
1093
end if;
1094
if Major_Version < 3 or else
1095
(Major_Version = 3 and then Minor_Version <= 15)
1096
then
1097
Asis.Implementation.Initialize (Parameters => "-ws");
1098
-- "-ws" means "suppress all warnings". In particular, we want
1099
-- to suppress the warnings about some body tree files not
1100
-- being present. As we process only specs, we don't care:
1101
-- the body trees needed for generic instantiations are
1102
-- included in the specs containing these instantiations
1103
-- anyway.
1104
else
1105
-- Use from GNAT 3.16 on (3.16, 3.17, 5.00, ...)
1106
Asis.Implementation.Initialize (Parameters => "-ws -k -nbb");
1107
-- "-k" means keep going; never, ever make the program quit.
1108
-- Hey, it's awful library design if a library can force the
1109
-- program using it to quit. Sergey, you'd better undo that
1110
-- immediately!
1111
--
1112
-- "-nbb" tells ASIS not to generate a GNAT-style bug-box on
1113
-- stderr, giving instructions how to submit a bug report to
1114
-- ACT. For heaven's sake, what kind of nonsense is this?! It's
1115
-- the application using ASIS-for-GNAT that has the sole right
1116
-- to decide what to do in the presence of fatal errors, such
1117
-- as bugs in ASIS. Maybe it can work around the bugs, or tell
1118
-- the users to submit bug reports somewhere else (e.g., to
1119
-- report them to me!).
1120
end if;
1121
end;
1122
end if;
1123
end Init_Asis;
1124
1125
procedure Shutdown
1126
(Normal : in Boolean)
1127
is
1128
begin
1129
if Asis.Ada_Environments.Is_Open (Asis_Context) then
1130
-- Must be the general context...
1131
Asis.Ada_Environments.Close (Asis_Context);
1132
Asis.Ada_Environments.Dissociate (Asis_Context);
1133
end if;
1134
1135
if Normal and then Generate_Index then
1136
AD.Indices.Write (The_Printer);
1137
end if;
1138
1139
AD.Parameters.Close;
1140
Asis.Implementation.Finalize ("");
1141
1142
AD.Printers.Free (The_Printer);
1143
1144
declare
1145
use type Ada.Text_IO.File_Access;
1146
1147
procedure Free is
1148
new Ada.Unchecked_Deallocation
1149
(Ada.Text_IO.File_Type, File_Ptr);
1150
begin
1151
if Src_Files /= null then
1152
if Ada.Text_IO.Is_Open (Src_Files.all) then
1153
Ada.Text_IO.Close (Src_Files.all);
1154
end if;
1155
Free (Src_Files);
1156
end if;
1157
end;
1158
1159
if Normal then
1160
AD.Projects.Reset (On_Error => False);
1161
Ada.Command_Line.Set_Exit_Status (Ada.Command_Line.Success);
1162
else
1163
AD.Projects.Reset (On_Error => True);
1164
Ada.Command_Line.Set_Exit_Status (Ada.Command_Line.Failure);
1165
end if;
1166
1167
end Shutdown;
1168
1169
procedure Main
1170
is
1171
begin -- AdaBrowse Main routine
1172
1173
AD.Crossrefs.Set_Standard_Units (False);
1174
1175
AD.Projects.Initialize;
1176
1177
Parse_Command_Line :
1178
declare
1179
Quit : Boolean;
1180
begin
1181
Handle_Command_Line (Quit);
1182
if Quit then
1183
Ada.Command_Line.Set_Exit_Status (Ada.Command_Line.Success);
1184
return;
1185
end if;
1186
end Parse_Command_Line;
1187
1188
AD.User_Tags.Verify;
1189
1190
-- Set up the enabled printers.
1191
1192
for I in Enabled_Printers'Range loop
1193
if Enabled_Printers (I) then
1194
case I is
1195
when HTML_Printer =>
1196
The_Printer :=
1197
The_Printer + Printer_Ref'(new AD.Printers.HTML.Printer);
1198
when XML_Printer =>
1199
The_Printer :=
1200
The_Printer + Printer_Ref'(new AD.Printers.XML.Printer);
1201
when DocBook_Printer =>
1202
-- The_Printer :=
1203
-- The_Printer + new AD.Printers.DocBook_Printer;
1204
null;
1205
end case;
1206
end if;
1207
end loop;
1208
1209
-- Now initialize Asis. This is highly GNAT-specific!
1210
1211
Init_Asis;
1212
1213
-- Set up index management.
1214
1215
if Generate_Index then
1216
AD.Indices.Verify;
1217
else
1218
AD.Indices.Disable;
1219
end if;
1220
1221
-- Set the output directory.
1222
1223
if AD.Options.Output_Directory = "" and then
1224
AD.Parameters.Path /= ""
1225
then
1226
AD.Options.Set_Output_Directory (AD.Parameters.Path);
1227
end if;
1228
1229
-- Process the input files.
1230
1231
loop
1232
Process_One_Unit;
1233
exit when not AD.Parameters.Advance_Input;
1234
end loop;
1235
1236
Shutdown (True);
1237
1238
exception
1239
when others =>
1240
Exception_Handler :
1241
begin
1242
Shutdown (False);
1243
raise;
1244
exception
1245
when E : AD.Printers.Open_Failed |
1246
AD.Printers.Cannot_Overwrite |
1247
AD.Config.Invalid_Config |
1248
AD.Parameters.Input_Error |
1249
AD.Filters.Recursive_Expansion =>
1250
Error (Ada.Exceptions.Exception_Message (E));
1251
1252
when No_Tree_File =>
1253
Error
1254
("Couldn't find unit """ & AD.Parameters.Unit_Name &
1255
""" in the library.");
1256
if AD.Compiler.Get_Compile_Command /= "" then
1257
if Index (AD.Version.Get_Version, "GNAT") > 0 then
1258
Error ("Couldn't find nor generate a tree " &
1259
"file. Try generating one ");
1260
Error ("using the command """ & AD.Setup.GNAT_Name &
1261
" -c -gnatc -gnatt ...""");
1262
else
1263
Error ("Couldn't generate the necessary info " &
1264
"either with """ &
1265
AD.Compiler.Get_Compile_Command &
1266
" ...""");
1267
end if;
1268
end if;
1269
1270
when Asis.Exceptions.ASIS_Inappropriate_Compilation_Unit =>
1271
Error ("Couldn't find unit """ & AD.Parameters.Unit_Name &
1272
""" in the library, or");
1273
Error ("the file """ & AD.Parameters.Source_Name &
1274
""" does not contain any Ada spec.");
1275
Put_Line (Current_Error,
1276
"Type ""adabrowse -?"" for more information.");
1277
1278
when Command_Line_Error =>
1279
Put_Line (Current_Error,
1280
"Type ""adabrowse -?"" for more information.");
1281
1282
when Help_Requested =>
1283
AD.Messages.Help_Text;
1284
1285
when E : others =>
1286
declare
1287
use Ada.Exceptions;
1288
Handled : Boolean := False;
1289
begin
1290
if Exception_Identity (E) =
1291
Asis.Exceptions.ASIS_Failed'Identity
1292
then
1293
declare
1294
use Asis.Errors;
1295
begin
1296
case Asis.Implementation.Status is
1297
when Asis.Errors.Use_Error |
1298
Obsolete_Reference_Error =>
1299
-- ASIS-for-GNAT specific!
1300
declare
1301
Msg : constant String :=
1302
Trim
1303
(To_String
1304
(Asis.Implementation.Diagnosis));
1305
begin
1306
if Index (Msg,
1307
" is inconsistent with a tree file")
1308
> 0
1309
then
1310
Handled := True;
1311
Error (Msg);
1312
elsif Index (Msg, "not compile-only") > 0 then
1313
Handled := True;
1314
Report_No_GNATC (E, Trim (Msg));
1315
end if;
1316
end;
1317
1318
when Parameter_Error =>
1319
Handled := True;
1320
Error
1321
(Trim
1322
(To_String (Asis.Implementation.Diagnosis)));
1323
1324
when Not_Implemented_Error =>
1325
Handled := True;
1326
Error ("ASIS doesn't implement a query!");
1327
Error (Ada.Exceptions.Exception_Information (E));
1328
Error
1329
(Trim
1330
(To_String (Asis.Implementation.Diagnosis)));
1331
Report;
1332
1333
when others =>
1334
declare
1335
Msg : constant String :=
1336
To_String (Asis.Implementation.Diagnosis);
1337
begin
1338
if (First_Index
1339
(To_Lower (Msg), "constraint_error") > 0
1340
and then
1341
First_Index
1342
(To_Lower (Msg), "namet.adb") > 0)
1343
or else
1344
(First_Index
1345
(To_Lower (Msg),
1346
"internal_implementation_error") > 0
1347
and then
1348
First_Index
1349
(To_Lower (Msg), "a4g-contt-ut.adb") > 0)
1350
then
1351
Handled := True;
1352
Report_No_GNATC (E, Trim (Msg));
1353
end if;
1354
end;
1355
1356
end case;
1357
end;
1358
elsif Exception_Identity (E) = Program_Error'Identity then
1359
declare
1360
Msg : constant String := Exception_Message (E);
1361
begin
1362
if Is_Prefix (Msg, "Inconsistent versions") then
1363
Handled := True;
1364
Error (Msg);
1365
Put_Line
1366
(Current_Error,
1367
"**** AdaBrowse has been compiled for " &
1368
AD.Version.Get_Asis_Version & ',');
1369
Put_Line
1370
(Current_Error,
1371
"but some tree file has been generated by " &
1372
"some other compiler.");
1373
Put_Line
1374
(Current_Error,
1375
"Make sure that the tree files are generated " &
1376
"by the compiler above,");
1377
Put_Line
1378
(Current_Error,
1379
"or rebuild AdaBrowse from the sources with " &
1380
"your other compiler.");
1381
end if;
1382
end;
1383
end if;
1384
if not Handled then
1385
Error ("An unexpected error occurred!");
1386
Error (Ada.Exceptions.Exception_Information (E));
1387
Error (Trim (To_String (Asis.Implementation.Diagnosis)));
1388
Report;
1389
end if;
1390
end;
1391
end Exception_Handler;
1392
1393
end Main;
1394
1395
end AD.Driver;
Loggerhead is a web-based interface for Breezy
Version: 2.0.1