1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2010, 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. --
18 -- As a special exception under Section 7 of GPL version 3, you are granted --
19 -- additional permissions described in the GCC Runtime Library Exception, --
20 -- version 3.1, as published by the Free Software Foundation. --
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/>. --
27 -- GNAT was originally developed by the GNAT team at New York University. --
28 -- Extensive contributions were provided by Ada Core Technologies Inc. --
30 ------------------------------------------------------------------------------
32 with Atree; use Atree;
33 with Casing; use Casing;
34 with Einfo; use Einfo;
37 with Nlists; use Nlists;
38 with Output; use Output;
39 with Sinfo; use Sinfo;
40 with Sinput; use Sinput;
48 function Get_Body_Name (N : Unit_Name_Type) return Unit_Name_Type is
52 pragma Assert (Name_Len > 2
53 and then Name_Buffer (Name_Len - 1) = '%'
54 and then Name_Buffer (Name_Len) = 's');
56 Name_Buffer (Name_Len) := 'b';
60 -----------------------------------
61 -- Get_External_Unit_Name_String --
62 -----------------------------------
64 procedure Get_External_Unit_Name_String (N : Unit_Name_Type) is
69 -- Get unit name and eliminate trailing %s or %b
72 Name_Len := Name_Len - 2;
74 -- Find number of components
77 for J in 1 .. Name_Len loop
78 if Name_Buffer (J) = '.' then
83 -- If simple name, nothing to do
89 -- If name has multiple components, replace dots by double underscore
91 Newlen := Name_Len + Pcount;
93 for J in reverse 1 .. Name_Len loop
94 if Name_Buffer (J) = '.' then
95 Name_Buffer (Newlen) := '_';
96 Name_Buffer (Newlen - 1) := '_';
100 Name_Buffer (Newlen) := Name_Buffer (J);
101 Newlen := Newlen - 1;
105 Name_Len := Name_Len + Pcount;
106 end Get_External_Unit_Name_String;
108 --------------------------
109 -- Get_Parent_Body_Name --
110 --------------------------
112 function Get_Parent_Body_Name (N : Unit_Name_Type) return Unit_Name_Type is
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;
121 Name_Buffer (Name_Len) := '%';
122 Name_Len := Name_Len + 1;
123 Name_Buffer (Name_Len) := 'b';
126 end Get_Parent_Body_Name;
128 --------------------------
129 -- Get_Parent_Spec_Name --
130 --------------------------
132 function Get_Parent_Spec_Name (N : Unit_Name_Type) return Unit_Name_Type is
136 while Name_Buffer (Name_Len) /= '.' loop
140 Name_Len := Name_Len - 1;
144 Name_Buffer (Name_Len) := '%';
145 Name_Len := Name_Len + 1;
146 Name_Buffer (Name_Len) := 's';
149 end Get_Parent_Spec_Name;
155 function Get_Spec_Name (N : Unit_Name_Type) return Unit_Name_Type is
159 pragma Assert (Name_Len > 2
160 and then Name_Buffer (Name_Len - 1) = '%'
161 and then Name_Buffer (Name_Len) = 'b');
163 Name_Buffer (Name_Len) := 's';
171 function Get_Unit_Name (N : Node_Id) return Unit_Name_Type is
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
178 Unit_Name_Length : Natural := 0;
179 -- Length of name stored in Unit_Name_Buffer
184 procedure Add_Char (C : Character);
185 -- Add a single character to stored unit name
187 procedure Add_Name (Name : Name_Id);
188 -- Add the characters of a names table entry to stored unit name
190 procedure Add_Node_Name (Node : Node_Id);
191 -- Recursive procedure adds characters associated with Node
193 function Get_Parent (Node : Node_Id) return Node_Id;
194 -- Get parent compilation unit of a stub
200 procedure Add_Char (C : Character) is
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;
211 procedure Add_Name (Name : Name_Id) is
213 Get_Name_String (Name);
215 for J in 1 .. Name_Len loop
216 Add_Char (Name_Buffer (J));
224 procedure Add_Node_Name (Node : Node_Id) is
225 Kind : constant Node_Kind := Nkind (Node);
228 -- Just ignore an error node (someone else will give a message)
233 -- Otherwise see what kind of node we have
239 N_Defining_Identifier |
240 N_Defining_Operator_Symbol =>
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!
246 Add_Name (Chars (Node));
248 when N_Defining_Program_Unit_Name =>
249 Add_Node_Name (Name (Node));
251 Add_Node_Name (Defining_Identifier (Node));
253 when N_Selected_Component |
255 Add_Node_Name (Prefix (Node));
257 Add_Node_Name (Selector_Name (Node));
259 when N_Subprogram_Specification |
260 N_Package_Specification =>
261 Add_Node_Name (Defining_Unit_Name (Node));
263 when N_Subprogram_Body |
264 N_Subprogram_Declaration |
265 N_Package_Declaration |
266 N_Generic_Declaration =>
267 Add_Node_Name (Specification (Node));
269 when N_Generic_Instantiation =>
270 Add_Node_Name (Defining_Unit_Name (Node));
272 when N_Package_Body =>
273 Add_Node_Name (Defining_Unit_Name (Node));
277 Add_Node_Name (Defining_Identifier (Node));
279 when N_Package_Renaming_Declaration =>
280 Add_Node_Name (Defining_Unit_Name (Node));
282 when N_Subprogram_Renaming_Declaration =>
283 Add_Node_Name (Specification (Node));
285 when N_Generic_Renaming_Declaration =>
286 Add_Node_Name (Defining_Unit_Name (Node));
288 when N_Subprogram_Body_Stub =>
289 Add_Node_Name (Get_Parent (Node));
291 Add_Node_Name (Specification (Node));
293 when N_Compilation_Unit =>
294 Add_Node_Name (Unit (Node));
296 when N_Package_Body_Stub =>
297 Add_Node_Name (Get_Parent (Node));
299 Add_Node_Name (Defining_Identifier (Node));
301 when N_Task_Body_Stub |
302 N_Protected_Body_Stub =>
303 Add_Node_Name (Get_Parent (Node));
305 Add_Node_Name (Defining_Identifier (Node));
308 Add_Node_Name (Name (Node));
310 Add_Node_Name (Proper_Body (Node));
312 when N_With_Clause =>
313 Add_Node_Name (Name (Node));
316 Add_Node_Name (Expression (First
317 (Pragma_Argument_Associations (Node))));
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.
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));
341 function Get_Parent (Node : Node_Id) return Node_Id is
345 while Nkind (N) /= N_Compilation_Unit loop
352 -- Start of processing for Get_Unit_Name
357 -- If we have Defining_Identifier, find the associated unit node
359 if Nkind (Node) = N_Defining_Identifier then
360 Node := Declaration_Node (Node);
362 -- If an expanded name, it is an already analyzed child unit, find
365 elsif Nkind (Node) = N_Expanded_Name then
366 Node := Declaration_Node (Entity (Node));
369 if Nkind (Node) = N_Package_Specification
370 or else Nkind (Node) in N_Subprogram_Specification
372 Node := Parent (Node);
375 -- Node points to the unit, so get its name and add proper suffix
377 Add_Node_Name (Node);
381 when N_Generic_Declaration |
382 N_Subprogram_Declaration |
383 N_Package_Declaration |
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 =>
397 when N_Subprogram_Body |
404 N_Selected_Component =>
412 Name_Buffer (1 .. Unit_Name_Length) :=
413 Unit_Name_Buffer (1 .. Unit_Name_Length);
414 Name_Len := Unit_Name_Length;
419 --------------------------
420 -- Get_Unit_Name_String --
421 --------------------------
423 procedure Get_Unit_Name_String
425 Suffix : Boolean := True)
427 Unit_Is_Body : Boolean;
430 Get_Decoded_Name_String (N);
431 Unit_Is_Body := Name_Buffer (Name_Len) = 'b';
432 Set_Casing (Identifier_Casing (Source_Index (Main_Unit)), Mixed_Case);
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:
440 -- and the %s or %b has already been eliminated so put 2 chars back
442 if Name_Buffer (1) = '"' then
443 Name_Len := Name_Len + 2;
446 -- Now adjust the %s or %b to (spec) or (body)
450 Name_Buffer (Name_Len - 1 .. Name_Len + 5) := " (body)";
452 Name_Buffer (Name_Len - 1 .. Name_Len + 5) := " (spec)";
456 for J in 1 .. Name_Len loop
457 if Name_Buffer (J) = '-' then
458 Name_Buffer (J) := '.';
465 Name_Len := Name_Len + (7 - 2);
467 Name_Len := Name_Len - 2;
469 end Get_Unit_Name_String;
475 function Is_Body_Name (N : Unit_Name_Type) return Boolean is
479 and then Name_Buffer (Name_Len - 1) = '%'
480 and then Name_Buffer (Name_Len) = 'b';
487 function Is_Child_Name (N : Unit_Name_Type) return Boolean is
494 while Name_Buffer (J) /= '.' loop
496 return False; -- not a child or subunit name
509 function Is_Spec_Name (N : Unit_Name_Type) return Boolean is
513 and then Name_Buffer (Name_Len - 1) = '%'
514 and then Name_Buffer (Name_Len) = 's';
517 -----------------------
518 -- Name_To_Unit_Name --
519 -----------------------
521 function Name_To_Unit_Name (N : Name_Id) return Unit_Name_Type is
524 Name_Buffer (Name_Len + 1) := '%';
525 Name_Buffer (Name_Len + 2) := 's';
526 Name_Len := Name_Len + 2;
528 end Name_To_Unit_Name;
535 (Old : Unit_Name_Type;
536 Newp : Unit_Name_Type) return Unit_Name_Type
541 Get_Name_String (Old);
544 Child : constant String := Name_Buffer (1 .. Name_Len);
547 Get_Name_String (Newp);
548 Name_Len := Name_Len - 2;
551 while Child (P) /= '.' loop
555 while P <= Child'Last loop
556 Name_Len := Name_Len + 1;
557 Name_Buffer (Name_Len) := Child (P);
569 function Uname_Ge (Left, Right : Unit_Name_Type) return Boolean is
571 return Left = Right or else Uname_Gt (Left, Right);
578 function Uname_Gt (Left, Right : Unit_Name_Type) return Boolean is
580 return Left /= Right and then not Uname_Lt (Left, Right);
587 function Uname_Le (Left, Right : Unit_Name_Type) return Boolean is
589 return Left = Right or else Uname_Lt (Left, Right);
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;
604 pragma Warnings (Off, Right_Length);
605 -- Suppress warnings on Right_Length, used in pragma Assert
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);
618 exit when Left_Name (J) = '%';
620 if Right_Name (J) = '%' then
621 return False; -- left name is longer
624 pragma Assert (J <= Left_Length and then J <= Right_Length);
626 if Left_Name (J) /= Right_Name (J) then
627 return Left_Name (J) < Right_Name (J); -- parent names different
633 -- Come here pointing to % in left name
635 if Right_Name (J) /= '%' then
636 return True; -- right name is longer
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.
643 return Left_Name (J + 1) = 's';
646 ---------------------
647 -- Write_Unit_Name --
648 ---------------------
650 procedure Write_Unit_Name (N : Unit_Name_Type) is
652 Get_Unit_Name_String (N);
653 Write_Str (Name_Buffer (1 .. Name_Len));