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

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [ada/] [prj-ext.adb] - Blame information for rev 768

Go to most recent revision | Details | Compare with Previous | View Log

Line No. Rev Author Line
1 706 jeremybenn 
------------------------------------------------------------------------------
2 
--                                                                          --
3 
--                         GNAT COMPILER COMPONENTS                         --
4 
--                                                                          --
5 
--                              P R J . E X T                               --
6 
--                                                                          --
7 
--                                 B o d y                                  --
8 
--                                                                          --
9 
--          Copyright (C) 2000-2011, 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 Osint;    use Osint;
27 
 
28 
with Ada.Unchecked_Deallocation;
29 
 
30 
package body Prj.Ext is
31 
 
32 
   ----------------
33 
   -- Initialize --
34 
   ----------------
35 
 
36 
   procedure Initialize
37 
     (Self      : out External_References;
38 
      Copy_From : External_References := No_External_Refs)
39 
   is
40 
      N  : Name_To_Name_Ptr;
41 
      N2 : Name_To_Name_Ptr;
42 
   begin
43 
      if Self.Refs = null then
44 
         Self.Refs := new Name_To_Name_HTable.Instance;
45 
 
46 
         if Copy_From.Refs /= null then
47 
            N := Name_To_Name_HTable.Get_First (Copy_From.Refs.all);
48 
            while N /= null loop
49 
               N2 := new Name_To_Name'
50 
                           (Key    => N.Key,
51 
                            Value  => N.Value,
52 
                            Source => N.Source,
53 
                            Next   => null);
54 
               Name_To_Name_HTable.Set (Self.Refs.all, N2);
55 
               N := Name_To_Name_HTable.Get_Next (Copy_From.Refs.all);
56 
            end loop;
57 
         end if;
58 
      end if;
59 
   end Initialize;
60 
 
61 
   ---------
62 
   -- Add --
63 
   ---------
64 
 
65 
   procedure Add
66 
     (Self          : External_References;
67 
      External_Name : String;
68 
      Value         : String;
69 
      Source        : External_Source := External_Source'First)
70 
   is
71 
      Key : Name_Id;
72 
      N   : Name_To_Name_Ptr;
73 
 
74 
   begin
75 
      Name_Len := External_Name'Length;
76 
      Name_Buffer (1 .. Name_Len) := External_Name;
77 
      Canonical_Case_Env_Var_Name (Name_Buffer (1 .. Name_Len));
78 
      Key := Name_Find;
79 
 
80 
      --  Check whether the value is already defined, to properly respect the
81 
      --  overriding order.
82 
 
83 
      if Source /= External_Source'First then
84 
         N := Name_To_Name_HTable.Get (Self.Refs.all, Key);
85 
 
86 
         if N /= null then
87 
            if External_Source'Pos (N.Source) <
88 
               External_Source'Pos (Source)
89 
            then
90 
               if Current_Verbosity = High then
91 
                  Debug_Output
92 
                    ("Not overridding existing variable '" & External_Name
93 
                     & "', value was defined in " & N.Source'Img);
94 
               end if;
95 
               return;
96 
            end if;
97 
         end if;
98 
      end if;
99 
 
100 
      Name_Len := Value'Length;
101 
      Name_Buffer (1 .. Name_Len) := Value;
102 
      N := new Name_To_Name'
103 
                 (Key    => Key,
104 
                  Source => Source,
105 
                  Value  => Name_Find,
106 
                  Next   => null);
107 
 
108 
      if Current_Verbosity = High then
109 
         Debug_Output ("Add external (" & External_Name & ") is", N.Value);
110 
      end if;
111 
 
112 
      Name_To_Name_HTable.Set (Self.Refs.all, N);
113 
   end Add;
114 
 
115 
   -----------
116 
   -- Check --
117 
   -----------
118 
 
119 
   function Check
120 
     (Self        : External_References;
121 
      Declaration : String) return Boolean
122 
   is
123 
   begin
124 
      for Equal_Pos in Declaration'Range loop
125 
         if Declaration (Equal_Pos) = '=' then
126 
            exit when Equal_Pos = Declaration'First;
127 
            Add
128 
              (Self          => Self,
129 
               External_Name =>
130 
                 Declaration (Declaration'First .. Equal_Pos - 1),
131 
               Value         =>
132 
                 Declaration (Equal_Pos + 1 .. Declaration'Last),
133 
               Source        => From_Command_Line);
134 
            return True;
135 
         end if;
136 
      end loop;
137 
 
138 
      return False;
139 
   end Check;
140 
 
141 
   -----------
142 
   -- Reset --
143 
   -----------
144 
 
145 
   procedure Reset (Self : External_References) is
146 
   begin
147 
      if Self.Refs /= null then
148 
         Debug_Output ("Reset external references");
149 
         Name_To_Name_HTable.Reset (Self.Refs.all);
150 
      end if;
151 
   end Reset;
152 
 
153 
   --------------
154 
   -- Value_Of --
155 
   --------------
156 
 
157 
   function Value_Of
158 
     (Self          : External_References;
159 
      External_Name : Name_Id;
160 
      With_Default  : Name_Id := No_Name)
161 
      return          Name_Id
162 
   is
163 
      Value : Name_To_Name_Ptr;
164 
      Val   : Name_Id;
165 
      Name  : String := Get_Name_String (External_Name);
166 
 
167 
   begin
168 
      Canonical_Case_Env_Var_Name (Name);
169 
 
170 
      if Self.Refs /= null then
171 
         Name_Len := Name'Length;
172 
         Name_Buffer (1 .. Name_Len) := Name;
173 
         Value := Name_To_Name_HTable.Get (Self.Refs.all, Name_Find);
174 
 
175 
         if Value /= null then
176 
            Debug_Output ("Value_Of (" & Name & ") is in cache", Value.Value);
177 
            return Value.Value;
178 
         end if;
179 
      end if;
180 
 
181 
      --  Find if it is an environment, if it is, put value in the hash table
182 
 
183 
      declare
184 
         Env_Value : String_Access := Getenv (Name);
185 
 
186 
      begin
187 
         if Env_Value /= null and then Env_Value'Length > 0 then
188 
            Name_Len := Env_Value'Length;
189 
            Name_Buffer (1 .. Name_Len) := Env_Value.all;
190 
            Val := Name_Find;
191 
 
192 
            if Current_Verbosity = High then
193 
               Debug_Output ("Value_Of (" & Name & ") is", Val);
194 
            end if;
195 
 
196 
            if Self.Refs /= null then
197 
               Value := new Name_To_Name'
198 
                 (Key    => External_Name,
199 
                  Value  => Val,
200 
                  Source => From_Environment,
201 
                  Next   => null);
202 
               Name_To_Name_HTable.Set (Self.Refs.all, Value);
203 
            end if;
204 
 
205 
            Free (Env_Value);
206 
            return Val;
207 
 
208 
         else
209 
            if Current_Verbosity = High then
210 
               Debug_Output
211 
                 ("Value_Of (" & Name & ") is default", With_Default);
212 
            end if;
213 
 
214 
            Free (Env_Value);
215 
            return With_Default;
216 
         end if;
217 
      end;
218 
   end Value_Of;
219 
 
220 
   ----------
221 
   -- Free --
222 
   ----------
223 
 
224 
   procedure Free (Self : in out External_References) is
225 
      procedure Unchecked_Free is new Ada.Unchecked_Deallocation
226 
        (Name_To_Name_HTable.Instance, Instance_Access);
227 
   begin
228 
      if Self.Refs /= null then
229 
         Reset (Self);
230 
         Unchecked_Free (Self.Refs);
231 
      end if;
232 
   end Free;
233 
 
234 
   --------------
235 
   -- Set_Next --
236 
   --------------
237 
 
238 
   procedure Set_Next (E : Name_To_Name_Ptr; Next : Name_To_Name_Ptr) is
239 
   begin
240 
      E.Next := Next;
241 
   end Set_Next;
242 
 
243 
   ----------
244 
   -- Next --
245 
   ----------
246 
 
247 
   function Next (E : Name_To_Name_Ptr) return Name_To_Name_Ptr is
248 
   begin
249 
      return E.Next;
250 
   end Next;
251 
 
252 
   -------------
253 
   -- Get_Key --
254 
   -------------
255 
 
256 
   function Get_Key (E : Name_To_Name_Ptr) return Name_Id is
257 
   begin
258 
      return E.Key;
259 
   end Get_Key;
260 
 
261 
end Prj.Ext;

powered by: WebSVN 2.1.0

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