OpenCores
URL https://opencores.org/ocsvn/openrisc_2011-10-31/openrisc_2011-10-31/trunk

Subversion Repositories openrisc_2011-10-31

[/] [openrisc/] [trunk/] [gnu-src/] [gcc-4.5.1/] [gcc/] [ada/] [uname.adb] - Blame information for rev 281

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 281 jeremybenn
------------------------------------------------------------------------------
2
--                                                                          --
3
--                         GNAT COMPILER COMPONENTS                         --
4
--                                                                          --
5
--                                U N A M E                                 --
6
--                                                                          --
7
--                                 B o d y                                  --
8
--                                                                          --
9
--          Copyright (C) 1992-2009  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
-- 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.               --
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
   -------------------------------------------
353
   -- Start of Processing for Get_Unit_Name --
354
   -------------------------------------------
355
 
356
   begin
357
      Node := N;
358
 
359
      --  If we have Defining_Identifier, find the associated unit node
360
 
361
      if Nkind (Node) = N_Defining_Identifier then
362
         Node := Declaration_Node (Node);
363
 
364
      --  If an expanded name, it is an already analyzed child unit, find
365
      --  unit node.
366
 
367
      elsif Nkind (Node) = N_Expanded_Name then
368
         Node := Declaration_Node (Entity (Node));
369
      end if;
370
 
371
      if Nkind (Node) = N_Package_Specification
372
        or else Nkind (Node) in N_Subprogram_Specification
373
      then
374
         Node := Parent (Node);
375
      end if;
376
 
377
      --  Node points to the unit, so get its name and add proper suffix
378
 
379
      Add_Node_Name (Node);
380
      Add_Char ('%');
381
 
382
      case Nkind (Node) is
383
         when N_Generic_Declaration             |
384
              N_Subprogram_Declaration          |
385
              N_Package_Declaration             |
386
              N_With_Clause                     |
387
              N_Pragma                          |
388
              N_Generic_Instantiation           |
389
              N_Package_Renaming_Declaration    |
390
              N_Subprogram_Renaming_Declaration |
391
              N_Generic_Renaming_Declaration    |
392
              N_Single_Task_Declaration         |
393
              N_Single_Protected_Declaration    |
394
              N_Task_Type_Declaration           |
395
              N_Protected_Type_Declaration      =>
396
 
397
            Add_Char ('s');
398
 
399
         when N_Subprogram_Body                 |
400
              N_Package_Body                    |
401
              N_Subunit                         |
402
              N_Body_Stub                       |
403
              N_Task_Body                       |
404
              N_Protected_Body                  |
405
              N_Identifier                      |
406
              N_Selected_Component              =>
407
 
408
            Add_Char ('b');
409
 
410
         when others =>
411
            raise Program_Error;
412
      end case;
413
 
414
      Name_Buffer (1 .. Unit_Name_Length) :=
415
        Unit_Name_Buffer (1 .. Unit_Name_Length);
416
      Name_Len := Unit_Name_Length;
417
      return Name_Find;
418
 
419
   end Get_Unit_Name;
420
 
421
   --------------------------
422
   -- Get_Unit_Name_String --
423
   --------------------------
424
 
425
   procedure Get_Unit_Name_String
426
     (N      : Unit_Name_Type;
427
      Suffix : Boolean := True)
428
   is
429
      Unit_Is_Body : Boolean;
430
 
431
   begin
432
      Get_Decoded_Name_String (N);
433
      Unit_Is_Body := Name_Buffer (Name_Len) = 'b';
434
      Set_Casing (Identifier_Casing (Source_Index (Main_Unit)), Mixed_Case);
435
 
436
      --  A special fudge, normally we don't have operator symbols present,
437
      --  since it is always an error to do so. However, if we do, at this
438
      --  stage it has the form:
439
 
440
      --    "and"
441
 
442
      --  and the %s or %b has already been eliminated so put 2 chars back
443
 
444
      if Name_Buffer (1) = '"' then
445
         Name_Len := Name_Len + 2;
446
      end if;
447
 
448
      --  Now adjust the %s or %b to (spec) or (body)
449
 
450
      if Suffix then
451
         if Unit_Is_Body then
452
            Name_Buffer (Name_Len - 1 .. Name_Len + 5) := " (body)";
453
         else
454
            Name_Buffer (Name_Len - 1 .. Name_Len + 5) := " (spec)";
455
         end if;
456
      end if;
457
 
458
      for J in 1 .. Name_Len loop
459
         if Name_Buffer (J) = '-' then
460
            Name_Buffer (J) := '.';
461
         end if;
462
      end loop;
463
 
464
      --  Adjust Name_Len
465
 
466
      if Suffix then
467
         Name_Len := Name_Len + (7 - 2);
468
      else
469
         Name_Len := Name_Len - 2;
470
      end if;
471
   end Get_Unit_Name_String;
472
 
473
   ------------------
474
   -- Is_Body_Name --
475
   ------------------
476
 
477
   function Is_Body_Name (N : Unit_Name_Type) return Boolean is
478
   begin
479
      Get_Name_String (N);
480
      return Name_Len > 2
481
        and then Name_Buffer (Name_Len - 1) = '%'
482
        and then Name_Buffer (Name_Len) = 'b';
483
   end Is_Body_Name;
484
 
485
   -------------------
486
   -- Is_Child_Name --
487
   -------------------
488
 
489
   function Is_Child_Name (N : Unit_Name_Type) return Boolean is
490
      J : Natural;
491
 
492
   begin
493
      Get_Name_String (N);
494
      J := Name_Len;
495
 
496
      while Name_Buffer (J) /= '.' loop
497
         if J = 1 then
498
            return False; -- not a child or subunit name
499
         else
500
            J := J - 1;
501
         end if;
502
      end loop;
503
 
504
      return True;
505
   end Is_Child_Name;
506
 
507
   ------------------
508
   -- Is_Spec_Name --
509
   ------------------
510
 
511
   function Is_Spec_Name (N : Unit_Name_Type) return Boolean is
512
   begin
513
      Get_Name_String (N);
514
      return Name_Len > 2
515
        and then Name_Buffer (Name_Len - 1) = '%'
516
        and then Name_Buffer (Name_Len) = 's';
517
   end Is_Spec_Name;
518
 
519
   -----------------------
520
   -- Name_To_Unit_Name --
521
   -----------------------
522
 
523
   function Name_To_Unit_Name (N : Name_Id) return Unit_Name_Type is
524
   begin
525
      Get_Name_String (N);
526
      Name_Buffer (Name_Len + 1) := '%';
527
      Name_Buffer (Name_Len + 2) := 's';
528
      Name_Len := Name_Len + 2;
529
      return Name_Find;
530
   end Name_To_Unit_Name;
531
 
532
   ---------------
533
   -- New_Child --
534
   ---------------
535
 
536
   function New_Child
537
     (Old  : Unit_Name_Type;
538
      Newp : Unit_Name_Type) return Unit_Name_Type
539
   is
540
      P : Natural;
541
 
542
   begin
543
      Get_Name_String (Old);
544
 
545
      declare
546
         Child : constant String := Name_Buffer (1 .. Name_Len);
547
 
548
      begin
549
         Get_Name_String (Newp);
550
         Name_Len := Name_Len - 2;
551
 
552
         P := Child'Last;
553
         while Child (P) /= '.' loop
554
            P := P - 1;
555
         end loop;
556
 
557
         while P <= Child'Last loop
558
            Name_Len := Name_Len + 1;
559
            Name_Buffer (Name_Len) := Child (P);
560
            P := P + 1;
561
         end loop;
562
 
563
         return Name_Find;
564
      end;
565
   end New_Child;
566
 
567
   --------------
568
   -- Uname_Ge --
569
   --------------
570
 
571
   function Uname_Ge (Left, Right : Unit_Name_Type) return Boolean is
572
   begin
573
      return Left = Right or else Uname_Gt (Left, Right);
574
   end Uname_Ge;
575
 
576
   --------------
577
   -- Uname_Gt --
578
   --------------
579
 
580
   function Uname_Gt (Left, Right : Unit_Name_Type) return Boolean is
581
   begin
582
      return Left /= Right and then not Uname_Lt (Left, Right);
583
   end Uname_Gt;
584
 
585
   --------------
586
   -- Uname_Le --
587
   --------------
588
 
589
   function Uname_Le (Left, Right : Unit_Name_Type) return Boolean is
590
   begin
591
      return Left = Right or else Uname_Lt (Left, Right);
592
   end Uname_Le;
593
 
594
   --------------
595
   -- Uname_Lt --
596
   --------------
597
 
598
   function Uname_Lt (Left, Right : Unit_Name_Type) return Boolean is
599
      Left_Name    : String (1 .. Hostparm.Max_Name_Length);
600
      Left_Length  : Natural;
601
      Right_Name   : String renames Name_Buffer;
602
      Right_Length : Natural renames Name_Len;
603
      J            : Natural;
604
 
605
   begin
606
      pragma Warnings (Off, Right_Length);
607
      --  Suppress warnings on Right_Length, used in pragma Assert
608
 
609
      if Left = Right then
610
         return False;
611
      end if;
612
 
613
      Get_Name_String (Left);
614
      Left_Name  (1 .. Name_Len + 1) := Name_Buffer (1 .. Name_Len + 1);
615
      Left_Length := Name_Len;
616
      Get_Name_String (Right);
617
      J := 1;
618
 
619
      loop
620
         exit when Left_Name (J) = '%';
621
 
622
         if Right_Name (J) = '%' then
623
            return False; -- left name is longer
624
         end if;
625
 
626
         pragma Assert (J <= Left_Length and then J <= Right_Length);
627
 
628
         if Left_Name (J) /= Right_Name (J) then
629
            return Left_Name (J) < Right_Name (J); -- parent names different
630
         end if;
631
 
632
         J := J + 1;
633
      end loop;
634
 
635
      --  Come here pointing to % in left name
636
 
637
      if Right_Name (J) /= '%' then
638
         return True; -- right name is longer
639
      end if;
640
 
641
      --  Here the parent names are the same and specs sort low. If neither is
642
      --  a spec, then we are comparing the same name and we want a result of
643
      --  False in any case.
644
 
645
      return Left_Name (J + 1) = 's';
646
   end Uname_Lt;
647
 
648
   ---------------------
649
   -- Write_Unit_Name --
650
   ---------------------
651
 
652
   procedure Write_Unit_Name (N : Unit_Name_Type) is
653
   begin
654
      Get_Unit_Name_String (N);
655
      Write_Str (Name_Buffer (1 .. Name_Len));
656
   end Write_Unit_Name;
657
 
658
end Uname;

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.