File : uname.adb
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- U N A M E --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 1992-2015, 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. --
17 -- --
18 -- --
19 -- --
20 -- --
21 -- --
22 -- You should have received a copy of the GNU General Public License and --
23 -- a copy of the GCC Runtime Library Exception along with this program; --
24 -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
25 -- <http://www.gnu.org/licenses/>. --
26 -- --
27 -- GNAT was originally developed by the GNAT team at New York University. --
28 -- Extensive contributions were provided by Ada Core Technologies Inc. --
29 -- --
30 ------------------------------------------------------------------------------
31
32 with Atree; use Atree;
33 with Casing; use Casing;
34 with Einfo; use Einfo;
35 with Hostparm;
36 with Lib; use Lib;
37 with Nlists; use Nlists;
38 with Output; use Output;
39 with Sinfo; use Sinfo;
40 with Sinput; use Sinput;
41
42 package body Uname is
43
44 -------------------
45 -- Get_Body_Name --
46 -------------------
47
48 function Get_Body_Name (N : Unit_Name_Type) return Unit_Name_Type is
49 begin
50 Get_Name_String (N);
51
52 pragma Assert (Name_Len > 2
53 and then Name_Buffer (Name_Len - 1) = '%'
54 and then Name_Buffer (Name_Len) = 's');
55
56 Name_Buffer (Name_Len) := 'b';
57 return Name_Find;
58 end Get_Body_Name;
59
60 -----------------------------------
61 -- Get_External_Unit_Name_String --
62 -----------------------------------
63
64 procedure Get_External_Unit_Name_String (N : Unit_Name_Type) is
65 Pcount : Natural;
66 Newlen : Natural;
67
68 begin
69 -- Get unit name and eliminate trailing %s or %b
70
71 Get_Name_String (N);
72 Name_Len := Name_Len - 2;
73
74 -- Find number of components
75
76 Pcount := 0;
77 for J in 1 .. Name_Len loop
78 if Name_Buffer (J) = '.' then
79 Pcount := Pcount + 1;
80 end if;
81 end loop;
82
83 -- If simple name, nothing to do
84
85 if Pcount = 0 then
86 return;
87 end if;
88
89 -- If name has multiple components, replace dots by double underscore
90
91 Newlen := Name_Len + Pcount;
92
93 for J in reverse 1 .. Name_Len loop
94 if Name_Buffer (J) = '.' then
95 Name_Buffer (Newlen) := '_';
96 Name_Buffer (Newlen - 1) := '_';
97 Newlen := Newlen - 2;
98
99 else
100 Name_Buffer (Newlen) := Name_Buffer (J);
101 Newlen := Newlen - 1;
102 end if;
103 end loop;
104
105 Name_Len := Name_Len + Pcount;
106 end Get_External_Unit_Name_String;
107
108 --------------------------
109 -- Get_Parent_Body_Name --
110 --------------------------
111
112 function Get_Parent_Body_Name (N : Unit_Name_Type) return Unit_Name_Type is
113 begin
114 Get_Name_String (N);
115
116 while Name_Buffer (Name_Len) /= '.' loop
117 pragma Assert (Name_Len > 1); -- not a child or subunit name
118 Name_Len := Name_Len - 1;
119 end loop;
120
121 Name_Buffer (Name_Len) := '%';
122 Name_Len := Name_Len + 1;
123 Name_Buffer (Name_Len) := 'b';
124 return Name_Find;
125
126 end Get_Parent_Body_Name;
127
128 --------------------------
129 -- Get_Parent_Spec_Name --
130 --------------------------
131
132 function Get_Parent_Spec_Name (N : Unit_Name_Type) return Unit_Name_Type is
133 begin
134 Get_Name_String (N);
135
136 while Name_Buffer (Name_Len) /= '.' loop
137 if Name_Len = 1 then
138 return No_Unit_Name;
139 else
140 Name_Len := Name_Len - 1;
141 end if;
142 end loop;
143
144 Name_Buffer (Name_Len) := '%';
145 Name_Len := Name_Len + 1;
146 Name_Buffer (Name_Len) := 's';
147 return Name_Find;
148
149 end Get_Parent_Spec_Name;
150
151 -------------------
152 -- Get_Spec_Name --
153 -------------------
154
155 function Get_Spec_Name (N : Unit_Name_Type) return Unit_Name_Type is
156 begin
157 Get_Name_String (N);
158
159 pragma Assert (Name_Len > 2
160 and then Name_Buffer (Name_Len - 1) = '%'
161 and then Name_Buffer (Name_Len) = 'b');
162
163 Name_Buffer (Name_Len) := 's';
164 return Name_Find;
165 end Get_Spec_Name;
166
167 -------------------
168 -- Get_Unit_Name --
169 -------------------
170
171 function Get_Unit_Name (N : Node_Id) return Unit_Name_Type is
172
173 Unit_Name_Buffer : String (1 .. Hostparm.Max_Name_Length);
174 -- Buffer used to build name of unit. Note that we cannot use the
175 -- Name_Buffer in package Name_Table because we use it to read
176 -- component names.
177
178 Unit_Name_Length : Natural := 0;
179 -- Length of name stored in Unit_Name_Buffer
180
181 Node : Node_Id;
182 -- Program unit node
183
184 procedure Add_Char (C : Character);
185 -- Add a single character to stored unit name
186
187 procedure Add_Name (Name : Name_Id);
188 -- Add the characters of a names table entry to stored unit name
189
190 procedure Add_Node_Name (Node : Node_Id);
191 -- Recursive procedure adds characters associated with Node
192
193 function Get_Parent (Node : Node_Id) return Node_Id;
194 -- Get parent compilation unit of a stub
195
196 --------------
197 -- Add_Char --
198 --------------
199
200 procedure Add_Char (C : Character) is
201 begin
202 -- Should really check for max length exceeded here???
203 Unit_Name_Length := Unit_Name_Length + 1;
204 Unit_Name_Buffer (Unit_Name_Length) := C;
205 end Add_Char;
206
207 --------------
208 -- Add_Name --
209 --------------
210
211 procedure Add_Name (Name : Name_Id) is
212 begin
213 Get_Name_String (Name);
214
215 for J in 1 .. Name_Len loop
216 Add_Char (Name_Buffer (J));
217 end loop;
218 end Add_Name;
219
220 -------------------
221 -- Add_Node_Name --
222 -------------------
223
224 procedure Add_Node_Name (Node : Node_Id) is
225 Kind : constant Node_Kind := Nkind (Node);
226
227 begin
228 -- Just ignore an error node (someone else will give a message)
229
230 if Node = Error then
231 return;
232
233 -- Otherwise see what kind of node we have
234
235 else
236 case Kind is
237
238 when N_Identifier |
239 N_Defining_Identifier |
240 N_Defining_Operator_Symbol =>
241
242 -- Note: it is of course an error to have a defining
243 -- operator symbol at this point, but this is not where
244 -- the error is signalled, so we handle it nicely here.
245
246 Add_Name (Chars (Node));
247
248 when N_Defining_Program_Unit_Name =>
249 Add_Node_Name (Name (Node));
250 Add_Char ('.');
251 Add_Node_Name (Defining_Identifier (Node));
252
253 when N_Selected_Component |
254 N_Expanded_Name =>
255 Add_Node_Name (Prefix (Node));
256 Add_Char ('.');
257 Add_Node_Name (Selector_Name (Node));
258
259 when N_Subprogram_Specification |
260 N_Package_Specification =>
261 Add_Node_Name (Defining_Unit_Name (Node));
262
263 when N_Subprogram_Body |
264 N_Subprogram_Declaration |
265 N_Package_Declaration |
266 N_Generic_Declaration =>
267 Add_Node_Name (Specification (Node));
268
269 when N_Generic_Instantiation =>
270 Add_Node_Name (Defining_Unit_Name (Node));
271
272 when N_Package_Body =>
273 Add_Node_Name (Defining_Unit_Name (Node));
274
275 when N_Task_Body |
276 N_Protected_Body =>
277 Add_Node_Name (Defining_Identifier (Node));
278
279 when N_Package_Renaming_Declaration =>
280 Add_Node_Name (Defining_Unit_Name (Node));
281
282 when N_Subprogram_Renaming_Declaration =>
283 Add_Node_Name (Specification (Node));
284
285 when N_Generic_Renaming_Declaration =>
286 Add_Node_Name (Defining_Unit_Name (Node));
287
288 when N_Subprogram_Body_Stub =>
289 Add_Node_Name (Get_Parent (Node));
290 Add_Char ('.');
291 Add_Node_Name (Specification (Node));
292
293 when N_Compilation_Unit =>
294 Add_Node_Name (Unit (Node));
295
296 when N_Package_Body_Stub =>
297 Add_Node_Name (Get_Parent (Node));
298 Add_Char ('.');
299 Add_Node_Name (Defining_Identifier (Node));
300
301 when N_Task_Body_Stub |
302 N_Protected_Body_Stub =>
303 Add_Node_Name (Get_Parent (Node));
304 Add_Char ('.');
305 Add_Node_Name (Defining_Identifier (Node));
306
307 when N_Subunit =>
308 Add_Node_Name (Name (Node));
309 Add_Char ('.');
310 Add_Node_Name (Proper_Body (Node));
311
312 when N_With_Clause =>
313 Add_Node_Name (Name (Node));
314
315 when N_Pragma =>
316 Add_Node_Name (Expression (First
317 (Pragma_Argument_Associations (Node))));
318
319 -- Tasks and protected stuff appear only in an error context,
320 -- but the error has been posted elsewhere, so we deal nicely
321 -- with these error situations here, and produce a reasonable
322 -- unit name using the defining identifier.
323
324 when N_Task_Type_Declaration |
325 N_Single_Task_Declaration |
326 N_Protected_Type_Declaration |
327 N_Single_Protected_Declaration =>
328 Add_Node_Name (Defining_Identifier (Node));
329
330 when others =>
331 raise Program_Error;
332
333 end case;
334 end if;
335 end Add_Node_Name;
336
337 ----------------
338 -- Get_Parent --
339 ----------------
340
341 function Get_Parent (Node : Node_Id) return Node_Id is
342 N : Node_Id := Node;
343
344 begin
345 while Nkind (N) /= N_Compilation_Unit loop
346 N := Parent (N);
347 end loop;
348
349 return N;
350 end Get_Parent;
351
352 -- Start of processing for Get_Unit_Name
353
354 begin
355 Node := N;
356
357 -- If we have Defining_Identifier, find the associated unit node
358
359 if Nkind (Node) = N_Defining_Identifier then
360 Node := Declaration_Node (Node);
361
362 -- If an expanded name, it is an already analyzed child unit, find
363 -- unit node.
364
365 elsif Nkind (Node) = N_Expanded_Name then
366 Node := Declaration_Node (Entity (Node));
367 end if;
368
369 if Nkind (Node) = N_Package_Specification
370 or else Nkind (Node) in N_Subprogram_Specification
371 then
372 Node := Parent (Node);
373 end if;
374
375 -- Node points to the unit, so get its name and add proper suffix
376
377 Add_Node_Name (Node);
378 Add_Char ('%');
379
380 case Nkind (Node) is
381 when N_Generic_Declaration |
382 N_Subprogram_Declaration |
383 N_Package_Declaration |
384 N_With_Clause |
385 N_Pragma |
386 N_Generic_Instantiation |
387 N_Package_Renaming_Declaration |
388 N_Subprogram_Renaming_Declaration |
389 N_Generic_Renaming_Declaration |
390 N_Single_Task_Declaration |
391 N_Single_Protected_Declaration |
392 N_Task_Type_Declaration |
393 N_Protected_Type_Declaration =>
394
395 Add_Char ('s');
396
397 when N_Subprogram_Body |
398 N_Package_Body |
399 N_Subunit |
400 N_Body_Stub |
401 N_Task_Body |
402 N_Protected_Body |
403 N_Identifier |
404 N_Selected_Component =>
405
406 Add_Char ('b');
407
408 when others =>
409 raise Program_Error;
410 end case;
411
412 Name_Buffer (1 .. Unit_Name_Length) :=
413 Unit_Name_Buffer (1 .. Unit_Name_Length);
414 Name_Len := Unit_Name_Length;
415 return Name_Find;
416
417 end Get_Unit_Name;
418
419 --------------------------
420 -- Get_Unit_Name_String --
421 --------------------------
422
423 procedure Get_Unit_Name_String
424 (N : Unit_Name_Type;
425 Suffix : Boolean := True)
426 is
427 Unit_Is_Body : Boolean;
428
429 begin
430 Get_Decoded_Name_String (N);
431 Unit_Is_Body := Name_Buffer (Name_Len) = 'b';
432 Set_Casing (Identifier_Casing (Source_Index (Main_Unit)));
433
434 -- A special fudge, normally we don't have operator symbols present,
435 -- since it is always an error to do so. However, if we do, at this
436 -- stage it has the form:
437
438 -- "and"
439
440 -- and the %s or %b has already been eliminated so put 2 chars back
441
442 if Name_Buffer (1) = '"' then
443 Name_Len := Name_Len + 2;
444 end if;
445
446 -- Now adjust the %s or %b to (spec) or (body)
447
448 if Suffix then
449 if Unit_Is_Body then
450 Name_Buffer (Name_Len - 1 .. Name_Len + 5) := " (body)";
451 else
452 Name_Buffer (Name_Len - 1 .. Name_Len + 5) := " (spec)";
453 end if;
454 end if;
455
456 for J in 1 .. Name_Len loop
457 if Name_Buffer (J) = '-' then
458 Name_Buffer (J) := '.';
459 end if;
460 end loop;
461
462 -- Adjust Name_Len
463
464 if Suffix then
465 Name_Len := Name_Len + (7 - 2);
466 else
467 Name_Len := Name_Len - 2;
468 end if;
469 end Get_Unit_Name_String;
470
471 ------------------
472 -- Is_Body_Name --
473 ------------------
474
475 function Is_Body_Name (N : Unit_Name_Type) return Boolean is
476 begin
477 Get_Name_String (N);
478 return Name_Len > 2
479 and then Name_Buffer (Name_Len - 1) = '%'
480 and then Name_Buffer (Name_Len) = 'b';
481 end Is_Body_Name;
482
483 -------------------
484 -- Is_Child_Name --
485 -------------------
486
487 function Is_Child_Name (N : Unit_Name_Type) return Boolean is
488 J : Natural;
489
490 begin
491 Get_Name_String (N);
492 J := Name_Len;
493
494 while Name_Buffer (J) /= '.' loop
495 if J = 1 then
496 return False; -- not a child or subunit name
497 else
498 J := J - 1;
499 end if;
500 end loop;
501
502 return True;
503 end Is_Child_Name;
504
505 ------------------
506 -- Is_Spec_Name --
507 ------------------
508
509 function Is_Spec_Name (N : Unit_Name_Type) return Boolean is
510 begin
511 Get_Name_String (N);
512 return Name_Len > 2
513 and then Name_Buffer (Name_Len - 1) = '%'
514 and then Name_Buffer (Name_Len) = 's';
515 end Is_Spec_Name;
516
517 -----------------------
518 -- Name_To_Unit_Name --
519 -----------------------
520
521 function Name_To_Unit_Name (N : Name_Id) return Unit_Name_Type is
522 begin
523 Get_Name_String (N);
524 Name_Buffer (Name_Len + 1) := '%';
525 Name_Buffer (Name_Len + 2) := 's';
526 Name_Len := Name_Len + 2;
527 return Name_Find;
528 end Name_To_Unit_Name;
529
530 ---------------
531 -- New_Child --
532 ---------------
533
534 function New_Child
535 (Old : Unit_Name_Type;
536 Newp : Unit_Name_Type) return Unit_Name_Type
537 is
538 P : Natural;
539
540 begin
541 Get_Name_String (Old);
542
543 declare
544 Child : constant String := Name_Buffer (1 .. Name_Len);
545
546 begin
547 Get_Name_String (Newp);
548 Name_Len := Name_Len - 2;
549
550 P := Child'Last;
551 while Child (P) /= '.' loop
552 P := P - 1;
553 end loop;
554
555 while P <= Child'Last loop
556 Name_Len := Name_Len + 1;
557 Name_Buffer (Name_Len) := Child (P);
558 P := P + 1;
559 end loop;
560
561 return Name_Find;
562 end;
563 end New_Child;
564
565 --------------
566 -- Uname_Ge --
567 --------------
568
569 function Uname_Ge (Left, Right : Unit_Name_Type) return Boolean is
570 begin
571 return Left = Right or else Uname_Gt (Left, Right);
572 end Uname_Ge;
573
574 --------------
575 -- Uname_Gt --
576 --------------
577
578 function Uname_Gt (Left, Right : Unit_Name_Type) return Boolean is
579 begin
580 return Left /= Right and then not Uname_Lt (Left, Right);
581 end Uname_Gt;
582
583 --------------
584 -- Uname_Le --
585 --------------
586
587 function Uname_Le (Left, Right : Unit_Name_Type) return Boolean is
588 begin
589 return Left = Right or else Uname_Lt (Left, Right);
590 end Uname_Le;
591
592 --------------
593 -- Uname_Lt --
594 --------------
595
596 function Uname_Lt (Left, Right : Unit_Name_Type) return Boolean is
597 Left_Name : String (1 .. Hostparm.Max_Name_Length);
598 Left_Length : Natural;
599 Right_Name : String renames Name_Buffer;
600 Right_Length : Natural renames Name_Len;
601 J : Natural;
602
603 begin
604 pragma Warnings (Off, Right_Length);
605 -- Suppress warnings on Right_Length, used in pragma Assert
606
607 if Left = Right then
608 return False;
609 end if;
610
611 Get_Name_String (Left);
612 Left_Name (1 .. Name_Len + 1) := Name_Buffer (1 .. Name_Len + 1);
613 Left_Length := Name_Len;
614 Get_Name_String (Right);
615 J := 1;
616
617 loop
618 exit when Left_Name (J) = '%';
619
620 if Right_Name (J) = '%' then
621 return False; -- left name is longer
622 end if;
623
624 pragma Assert (J <= Left_Length and then J <= Right_Length);
625
626 if Left_Name (J) /= Right_Name (J) then
627 return Left_Name (J) < Right_Name (J); -- parent names different
628 end if;
629
630 J := J + 1;
631 end loop;
632
633 -- Come here pointing to % in left name
634
635 if Right_Name (J) /= '%' then
636 return True; -- right name is longer
637 end if;
638
639 -- Here the parent names are the same and specs sort low. If neither is
640 -- a spec, then we are comparing the same name and we want a result of
641 -- False in any case.
642
643 return Left_Name (J + 1) = 's';
644 end Uname_Lt;
645
646 ---------------------
647 -- Write_Unit_Name --
648 ---------------------
649
650 procedure Write_Unit_Name (N : Unit_Name_Type) is
651 begin
652 Get_Unit_Name_String (N);
653 Write_Str (Name_Buffer (1 .. Name_Len));
654 end Write_Unit_Name;
655
656 end Uname;