OpenCores
URL https://opencores.org/ocsvn/openrisc_me/openrisc_me/trunk

Subversion Repositories openrisc_me

[/] [openrisc/] [trunk/] [gnu-src/] [gcc-4.5.1/] [gcc/] [ada/] [butil.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
--                                B U T I L                                 --
6
--                                                                          --
7
--                                 B o d y                                  --
8
--                                                                          --
9
--          Copyright (C) 1992-2007, 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
------------------------------------------------------------------------------
25
 
26
with Output;   use Output;
27
with Targparm; use Targparm;
28
 
29
package body Butil is
30
 
31
   ----------------------
32
   -- Is_Internal_Unit --
33
   ----------------------
34
 
35
   --  Note: the reason we do not use the Fname package for this function
36
   --  is that it would drag too much junk into the binder.
37
 
38
   function Is_Internal_Unit return Boolean is
39
   begin
40
      return Is_Predefined_Unit
41
        or else (Name_Len > 4
42
                   and then (Name_Buffer (1 .. 5) = "gnat%"
43
                               or else
44
                             Name_Buffer (1 .. 5) = "gnat."))
45
        or else
46
          (OpenVMS_On_Target
47
           and then Name_Len > 3
48
           and then (Name_Buffer (1 .. 4) = "dec%"
49
                      or else
50
                     Name_Buffer (1 .. 4) = "dec."));
51
 
52
   end Is_Internal_Unit;
53
 
54
   ------------------------
55
   -- Is_Predefined_Unit --
56
   ------------------------
57
 
58
   --  Note: the reason we do not use the Fname package for this function
59
   --  is that it would drag too much junk into the binder.
60
 
61
   function Is_Predefined_Unit return Boolean is
62
   begin
63
      return    (Name_Len >  3
64
                  and then Name_Buffer (1 ..  4) = "ada.")
65
 
66
        or else (Name_Len >  6
67
                  and then Name_Buffer (1 ..  7) = "system.")
68
 
69
        or else (Name_Len > 10
70
                   and then Name_Buffer (1 .. 11) = "interfaces.")
71
 
72
        or else (Name_Len >  3
73
                   and then Name_Buffer (1 ..  4) = "ada%")
74
 
75
        or else (Name_Len >  8
76
                   and then Name_Buffer (1 ..  9) = "calendar%")
77
 
78
        or else (Name_Len >  9
79
                   and then Name_Buffer (1 .. 10) = "direct_io%")
80
 
81
        or else (Name_Len > 10
82
                   and then Name_Buffer (1 .. 11) = "interfaces%")
83
 
84
        or else (Name_Len > 13
85
                   and then Name_Buffer (1 .. 14) = "io_exceptions%")
86
 
87
        or else (Name_Len > 12
88
                   and then Name_Buffer (1 .. 13) = "machine_code%")
89
 
90
        or else (Name_Len > 13
91
                   and then Name_Buffer (1 .. 14) = "sequential_io%")
92
 
93
        or else (Name_Len >  6
94
                   and then Name_Buffer (1 ..  7) = "system%")
95
 
96
        or else (Name_Len >  7
97
                   and then Name_Buffer (1 ..  8) = "text_io%")
98
 
99
        or else (Name_Len > 20
100
                   and then Name_Buffer (1 .. 21) = "unchecked_conversion%")
101
 
102
        or else (Name_Len > 22
103
                   and then Name_Buffer (1 .. 23) = "unchecked_deallocation%")
104
 
105
        or else (Name_Len > 4
106
                   and then Name_Buffer (1 .. 5) = "gnat%")
107
 
108
        or else (Name_Len > 4
109
                   and then Name_Buffer (1 .. 5) = "gnat.");
110
   end Is_Predefined_Unit;
111
 
112
   ----------------
113
   -- Uname_Less --
114
   ----------------
115
 
116
   function Uname_Less (U1, U2 : Unit_Name_Type) return Boolean is
117
   begin
118
      Get_Name_String (U1);
119
 
120
      declare
121
         U1_Name : constant String (1 .. Name_Len) :=
122
                                           Name_Buffer (1 .. Name_Len);
123
         Min_Length : Natural;
124
 
125
      begin
126
         Get_Name_String (U2);
127
 
128
         if Name_Len < U1_Name'Last then
129
            Min_Length := Name_Len;
130
         else
131
            Min_Length := U1_Name'Last;
132
         end if;
133
 
134
         for I in 1 .. Min_Length loop
135
            if U1_Name (I) > Name_Buffer (I) then
136
               return False;
137
            elsif U1_Name (I) < Name_Buffer (I) then
138
               return True;
139
            end if;
140
         end loop;
141
 
142
         return U1_Name'Last < Name_Len;
143
      end;
144
   end Uname_Less;
145
 
146
   ---------------------
147
   -- Write_Unit_Name --
148
   ---------------------
149
 
150
   procedure Write_Unit_Name (U : Unit_Name_Type) is
151
   begin
152
      Get_Name_String (U);
153
      Write_Str (Name_Buffer (1 .. Name_Len - 2));
154
 
155
      if Name_Buffer (Name_Len) = 's' then
156
         Write_Str (" (spec)");
157
      else
158
         Write_Str (" (body)");
159
      end if;
160
 
161
      Name_Len := Name_Len + 5;
162
   end Write_Unit_Name;
163
 
164
end Butil;

powered by: WebSVN 2.1.0

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