← Back to branch summary

~ubuntu-branches/ubuntu/karmic/asis/karmic

« back to all changes in this revision

Viewing changes to asis/asis-ada_environments.adb

  • Committer: Bazaar Package Importer
  • Author(s): Thomas Quinot
  • Date: 2002-03-03 19:55:58 UTC
  • Revision ID: james.westby@ubuntu.com-20020303195558-g7dp4vaq1zdkf814
Tags: upstream-3.14p
Import upstream version 3.14p

Show diffs side-by-side

added added

removed removed

Lines of Context:
asis/asis-ada_environments.adb
 
1
------------------------------------------------------------------------------
 
2
--                                                                          --
 
3
--                 ASIS-for-GNAT IMPLEMENTATION COMPONENTS                  --
 
4
--                                                                          --
 
5
--                A S I S . A D A _ E N V I R O N M E N T S                 --
 
6
--                                                                          --
 
7
--                                 B o d y                                  --
 
8
--                                                                          --
 
9
--                            $Revision: 1.19 $
 
10
--                                                                          --
 
11
--            Copyright (c) 1995-2000, Free Software Foundation, Inc.       --
 
12
--                                                                          --
 
13
-- ASIS-for-GNAT is free software; you can redistribute it and/or modify it --
 
14
-- under terms of the  GNU General Public License  as published by the Free --
 
15
-- Software Foundation;  either version 2,  or  (at your option)  any later --
 
16
-- version. ASIS-for-GNAT is distributed  in the hope  that it will be use- --
 
17
-- ful, but WITHOUT ANY WARRANTY; without even the implied warranty of MER- --
 
18
-- CHANTABILITY or  FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General  --
 
19
-- Public License for more details. You should have received a copy of the  --
 
20
-- GNU General Public License  distributed with ASIS-for-GNAT; see file     --
 
21
-- COPYING. If not, write to the Free Software Foundation,  59 Temple Place --
 
22
-- - Suite 330,  Boston, MA 02111-1307, USA.                                --
 
23
--                                                                          --
 
24
-- As a special exception,  if other files  instantiate  generics from this --
 
25
-- unit, or you link  this unit with other files  to produce an executable, --
 
26
-- this  unit  does not  by itself cause  the resulting  executable  to  be --
 
27
-- covered  by the  GNU  General  Public  License.  This exception does not --
 
28
-- however invalidate  any other reasons why  the executable file  might be --
 
29
-- covered by the  GNU Public License.                                      --
 
30
--                                                                          --
 
31
-- ASIS-for-GNAT was originally developed  by the ASIS-for-GNAT team at the --
 
32
-- Software  Engineering  Laboratory  of  the Swiss  Federal  Institute  of --
 
33
-- Technology (LGL-EPFL) in Lausanne,  Switzerland, in cooperation with the --
 
34
-- Scientific  Research  Computer  Center of  Moscow State University (SRCC --
 
35
-- MSU), Russia,  with funding partially provided  by grants from the Swiss --
 
36
-- National  Science  Foundation  and  the  Swiss  Academy  of  Engineering --
 
37
-- Sciences.  ASIS-for-GNAT is now maintained by  Ada Core Technologies Inc --
 
38
-- (http://www.gnat.com).                                                   --
 
39
--                                                                          --
 
40
------------------------------------------------------------------------------
 
41
 
 
42
with Ada.Characters.Handling; use Ada.Characters.Handling;
 
43
with Ada.Strings;             use Ada.Strings;
 
44
with Ada.Strings.Fixed;       use Ada.Strings.Fixed;
 
45
 
 
46
with Asis.Exceptions;         use Asis.Exceptions;
 
47
with Asis.Errors;             use Asis.Errors;
 
48
 
 
49
with Asis.Set_Get;            use Asis.Set_Get;
 
50
 
 
51
with A4G.A_Debug;             use A4G.A_Debug;
 
52
with A4G.A_Opt;               use A4G.A_Opt;
 
53
with A4G.Vcheck;              use A4G.Vcheck;
 
54
with A4G.Contt;               use A4G.Contt;
 
55
with A4G.A_Output;            use A4G.A_Output;
 
56
with A4G.Contt.UT;            use A4G.Contt.UT;
 
57
with A4G.Contt.TT;            use A4G.Contt.TT;
 
58
 
 
59
with Output;                  use Output;
 
60
 
 
61
package body Asis.Ada_Environments is
 
62
 
 
63
   ---------------
 
64
   -- Associate --
 
65
   ---------------
 
66
 
 
67
   procedure Associate
 
68
     (The_Context : in out Asis.Context;
 
69
      Name        : in     Wide_String;
 
70
      Parameters  : in     Wide_String := Default_Parameters)
 
71
   is
 
72
      S_Parameters : String := Trim (To_String (Parameters), Both);
 
73
      Cont : Context_Id;
 
74
   begin
 
75
 
 
76
      if not A4G.A_Opt.Is_Initialized then
 
77
 
 
78
         Set_Error_Status
 
79
           (Status    => Initialization_Error,
 
80
            Diagnosis => "Asis.Ada_Environments.Associate: "
 
81
                       & "called for non-initialized ASIS");
 
82
 
 
83
         raise ASIS_Failed;
 
84
 
 
85
      end if;
 
86
 
 
87
      Cont := Get_Cont_Id (The_Context);
 
88
 
 
89
      if Is_Opened (Cont) then
 
90
         Set_Error_Status (Status    => Value_Error,
 
91
                           Diagnosis => "Asis.Ada_Environments.Associate: "
 
92
                                       &
 
93
                                        "the Context has already been opened");
 
94
         raise ASIS_Inappropriate_Context;
 
95
      end if;
 
96
 
 
97
      if Cont = Non_Associated then
 
98
         --  this is the first association for a given Context
 
99
         Cont := Allocate_New_Context;
 
100
         Set_Cont (The_Context, Cont);
 
101
      else
 
102
         Erase_Old (Cont);
 
103
      end if;
 
104
 
 
105
      Pre_Initialize (Cont);
 
106
 
 
107
      Verify_Context_Name (To_String (Name), Cont);
 
108
      Process_Context_Parameters (S_Parameters, Cont);
 
109
 
 
110
      Set_Is_Associated (Cont, True);
 
111
 
 
112
      Save_Context (Cont);
 
113
      Set_Current_Cont (Nil_Context_Id);
 
114
 
 
115
   exception
 
116
      when ASIS_Inappropriate_Context =>
 
117
         raise;
 
118
      when ASIS_Failed =>
 
119
         if not (Status_Indicator = Errors.Parameter_Error or else
 
120
                 Status_Indicator = Errors.Initialization_Error)
 
121
         then
 
122
            Add_Call_Information (Outer_Call =>
 
123
              "Asis.Ada_Environments.Associate");
 
124
         end if;
 
125
         raise;
 
126
      when others =>
 
127
         Raise_ASIS_Failed (Diagnosis => "Asis.Ada_Environments.Associate");
 
128
   end Associate;
 
129
 
 
130
   -----------
 
131
   -- Close --
 
132
   -----------
 
133
 
 
134
   procedure Close (The_Context : in out Asis.Context) is
 
135
      Cont : Context_Id;
 
136
   begin
 
137
      Cont := Get_Cont_Id (The_Context);
 
138
      Reset_Context (Cont);
 
139
 
 
140
      if not Is_Opened (Cont) then
 
141
         Set_Error_Status (Status    => Value_Error,
 
142
                           Diagnosis => "Asis.Ada_Environments.Close: " &
 
143
                           "the Context is not open");
 
144
         raise ASIS_Inappropriate_Context;
 
145
      end if;
 
146
 
 
147
      if Debug_Flag_C    or else
 
148
         Debug_Lib_Model or else
 
149
         Debug_Mode
 
150
      then
 
151
         Write_Str ("Closing Context ");
 
152
         Write_Int (Int (Cont));
 
153
         Write_Eol;
 
154
         Print_Units (Cont);
 
155
         Print_Trees (Cont);
 
156
      end if;
 
157
 
 
158
      Set_Is_Opened (Cont, False);
 
159
 
 
160
      Set_Current_Cont (Nil_Context_Id);
 
161
 
 
162
   exception
 
163
      when ASIS_Inappropriate_Context =>
 
164
         raise;
 
165
      when ASIS_Failed =>
 
166
         Set_Current_Cont (Nil_Context_Id);
 
167
         Add_Call_Information (Outer_Call =>
 
168
                     "Asis.Ada_Environments.Close");
 
169
         raise;
 
170
      when others =>
 
171
         Set_Current_Cont (Nil_Context_Id);
 
172
         Raise_ASIS_Failed (Diagnosis =>
 
173
                     "Asis.Ada_Environments.Close");
 
174
   end Close;
 
175
 
 
176
   -----------------
 
177
   -- Debug_Image --
 
178
   -----------------
 
179
 
 
180
   function Debug_Image
 
181
     (The_Context : in Asis.Context)
 
182
       return Wide_String
 
183
   is
 
184
      Arg_Cont : Context_Id;
 
185
      LT       : Wide_String renames A4G.A_Types.Asis_Wide_Line_Terminator;
 
186
   begin
 
187
      Arg_Cont := Get_Cont_Id (The_Context);
 
188
      Reset_Context (Arg_Cont);
 
189
 
 
190
      return LT & "Context Debug_Image: " &
 
191
             LT & "Context Id is" &
 
192
             Context_Id'Wide_Image (Arg_Cont) &
 
193
             LT & To_Wide_String (Debug_String (The_Context));
 
194
   end Debug_Image;
 
195
 
 
196
   ------------------
 
197
   -- Default_Name --
 
198
   ------------------
 
199
 
 
200
   function Default_Name return Wide_String is
 
201
   begin
 
202
      return Nil_Asis_Wide_String;
 
203
   end Default_Name;
 
204
 
 
205
   ------------------------
 
206
   -- Default_Parameters --
 
207
   ------------------------
 
208
 
 
209
   function Default_Parameters return Wide_String is
 
210
   begin
 
211
      return Nil_Asis_Wide_String;
 
212
   end Default_Parameters;
 
213
 
 
214
   ----------------
 
215
   -- Dissociate --
 
216
   ----------------
 
217
 
 
218
   procedure Dissociate (The_Context : in out Asis.Context) is
 
219
      Cont : Context_Id;
 
220
   begin
 
221
      Cont := Get_Cont_Id (The_Context);
 
222
 
 
223
      if Is_Opened (Cont) then
 
224
         Set_Error_Status (Status    => Value_Error,
 
225
                           Diagnosis => "Asis.Ada_Environments.Dissociate: "
 
226
                                      & "the Context is open");
 
227
         raise ASIS_Inappropriate_Context;
 
228
      end if;
 
229
 
 
230
      if Debug_Flag_C    or else
 
231
         Debug_Lib_Model or else
 
232
         Debug_Mode
 
233
      then
 
234
         Write_Str ("Dissociating Context ");
 
235
         Write_Int (Int (Cont));
 
236
         Write_Eol;
 
237
         Print_Context_Parameters (Cont);
 
238
      end if;
 
239
 
 
240
      if Is_Associated (Cont) then
 
241
         Erase_Old (Cont);
 
242
         Set_Is_Associated (Cont, False);
 
243
      end if;
 
244
 
 
245
   exception
 
246
      when ASIS_Inappropriate_Context =>
 
247
         raise;
 
248
      when ASIS_Failed =>
 
249
         Add_Call_Information (Outer_Call =>
 
250
           "Asis.Ada_Environments.Dissociate");
 
251
         raise;
 
252
      when others =>
 
253
         Raise_ASIS_Failed (Diagnosis => "Asis.Ada_Environments.Dissociate");
 
254
   end Dissociate;
 
255
 
 
256
   ------------
 
257
   -- Exists --
 
258
   ------------
 
259
 
 
260
   function Exists (The_Context : in Asis.Context) return Boolean is
 
261
      Cont : Context_Id;
 
262
   begin
 
263
      Cont := Get_Cont_Id (The_Context);
 
264
      return Is_Associated (Cont);
 
265
   end Exists;
 
266
 
 
267
   ----------------------
 
268
   -- Has_Associations --
 
269
   ----------------------
 
270
 
 
271
   function Has_Associations
 
272
     (The_Context : in Asis.Context)
 
273
      return Boolean
 
274
   is
 
275
      Cont : Context_Id;
 
276
   begin
 
277
      Cont := Get_Cont_Id (The_Context);
 
278
      return Is_Associated (Cont);
 
279
   end Has_Associations;
 
280
 
 
281
   --------------
 
282
   -- Is_Equal --
 
283
   --------------
 
284
 
 
285
   function Is_Equal (Left  : in Asis.Context;
 
286
                      Right : in Asis.Context) return Boolean is
 
287
   begin
 
288
      return Get_Cont_Id (Left) = Get_Cont_Id (Right);
 
289
      --  Should be revised
 
290
   end Is_Equal;
 
291
 
 
292
   ------------------
 
293
   -- Is_Identical --
 
294
   ------------------
 
295
 
 
296
   function Is_Identical (Left  : in Asis.Context;
 
297
                          Right : in Asis.Context) return Boolean is
 
298
   begin
 
299
      return Get_Cont_Id (Left) = Get_Cont_Id (Right);
 
300
   end Is_Identical;
 
301
 
 
302
   -------------
 
303
   -- Is_Open --
 
304
   -------------
 
305
 
 
306
   function Is_Open (The_Context : in Asis.Context) return Boolean is
 
307
      Cont : Context_Id;
 
308
   begin
 
309
      Cont := Get_Cont_Id (The_Context);
 
310
      return Is_Opened (Cont);
 
311
   end Is_Open;
 
312
 
 
313
   ----------
 
314
   -- Name --
 
315
   ----------
 
316
 
 
317
   function Name (The_Context : in Asis.Context) return Wide_String is
 
318
      Cont : Context_Id;
 
319
   begin
 
320
      Cont := Get_Cont_Id (The_Context);
 
321
      return  To_Wide_String (Get_Context_Name (Cont));
 
322
   end Name;
 
323
 
 
324
   ----------
 
325
   -- Open --
 
326
   ----------
 
327
 
 
328
   procedure Open (The_Context : in out Asis.Context) is
 
329
      Cont              : Context_Id;
 
330
      Context_Tree_Mode : Tree_Mode;
 
331
   begin
 
332
      Cont := Get_Cont_Id (The_Context);
 
333
 
 
334
      if not Is_Associated (Cont) then
 
335
         Set_Error_Status (Status    => Value_Error,
 
336
                           Diagnosis => "Asis.Ada_Environments.Open: " &
 
337
                           "the Context dos not have association");
 
338
         raise ASIS_Inappropriate_Context;
 
339
      elsif Is_Opened (Cont) then
 
340
         Set_Error_Status (Status    => Value_Error,
 
341
                           Diagnosis => "Asis.Ada_Environments.Open: " &
 
342
                           "the Context has already been opened");
 
343
         raise ASIS_Inappropriate_Context;
 
344
      end if;
 
345
      Reset_Context (Cont);
 
346
 
 
347
      Increase_ASIS_OS_Time;
 
348
 
 
349
      Pre_Initialize (Cont);
 
350
      A4G.Contt.Initialize (Cont);
 
351
      --  Having these two Pre_Initialize and A4G.Contt.Initialize calling
 
352
      --  one after another is a kind of junk, but there are some problems
 
353
      --  with multi-context processing which have not been completely
 
354
      --  detected and which does not allow to get rid of this definitely
 
355
      --  redundunt "initialization"
 
356
 
 
357
      Context_Tree_Mode := Tree_Processing_Mode (Cont);
 
358
 
 
359
      case Context_Tree_Mode is
 
360
         when Pre_Created | Mixed =>
 
361
            Scan_Trees_New (Cont);
 
362
 
 
363
         when Incremental =>
 
364
 
 
365
            --  Not the best approach, unfortunately
 
366
            begin
 
367
               Scan_Trees_New (Cont);
 
368
            exception
 
369
               when Inconsistent_Incremental_Context =>
 
370
                  --  Setting empty incremental context:
 
371
                  Pre_Initialize (Cont);
 
372
                  A4G.Contt.Initialize (Cont);
 
373
               when others =>
 
374
                  raise;
 
375
            end;
 
376
 
 
377
         when others =>
 
378
            null;
 
379
      end case;
 
380
 
 
381
      Set_Is_Opened (Cont, True);
 
382
 
 
383
      Save_Context (Cont);
 
384
 
 
385
      Set_Current_Cont (Nil_Context_Id);
 
386
 
 
387
 
 
388
   exception
 
389
      when Program_Error =>
 
390
         raise;
 
391
      when ASIS_Inappropriate_Context =>
 
392
         raise;
 
393
      when ASIS_Failed =>
 
394
         Set_Current_Cont (Nil_Context_Id);
 
395
         raise;
 
396
      when others =>
 
397
         Set_Current_Cont (Nil_Context_Id);
 
398
         Raise_ASIS_Failed (Diagnosis => "Asis.Ada_Environments.Open");
 
399
   end Open;
 
400
 
 
401
   ----------------
 
402
   -- Parameters --
 
403
   ----------------
 
404
 
 
405
   function Parameters (The_Context : in Asis.Context) return Wide_String is
 
406
      Cont : Context_Id;
 
407
   begin
 
408
      Cont := Get_Cont_Id (The_Context);
 
409
      return  To_Wide_String (Get_Context_Parameters (Cont));
 
410
   end Parameters;
 
411
 
 
412
end Asis.Ada_Environments;