?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
[gcc/]
[official-gcc.git] / gcc / ada / prj-makr.adb
blob4f4ab43c08c63aa8d3d4c22ebf6560525a0f8df6
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- P R J . M A K R --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 2001-2013, Free Software Foundation, Inc. --
10 -- --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
20 -- --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
23 -- --
24 ------------------------------------------------------------------------------
25
26 with Csets;
27 with Hostparm;
28 with Makeutl; use Makeutl;
29 with Opt;
30 with Output;
31 with Osint; use Osint;
32 with Prj; use Prj;
33 with Prj.Com;
34 with Prj.Env;
35 with Prj.Part;
36 with Prj.PP;
37 with Prj.Tree; use Prj.Tree;
38 with Prj.Util; use Prj.Util;
39 with Sdefault;
40 with Snames; use Snames;
41 with Stringt;
42 with Table; use Table;
43 with Tempdir;
44
45 with Ada.Characters.Handling; use Ada.Characters.Handling;
46 with GNAT.Directory_Operations; use GNAT.Directory_Operations;
47
48 with System.Case_Util; use System.Case_Util;
49 with System.CRTL;
50 with System.HTable;
51
52 package body Prj.Makr is
53
54 -- Packages of project files where unknown attributes are errors
55
56 -- All the following need comments ??? All global variables and
57 -- subprograms must be fully commented.
58
59 Very_Verbose : Boolean := False;
60 -- Set in call to Initialize to indicate very verbose output
61
62 Project_File : Boolean := False;
63 -- True when gnatname is creating/modifying a project file. False when
64 -- gnatname is creating a configuration pragmas file.
65
66 Tree : constant Project_Node_Tree_Ref := new Project_Node_Tree_Data;
67 -- The project tree where the project file is parsed
68
69 Args : Argument_List_Access;
70 -- The list of arguments for calls to the compiler to get the unit names
71 -- and kinds (spec or body) in the Ada sources.
72
73 Path_Name : String_Access;
74
75 Path_Last : Natural;
76
77 Directory_Last : Natural := 0;
78
79 Output_Name : String_Access;
80 Output_Name_Last : Natural;
81 Output_Name_Id : Name_Id;
82
83 Project_Naming_File_Name : String_Access;
84 -- String (1 .. Output_Name'Length + Naming_File_Suffix'Length);
85
86 Project_Naming_Last : Natural;
87 Project_Naming_Id : Name_Id := No_Name;
88
89 Source_List_Path : String_Access;
90 -- (1 .. Output_Name'Length + Source_List_File_Suffix'Length);
91 Source_List_Last : Natural;
92
93 Source_List_FD : File_Descriptor;
94
95 Project_Node : Project_Node_Id := Empty_Node;
96 Project_Declaration : Project_Node_Id := Empty_Node;
97 Source_Dirs_List : Project_Node_Id := Empty_Node;
98
99 Project_Naming_Node : Project_Node_Id := Empty_Node;
100 Project_Naming_Decl : Project_Node_Id := Empty_Node;
101 Naming_Package : Project_Node_Id := Empty_Node;
102 Naming_Package_Comments : Project_Node_Id := Empty_Node;
103
104 Source_Files_Comments : Project_Node_Id := Empty_Node;
105 Source_Dirs_Comments : Project_Node_Id := Empty_Node;
106 Source_List_File_Comments : Project_Node_Id := Empty_Node;
107
108 Naming_String : aliased String := "naming";
109
110 Gnatname_Packages : aliased String_List := (1 => Naming_String'Access);
111
112 Packages_To_Check_By_Gnatname : constant String_List_Access :=
113 Gnatname_Packages'Access;
114
115 function Dup (Fd : File_Descriptor) return File_Descriptor;
116
117 procedure Dup2 (Old_Fd, New_Fd : File_Descriptor);
118
119 Gcc : constant String := "gcc";
120 Gcc_Path : String_Access := null;
121
122 Non_Empty_Node : constant Project_Node_Id := 1;
123 -- Used for the With_Clause of the naming project
124
125 -- Turn off warnings for now around this redefinition of True and False,
126 -- but it really seems a bit horrible to do this redefinition ???
127
128 pragma Warnings (Off);
129 type Matched_Type is (True, False, Excluded);
130 pragma Warnings (On);
131
132 Naming_File_Suffix : constant String := "_naming";
133 Source_List_File_Suffix : constant String := "_source_list.txt";
134
135 Output_FD : File_Descriptor;
136 -- To save the project file and its naming project file
137
138 procedure Write_Eol;
139 -- Output an empty line
140
141 procedure Write_A_Char (C : Character);
142 -- Write one character to Output_FD
143
144 procedure Write_A_String (S : String);
145 -- Write a String to Output_FD
146
147 package Processed_Directories is new Table.Table
148 (Table_Component_Type => String_Access,
149 Table_Index_Type => Natural,
150 Table_Low_Bound => 0,
151 Table_Initial => 10,
152 Table_Increment => 100,
153 Table_Name => "Prj.Makr.Processed_Directories");
154 -- The list of already processed directories for each section, to avoid
155 -- processing several times the same directory in the same section.
156
157 package Source_Directories is new Table.Table
158 (Table_Component_Type => String_Access,
159 Table_Index_Type => Natural,
160 Table_Low_Bound => 0,
161 Table_Initial => 10,
162 Table_Increment => 100,
163 Table_Name => "Prj.Makr.Source_Directories");
164 -- The complete list of directories to be put in attribute Source_Dirs in
165 -- the project file.
166
167 type Source is record
168 File_Name : Name_Id;
169 Unit_Name : Name_Id;
170 Index : Int := 0;
171 Spec : Boolean;
172 end record;
173
174 package Sources is new Table.Table
175 (Table_Component_Type => Source,
176 Table_Index_Type => Natural,
177 Table_Low_Bound => 0,
178 Table_Initial => 10,
179 Table_Increment => 100,
180 Table_Name => "Prj.Makr.Sources");
181 -- The list of Ada sources found, with their unit name and kind, to be put
182 -- in the source attribute and package Naming of the project file, or in
183 -- the pragmas Source_File_Name in the configuration pragmas file.
184
185 package Source_Files is new System.HTable.Simple_HTable
186 (Header_Num => Prj.Header_Num,
187 Element => Boolean,
188 No_Element => False,
189 Key => Name_Id,
190 Hash => Prj.Hash,
191 Equal => "=");
192 -- Hash table to keep track of source file names, to avoid putting several
193 -- times the same file name in case of multi-unit files.
194
195 ---------
196 -- Dup --
197 ---------
198
199 function Dup (Fd : File_Descriptor) return File_Descriptor is
200 begin
201 return File_Descriptor (System.CRTL.dup (Integer (Fd)));
202 end Dup;
203
204 ----------
205 -- Dup2 --
206 ----------
207
208 procedure Dup2 (Old_Fd, New_Fd : File_Descriptor) is
209 Fd : Integer;
210 pragma Warnings (Off, Fd);
211 begin
212 Fd := System.CRTL.dup2 (Integer (Old_Fd), Integer (New_Fd));
213 end Dup2;
214
215 --------------
216 -- Finalize --
217 --------------
218
219 procedure Finalize is
220 Discard : Boolean;
221 pragma Warnings (Off, Discard);
222
223 Current_Source_Dir : Project_Node_Id := Empty_Node;
224
225 begin
226 if Project_File then
227 -- If there were no already existing project file, or if the parsing
228 -- was unsuccessful, create an empty project node with the correct
229 -- name and its project declaration node.
230
231 if No (Project_Node) then
232 Project_Node :=
233 Default_Project_Node (Of_Kind => N_Project, In_Tree => Tree);
234 Set_Name_Of (Project_Node, Tree, To => Output_Name_Id);
235 Set_Project_Declaration_Of
236 (Project_Node, Tree,
237 To => Default_Project_Node
238 (Of_Kind => N_Project_Declaration, In_Tree => Tree));
239
240 end if;
241
242 end if;
243
244 -- Delete the file if it already exists
245
246 Delete_File
247 (Path_Name (Directory_Last + 1 .. Path_Last),
248 Success => Discard);
249
250 -- Create a new one
251
252 if Opt.Verbose_Mode then
253 Output.Write_Str ("Creating new file """);
254 Output.Write_Str (Path_Name (Directory_Last + 1 .. Path_Last));
255 Output.Write_Line ("""");
256 end if;
257
258 Output_FD := Create_New_File
259 (Path_Name (Directory_Last + 1 .. Path_Last),
260 Fmode => Text);
261
262 -- Fails if project file cannot be created
263
264 if Output_FD = Invalid_FD then
265 Prj.Com.Fail
266 ("cannot create new """ & Path_Name (1 .. Path_Last) & """");
267 end if;
268
269 if Project_File then
270
271 -- Delete the source list file, if it already exists
272
273 declare
274 Discard : Boolean;
275 pragma Warnings (Off, Discard);
276 begin
277 Delete_File
278 (Source_List_Path (1 .. Source_List_Last),
279 Success => Discard);
280 end;
281
282 -- And create a new source list file, fail if file cannot be created
283
284 Source_List_FD := Create_New_File
285 (Name => Source_List_Path (1 .. Source_List_Last),
286 Fmode => Text);
287
288 if Source_List_FD = Invalid_FD then
289 Prj.Com.Fail
290 ("cannot create file """
291 & Source_List_Path (1 .. Source_List_Last)
292 & """");
293 end if;
294
295 if Opt.Verbose_Mode then
296 Output.Write_Str ("Naming project file name is """);
297 Output.Write_Str
298 (Project_Naming_File_Name (1 .. Project_Naming_Last));
299 Output.Write_Line ("""");
300 end if;
301
302 -- Create the naming project node
303
304 Project_Naming_Node :=
305 Default_Project_Node (Of_Kind => N_Project, In_Tree => Tree);
306 Set_Name_Of (Project_Naming_Node, Tree, To => Project_Naming_Id);
307 Project_Naming_Decl :=
308 Default_Project_Node
309 (Of_Kind => N_Project_Declaration, In_Tree => Tree);
310 Set_Project_Declaration_Of
311 (Project_Naming_Node, Tree, Project_Naming_Decl);
312 Naming_Package :=
313 Default_Project_Node
314 (Of_Kind => N_Package_Declaration, In_Tree => Tree);
315 Set_Name_Of (Naming_Package, Tree, To => Name_Naming);
316
317 -- Add an attribute declaration for Source_Files as an empty list (to
318 -- indicate there are no sources in the naming project) and a package
319 -- Naming (that will be filled later).
320
321 declare
322 Decl_Item : constant Project_Node_Id :=
323 Default_Project_Node
324 (Of_Kind => N_Declarative_Item, In_Tree => Tree);
325
326 Attribute : constant Project_Node_Id :=
327 Default_Project_Node
328 (Of_Kind => N_Attribute_Declaration,
329 In_Tree => Tree,
330 And_Expr_Kind => List);
331
332 Expression : constant Project_Node_Id :=
333 Default_Project_Node
334 (Of_Kind => N_Expression,
335 In_Tree => Tree,
336 And_Expr_Kind => List);
337
338 Term : constant Project_Node_Id :=
339 Default_Project_Node
340 (Of_Kind => N_Term,
341 In_Tree => Tree,
342 And_Expr_Kind => List);
343
344 Empty_List : constant Project_Node_Id :=
345 Default_Project_Node
346 (Of_Kind => N_Literal_String_List,
347 In_Tree => Tree);
348
349 begin
350 Set_First_Declarative_Item_Of
351 (Project_Naming_Decl, Tree, To => Decl_Item);
352 Set_Next_Declarative_Item (Decl_Item, Tree, Naming_Package);
353 Set_Current_Item_Node (Decl_Item, Tree, To => Attribute);
354 Set_Name_Of (Attribute, Tree, To => Name_Source_Files);
355 Set_Expression_Of (Attribute, Tree, To => Expression);
356 Set_First_Term (Expression, Tree, To => Term);
357 Set_Current_Term (Term, Tree, To => Empty_List);
358 end;
359
360 -- Add a with clause on the naming project in the main project, if
361 -- there is not already one.
362
363 declare
364 With_Clause : Project_Node_Id :=
365 First_With_Clause_Of (Project_Node, Tree);
366
367 begin
368 while Present (With_Clause) loop
369 exit when
370 Prj.Tree.Name_Of (With_Clause, Tree) = Project_Naming_Id;
371 With_Clause := Next_With_Clause_Of (With_Clause, Tree);
372 end loop;
373
374 if No (With_Clause) then
375 With_Clause := Default_Project_Node
376 (Of_Kind => N_With_Clause, In_Tree => Tree);
377 Set_Next_With_Clause_Of
378 (With_Clause, Tree,
379 To => First_With_Clause_Of (Project_Node, Tree));
380 Set_First_With_Clause_Of
381 (Project_Node, Tree, To => With_Clause);
382 Set_Name_Of (With_Clause, Tree, To => Project_Naming_Id);
383
384 -- We set the project node to something different than
385 -- Empty_Node, so that Prj.PP does not generate a limited
386 -- with clause.
387
388 Set_Project_Node_Of (With_Clause, Tree, Non_Empty_Node);
389
390 Name_Len := Project_Naming_Last;
391 Name_Buffer (1 .. Name_Len) :=
392 Project_Naming_File_Name (1 .. Project_Naming_Last);
393 Set_String_Value_Of (With_Clause, Tree, To => Name_Find);
394 end if;
395 end;
396
397 Project_Declaration := Project_Declaration_Of (Project_Node, Tree);
398
399 -- Add a package Naming in the main project, that is a renaming of
400 -- package Naming in the naming project.
401
402 declare
403 Decl_Item : constant Project_Node_Id :=
404 Default_Project_Node
405 (Of_Kind => N_Declarative_Item,
406 In_Tree => Tree);
407
408 Naming : constant Project_Node_Id :=
409 Default_Project_Node
410 (Of_Kind => N_Package_Declaration,
411 In_Tree => Tree);
412
413 begin
414 Set_Next_Declarative_Item
415 (Decl_Item, Tree,
416 To => First_Declarative_Item_Of (Project_Declaration, Tree));
417 Set_First_Declarative_Item_Of
418 (Project_Declaration, Tree, To => Decl_Item);
419 Set_Current_Item_Node (Decl_Item, Tree, To => Naming);
420 Set_Name_Of (Naming, Tree, To => Name_Naming);
421 Set_Project_Of_Renamed_Package_Of
422 (Naming, Tree, To => Project_Naming_Node);
423
424 -- Attach the comments, if any, that were saved for package
425 -- Naming.
426
427 Tree.Project_Nodes.Table (Naming).Comments :=
428 Naming_Package_Comments;
429 end;
430
431 -- Add an attribute declaration for Source_Dirs, initialized as an
432 -- empty list.
433
434 declare
435 Decl_Item : constant Project_Node_Id :=
436 Default_Project_Node
437 (Of_Kind => N_Declarative_Item,
438 In_Tree => Tree);
439
440 Attribute : constant Project_Node_Id :=
441 Default_Project_Node
442 (Of_Kind => N_Attribute_Declaration,
443 In_Tree => Tree,
444 And_Expr_Kind => List);
445
446 Expression : constant Project_Node_Id :=
447 Default_Project_Node
448 (Of_Kind => N_Expression,
449 In_Tree => Tree,
450 And_Expr_Kind => List);
451
452 Term : constant Project_Node_Id :=
453 Default_Project_Node
454 (Of_Kind => N_Term, In_Tree => Tree,
455 And_Expr_Kind => List);
456
457 begin
458 Set_Next_Declarative_Item
459 (Decl_Item, Tree,
460 To => First_Declarative_Item_Of (Project_Declaration, Tree));
461 Set_First_Declarative_Item_Of
462 (Project_Declaration, Tree, To => Decl_Item);
463 Set_Current_Item_Node (Decl_Item, Tree, To => Attribute);
464 Set_Name_Of (Attribute, Tree, To => Name_Source_Dirs);
465 Set_Expression_Of (Attribute, Tree, To => Expression);
466 Set_First_Term (Expression, Tree, To => Term);
467 Source_Dirs_List :=
468 Default_Project_Node
469 (Of_Kind => N_Literal_String_List,
470 In_Tree => Tree,
471 And_Expr_Kind => List);
472 Set_Current_Term (Term, Tree, To => Source_Dirs_List);
473
474 -- Attach the comments, if any, that were saved for attribute
475 -- Source_Dirs.
476
477 Tree.Project_Nodes.Table (Attribute).Comments :=
478 Source_Dirs_Comments;
479 end;
480
481 -- Put the source directories in attribute Source_Dirs
482
483 for Source_Dir_Index in 1 .. Source_Directories.Last loop
484 declare
485 Expression : constant Project_Node_Id :=
486 Default_Project_Node
487 (Of_Kind => N_Expression,
488 In_Tree => Tree,
489 And_Expr_Kind => Single);
490
491 Term : constant Project_Node_Id :=
492 Default_Project_Node
493 (Of_Kind => N_Term,
494 In_Tree => Tree,
495 And_Expr_Kind => Single);
496
497 Value : constant Project_Node_Id :=
498 Default_Project_Node
499 (Of_Kind => N_Literal_String,
500 In_Tree => Tree,
501 And_Expr_Kind => Single);
502
503 begin
504 if No (Current_Source_Dir) then
505 Set_First_Expression_In_List
506 (Source_Dirs_List, Tree, To => Expression);
507 else
508 Set_Next_Expression_In_List
509 (Current_Source_Dir, Tree, To => Expression);
510 end if;
511
512 Current_Source_Dir := Expression;
513 Set_First_Term (Expression, Tree, To => Term);
514 Set_Current_Term (Term, Tree, To => Value);
515 Name_Len := 0;
516 Add_Str_To_Name_Buffer
517 (Source_Directories.Table (Source_Dir_Index).all);
518 Set_String_Value_Of (Value, Tree, To => Name_Find);
519 end;
520 end loop;
521
522 -- Add an attribute declaration for Source_Files or Source_List_File
523 -- with the source list file name that will be created.
524
525 declare
526 Decl_Item : constant Project_Node_Id :=
527 Default_Project_Node
528 (Of_Kind => N_Declarative_Item,
529 In_Tree => Tree);
530
531 Attribute : constant Project_Node_Id :=
532 Default_Project_Node
533 (Of_Kind => N_Attribute_Declaration,
534 In_Tree => Tree,
535 And_Expr_Kind => Single);
536
537 Expression : constant Project_Node_Id :=
538 Default_Project_Node
539 (Of_Kind => N_Expression,
540 In_Tree => Tree,
541 And_Expr_Kind => Single);
542
543 Term : constant Project_Node_Id :=
544 Default_Project_Node
545 (Of_Kind => N_Term,
546 In_Tree => Tree,
547 And_Expr_Kind => Single);
548
549 Value : constant Project_Node_Id :=
550 Default_Project_Node
551 (Of_Kind => N_Literal_String,
552 In_Tree => Tree,
553 And_Expr_Kind => Single);
554
555 begin
556 Set_Next_Declarative_Item
557 (Decl_Item, Tree,
558 To => First_Declarative_Item_Of (Project_Declaration, Tree));
559 Set_First_Declarative_Item_Of
560 (Project_Declaration, Tree, To => Decl_Item);
561 Set_Current_Item_Node (Decl_Item, Tree, To => Attribute);
562
563 Set_Name_Of (Attribute, Tree, To => Name_Source_List_File);
564 Set_Expression_Of (Attribute, Tree, To => Expression);
565 Set_First_Term (Expression, Tree, To => Term);
566 Set_Current_Term (Term, Tree, To => Value);
567 Name_Len := Source_List_Last;
568 Name_Buffer (1 .. Name_Len) :=
569 Source_List_Path (1 .. Source_List_Last);
570 Set_String_Value_Of (Value, Tree, To => Name_Find);
571
572 -- If there was no comments for attribute Source_List_File, put
573 -- those for Source_Files, if they exist.
574
575 if Present (Source_List_File_Comments) then
576 Tree.Project_Nodes.Table (Attribute).Comments :=
577 Source_List_File_Comments;
578 else
579 Tree.Project_Nodes.Table (Attribute).Comments :=
580 Source_Files_Comments;
581 end if;
582 end;
583
584 -- Put the sources in the source list files and in the naming
585 -- project.
586
587 for Source_Index in 1 .. Sources.Last loop
588
589 -- Add the corresponding attribute in the
590 -- Naming package of the naming project.
591
592 declare
593 Current_Source : constant Source :=
594 Sources.Table (Source_Index);
595
596 Decl_Item : constant Project_Node_Id :=
597 Default_Project_Node
598 (Of_Kind =>
599 N_Declarative_Item,
600 In_Tree => Tree);
601
602 Attribute : constant Project_Node_Id :=
603 Default_Project_Node
604 (Of_Kind =>
605 N_Attribute_Declaration,
606 In_Tree => Tree);
607
608 Expression : constant Project_Node_Id :=
609 Default_Project_Node
610 (Of_Kind => N_Expression,
611 And_Expr_Kind => Single,
612 In_Tree => Tree);
613
614 Term : constant Project_Node_Id :=
615 Default_Project_Node
616 (Of_Kind => N_Term,
617 And_Expr_Kind => Single,
618 In_Tree => Tree);
619
620 Value : constant Project_Node_Id :=
621 Default_Project_Node
622 (Of_Kind => N_Literal_String,
623 And_Expr_Kind => Single,
624 In_Tree => Tree);
625
626 begin
627 -- Add source file name to the source list file if it is not
628 -- already there.
629
630 if not Source_Files.Get (Current_Source.File_Name) then
631 Source_Files.Set (Current_Source.File_Name, True);
632 Get_Name_String (Current_Source.File_Name);
633 Add_Char_To_Name_Buffer (ASCII.LF);
634
635 if Write (Source_List_FD,
636 Name_Buffer (1)'Address,
637 Name_Len) /= Name_Len
638 then
639 Prj.Com.Fail ("disk full");
640 end if;
641 end if;
642
643 -- For an Ada source, add entry in package Naming
644
645 if Current_Source.Unit_Name /= No_Name then
646 Set_Next_Declarative_Item
647 (Decl_Item,
648 To => First_Declarative_Item_Of
649 (Naming_Package, Tree),
650 In_Tree => Tree);
651 Set_First_Declarative_Item_Of
652 (Naming_Package,
653 To => Decl_Item,
654 In_Tree => Tree);
655 Set_Current_Item_Node
656 (Decl_Item,
657 To => Attribute,
658 In_Tree => Tree);
659
660 -- Is it a spec or a body?
661
662 if Current_Source.Spec then
663 Set_Name_Of
664 (Attribute, Tree,
665 To => Name_Spec);
666 else
667 Set_Name_Of
668 (Attribute, Tree,
669 To => Name_Body);
670 end if;
671
672 -- Get the name of the unit
673
674 Get_Name_String (Current_Source.Unit_Name);
675 To_Lower (Name_Buffer (1 .. Name_Len));
676 Set_Associative_Array_Index_Of
677 (Attribute, Tree, To => Name_Find);
678
679 Set_Expression_Of
680 (Attribute, Tree, To => Expression);
681 Set_First_Term
682 (Expression, Tree, To => Term);
683 Set_Current_Term
684 (Term, Tree, To => Value);
685
686 -- And set the name of the file
687
688 Set_String_Value_Of
689 (Value, Tree, To => Current_Source.File_Name);
690 Set_Source_Index_Of
691 (Value, Tree, To => Current_Source.Index);
692 end if;
693 end;
694 end loop;
695
696 -- Close the source list file
697
698 Close (Source_List_FD);
699
700 -- Output the project file
701
702 Prj.PP.Pretty_Print
703 (Project_Node, Tree,
704 W_Char => Write_A_Char'Access,
705 W_Eol => Write_Eol'Access,
706 W_Str => Write_A_String'Access,
707 Backward_Compatibility => False,
708 Max_Line_Length => 79);
709 Close (Output_FD);
710
711 -- Delete the naming project file if it already exists
712
713 Delete_File
714 (Project_Naming_File_Name (1 .. Project_Naming_Last),
715 Success => Discard);
716
717 -- Create a new one
718
719 if Opt.Verbose_Mode then
720 Output.Write_Str ("Creating new naming project file """);
721 Output.Write_Str (Project_Naming_File_Name
722 (1 .. Project_Naming_Last));
723 Output.Write_Line ("""");
724 end if;
725
726 Output_FD := Create_New_File
727 (Project_Naming_File_Name (1 .. Project_Naming_Last),
728 Fmode => Text);
729
730 -- Fails if naming project file cannot be created
731
732 if Output_FD = Invalid_FD then
733 Prj.Com.Fail
734 ("cannot create new """
735 & Project_Naming_File_Name (1 .. Project_Naming_Last)
736 & """");
737 end if;
738
739 -- Output the naming project file
740
741 Prj.PP.Pretty_Print
742 (Project_Naming_Node, Tree,
743 W_Char => Write_A_Char'Access,
744 W_Eol => Write_Eol'Access,
745 W_Str => Write_A_String'Access,
746 Backward_Compatibility => False);
747 Close (Output_FD);
748
749 else
750 -- For each Ada source, write a pragma Source_File_Name to the
751 -- configuration pragmas file.
752
753 for Index in 1 .. Sources.Last loop
754 if Sources.Table (Index).Unit_Name /= No_Name then
755 Write_A_String ("pragma Source_File_Name");
756 Write_Eol;
757 Write_A_String (" (");
758 Write_A_String
759 (Get_Name_String (Sources.Table (Index).Unit_Name));
760 Write_A_String (",");
761 Write_Eol;
762
763 if Sources.Table (Index).Spec then
764 Write_A_String (" Spec_File_Name => """);
765
766 else
767 Write_A_String (" Body_File_Name => """);
768 end if;
769
770 Write_A_String
771 (Get_Name_String (Sources.Table (Index).File_Name));
772
773 Write_A_String ("""");
774
775 if Sources.Table (Index).Index /= 0 then
776 Write_A_String (", Index =>");
777 Write_A_String (Sources.Table (Index).Index'Img);
778 end if;
779
780 Write_A_String (");");
781 Write_Eol;
782 end if;
783 end loop;
784
785 Close (Output_FD);
786 end if;
787 end Finalize;
788
789 ----------------
790 -- Initialize --
791 ----------------
792
793 procedure Initialize
794 (File_Path : String;
795 Project_File : Boolean;
796 Preproc_Switches : Argument_List;
797 Very_Verbose : Boolean;
798 Flags : Processing_Flags)
799 is
800 begin
801 Makr.Very_Verbose := Initialize.Very_Verbose;
802 Makr.Project_File := Initialize.Project_File;
803
804 -- Do some needed initializations
805
806 Csets.Initialize;
807 Snames.Initialize;
808 Stringt.Initialize;
809
810 Prj.Initialize (No_Project_Tree);
811
812 Prj.Tree.Initialize (Root_Environment, Flags);
813 Prj.Env.Initialize_Default_Project_Path
814 (Root_Environment.Project_Path,
815 Target_Name => Sdefault.Target_Name.all);
816
817 Prj.Tree.Initialize (Tree);
818
819 Sources.Set_Last (0);
820 Source_Directories.Set_Last (0);
821
822 -- Initialize the compiler switches
823
824 Args := new Argument_List (1 .. Preproc_Switches'Length + 6);
825 Args (1) := new String'("-c");
826 Args (2) := new String'("-gnats");
827 Args (3) := new String'("-gnatu");
828 Args (4 .. 3 + Preproc_Switches'Length) := Preproc_Switches;
829 Args (4 + Preproc_Switches'Length) := new String'("-x");
830 Args (5 + Preproc_Switches'Length) := new String'("ada");
831
832 -- Get the path and file names
833
834 Path_Name := new
835 String (1 .. File_Path'Length + Project_File_Extension'Length);
836 Path_Last := File_Path'Length;
837
838 if File_Names_Case_Sensitive then
839 Path_Name (1 .. Path_Last) := File_Path;
840 else
841 Path_Name (1 .. Path_Last) := To_Lower (File_Path);
842 end if;
843
844 Path_Name (Path_Last + 1 .. Path_Name'Last) :=
845 Project_File_Extension;
846
847 -- Get the end of directory information, if any
848
849 for Index in reverse 1 .. Path_Last loop
850 if Path_Name (Index) = Directory_Separator then
851 Directory_Last := Index;
852 exit;
853 end if;
854 end loop;
855
856 if Project_File then
857 if Path_Last < Project_File_Extension'Length + 1
858 or else Path_Name
859 (Path_Last - Project_File_Extension'Length + 1 .. Path_Last)
860 /= Project_File_Extension
861 then
862 Path_Last := Path_Name'Last;
863 end if;
864
865 Output_Name := new String'(To_Lower (Path_Name (1 .. Path_Last)));
866 Output_Name_Last := Output_Name'Last - 4;
867
868 -- If there is already a project file with the specified name, parse
869 -- it to get the components that are not automatically generated.
870
871 if Is_Regular_File (Output_Name (1 .. Path_Last)) then
872 if Opt.Verbose_Mode then
873 Output.Write_Str ("Parsing already existing project file """);
874 Output.Write_Str (Output_Name.all);
875 Output.Write_Line ("""");
876 end if;
877
878 Part.Parse
879 (In_Tree => Tree,
880 Project => Project_Node,
881 Project_File_Name => Output_Name.all,
882 Errout_Handling => Part.Finalize_If_Error,
883 Store_Comments => True,
884 Is_Config_File => False,
885 Env => Root_Environment,
886 Current_Directory => Get_Current_Dir,
887 Packages_To_Check => Packages_To_Check_By_Gnatname);
888
889 -- Fail if parsing was not successful
890
891 if No (Project_Node) then
892 Prj.Com.Fail ("parsing of existing project file failed");
893
894 elsif Project_Qualifier_Of (Project_Node, Tree) = Aggregate then
895 Prj.Com.Fail ("aggregate projects are not supported");
896
897 elsif Project_Qualifier_Of (Project_Node, Tree) =
898 Aggregate_Library
899 then
900 Prj.Com.Fail ("aggregate library projects are not supported");
901
902 else
903 -- If parsing was successful, remove the components that are
904 -- automatically generated, if any, so that they will be
905 -- unconditionally added later.
906
907 -- Remove the with clause for the naming project file
908
909 declare
910 With_Clause : Project_Node_Id :=
911 First_With_Clause_Of (Project_Node, Tree);
912 Previous : Project_Node_Id := Empty_Node;
913
914 begin
915 while Present (With_Clause) loop
916 if Prj.Tree.Name_Of (With_Clause, Tree) =
917 Project_Naming_Id
918 then
919 if No (Previous) then
920 Set_First_With_Clause_Of
921 (Project_Node, Tree,
922 To => Next_With_Clause_Of (With_Clause, Tree));
923 else
924 Set_Next_With_Clause_Of
925 (Previous, Tree,
926 To => Next_With_Clause_Of (With_Clause, Tree));
927 end if;
928
929 exit;
930 end if;
931
932 Previous := With_Clause;
933 With_Clause := Next_With_Clause_Of (With_Clause, Tree);
934 end loop;
935 end;
936
937 -- Remove attribute declarations of Source_Files,
938 -- Source_List_File, Source_Dirs, and the declaration of
939 -- package Naming, if they exist, but preserve the comments
940 -- attached to these nodes.
941
942 declare
943 Declaration : Project_Node_Id :=
944 First_Declarative_Item_Of
945 (Project_Declaration_Of
946 (Project_Node, Tree),
947 Tree);
948 Previous : Project_Node_Id := Empty_Node;
949 Current_Node : Project_Node_Id := Empty_Node;
950
951 Name : Name_Id;
952 Kind_Of_Node : Project_Node_Kind;
953 Comments : Project_Node_Id;
954
955 begin
956 while Present (Declaration) loop
957 Current_Node := Current_Item_Node (Declaration, Tree);
958
959 Kind_Of_Node := Kind_Of (Current_Node, Tree);
960
961 if Kind_Of_Node = N_Attribute_Declaration or else
962 Kind_Of_Node = N_Package_Declaration
963 then
964 Name := Prj.Tree.Name_Of (Current_Node, Tree);
965
966 if Nam_In (Name, Name_Source_Files,
967 Name_Source_List_File,
968 Name_Source_Dirs,
969 Name_Naming)
970 then
971 Comments :=
972 Tree.Project_Nodes.Table (Current_Node).Comments;
973
974 if Name = Name_Source_Files then
975 Source_Files_Comments := Comments;
976
977 elsif Name = Name_Source_List_File then
978 Source_List_File_Comments := Comments;
979
980 elsif Name = Name_Source_Dirs then
981 Source_Dirs_Comments := Comments;
982
983 elsif Name = Name_Naming then
984 Naming_Package_Comments := Comments;
985 end if;
986
987 if No (Previous) then
988 Set_First_Declarative_Item_Of
989 (Project_Declaration_Of (Project_Node, Tree),
990 Tree,
991 To => Next_Declarative_Item
992 (Declaration, Tree));
993
994 else
995 Set_Next_Declarative_Item
996 (Previous, Tree,
997 To => Next_Declarative_Item
998 (Declaration, Tree));
999 end if;
1000
1001 else
1002 Previous := Declaration;
1003 end if;
1004 end if;
1005
1006 Declaration := Next_Declarative_Item (Declaration, Tree);
1007 end loop;
1008 end;
1009 end if;
1010 end if;
1011
1012 if Directory_Last /= 0 then
1013 Output_Name (1 .. Output_Name_Last - Directory_Last) :=
1014 Output_Name (Directory_Last + 1 .. Output_Name_Last);
1015 Output_Name_Last := Output_Name_Last - Directory_Last;
1016 end if;
1017
1018 -- Get the project name id
1019
1020 Name_Len := Output_Name_Last;
1021 Name_Buffer (1 .. Name_Len) := Output_Name (1 .. Name_Len);
1022 Output_Name_Id := Name_Find;
1023
1024 -- Create the project naming file name
1025
1026 Project_Naming_Last := Output_Name_Last;
1027 Project_Naming_File_Name :=
1028 new String'(Output_Name (1 .. Output_Name_Last) &
1029 Naming_File_Suffix &
1030 Project_File_Extension);
1031 Project_Naming_Last :=
1032 Project_Naming_Last + Naming_File_Suffix'Length;
1033
1034 -- Get the project naming id
1035
1036 Name_Len := Project_Naming_Last;
1037 Name_Buffer (1 .. Name_Len) :=
1038 Project_Naming_File_Name (1 .. Name_Len);
1039 Project_Naming_Id := Name_Find;
1040
1041 Project_Naming_Last :=
1042 Project_Naming_Last + Project_File_Extension'Length;
1043
1044 -- Create the source list file name
1045
1046 Source_List_Last := Output_Name_Last;
1047 Source_List_Path :=
1048 new String'(Output_Name (1 .. Output_Name_Last) &
1049 Source_List_File_Suffix);
1050 Source_List_Last :=
1051 Output_Name_Last + Source_List_File_Suffix'Length;
1052
1053 -- Add the project file extension to the project name
1054
1055 Output_Name
1056 (Output_Name_Last + 1 ..
1057 Output_Name_Last + Project_File_Extension'Length) :=
1058 Project_File_Extension;
1059 Output_Name_Last := Output_Name_Last + Project_File_Extension'Length;
1060
1061 -- Back up project file if it already exists (not needed in VMS since
1062 -- versioning of files takes care of this requirement on VMS).
1063
1064 if not Hostparm.OpenVMS
1065 and then not Opt.No_Backup
1066 and then Is_Regular_File (Path_Name (1 .. Path_Last))
1067 then
1068 declare
1069 Discard : Boolean;
1070 Saved_Path : constant String :=
1071 Path_Name (1 .. Path_Last) & ".saved_";
1072 Nmb : Natural;
1073
1074 begin
1075 Nmb := 0;
1076 loop
1077 declare
1078 Img : constant String := Nmb'Img;
1079
1080 begin
1081 if not Is_Regular_File
1082 (Saved_Path & Img (2 .. Img'Last))
1083 then
1084 Copy_File
1085 (Name => Path_Name (1 .. Path_Last),
1086 Pathname => Saved_Path & Img (2 .. Img'Last),
1087 Mode => Overwrite,
1088 Success => Discard);
1089 exit;
1090 end if;
1091
1092 Nmb := Nmb + 1;
1093 end;
1094 end loop;
1095 end;
1096 end if;
1097 end if;
1098
1099 -- Change the current directory to the directory of the project file,
1100 -- if any directory information is specified.
1101
1102 if Directory_Last /= 0 then
1103 begin
1104 Change_Dir (Path_Name (1 .. Directory_Last));
1105 exception
1106 when Directory_Error =>
1107 Prj.Com.Fail
1108 ("unknown directory """
1109 & Path_Name (1 .. Directory_Last)
1110 & """");
1111 end;
1112 end if;
1113 end Initialize;
1114
1115 -------------
1116 -- Process --
1117 -------------
1118
1119 procedure Process
1120 (Directories : Argument_List;
1121 Name_Patterns : Regexp_List;
1122 Excluded_Patterns : Regexp_List;
1123 Foreign_Patterns : Regexp_List)
1124 is
1125 procedure Process_Directory (Dir_Name : String; Recursively : Boolean);
1126 -- Look for Ada and foreign sources in a directory, according to the
1127 -- patterns. When Recursively is True, after looking for sources in
1128 -- Dir_Name, look also in its subdirectories, if any.
1129
1130 -----------------------
1131 -- Process_Directory --
1132 -----------------------
1133
1134 procedure Process_Directory (Dir_Name : String; Recursively : Boolean) is
1135 Matched : Matched_Type := False;
1136 Str : String (1 .. 2_000);
1137 Canon : String (1 .. 2_000);
1138 Last : Natural;
1139 Dir : Dir_Type;
1140 Do_Process : Boolean := True;
1141
1142 Temp_File_Name : String_Access := null;
1143 Save_Last_Source_Index : Natural := 0;
1144 File_Name_Id : Name_Id := No_Name;
1145
1146 Current_Source : Source;
1147
1148 begin
1149 -- Avoid processing the same directory more than once
1150
1151 for Index in 1 .. Processed_Directories.Last loop
1152 if Processed_Directories.Table (Index).all = Dir_Name then
1153 Do_Process := False;
1154 exit;
1155 end if;
1156 end loop;
1157
1158 if Do_Process then
1159 if Opt.Verbose_Mode then
1160 Output.Write_Str ("Processing directory """);
1161 Output.Write_Str (Dir_Name);
1162 Output.Write_Line ("""");
1163 end if;
1164
1165 Processed_Directories. Increment_Last;
1166 Processed_Directories.Table (Processed_Directories.Last) :=
1167 new String'(Dir_Name);
1168
1169 -- Get the source file names from the directory. Fails if the
1170 -- directory does not exist.
1171
1172 begin
1173 Open (Dir, Dir_Name);
1174 exception
1175 when Directory_Error =>
1176 Prj.Com.Fail ("cannot open directory """ & Dir_Name & """");
1177 end;
1178
1179 -- Process each regular file in the directory
1180
1181 File_Loop : loop
1182 Read (Dir, Str, Last);
1183 exit File_Loop when Last = 0;
1184
1185 -- Copy the file name and put it in canonical case to match
1186 -- against the patterns that have themselves already been put
1187 -- in canonical case.
1188
1189 Canon (1 .. Last) := Str (1 .. Last);
1190 Canonical_Case_File_Name (Canon (1 .. Last));
1191
1192 if Is_Regular_File
1193 (Dir_Name & Directory_Separator & Str (1 .. Last))
1194 then
1195 Matched := True;
1196
1197 Name_Len := Last;
1198 Name_Buffer (1 .. Name_Len) := Str (1 .. Last);
1199 File_Name_Id := Name_Find;
1200
1201 -- First, check if the file name matches at least one of
1202 -- the excluded expressions;
1203
1204 for Index in Excluded_Patterns'Range loop
1205 if
1206 Match (Canon (1 .. Last), Excluded_Patterns (Index))
1207 then
1208 Matched := Excluded;
1209 exit;
1210 end if;
1211 end loop;
1212
1213 -- If it does not match any of the excluded expressions,
1214 -- check if the file name matches at least one of the
1215 -- regular expressions.
1216
1217 if Matched = True then
1218 Matched := False;
1219
1220 for Index in Name_Patterns'Range loop
1221 if
1222 Match
1223 (Canon (1 .. Last), Name_Patterns (Index))
1224 then
1225 Matched := True;
1226 exit;
1227 end if;
1228 end loop;
1229 end if;
1230
1231 if Very_Verbose
1232 or else (Matched = True and then Opt.Verbose_Mode)
1233 then
1234 Output.Write_Str (" Checking """);
1235 Output.Write_Str (Str (1 .. Last));
1236 Output.Write_Line (""": ");
1237 end if;
1238
1239 -- If the file name matches one of the regular expressions,
1240 -- parse it to get its unit name.
1241
1242 if Matched = True then
1243 declare
1244 FD : File_Descriptor;
1245 Success : Boolean;
1246 Saved_Output : File_Descriptor;
1247 Saved_Error : File_Descriptor;
1248 Tmp_File : Path_Name_Type;
1249
1250 begin
1251 -- If we don't have the path of the compiler yet,
1252 -- get it now. The compiler name may have a prefix,
1253 -- so we get the potentially prefixed name.
1254
1255 if Gcc_Path = null then
1256 declare
1257 Prefix_Gcc : String_Access :=
1258 Program_Name (Gcc, "gnatname");
1259 begin
1260 Gcc_Path :=
1261 Locate_Exec_On_Path (Prefix_Gcc.all);
1262 Free (Prefix_Gcc);
1263 end;
1264
1265 if Gcc_Path = null then
1266 Prj.Com.Fail ("could not locate " & Gcc);
1267 end if;
1268 end if;
1269
1270 -- Create the temporary file
1271
1272 Tempdir.Create_Temp_File (FD, Tmp_File);
1273
1274 if FD = Invalid_FD then
1275 Prj.Com.Fail
1276 ("could not create temporary file");
1277
1278 else
1279 Temp_File_Name :=
1280 new String'(Get_Name_String (Tmp_File));
1281 end if;
1282
1283 -- On VMS, a file created with Create_Temp_File cannot
1284 -- be used to redirect output.
1285
1286 if Hostparm.OpenVMS then
1287 Close (FD);
1288 Delete_File (Temp_File_Name.all, Success);
1289 FD := Create_Output_Text_File (Temp_File_Name.all);
1290 end if;
1291
1292 Args (Args'Last) := new String'
1293 (Dir_Name &
1294 Directory_Separator &
1295 Str (1 .. Last));
1296
1297 -- Save the standard output and error
1298
1299 Saved_Output := Dup (Standout);
1300 Saved_Error := Dup (Standerr);
1301
1302 -- Set standard output and error to the temporary file
1303
1304 Dup2 (FD, Standout);
1305 Dup2 (FD, Standerr);
1306
1307 -- And spawn the compiler
1308
1309 Spawn (Gcc_Path.all, Args.all, Success);
1310
1311 -- Restore the standard output and error
1312
1313 Dup2 (Saved_Output, Standout);
1314 Dup2 (Saved_Error, Standerr);
1315
1316 -- Close the temporary file
1317
1318 Close (FD);
1319
1320 -- And close the saved standard output and error to
1321 -- avoid too many file descriptors.
1322
1323 Close (Saved_Output);
1324 Close (Saved_Error);
1325
1326 -- Now that standard output is restored, check if
1327 -- the compiler ran correctly.
1328
1329 -- Read the lines of the temporary file:
1330 -- they should contain the kind and name of the unit.
1331
1332 declare
1333 File : Text_File;
1334 Text_Line : String (1 .. 1_000);
1335 Text_Last : Natural;
1336
1337 begin
1338 Open (File, Temp_File_Name.all);
1339
1340 if not Is_Valid (File) then
1341 Prj.Com.Fail
1342 ("could not read temporary file " &
1343 Temp_File_Name.all);
1344 end if;
1345
1346 Save_Last_Source_Index := Sources.Last;
1347
1348 if End_Of_File (File) then
1349 if Opt.Verbose_Mode then
1350 if not Success then
1351 Output.Write_Str (" (process died) ");
1352 end if;
1353 end if;
1354
1355 else
1356 Line_Loop : while not End_Of_File (File) loop
1357 Get_Line (File, Text_Line, Text_Last);
1358
1359 -- Find the first closing parenthesis
1360
1361 Char_Loop : for J in 1 .. Text_Last loop
1362 if Text_Line (J) = ')' then
1363 if J >= 13 and then
1364 Text_Line (1 .. 4) = "Unit"
1365 then
1366 -- Add entry to Sources table
1367
1368 Name_Len := J - 12;
1369 Name_Buffer (1 .. Name_Len) :=
1370 Text_Line (6 .. J - 7);
1371 Current_Source :=
1372 (Unit_Name => Name_Find,
1373 File_Name => File_Name_Id,
1374 Index => 0,
1375 Spec => Text_Line (J - 5 .. J) =
1376 "(spec)");
1377
1378 Sources.Append (Current_Source);
1379 end if;
1380
1381 exit Char_Loop;
1382 end if;
1383 end loop Char_Loop;
1384 end loop Line_Loop;
1385 end if;
1386
1387 if Save_Last_Source_Index = Sources.Last then
1388 if Opt.Verbose_Mode then
1389 Output.Write_Line (" not a unit");
1390 end if;
1391
1392 else
1393 if Sources.Last >
1394 Save_Last_Source_Index + 1
1395 then
1396 for Index in Save_Last_Source_Index + 1 ..
1397 Sources.Last
1398 loop
1399 Sources.Table (Index).Index :=
1400 Int (Index - Save_Last_Source_Index);
1401 end loop;
1402 end if;
1403
1404 for Index in Save_Last_Source_Index + 1 ..
1405 Sources.Last
1406 loop
1407 Current_Source := Sources.Table (Index);
1408
1409 if Opt.Verbose_Mode then
1410 if Current_Source.Spec then
1411 Output.Write_Str (" spec of ");
1412
1413 else
1414 Output.Write_Str (" body of ");
1415 end if;
1416
1417 Output.Write_Line
1418 (Get_Name_String
1419 (Current_Source.Unit_Name));
1420 end if;
1421 end loop;
1422 end if;
1423
1424 Close (File);
1425
1426 Delete_File (Temp_File_Name.all, Success);
1427 end;
1428 end;
1429
1430 -- File name matches none of the regular expressions
1431
1432 else
1433 -- If file is not excluded, see if this is foreign source
1434
1435 if Matched /= Excluded then
1436 for Index in Foreign_Patterns'Range loop
1437 if Match (Canon (1 .. Last),
1438 Foreign_Patterns (Index))
1439 then
1440 Matched := True;
1441 exit;
1442 end if;
1443 end loop;
1444 end if;
1445
1446 if Very_Verbose then
1447 case Matched is
1448 when False =>
1449 Output.Write_Line ("no match");
1450
1451 when Excluded =>
1452 Output.Write_Line ("excluded");
1453
1454 when True =>
1455 Output.Write_Line ("foreign source");
1456 end case;
1457 end if;
1458
1459 if Matched = True then
1460
1461 -- Add source file name without unit name
1462
1463 Name_Len := 0;
1464 Add_Str_To_Name_Buffer (Canon (1 .. Last));
1465 Sources.Append
1466 ((File_Name => Name_Find,
1467 Unit_Name => No_Name,
1468 Index => 0,
1469 Spec => False));
1470 end if;
1471 end if;
1472 end if;
1473 end loop File_Loop;
1474
1475 Close (Dir);
1476 end if;
1477
1478 -- If Recursively is True, call itself for each subdirectory.
1479 -- We do that, even when this directory has already been processed,
1480 -- because all of its subdirectories may not have been processed.
1481
1482 if Recursively then
1483 Open (Dir, Dir_Name);
1484
1485 loop
1486 Read (Dir, Str, Last);
1487 exit when Last = 0;
1488
1489 -- Do not call itself for "." or ".."
1490
1491 if Is_Directory
1492 (Dir_Name & Directory_Separator & Str (1 .. Last))
1493 and then Str (1 .. Last) /= "."
1494 and then Str (1 .. Last) /= ".."
1495 then
1496 Process_Directory
1497 (Dir_Name & Directory_Separator & Str (1 .. Last),
1498 Recursively => True);
1499 end if;
1500 end loop;
1501
1502 Close (Dir);
1503 end if;
1504 end Process_Directory;
1505
1506 -- Start of processing for Process
1507
1508 begin
1509 Processed_Directories.Set_Last (0);
1510
1511 -- Process each directory
1512
1513 for Index in Directories'Range loop
1514
1515 declare
1516 Dir_Name : constant String := Directories (Index).all;
1517 Last : Natural := Dir_Name'Last;
1518 Recursively : Boolean := False;
1519 Found : Boolean;
1520 Canonical : String (1 .. Dir_Name'Length) := Dir_Name;
1521
1522 begin
1523 Canonical_Case_File_Name (Canonical);
1524
1525 Found := False;
1526 for J in 1 .. Source_Directories.Last loop
1527 if Source_Directories.Table (J).all = Canonical then
1528 Found := True;
1529 exit;
1530 end if;
1531 end loop;
1532
1533 if not Found then
1534 Source_Directories.Append (new String'(Canonical));
1535 end if;
1536
1537 if Dir_Name'Length >= 4
1538 and then (Dir_Name (Last - 2 .. Last) = "/**")
1539 then
1540 Last := Last - 3;
1541 Recursively := True;
1542 end if;
1543
1544 Process_Directory (Dir_Name (Dir_Name'First .. Last), Recursively);
1545 end;
1546
1547 end loop;
1548 end Process;
1549
1550 ----------------
1551 -- Write_Char --
1552 ----------------
1553 procedure Write_A_Char (C : Character) is
1554 begin
1555 Write_A_String ((1 => C));
1556 end Write_A_Char;
1557
1558 ---------------
1559 -- Write_Eol --
1560 ---------------
1561
1562 procedure Write_Eol is
1563 begin
1564 Write_A_String ((1 => ASCII.LF));
1565 end Write_Eol;
1566
1567 --------------------
1568 -- Write_A_String --
1569 --------------------
1570
1571 procedure Write_A_String (S : String) is
1572 Str : String (1 .. S'Length);
1573
1574 begin
1575 if S'Length > 0 then
1576 Str := S;
1577
1578 if Write (Output_FD, Str (1)'Address, Str'Length) /= Str'Length then
1579 Prj.Com.Fail ("disk full");
1580 end if;
1581 end if;
1582 end Write_A_String;
1583
1584 end Prj.Makr;
Mirror of the offical gcc git repository hosted at gcc.gnu.org