1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2024, Free Software Foundation, Inc. --
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. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 with Atree
; use Atree
;
27 with Casing
; use Casing
;
28 with Einfo
; use Einfo
;
29 with Einfo
.Utils
; use Einfo
.Utils
;
32 with Nlists
; use Nlists
;
33 with Output
; use Output
;
34 with Sinfo
; use Sinfo
;
35 with Sinfo
.Nodes
; use Sinfo
.Nodes
;
36 with Sinfo
.Utils
; use Sinfo
.Utils
;
37 with Sinput
; use Sinput
;
41 function Has_Prefix
(X
, Prefix
: String) return Boolean;
42 -- True if Prefix is at the beginning of X. For example,
43 -- Has_Prefix("a-filename.ads", Prefix => "a-") is True.
49 function Get_Body_Name
(N
: Unit_Name_Type
) return Unit_Name_Type
is
50 Buffer
: Bounded_String
;
53 pragma Assert
(Is_Spec_Name
(N
));
54 Buffer
.Chars
(Buffer
.Length
) := 'b';
55 return Name_Find
(Buffer
);
58 -----------------------------------
59 -- Get_External_Unit_Name_String --
60 -----------------------------------
62 procedure Get_External_Unit_Name_String
(N
: Unit_Name_Type
) is
67 -- Get unit name and eliminate trailing %s or %b
70 Name_Len
:= Name_Len
- 2;
72 -- Find number of components
75 for J
in 1 .. Name_Len
loop
76 if Name_Buffer
(J
) = '.' then
81 -- If simple name, nothing to do
87 -- If name has multiple components, replace dots by double underscore
89 Newlen
:= Name_Len
+ Pcount
;
91 for J
in reverse 1 .. Name_Len
loop
92 if Name_Buffer
(J
) = '.' then
93 Name_Buffer
(Newlen
) := '_';
94 Name_Buffer
(Newlen
- 1) := '_';
98 Name_Buffer
(Newlen
) := Name_Buffer
(J
);
103 Name_Len
:= Name_Len
+ Pcount
;
104 end Get_External_Unit_Name_String
;
106 --------------------------
107 -- Get_Parent_Body_Name --
108 --------------------------
110 function Get_Parent_Body_Name
(N
: Unit_Name_Type
) return Unit_Name_Type
is
111 Buffer
: Bounded_String
;
115 while Buffer
.Chars
(Buffer
.Length
) /= '.' loop
116 pragma Assert
(Buffer
.Length
> 1); -- not a child or subunit name
117 Buffer
.Length
:= Buffer
.Length
- 1;
120 Buffer
.Chars
(Buffer
.Length
) := '%';
121 Append
(Buffer
, 'b');
123 return Name_Find
(Buffer
);
124 end Get_Parent_Body_Name
;
126 --------------------------
127 -- Get_Parent_Spec_Name --
128 --------------------------
130 function Get_Parent_Spec_Name
(N
: Unit_Name_Type
) return Unit_Name_Type
is
131 Buffer
: Bounded_String
;
135 while Buffer
.Chars
(Buffer
.Length
) /= '.' loop
136 if Buffer
.Length
= 1 then
139 Buffer
.Length
:= Buffer
.Length
- 1;
143 Buffer
.Chars
(Buffer
.Length
) := '%';
144 Append
(Buffer
, 's');
146 return Name_Find
(Buffer
);
147 end Get_Parent_Spec_Name
;
153 function Get_Spec_Name
(N
: Unit_Name_Type
) return Unit_Name_Type
is
154 Buffer
: Bounded_String
;
157 pragma Assert
(Is_Body_Name
(N
));
158 Buffer
.Chars
(Buffer
.Length
) := 's';
159 return Name_Find
(Buffer
);
166 function Get_Unit_Name
(N
: Node_Id
) return Unit_Name_Type
is
168 Unit_Name_Buffer
: Bounded_String
;
169 -- Buffer used to build name of unit
174 procedure Add_Char
(C
: Character);
175 -- Add a single character to stored unit name
177 procedure Add_Name
(Name
: Name_Id
);
178 -- Add the characters of a names table entry to stored unit name
180 procedure Add_Node_Name
(Node
: Node_Id
);
181 -- Recursive procedure adds characters associated with Node
183 function Get_Parent
(Node
: Node_Id
) return Node_Id
;
184 -- Get parent compilation unit of a stub
190 procedure Add_Char
(C
: Character) is
192 Append
(Unit_Name_Buffer
, C
);
199 procedure Add_Name
(Name
: Name_Id
) is
201 Append
(Unit_Name_Buffer
, Name
);
208 procedure Add_Node_Name
(Node
: Node_Id
) is
210 -- Just ignore an error node (someone else will give a message)
215 -- Otherwise see what kind of node we have
219 when N_Defining_Identifier
220 | N_Defining_Operator_Symbol
223 -- Note: it is of course an error to have a defining
224 -- operator symbol at this point, but this is not where
225 -- the error is signalled, so we handle it nicely here.
227 Add_Name
(Chars
(Node
));
229 when N_Defining_Program_Unit_Name
=>
230 Add_Node_Name
(Name
(Node
));
232 Add_Node_Name
(Defining_Identifier
(Node
));
235 | N_Selected_Component
237 Add_Node_Name
(Prefix
(Node
));
239 Add_Node_Name
(Selector_Name
(Node
));
241 when N_Package_Specification
242 | N_Subprogram_Specification
244 Add_Node_Name
(Defining_Unit_Name
(Node
));
246 when N_Generic_Declaration
247 | N_Package_Declaration
249 | N_Subprogram_Declaration
251 Add_Node_Name
(Specification
(Node
));
253 when N_Generic_Instantiation
=>
254 Add_Node_Name
(Defining_Unit_Name
(Node
));
256 when N_Package_Body
=>
257 Add_Node_Name
(Defining_Unit_Name
(Node
));
259 when N_Protected_Body
262 Add_Node_Name
(Defining_Identifier
(Node
));
264 when N_Package_Renaming_Declaration
=>
265 Add_Node_Name
(Defining_Unit_Name
(Node
));
267 when N_Subprogram_Renaming_Declaration
=>
268 Add_Node_Name
(Specification
(Node
));
270 when N_Generic_Renaming_Declaration
=>
271 Add_Node_Name
(Defining_Unit_Name
(Node
));
273 when N_Subprogram_Body_Stub
=>
274 Add_Node_Name
(Get_Parent
(Node
));
276 Add_Node_Name
(Specification
(Node
));
278 when N_Compilation_Unit
=>
279 Add_Node_Name
(Unit
(Node
));
281 when N_Package_Body_Stub
282 | N_Protected_Body_Stub
285 Add_Node_Name
(Get_Parent
(Node
));
287 Add_Node_Name
(Defining_Identifier
(Node
));
290 Add_Node_Name
(Name
(Node
));
292 Add_Node_Name
(Proper_Body
(Node
));
294 when N_With_Clause
=>
295 Add_Node_Name
(Name
(Node
));
298 Add_Node_Name
(Expression
(First
299 (Pragma_Argument_Associations
(Node
))));
301 -- Tasks and protected stuff appear only in an error context,
302 -- but the error has been posted elsewhere, so we deal nicely
303 -- with these error situations here, and produce a reasonable
304 -- unit name using the defining identifier.
306 when N_Protected_Type_Declaration
307 | N_Single_Protected_Declaration
308 | N_Single_Task_Declaration
309 | N_Task_Type_Declaration
311 Add_Node_Name
(Defining_Identifier
(Node
));
323 function Get_Parent
(Node
: Node_Id
) return Node_Id
is
327 while Nkind
(N
) /= N_Compilation_Unit
loop
334 -- Start of processing for Get_Unit_Name
339 -- If we have Defining_Identifier, find the associated unit node
341 if Nkind
(Node
) = N_Defining_Identifier
then
342 Node
:= Declaration_Node
(Node
);
344 -- If an expanded name, it is an already analyzed child unit, find
347 elsif Nkind
(Node
) = N_Expanded_Name
then
348 Node
:= Declaration_Node
(Entity
(Node
));
351 if Nkind
(Node
) in N_Package_Specification
352 | N_Subprogram_Specification
354 Node
:= Parent
(Node
);
357 -- Node points to the unit, so get its name and add proper suffix
359 Add_Node_Name
(Node
);
363 when N_Generic_Declaration
364 | N_Generic_Instantiation
365 | N_Generic_Renaming_Declaration
366 | N_Package_Declaration
367 | N_Package_Renaming_Declaration
369 | N_Protected_Type_Declaration
370 | N_Single_Protected_Declaration
371 | N_Single_Task_Declaration
372 | N_Subprogram_Declaration
373 | N_Subprogram_Renaming_Declaration
374 | N_Task_Type_Declaration
383 | N_Selected_Component
394 return Name_Find
(Unit_Name_Buffer
);
397 --------------------------
398 -- Get_Unit_Name_String --
399 --------------------------
401 procedure Get_Unit_Name_String
402 (Buf
: in out Bounded_String
;
404 Suffix
: Boolean := True)
408 Append_Decoded
(Buf
, N
);
409 pragma Assert
(Buf
.Chars
(1) /= '"');
410 pragma Assert
(Is_Body_Name
(N
) or else Is_Spec_Name
(N
));
412 -- Buf always ends with "%s" or "%b", which we either remove, or replace
413 -- with " (spec)" or " (body)". Set_Casing of Buf after checking for
414 -- (lower case) 's'/'b', and before appending (lower case) "spec" or
418 S
: constant String :=
419 (if Buf
.Chars
(Buf
.Length
) = 's' then " (spec)" else " (body)");
421 Buf
.Length
:= Buf
.Length
- 2; -- remove "%s" or "%b"
422 Set_Casing
(Buf
, Identifier_Casing
(Source_Index
(Main_Unit
)));
429 for J
in 1 .. Buf
.Length
loop
430 if Buf
.Chars
(J
) = '-' then
431 Buf
.Chars
(J
) := '.';
434 end Get_Unit_Name_String
;
440 function Has_Prefix
(X
, Prefix
: String) return Boolean is
442 if X
'Length >= Prefix
'Length then
444 Slice
: String renames
445 X
(X
'First .. X
'First + Prefix
'Length - 1);
447 return Slice
= Prefix
;
457 function Is_Body_Name
(N
: Unit_Name_Type
) return Boolean is
458 Buffer
: Bounded_String
;
462 (Buffer
.Length
> 2 and then Buffer
.Chars
(Buffer
.Length
- 1) = '%');
463 return Buffer
.Chars
(Buffer
.Length
) = 'b';
470 function Is_Child_Name
(N
: Unit_Name_Type
) return Boolean is
471 Buffer
: Bounded_String
;
476 while Buffer
.Chars
(Buffer
.Length
) /= '.' loop
477 if Buffer
.Length
= 1 then
478 return False; -- not a child or subunit name
480 Buffer
.Length
:= Buffer
.Length
- 1;
487 ---------------------------
488 -- Is_Internal_Unit_Name --
489 ---------------------------
491 function Is_Internal_Unit_Name
493 Renamings_Included
: Boolean := True) return Boolean
495 Gnat
: constant String := "gnat";
502 if Has_Prefix
(Name
, Prefix
=> Gnat
& ".") then
506 return Is_Predefined_Unit_Name
(Name
, Renamings_Included
);
507 end Is_Internal_Unit_Name
;
509 -----------------------------
510 -- Is_Predefined_Unit_Name --
511 -----------------------------
513 function Is_Predefined_Unit_Name
515 Renamings_Included
: Boolean := True) return Boolean
517 Ada
: constant String := "ada";
518 Interfaces
: constant String := "interfaces";
519 System
: constant String := "system";
522 if Name
in Ada | Interfaces | System
then
526 if Has_Prefix
(Name
, Prefix
=> Ada
& ".")
527 or else Has_Prefix
(Name
, Prefix
=> Interfaces
& ".")
528 or else Has_Prefix
(Name
, Prefix
=> System
& ".")
533 if not Renamings_Included
then
537 -- The following are the predefined renamings
539 return Name
in "calendar"
541 |
"unchecked_conversion"
542 |
"unchecked_deallocation"
547 end Is_Predefined_Unit_Name
;
553 function Is_Spec_Name
(N
: Unit_Name_Type
) return Boolean is
554 Buffer
: Bounded_String
;
558 (Buffer
.Length
> 2 and then Buffer
.Chars
(Buffer
.Length
- 1) = '%');
559 return Buffer
.Chars
(Buffer
.Length
) = 's';
562 -----------------------
563 -- Name_To_Unit_Name --
564 -----------------------
566 function Name_To_Unit_Name
(N
: Name_Id
) return Unit_Name_Type
is
567 Buffer
: Bounded_String
;
570 Append
(Buffer
, "%s");
571 return Name_Find
(Buffer
);
572 end Name_To_Unit_Name
;
579 (Old
: Unit_Name_Type
;
580 Newp
: Unit_Name_Type
) return Unit_Name_Type
585 Get_Name_String
(Old
);
588 Child
: constant String := Name_Buffer
(1 .. Name_Len
);
591 Get_Name_String
(Newp
);
592 Name_Len
:= Name_Len
- 2;
595 while Child
(P
) /= '.' loop
599 while P
<= Child
'Last loop
600 Name_Len
:= Name_Len
+ 1;
601 Name_Buffer
(Name_Len
) := Child
(P
);
613 function Uname_Ge
(Left
, Right
: Unit_Name_Type
) return Boolean is
615 return Left
= Right
or else Uname_Gt
(Left
, Right
);
622 function Uname_Gt
(Left
, Right
: Unit_Name_Type
) return Boolean is
624 return Left
/= Right
and then not Uname_Lt
(Left
, Right
);
631 function Uname_Le
(Left
, Right
: Unit_Name_Type
) return Boolean is
633 return Left
= Right
or else Uname_Lt
(Left
, Right
);
640 function Uname_Lt
(Left
, Right
: Unit_Name_Type
) return Boolean is
641 Left_Name
: String (1 .. Hostparm
.Max_Name_Length
);
642 Left_Length
: Natural;
643 Right_Name
: String renames Name_Buffer
;
644 Right_Length
: Natural renames Name_Len
;
648 pragma Warnings
(Off
, Right_Length
);
649 -- Suppress warnings on Right_Length, used in pragma Assert
655 Get_Name_String
(Left
);
656 Left_Name
(1 .. Name_Len
+ 1) := Name_Buffer
(1 .. Name_Len
+ 1);
657 Left_Length
:= Name_Len
;
658 Get_Name_String
(Right
);
662 exit when Left_Name
(J
) = '%';
664 if Right_Name
(J
) = '%' then
665 return False; -- left name is longer
668 pragma Assert
(J
<= Left_Length
and then J
<= Right_Length
);
670 if Left_Name
(J
) /= Right_Name
(J
) then
671 return Left_Name
(J
) < Right_Name
(J
); -- parent names different
677 -- Come here pointing to % in left name
679 if Right_Name
(J
) /= '%' then
680 return True; -- right name is longer
683 -- Here the parent names are the same and specs sort low. If neither is
684 -- a spec, then we are comparing the same name and we want a result of
685 -- False in any case.
687 return Left_Name
(J
+ 1) = 's';
690 ---------------------
691 -- Write_Unit_Name --
692 ---------------------
694 procedure Write_Unit_Name
(N
: Unit_Name_Type
) is
695 Buf
: Bounded_String
;
697 Get_Unit_Name_String
(Buf
, N
);
698 Write_Str
(Buf
.Chars
(1 .. Buf
.Length
));
701 -------------------------------
702 -- Write_Unit_Name_For_Debug --
703 -------------------------------
705 procedure Write_Unit_Name_For_Debug
(N
: Unit_Name_Type
) is
707 if Is_Valid_Name
(N
) then
710 Write_Name_For_Debug
(N
);
712 end Write_Unit_Name_For_Debug
;