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

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-stable/] [gcc-4.5.1/] [gcc/] [ada/] [a-clrefi.adb] - Blame information for rev 826

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 281 jeremybenn
------------------------------------------------------------------------------
2
--                                                                          --
3
--                         GNAT RUN-TIME COMPONENTS                         --
4
--                                                                          --
5
--       A D A . C O M M A N D _ L I N E . R E S P O N S E _ F I L E        --
6
--                                                                          --
7
--                                 B o d y                                  --
8
--                                                                          --
9
--          Copyright (C) 2007-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
pragma Compiler_Unit;
33
 
34
with Ada.Unchecked_Deallocation;
35
 
36
with System.OS_Lib; use System.OS_Lib;
37
 
38
package body Ada.Command_Line.Response_File is
39
 
40
   type File_Rec;
41
   type File_Ptr is access File_Rec;
42
   type File_Rec is record
43
      Name : String_Access;
44
      Next : File_Ptr;
45
      Prev : File_Ptr;
46
   end record;
47
   --  To build a stack of response file names
48
 
49
   procedure Free is new Ada.Unchecked_Deallocation (File_Rec, File_Ptr);
50
 
51
   type Argument_List_Access is access Argument_List;
52
   procedure Free is new Ada.Unchecked_Deallocation
53
     (Argument_List, Argument_List_Access);
54
   --  Free only the allocated Argument_List, not allocated String components
55
 
56
   --------------------
57
   -- Arguments_From --
58
   --------------------
59
 
60
   function Arguments_From
61
     (Response_File_Name        : String;
62
      Recursive                 : Boolean := False;
63
      Ignore_Non_Existing_Files : Boolean := False)
64
      return Argument_List
65
   is
66
      First_File : File_Ptr := null;
67
      Last_File  : File_Ptr := null;
68
      --  The stack of response files
69
 
70
      Arguments  : Argument_List_Access := new Argument_List (1 .. 4);
71
      Last_Arg   : Natural := 0;
72
 
73
      procedure Add_Argument (Arg : String);
74
      --  Add argument Arg to argument list Arguments, increasing Arguments
75
      --  if necessary.
76
 
77
      procedure Recurse (File_Name : String);
78
      --  Get the arguments from the file and call itself recursively if one of
79
      --  the argument starts with character '@'.
80
 
81
      ------------------
82
      -- Add_Argument --
83
      ------------------
84
 
85
      procedure Add_Argument (Arg : String) is
86
      begin
87
         if Last_Arg = Arguments'Last then
88
            declare
89
               New_Arguments : constant Argument_List_Access :=
90
                                 new Argument_List (1 .. Arguments'Last * 2);
91
            begin
92
               New_Arguments (Arguments'Range) := Arguments.all;
93
               Arguments.all := (others => null);
94
               Free (Arguments);
95
               Arguments := New_Arguments;
96
            end;
97
         end if;
98
 
99
         Last_Arg := Last_Arg + 1;
100
         Arguments (Last_Arg) := new String'(Arg);
101
      end Add_Argument;
102
 
103
      -------------
104
      -- Recurse --
105
      -------------
106
 
107
      procedure Recurse (File_Name : String) is
108
         FD : File_Descriptor;
109
 
110
         Buffer_Size : constant := 1500;
111
         Buffer : String (1 .. Buffer_Size);
112
 
113
         Buffer_Length : Natural;
114
 
115
         Buffer_Cursor : Natural;
116
 
117
         End_Of_File_Reached : Boolean;
118
 
119
         Line : String (1 .. Max_Line_Length + 1);
120
         Last : Natural;
121
 
122
         First_Char : Positive;
123
         --  Index of the first character of an argument in Line
124
 
125
         Last_Char : Natural;
126
         --  Index of the last character of an argument in Line
127
 
128
         In_String : Boolean;
129
         --  True when inside a quoted string
130
 
131
         Arg : Positive;
132
 
133
         function End_Of_File return Boolean;
134
         --  True when the end of the response file has been reached
135
 
136
         procedure Get_Buffer;
137
         --  Read one buffer from the response file
138
 
139
         procedure Get_Line;
140
         --  Get one line from the response file
141
 
142
         -----------------
143
         -- End_Of_File --
144
         -----------------
145
 
146
         function End_Of_File return Boolean is
147
         begin
148
            return End_Of_File_Reached and then Buffer_Cursor > Buffer_Length;
149
         end End_Of_File;
150
 
151
         ----------------
152
         -- Get_Buffer --
153
         ----------------
154
 
155
         procedure Get_Buffer is
156
         begin
157
            Buffer_Length := Read (FD, Buffer (1)'Address, Buffer'Length);
158
            End_Of_File_Reached := Buffer_Length < Buffer'Length;
159
            Buffer_Cursor := 1;
160
         end Get_Buffer;
161
 
162
         --------------
163
         -- Get_Line --
164
         --------------
165
 
166
         procedure Get_Line is
167
            Ch : Character;
168
 
169
         begin
170
            Last := 0;
171
 
172
            if End_Of_File then
173
               return;
174
            end if;
175
 
176
            loop
177
               Ch := Buffer (Buffer_Cursor);
178
 
179
               exit when Ch = ASCII.CR or else
180
                         Ch = ASCII.LF or else
181
                         Ch = ASCII.FF;
182
 
183
               Last := Last + 1;
184
               Line (Last) := Ch;
185
 
186
               if Last = Line'Last then
187
                  return;
188
               end if;
189
 
190
               Buffer_Cursor := Buffer_Cursor + 1;
191
 
192
               if Buffer_Cursor > Buffer_Length then
193
                  Get_Buffer;
194
 
195
                  if End_Of_File then
196
                     return;
197
                  end if;
198
               end if;
199
            end loop;
200
 
201
            loop
202
               Ch := Buffer (Buffer_Cursor);
203
 
204
               exit when Ch /= ASCII.HT and then
205
                         Ch /= ASCII.LF and then
206
                         Ch /= ASCII.FF;
207
 
208
               Buffer_Cursor := Buffer_Cursor + 1;
209
 
210
               if Buffer_Cursor > Buffer_Length then
211
                  Get_Buffer;
212
 
213
                  if End_Of_File then
214
                     return;
215
                  end if;
216
               end if;
217
            end loop;
218
         end Get_Line;
219
 
220
      --  Start or Recurse
221
 
222
      begin
223
         Last_Arg := 0;
224
 
225
         --  Open the response file. If not found, fail or report a warning,
226
         --  depending on the value of Ignore_Non_Existing_Files.
227
 
228
         FD := Open_Read (File_Name, Text);
229
 
230
         if FD = Invalid_FD then
231
            if Ignore_Non_Existing_Files then
232
               return;
233
            else
234
               raise File_Does_Not_Exist;
235
            end if;
236
         end if;
237
 
238
         --  Put the response file name on the stack
239
 
240
         if First_File = null then
241
            First_File :=
242
              new File_Rec'
243
                (Name => new String'(File_Name),
244
                 Next => null,
245
                 Prev => null);
246
            Last_File  := First_File;
247
 
248
         else
249
            declare
250
               Current : File_Ptr := First_File;
251
 
252
            begin
253
               loop
254
                  if Current.Name.all = File_Name then
255
                     raise Circularity_Detected;
256
                  end if;
257
 
258
                  Current := Current.Next;
259
                  exit when Current = null;
260
               end loop;
261
 
262
               Last_File.Next :=
263
                 new File_Rec'
264
                   (Name => new String'(File_Name),
265
                    Next => null,
266
                    Prev => Last_File);
267
               Last_File := Last_File.Next;
268
            end;
269
         end if;
270
 
271
         End_Of_File_Reached := False;
272
         Get_Buffer;
273
 
274
         --  Read the response file line by line
275
 
276
         Line_Loop :
277
         while not End_Of_File loop
278
            Get_Line;
279
 
280
            if Last = Line'Last then
281
               raise Line_Too_Long;
282
            end if;
283
 
284
            First_Char := 1;
285
 
286
            --  Get each argument on the line
287
 
288
            Arg_Loop :
289
            loop
290
               --  First, skip any white space
291
 
292
               while First_Char <= Last loop
293
                  exit when Line (First_Char) /= ' ' and then
294
                            Line (First_Char) /= ASCII.HT;
295
                  First_Char := First_Char + 1;
296
               end loop;
297
 
298
               exit Arg_Loop when First_Char > Last;
299
 
300
               Last_Char := First_Char;
301
               In_String := False;
302
 
303
               --  Get the character one by one
304
 
305
               Character_Loop :
306
               while Last_Char <= Last loop
307
 
308
                  --  Inside a string, check only for '"'
309
 
310
                  if In_String then
311
                     if Line (Last_Char) = '"' then
312
 
313
                        --  Remove the '"'
314
 
315
                        Line (Last_Char .. Last - 1) :=
316
                          Line (Last_Char + 1 .. Last);
317
                        Last := Last - 1;
318
 
319
                        --  End of string is end of argument
320
 
321
                        if Last_Char > Last or else
322
                          Line (Last_Char) = ' ' or else
323
                          Line (Last_Char) = ASCII.HT
324
                        then
325
                           In_String := False;
326
 
327
                           Last_Char := Last_Char - 1;
328
                           exit Character_Loop;
329
 
330
                        else
331
                           --  If there are two consecutive '"', the quoted
332
                           --  string is not closed
333
 
334
                           In_String := Line (Last_Char) = '"';
335
 
336
                           if In_String then
337
                              Last_Char := Last_Char + 1;
338
                           end if;
339
                        end if;
340
 
341
                     else
342
                        Last_Char := Last_Char + 1;
343
                     end if;
344
 
345
                  elsif Last_Char = Last then
346
 
347
                     --  An opening '"' at the end of the line is an error
348
 
349
                     if Line (Last) = '"' then
350
                        raise No_Closing_Quote;
351
 
352
                     else
353
                        --  The argument ends with the line
354
 
355
                        exit Character_Loop;
356
                     end if;
357
 
358
                  elsif Line (Last_Char) = '"' then
359
 
360
                     --  Entering a quoted string: remove the '"'
361
 
362
                     In_String := True;
363
                     Line (Last_Char .. Last - 1) :=
364
                       Line (Last_Char + 1 .. Last);
365
                     Last := Last - 1;
366
 
367
                  else
368
                     --  Outside quoted strings, white space ends the argument
369
 
370
                     exit Character_Loop
371
                          when Line (Last_Char + 1) = ' ' or else
372
                               Line (Last_Char + 1) = ASCII.HT;
373
 
374
                     Last_Char := Last_Char + 1;
375
                  end if;
376
               end loop Character_Loop;
377
 
378
               --  It is an error to not close a quoted string before the end
379
               --  of the line.
380
 
381
               if In_String then
382
                  raise No_Closing_Quote;
383
               end if;
384
 
385
               --  Add the argument to the list
386
 
387
               declare
388
                  Arg : String (1 .. Last_Char - First_Char + 1);
389
               begin
390
                  Arg := Line (First_Char .. Last_Char);
391
                  Add_Argument (Arg);
392
               end;
393
 
394
               --  Next argument, if line is not finished
395
 
396
               First_Char := Last_Char + 1;
397
            end loop Arg_Loop;
398
         end loop Line_Loop;
399
 
400
         Close (FD);
401
 
402
         --  If Recursive is True, check for any argument starting with '@'
403
 
404
         if Recursive then
405
            Arg := 1;
406
            while Arg <= Last_Arg loop
407
 
408
               if Arguments (Arg)'Length > 0 and then
409
                  Arguments (Arg) (1) = '@'
410
               then
411
                  --  Ignore argument "@" with no file name
412
 
413
                  if Arguments (Arg)'Length = 1 then
414
                     Arguments (Arg .. Last_Arg - 1) :=
415
                       Arguments (Arg + 1 .. Last_Arg);
416
                     Last_Arg := Last_Arg - 1;
417
 
418
                  else
419
                     --  Save the current arguments and get those in the new
420
                     --  response file.
421
 
422
                     declare
423
                        Inc_File_Name     : constant String :=
424
                                              Arguments (Arg)
425
                                              (2 .. Arguments (Arg)'Last);
426
                        Current_Arguments : constant Argument_List :=
427
                                              Arguments (1 .. Last_Arg);
428
                     begin
429
                        Recurse (Inc_File_Name);
430
 
431
                        --  Insert the new arguments where the new response
432
                        --  file was imported.
433
 
434
                        declare
435
                           New_Arguments : constant Argument_List :=
436
                                             Arguments (1 .. Last_Arg);
437
                           New_Last_Arg  : constant Positive :=
438
                                             Current_Arguments'Length +
439
                                             New_Arguments'Length - 1;
440
 
441
                        begin
442
                           --  Grow Arguments if it is not large enough
443
 
444
                           if Arguments'Last < New_Last_Arg then
445
                              Last_Arg := Arguments'Last;
446
                              Free (Arguments);
447
 
448
                              while Last_Arg < New_Last_Arg loop
449
                                 Last_Arg := Last_Arg * 2;
450
                              end loop;
451
 
452
                              Arguments := new Argument_List (1 .. Last_Arg);
453
                           end if;
454
 
455
                           Last_Arg := New_Last_Arg;
456
 
457
                           Arguments (1 .. Last_Arg) :=
458
                             Current_Arguments (1 .. Arg - 1) &
459
                           New_Arguments &
460
                           Current_Arguments
461
                             (Arg + 1 .. Current_Arguments'Last);
462
 
463
                           Arg := Arg + New_Arguments'Length;
464
                        end;
465
                     end;
466
                  end if;
467
 
468
               else
469
                  Arg := Arg + 1;
470
               end if;
471
            end loop;
472
         end if;
473
 
474
         --  Remove the response file name from the stack
475
 
476
         if First_File = Last_File then
477
            System.Strings.Free (First_File.Name);
478
            Free (First_File);
479
            First_File := null;
480
            Last_File := null;
481
 
482
         else
483
            System.Strings.Free (Last_File.Name);
484
            Last_File := Last_File.Prev;
485
            Free (Last_File.Next);
486
         end if;
487
 
488
      exception
489
         when others =>
490
            Close (FD);
491
 
492
            raise;
493
      end Recurse;
494
 
495
   --  Start of Arguments_From
496
 
497
   begin
498
      --  The job is done by procedure Recurse
499
 
500
      Recurse (Response_File_Name);
501
 
502
      --  Free Arguments before returning the result
503
 
504
      declare
505
         Result : constant Argument_List := Arguments (1 .. Last_Arg);
506
      begin
507
         Free (Arguments);
508
         return Result;
509
      end;
510
 
511
   exception
512
      when others =>
513
 
514
         --  When an exception occurs, deallocate everything
515
 
516
         Free (Arguments);
517
 
518
         while First_File /= null loop
519
            Last_File := First_File.Next;
520
            System.Strings.Free (First_File.Name);
521
            Free (First_File);
522
            First_File := Last_File;
523
         end loop;
524
 
525
         raise;
526
   end Arguments_From;
527
 
528
end Ada.Command_Line.Response_File;

powered by: WebSVN 2.1.0

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