hppa: Revise REG+D address support to allow long displacements before reload
[official-gcc.git] / gcc / ada / uname.adb
blob96aa16a6c83dbec8c2c338da772401c1eeecd4f7
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- U N A M E --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 1992-2023, 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 ------------------------------------------------------------------------------
26 with Atree; use Atree;
27 with Casing; use Casing;
28 with Einfo; use Einfo;
29 with Einfo.Utils; use Einfo.Utils;
30 with Hostparm;
31 with Lib; use Lib;
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;
39 package body Uname is
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.
45 -------------------
46 -- Get_Body_Name --
47 -------------------
49 function Get_Body_Name (N : Unit_Name_Type) return Unit_Name_Type is
50 Buffer : Bounded_String;
51 begin
52 Append (Buffer, N);
54 pragma Assert
55 (Buffer.Length > 2
56 and then Buffer.Chars (Buffer.Length - 1) = '%'
57 and then Buffer.Chars (Buffer.Length) = 's');
59 Buffer.Chars (Buffer.Length) := 'b';
61 return Name_Find (Buffer);
62 end Get_Body_Name;
64 -----------------------------------
65 -- Get_External_Unit_Name_String --
66 -----------------------------------
68 procedure Get_External_Unit_Name_String (N : Unit_Name_Type) is
69 Pcount : Natural;
70 Newlen : Natural;
72 begin
73 -- Get unit name and eliminate trailing %s or %b
75 Get_Name_String (N);
76 Name_Len := Name_Len - 2;
78 -- Find number of components
80 Pcount := 0;
81 for J in 1 .. Name_Len loop
82 if Name_Buffer (J) = '.' then
83 Pcount := Pcount + 1;
84 end if;
85 end loop;
87 -- If simple name, nothing to do
89 if Pcount = 0 then
90 return;
91 end if;
93 -- If name has multiple components, replace dots by double underscore
95 Newlen := Name_Len + Pcount;
97 for J in reverse 1 .. Name_Len loop
98 if Name_Buffer (J) = '.' then
99 Name_Buffer (Newlen) := '_';
100 Name_Buffer (Newlen - 1) := '_';
101 Newlen := Newlen - 2;
103 else
104 Name_Buffer (Newlen) := Name_Buffer (J);
105 Newlen := Newlen - 1;
106 end if;
107 end loop;
109 Name_Len := Name_Len + Pcount;
110 end Get_External_Unit_Name_String;
112 --------------------------
113 -- Get_Parent_Body_Name --
114 --------------------------
116 function Get_Parent_Body_Name (N : Unit_Name_Type) return Unit_Name_Type is
117 Buffer : Bounded_String;
118 begin
119 Append (Buffer, N);
121 while Buffer.Chars (Buffer.Length) /= '.' loop
122 pragma Assert (Buffer.Length > 1); -- not a child or subunit name
123 Buffer.Length := Buffer.Length - 1;
124 end loop;
126 Buffer.Chars (Buffer.Length) := '%';
127 Append (Buffer, 'b');
129 return Name_Find (Buffer);
130 end Get_Parent_Body_Name;
132 --------------------------
133 -- Get_Parent_Spec_Name --
134 --------------------------
136 function Get_Parent_Spec_Name (N : Unit_Name_Type) return Unit_Name_Type is
137 Buffer : Bounded_String;
138 begin
139 Append (Buffer, N);
141 while Buffer.Chars (Buffer.Length) /= '.' loop
142 if Buffer.Length = 1 then
143 return No_Unit_Name;
144 else
145 Buffer.Length := Buffer.Length - 1;
146 end if;
147 end loop;
149 Buffer.Chars (Buffer.Length) := '%';
150 Append (Buffer, 's');
152 return Name_Find (Buffer);
153 end Get_Parent_Spec_Name;
155 -------------------
156 -- Get_Spec_Name --
157 -------------------
159 function Get_Spec_Name (N : Unit_Name_Type) return Unit_Name_Type is
160 Buffer : Bounded_String;
161 begin
162 Append (Buffer, N);
164 pragma Assert
165 (Buffer.Length > 2
166 and then Buffer.Chars (Buffer.Length - 1) = '%'
167 and then Buffer.Chars (Buffer.Length) = 'b');
169 Buffer.Chars (Buffer.Length) := 's';
171 return Name_Find (Buffer);
172 end Get_Spec_Name;
174 -------------------
175 -- Get_Unit_Name --
176 -------------------
178 function Get_Unit_Name (N : Node_Id) return Unit_Name_Type is
180 Unit_Name_Buffer : Bounded_String;
181 -- Buffer used to build name of unit
183 Node : Node_Id;
184 -- Program unit node
186 procedure Add_Char (C : Character);
187 -- Add a single character to stored unit name
189 procedure Add_Name (Name : Name_Id);
190 -- Add the characters of a names table entry to stored unit name
192 procedure Add_Node_Name (Node : Node_Id);
193 -- Recursive procedure adds characters associated with Node
195 function Get_Parent (Node : Node_Id) return Node_Id;
196 -- Get parent compilation unit of a stub
198 --------------
199 -- Add_Char --
200 --------------
202 procedure Add_Char (C : Character) is
203 begin
204 Append (Unit_Name_Buffer, C);
205 end Add_Char;
207 --------------
208 -- Add_Name --
209 --------------
211 procedure Add_Name (Name : Name_Id) is
212 begin
213 Append (Unit_Name_Buffer, Name);
214 end Add_Name;
216 -------------------
217 -- Add_Node_Name --
218 -------------------
220 procedure Add_Node_Name (Node : Node_Id) is
221 begin
222 -- Just ignore an error node (someone else will give a message)
224 if Node = Error then
225 return;
227 -- Otherwise see what kind of node we have
229 else
230 case Nkind (Node) is
231 when N_Defining_Identifier
232 | N_Defining_Operator_Symbol
233 | N_Identifier
235 -- Note: it is of course an error to have a defining
236 -- operator symbol at this point, but this is not where
237 -- the error is signalled, so we handle it nicely here.
239 Add_Name (Chars (Node));
241 when N_Defining_Program_Unit_Name =>
242 Add_Node_Name (Name (Node));
243 Add_Char ('.');
244 Add_Node_Name (Defining_Identifier (Node));
246 when N_Expanded_Name
247 | N_Selected_Component
249 Add_Node_Name (Prefix (Node));
250 Add_Char ('.');
251 Add_Node_Name (Selector_Name (Node));
253 when N_Package_Specification
254 | N_Subprogram_Specification
256 Add_Node_Name (Defining_Unit_Name (Node));
258 when N_Generic_Declaration
259 | N_Package_Declaration
260 | N_Subprogram_Body
261 | N_Subprogram_Declaration
263 Add_Node_Name (Specification (Node));
265 when N_Generic_Instantiation =>
266 Add_Node_Name (Defining_Unit_Name (Node));
268 when N_Package_Body =>
269 Add_Node_Name (Defining_Unit_Name (Node));
271 when N_Protected_Body
272 | N_Task_Body
274 Add_Node_Name (Defining_Identifier (Node));
276 when N_Package_Renaming_Declaration =>
277 Add_Node_Name (Defining_Unit_Name (Node));
279 when N_Subprogram_Renaming_Declaration =>
280 Add_Node_Name (Specification (Node));
282 when N_Generic_Renaming_Declaration =>
283 Add_Node_Name (Defining_Unit_Name (Node));
285 when N_Subprogram_Body_Stub =>
286 Add_Node_Name (Get_Parent (Node));
287 Add_Char ('.');
288 Add_Node_Name (Specification (Node));
290 when N_Compilation_Unit =>
291 Add_Node_Name (Unit (Node));
293 when N_Package_Body_Stub
294 | N_Protected_Body_Stub
295 | N_Task_Body_Stub
297 Add_Node_Name (Get_Parent (Node));
298 Add_Char ('.');
299 Add_Node_Name (Defining_Identifier (Node));
301 when N_Subunit =>
302 Add_Node_Name (Name (Node));
303 Add_Char ('.');
304 Add_Node_Name (Proper_Body (Node));
306 when N_With_Clause =>
307 Add_Node_Name (Name (Node));
309 when N_Pragma =>
310 Add_Node_Name (Expression (First
311 (Pragma_Argument_Associations (Node))));
313 -- Tasks and protected stuff appear only in an error context,
314 -- but the error has been posted elsewhere, so we deal nicely
315 -- with these error situations here, and produce a reasonable
316 -- unit name using the defining identifier.
318 when N_Protected_Type_Declaration
319 | N_Single_Protected_Declaration
320 | N_Single_Task_Declaration
321 | N_Task_Type_Declaration
323 Add_Node_Name (Defining_Identifier (Node));
325 when others =>
326 raise Program_Error;
327 end case;
328 end if;
329 end Add_Node_Name;
331 ----------------
332 -- Get_Parent --
333 ----------------
335 function Get_Parent (Node : Node_Id) return Node_Id is
336 N : Node_Id := Node;
338 begin
339 while Nkind (N) /= N_Compilation_Unit loop
340 N := Parent (N);
341 end loop;
343 return N;
344 end Get_Parent;
346 -- Start of processing for Get_Unit_Name
348 begin
349 Node := N;
351 -- If we have Defining_Identifier, find the associated unit node
353 if Nkind (Node) = N_Defining_Identifier then
354 Node := Declaration_Node (Node);
356 -- If an expanded name, it is an already analyzed child unit, find
357 -- unit node.
359 elsif Nkind (Node) = N_Expanded_Name then
360 Node := Declaration_Node (Entity (Node));
361 end if;
363 if Nkind (Node) in N_Package_Specification
364 | N_Subprogram_Specification
365 then
366 Node := Parent (Node);
367 end if;
369 -- Node points to the unit, so get its name and add proper suffix
371 Add_Node_Name (Node);
372 Add_Char ('%');
374 case Nkind (Node) is
375 when N_Generic_Declaration
376 | N_Generic_Instantiation
377 | N_Generic_Renaming_Declaration
378 | N_Package_Declaration
379 | N_Package_Renaming_Declaration
380 | N_Pragma
381 | N_Protected_Type_Declaration
382 | N_Single_Protected_Declaration
383 | N_Single_Task_Declaration
384 | N_Subprogram_Declaration
385 | N_Subprogram_Renaming_Declaration
386 | N_Task_Type_Declaration
387 | N_With_Clause
389 Add_Char ('s');
391 when N_Body_Stub
392 | N_Identifier
393 | N_Package_Body
394 | N_Protected_Body
395 | N_Selected_Component
396 | N_Subprogram_Body
397 | N_Subunit
398 | N_Task_Body
400 Add_Char ('b');
402 when others =>
403 raise Program_Error;
404 end case;
406 return Name_Find (Unit_Name_Buffer);
407 end Get_Unit_Name;
409 --------------------------
410 -- Get_Unit_Name_String --
411 --------------------------
413 procedure Get_Unit_Name_String
414 (Buf : in out Bounded_String;
415 N : Unit_Name_Type;
416 Suffix : Boolean := True)
418 begin
419 Buf.Length := 0;
420 Append_Decoded (Buf, N);
422 -- Buf always ends with "%s" or "%b", which we either remove, or replace
423 -- with " (spec)" or " (body)". Set_Casing of Buf after checking for
424 -- (lower case) 's'/'b', and before appending (lower case) "spec" or
425 -- "body".
427 pragma Assert (Buf.Length >= 3);
428 pragma Assert (Buf.Chars (1) /= '"');
429 pragma Assert (Buf.Chars (Buf.Length) in 's' | 'b');
431 declare
432 S : constant String :=
433 (if Buf.Chars (Buf.Length) = 's' then " (spec)" else " (body)");
434 begin
435 Buf.Length := Buf.Length - 1; -- remove 's' or 'b'
436 pragma Assert (Buf.Chars (Buf.Length) = '%');
437 Buf.Length := Buf.Length - 1; -- remove '%'
438 Set_Casing (Buf, Identifier_Casing (Source_Index (Main_Unit)));
440 if Suffix then
441 Append (Buf, S);
442 end if;
443 end;
445 for J in 1 .. Buf.Length loop
446 if Buf.Chars (J) = '-' then
447 Buf.Chars (J) := '.';
448 end if;
449 end loop;
450 end Get_Unit_Name_String;
452 ----------------
453 -- Has_Prefix --
454 ----------------
456 function Has_Prefix (X, Prefix : String) return Boolean is
457 begin
458 if X'Length >= Prefix'Length then
459 declare
460 Slice : String renames
461 X (X'First .. X'First + Prefix'Length - 1);
462 begin
463 return Slice = Prefix;
464 end;
465 end if;
466 return False;
467 end Has_Prefix;
469 ------------------
470 -- Is_Body_Name --
471 ------------------
473 function Is_Body_Name (N : Unit_Name_Type) return Boolean is
474 Buffer : Bounded_String;
475 begin
476 Append (Buffer, N);
477 return Buffer.Length > 2
478 and then Buffer.Chars (Buffer.Length - 1) = '%'
479 and then Buffer.Chars (Buffer.Length) = 'b';
480 end Is_Body_Name;
482 -------------------
483 -- Is_Child_Name --
484 -------------------
486 function Is_Child_Name (N : Unit_Name_Type) return Boolean is
487 Buffer : Bounded_String;
489 begin
490 Append (Buffer, N);
492 while Buffer.Chars (Buffer.Length) /= '.' loop
493 if Buffer.Length = 1 then
494 return False; -- not a child or subunit name
495 else
496 Buffer.Length := Buffer.Length - 1;
497 end if;
498 end loop;
500 return True;
501 end Is_Child_Name;
503 ---------------------------
504 -- Is_Internal_Unit_Name --
505 ---------------------------
507 function Is_Internal_Unit_Name
508 (Name : String;
509 Renamings_Included : Boolean := True) return Boolean
511 Gnat : constant String := "gnat";
513 begin
514 if Name = Gnat then
515 return True;
516 end if;
518 if Has_Prefix (Name, Prefix => Gnat & ".") then
519 return True;
520 end if;
522 return Is_Predefined_Unit_Name (Name, Renamings_Included);
523 end Is_Internal_Unit_Name;
525 -----------------------------
526 -- Is_Predefined_Unit_Name --
527 -----------------------------
529 function Is_Predefined_Unit_Name
530 (Name : String;
531 Renamings_Included : Boolean := True) return Boolean
533 Ada : constant String := "ada";
534 Interfaces : constant String := "interfaces";
535 System : constant String := "system";
537 begin
538 if Name = Ada
539 or else Name = Interfaces
540 or else Name = System
541 then
542 return True;
543 end if;
545 if Has_Prefix (Name, Prefix => Ada & ".")
546 or else Has_Prefix (Name, Prefix => Interfaces & ".")
547 or else Has_Prefix (Name, Prefix => System & ".")
548 then
549 return True;
550 end if;
552 if not Renamings_Included then
553 return False;
554 end if;
556 -- The following are the predefined renamings
558 return
559 Name = "calendar"
560 or else Name = "machine_code"
561 or else Name = "unchecked_conversion"
562 or else Name = "unchecked_deallocation"
563 or else Name = "direct_io"
564 or else Name = "io_exceptions"
565 or else Name = "sequential_io"
566 or else Name = "text_io";
567 end Is_Predefined_Unit_Name;
569 ------------------
570 -- Is_Spec_Name --
571 ------------------
573 function Is_Spec_Name (N : Unit_Name_Type) return Boolean is
574 Buffer : Bounded_String;
575 begin
576 Append (Buffer, N);
577 return Buffer.Length > 2
578 and then Buffer.Chars (Buffer.Length - 1) = '%'
579 and then Buffer.Chars (Buffer.Length) = 's';
580 end Is_Spec_Name;
582 -----------------------
583 -- Name_To_Unit_Name --
584 -----------------------
586 function Name_To_Unit_Name (N : Name_Id) return Unit_Name_Type is
587 Buffer : Bounded_String;
588 begin
589 Append (Buffer, N);
590 Append (Buffer, "%s");
591 return Name_Find (Buffer);
592 end Name_To_Unit_Name;
594 ---------------
595 -- New_Child --
596 ---------------
598 function New_Child
599 (Old : Unit_Name_Type;
600 Newp : Unit_Name_Type) return Unit_Name_Type
602 P : Natural;
604 begin
605 Get_Name_String (Old);
607 declare
608 Child : constant String := Name_Buffer (1 .. Name_Len);
610 begin
611 Get_Name_String (Newp);
612 Name_Len := Name_Len - 2;
614 P := Child'Last;
615 while Child (P) /= '.' loop
616 P := P - 1;
617 end loop;
619 while P <= Child'Last loop
620 Name_Len := Name_Len + 1;
621 Name_Buffer (Name_Len) := Child (P);
622 P := P + 1;
623 end loop;
625 return Name_Find;
626 end;
627 end New_Child;
629 --------------
630 -- Uname_Ge --
631 --------------
633 function Uname_Ge (Left, Right : Unit_Name_Type) return Boolean is
634 begin
635 return Left = Right or else Uname_Gt (Left, Right);
636 end Uname_Ge;
638 --------------
639 -- Uname_Gt --
640 --------------
642 function Uname_Gt (Left, Right : Unit_Name_Type) return Boolean is
643 begin
644 return Left /= Right and then not Uname_Lt (Left, Right);
645 end Uname_Gt;
647 --------------
648 -- Uname_Le --
649 --------------
651 function Uname_Le (Left, Right : Unit_Name_Type) return Boolean is
652 begin
653 return Left = Right or else Uname_Lt (Left, Right);
654 end Uname_Le;
656 --------------
657 -- Uname_Lt --
658 --------------
660 function Uname_Lt (Left, Right : Unit_Name_Type) return Boolean is
661 Left_Name : String (1 .. Hostparm.Max_Name_Length);
662 Left_Length : Natural;
663 Right_Name : String renames Name_Buffer;
664 Right_Length : Natural renames Name_Len;
665 J : Natural;
667 begin
668 pragma Warnings (Off, Right_Length);
669 -- Suppress warnings on Right_Length, used in pragma Assert
671 if Left = Right then
672 return False;
673 end if;
675 Get_Name_String (Left);
676 Left_Name (1 .. Name_Len + 1) := Name_Buffer (1 .. Name_Len + 1);
677 Left_Length := Name_Len;
678 Get_Name_String (Right);
679 J := 1;
681 loop
682 exit when Left_Name (J) = '%';
684 if Right_Name (J) = '%' then
685 return False; -- left name is longer
686 end if;
688 pragma Assert (J <= Left_Length and then J <= Right_Length);
690 if Left_Name (J) /= Right_Name (J) then
691 return Left_Name (J) < Right_Name (J); -- parent names different
692 end if;
694 J := J + 1;
695 end loop;
697 -- Come here pointing to % in left name
699 if Right_Name (J) /= '%' then
700 return True; -- right name is longer
701 end if;
703 -- Here the parent names are the same and specs sort low. If neither is
704 -- a spec, then we are comparing the same name and we want a result of
705 -- False in any case.
707 return Left_Name (J + 1) = 's';
708 end Uname_Lt;
710 ---------------------
711 -- Write_Unit_Name --
712 ---------------------
714 procedure Write_Unit_Name (N : Unit_Name_Type) is
715 Buf : Bounded_String;
716 begin
717 Get_Unit_Name_String (Buf, N);
718 Write_Str (Buf.Chars (1 .. Buf.Length));
719 end Write_Unit_Name;
721 -------------------------------
722 -- Write_Unit_Name_For_Debug --
723 -------------------------------
725 procedure Write_Unit_Name_For_Debug (N : Unit_Name_Type) is
726 begin
727 if Is_Valid_Name (N) then
728 Write_Unit_Name (N);
729 else
730 Write_Name_For_Debug (N);
731 end if;
732 end Write_Unit_Name_For_Debug;
734 end Uname;