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

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [ada/] [output.adb] - Blame information for rev 760

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


------------------------------------------------------------------------------
--                                                                          --
--                         GNAT COMPILER COMPONENTS                         --
--                                                                          --
--                               O U T P U T                                --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--          Copyright (C) 1992-2010, Free Software Foundation, Inc.         --
--                                                                          --
-- GNAT is free software;  you can  redistribute it  and/or modify it under --
-- terms of the  GNU General Public License as published  by the Free Soft- --
-- ware  Foundation;  either version 3,  or (at your option) any later ver- --
-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE.                                     --
--                                                                          --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception,   --
-- version 3.1, as published by the Free Software Foundation.               --
--                                                                          --
-- You should have received a copy of the GNU General Public License and    --
-- a copy of the GCC Runtime Library Exception along with this program;     --
-- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
-- <http://www.gnu.org/licenses/>.                                          --
--                                                                          --
-- GNAT was originally developed  by the GNAT team at  New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc.      --
--                                                                          --
------------------------------------------------------------------------------
 
package body Output is
 
   Current_FD : File_Descriptor := Standout;
   --  File descriptor for current output
 
   Special_Output_Proc : Output_Proc := null;
   --  Record argument to last call to Set_Special_Output. If this is
   --  non-null, then we are in special output mode.
 
   Indentation_Amount : constant Positive := 3;
   --  Number of spaces to output for each indentation level
 
   Indentation_Limit : constant Positive := 40;
   --  Indentation beyond this number of spaces wraps around
 
   pragma Assert (Indentation_Limit < Buffer_Max / 2);
   --  Make sure this is substantially shorter than the line length
 
   Cur_Indentation : Natural := 0;
   --  Number of spaces to indent each line
 
   -----------------------
   -- Local_Subprograms --
   -----------------------
 
   procedure Flush_Buffer;
   --  Flush buffer if non-empty and reset column counter
 
   ---------------------------
   -- Cancel_Special_Output --
   ---------------------------
 
   procedure Cancel_Special_Output is
   begin
      Special_Output_Proc := null;
   end Cancel_Special_Output;
 
   ------------
   -- Column --
   ------------
 
   function Column return Pos is
   begin
      return Pos (Next_Col);
   end Column;
 
   ------------------
   -- Flush_Buffer --
   ------------------
 
   procedure Flush_Buffer is
      Write_Error : exception;
      --  Raised if Write fails
 
      ------------------
      -- Write_Buffer --
      ------------------
 
      procedure Write_Buffer (Buf : String);
      --  Write out Buf, either using Special_Output_Proc, or the normal way
      --  using Write. Raise Write_Error if Write fails (presumably due to disk
      --  full). Write_Error is not used in the case of Special_Output_Proc.
 
      procedure Write_Buffer (Buf : String) is
      begin
         --  If Special_Output_Proc has been set, then use it
 
         if Special_Output_Proc /= null then
            Special_Output_Proc.all (Buf);
 
         --  If output is not set, then output to either standard output
         --  or standard error.
 
         elsif Write (Current_FD, Buf'Address, Buf'Length) /= Buf'Length then
            raise Write_Error;
 
         end if;
      end Write_Buffer;
 
      Len : constant Natural := Next_Col - 1;
 
   --  Start of processing for Flush_Buffer
 
   begin
      if Len /= 0 then
         begin
            --  If there's no indentation, or if the line is too long with
            --  indentation, or if it's a blank line, just write the buffer.
 
            if Cur_Indentation = 0
              or else Cur_Indentation + Len > Buffer_Max
              or else Buffer (1 .. Len) = (1 => ASCII.LF)
            then
               Write_Buffer (Buffer (1 .. Len));
 
            --  Otherwise, construct a new buffer with preceding spaces, and
            --  write that.
 
            else
               declare
                  Indented_Buffer : constant String :=
                                      (1 .. Cur_Indentation => ' ') &
                                                          Buffer (1 .. Len);
               begin
                  Write_Buffer (Indented_Buffer);
               end;
            end if;
 
         exception
            when Write_Error =>
 
               --  If there are errors with standard error just quit. Otherwise
               --  set the output to standard error before reporting a failure
               --  and quitting.
 
               if Current_FD /= Standerr then
                  Current_FD := Standerr;
                  Next_Col := 1;
                  Write_Line ("fatal error: disk full");
               end if;
 
               OS_Exit (2);
         end;
 
         --  Buffer is now empty
 
         Next_Col := 1;
      end if;
   end Flush_Buffer;
 
   -------------------
   -- Ignore_Output --
   -------------------
 
   procedure Ignore_Output (S : String) is
   begin
      null;
   end Ignore_Output;
 
   ------------
   -- Indent --
   ------------
 
   procedure Indent is
   begin
      --  The "mod" in the following assignment is to cause a wrap around in
      --  the case where there is too much indentation.
 
      Cur_Indentation :=
        (Cur_Indentation + Indentation_Amount) mod Indentation_Limit;
   end Indent;
 
   -------------
   -- Outdent --
   -------------
 
   procedure Outdent is
   begin
      --  The "mod" here undoes the wrap around from Indent above
 
      Cur_Indentation :=
        (Cur_Indentation - Indentation_Amount) mod Indentation_Limit;
   end Outdent;
 
   ---------------------------
   -- Restore_Output_Buffer --
   ---------------------------
 
   procedure Restore_Output_Buffer (S : Saved_Output_Buffer) is
   begin
      Next_Col := S.Next_Col;
      Cur_Indentation := S.Cur_Indentation;
      Buffer (1 .. Next_Col - 1) := S.Buffer (1 .. Next_Col - 1);
   end Restore_Output_Buffer;
 
   ------------------------
   -- Save_Output_Buffer --
   ------------------------
 
   function Save_Output_Buffer return Saved_Output_Buffer is
      S : Saved_Output_Buffer;
   begin
      S.Buffer (1 .. Next_Col - 1) := Buffer (1 .. Next_Col - 1);
      S.Next_Col := Next_Col;
      S.Cur_Indentation := Cur_Indentation;
      Next_Col := 1;
      Cur_Indentation := 0;
      return S;
   end Save_Output_Buffer;
 
   ------------------------
   -- Set_Special_Output --
   ------------------------
 
   procedure Set_Special_Output (P : Output_Proc) is
   begin
      Special_Output_Proc := P;
   end Set_Special_Output;
 
   ----------------
   -- Set_Output --
   ----------------
 
   procedure Set_Output (FD : File_Descriptor) is
   begin
      if Special_Output_Proc = null then
         Flush_Buffer;
      end if;
 
      Current_FD := FD;
   end Set_Output;
 
   ------------------------
   -- Set_Standard_Error --
   ------------------------
 
   procedure Set_Standard_Error is
   begin
      Set_Output (Standerr);
   end Set_Standard_Error;
 
   -------------------------
   -- Set_Standard_Output --
   -------------------------
 
   procedure Set_Standard_Output is
   begin
      Set_Output (Standout);
   end Set_Standard_Output;
 
   -------
   -- w --
   -------
 
   procedure w (C : Character) is
   begin
      Write_Char (''');
      Write_Char (C);
      Write_Char (''');
      Write_Eol;
   end w;
 
   procedure w (S : String) is
   begin
      Write_Str (S);
      Write_Eol;
   end w;
 
   procedure w (V : Int) is
   begin
      Write_Int (V);
      Write_Eol;
   end w;
 
   procedure w (B : Boolean) is
   begin
      if B then
         w ("True");
      else
         w ("False");
      end if;
   end w;
 
   procedure w (L : String; C : Character) is
   begin
      Write_Str (L);
      Write_Char (' ');
      w (C);
   end w;
 
   procedure w (L : String; S : String) is
   begin
      Write_Str (L);
      Write_Char (' ');
      w (S);
   end w;
 
   procedure w (L : String; V : Int) is
   begin
      Write_Str (L);
      Write_Char (' ');
      w (V);
   end w;
 
   procedure w (L : String; B : Boolean) is
   begin
      Write_Str (L);
      Write_Char (' ');
      w (B);
   end w;
 
   ----------------
   -- Write_Char --
   ----------------
 
   procedure Write_Char (C : Character) is
   begin
      if Next_Col = Buffer'Length then
         Write_Eol;
      end if;
 
      if C = ASCII.LF then
         Write_Eol;
      else
         Buffer (Next_Col) := C;
         Next_Col := Next_Col + 1;
      end if;
   end Write_Char;
 
   ---------------
   -- Write_Eol --
   ---------------
 
   procedure Write_Eol is
   begin
      --  Remove any trailing space
 
      while Next_Col > 1 and then Buffer (Next_Col - 1) = ' ' loop
         Next_Col := Next_Col - 1;
      end loop;
 
      Buffer (Next_Col) := ASCII.LF;
      Next_Col := Next_Col + 1;
      Flush_Buffer;
   end Write_Eol;
 
   ---------------------------
   -- Write_Eol_Keep_Blanks --
   ---------------------------
 
   procedure Write_Eol_Keep_Blanks is
   begin
      Buffer (Next_Col) := ASCII.LF;
      Next_Col := Next_Col + 1;
      Flush_Buffer;
   end Write_Eol_Keep_Blanks;
 
   ----------------------
   -- Write_Erase_Char --
   ----------------------
 
   procedure Write_Erase_Char (C : Character) is
   begin
      if Next_Col /= 1 and then Buffer (Next_Col - 1) = C then
         Next_Col := Next_Col - 1;
      end if;
   end Write_Erase_Char;
 
   ---------------
   -- Write_Int --
   ---------------
 
   procedure Write_Int (Val : Int) is
   begin
      if Val < 0 then
         Write_Char ('-');
         Write_Int (-Val);
 
      else
         if Val > 9 then
            Write_Int (Val / 10);
         end if;
 
         Write_Char (Character'Val ((Val mod 10) + Character'Pos ('0')));
      end if;
   end Write_Int;
 
   ----------------
   -- Write_Line --
   ----------------
 
   procedure Write_Line (S : String) is
   begin
      Write_Str (S);
      Write_Eol;
   end Write_Line;
 
   ------------------
   -- Write_Spaces --
   ------------------
 
   procedure Write_Spaces (N : Nat) is
   begin
      for J in 1 .. N loop
         Write_Char (' ');
      end loop;
   end Write_Spaces;
 
   ---------------
   -- Write_Str --
   ---------------
 
   procedure Write_Str (S : String) is
   begin
      for J in S'Range loop
         Write_Char (S (J));
      end loop;
   end Write_Str;
 
end Output;

Browse

Tools

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [ada/] [output.adb] - Blame information for rev 760

Line No.	Rev	Author	Line
1	706	jeremybenn	`------------------------------------------------------------------------------`
2			`-- --`
3			`-- GNAT COMPILER COMPONENTS --`
4			`-- --`
5			`-- O U T P U T --`
6			`-- --`
7			`-- B o d y --`
8			`-- --`
9			`-- Copyright (C) 1992-2010, 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			`package body Output is`
33
34			`Current_FD : File_Descriptor := Standout;`
35			`-- File descriptor for current output`
36
37			`Special_Output_Proc : Output_Proc := null;`
38			`-- Record argument to last call to Set_Special_Output. If this is`
39			`-- non-null, then we are in special output mode.`
40
41			`Indentation_Amount : constant Positive := 3;`
42			`-- Number of spaces to output for each indentation level`
43
44			`Indentation_Limit : constant Positive := 40;`
45			`-- Indentation beyond this number of spaces wraps around`
46
47			`pragma Assert (Indentation_Limit < Buffer_Max / 2);`
48			`-- Make sure this is substantially shorter than the line length`
49
50			`Cur_Indentation : Natural := 0;`
51			`-- Number of spaces to indent each line`
52
53			`-----------------------`
54			`-- Local_Subprograms --`
55			`-----------------------`
56
57			`procedure Flush_Buffer;`
58			`-- Flush buffer if non-empty and reset column counter`
59
60			`---------------------------`
61			`-- Cancel_Special_Output --`
62			`---------------------------`
63
64			`procedure Cancel_Special_Output is`
65			`begin`
66			`Special_Output_Proc := null;`
67			`end Cancel_Special_Output;`
68
69			`------------`
70			`-- Column --`
71			`------------`
72
73			`function Column return Pos is`
74			`begin`
75			`return Pos (Next_Col);`
76			`end Column;`
77
78			`------------------`
79			`-- Flush_Buffer --`
80			`------------------`
81
82			`procedure Flush_Buffer is`
83			`Write_Error : exception;`
84			`-- Raised if Write fails`
85
86			`------------------`
87			`-- Write_Buffer --`
88			`------------------`
89
90			`procedure Write_Buffer (Buf : String);`
91			`-- Write out Buf, either using Special_Output_Proc, or the normal way`
92			`-- using Write. Raise Write_Error if Write fails (presumably due to disk`
93			`-- full). Write_Error is not used in the case of Special_Output_Proc.`
94
95			`procedure Write_Buffer (Buf : String) is`
96			`begin`
97			`-- If Special_Output_Proc has been set, then use it`
98
99			`if Special_Output_Proc /= null then`
100			`Special_Output_Proc.all (Buf);`
101
102			`-- If output is not set, then output to either standard output`
103			`-- or standard error.`
104
105			`elsif Write (Current_FD, Buf'Address, Buf'Length) /= Buf'Length then`
106			`raise Write_Error;`
107
108			`end if;`
109			`end Write_Buffer;`
110
111			`Len : constant Natural := Next_Col - 1;`
112
113			`-- Start of processing for Flush_Buffer`
114
115			`begin`
116			`if Len /= 0 then`
117			`begin`
118			`-- If there's no indentation, or if the line is too long with`
119			`-- indentation, or if it's a blank line, just write the buffer.`
120
121			`if Cur_Indentation = 0`
122			`or else Cur_Indentation + Len > Buffer_Max`
123			`or else Buffer (1 .. Len) = (1 => ASCII.LF)`
124			`then`
125			`Write_Buffer (Buffer (1 .. Len));`
126
127			`-- Otherwise, construct a new buffer with preceding spaces, and`
128			`-- write that.`
129
130			`else`
131			`declare`
132			`Indented_Buffer : constant String :=`
133			`(1 .. Cur_Indentation => ' ') &`
134			`Buffer (1 .. Len);`
135			`begin`
136			`Write_Buffer (Indented_Buffer);`
137			`end;`
138			`end if;`
139
140			`exception`
141			`when Write_Error =>`
142
143			`-- If there are errors with standard error just quit. Otherwise`
144			`-- set the output to standard error before reporting a failure`
145			`-- and quitting.`
146
147			`if Current_FD /= Standerr then`
148			`Current_FD := Standerr;`
149			`Next_Col := 1;`
150			`Write_Line ("fatal error: disk full");`
151			`end if;`
152
153			`OS_Exit (2);`
154			`end;`
155
156			`-- Buffer is now empty`
157
158			`Next_Col := 1;`
159			`end if;`
160			`end Flush_Buffer;`
161
162			`-------------------`
163			`-- Ignore_Output --`
164			`-------------------`
165
166			`procedure Ignore_Output (S : String) is`
167			`begin`
168			`null;`
169			`end Ignore_Output;`
170
171			`------------`
172			`-- Indent --`
173			`------------`
174
175			`procedure Indent is`
176			`begin`
177			`-- The "mod" in the following assignment is to cause a wrap around in`
178			`-- the case where there is too much indentation.`
179
180			`Cur_Indentation :=`
181			`(Cur_Indentation + Indentation_Amount) mod Indentation_Limit;`
182			`end Indent;`
183
184			`-------------`
185			`-- Outdent --`
186			`-------------`
187
188			`procedure Outdent is`
189			`begin`
190			`-- The "mod" here undoes the wrap around from Indent above`
191
192			`Cur_Indentation :=`
193			`(Cur_Indentation - Indentation_Amount) mod Indentation_Limit;`
194			`end Outdent;`
195
196			`---------------------------`
197			`-- Restore_Output_Buffer --`
198			`---------------------------`
199
200			`procedure Restore_Output_Buffer (S : Saved_Output_Buffer) is`
201			`begin`
202			`Next_Col := S.Next_Col;`
203			`Cur_Indentation := S.Cur_Indentation;`
204			`Buffer (1 .. Next_Col - 1) := S.Buffer (1 .. Next_Col - 1);`
205			`end Restore_Output_Buffer;`
206
207			`------------------------`
208			`-- Save_Output_Buffer --`
209			`------------------------`
210
211			`function Save_Output_Buffer return Saved_Output_Buffer is`
212			`S : Saved_Output_Buffer;`
213			`begin`
214			`S.Buffer (1 .. Next_Col - 1) := Buffer (1 .. Next_Col - 1);`
215			`S.Next_Col := Next_Col;`
216			`S.Cur_Indentation := Cur_Indentation;`
217			`Next_Col := 1;`
218			`Cur_Indentation := 0;`
219			`return S;`
220			`end Save_Output_Buffer;`
221
222			`------------------------`
223			`-- Set_Special_Output --`
224			`------------------------`
225
226			`procedure Set_Special_Output (P : Output_Proc) is`
227			`begin`
228			`Special_Output_Proc := P;`
229			`end Set_Special_Output;`
230
231			`----------------`
232			`-- Set_Output --`
233			`----------------`
234
235			`procedure Set_Output (FD : File_Descriptor) is`
236			`begin`
237			`if Special_Output_Proc = null then`
238			`Flush_Buffer;`
239			`end if;`
240
241			`Current_FD := FD;`
242			`end Set_Output;`
243
244			`------------------------`
245			`-- Set_Standard_Error --`
246			`------------------------`
247
248			`procedure Set_Standard_Error is`
249			`begin`
250			`Set_Output (Standerr);`
251			`end Set_Standard_Error;`
252
253			`-------------------------`
254			`-- Set_Standard_Output --`
255			`-------------------------`
256
257			`procedure Set_Standard_Output is`
258			`begin`
259			`Set_Output (Standout);`
260			`end Set_Standard_Output;`
261
262			`-------`
263			`-- w --`
264			`-------`
265
266			`procedure w (C : Character) is`
267			`begin`
268			`Write_Char (''');`
269			`Write_Char (C);`
270			`Write_Char (''');`
271			`Write_Eol;`
272			`end w;`
273
274			`procedure w (S : String) is`
275			`begin`
276			`Write_Str (S);`
277			`Write_Eol;`
278			`end w;`
279
280			`procedure w (V : Int) is`
281			`begin`
282			`Write_Int (V);`
283			`Write_Eol;`
284			`end w;`
285
286			`procedure w (B : Boolean) is`
287			`begin`
288			`if B then`
289			`w ("True");`
290			`else`
291			`w ("False");`
292			`end if;`
293			`end w;`
294
295			`procedure w (L : String; C : Character) is`
296			`begin`
297			`Write_Str (L);`
298			`Write_Char (' ');`
299			`w (C);`
300			`end w;`
301
302			`procedure w (L : String; S : String) is`
303			`begin`
304			`Write_Str (L);`
305			`Write_Char (' ');`
306			`w (S);`
307			`end w;`
308
309			`procedure w (L : String; V : Int) is`
310			`begin`
311			`Write_Str (L);`
312			`Write_Char (' ');`
313			`w (V);`
314			`end w;`
315
316			`procedure w (L : String; B : Boolean) is`
317			`begin`
318			`Write_Str (L);`
319			`Write_Char (' ');`
320			`w (B);`
321			`end w;`
322
323			`----------------`
324			`-- Write_Char --`
325			`----------------`
326
327			`procedure Write_Char (C : Character) is`
328			`begin`
329			`if Next_Col = Buffer'Length then`
330			`Write_Eol;`
331			`end if;`
332
333			`if C = ASCII.LF then`
334			`Write_Eol;`
335			`else`
336			`Buffer (Next_Col) := C;`
337			`Next_Col := Next_Col + 1;`
338			`end if;`
339			`end Write_Char;`
340
341			`---------------`
342			`-- Write_Eol --`
343			`---------------`
344
345			`procedure Write_Eol is`
346			`begin`
347			`-- Remove any trailing space`
348
349			`while Next_Col > 1 and then Buffer (Next_Col - 1) = ' ' loop`
350			`Next_Col := Next_Col - 1;`
351			`end loop;`
352
353			`Buffer (Next_Col) := ASCII.LF;`
354			`Next_Col := Next_Col + 1;`
355			`Flush_Buffer;`
356			`end Write_Eol;`
357
358			`---------------------------`
359			`-- Write_Eol_Keep_Blanks --`
360			`---------------------------`
361
362			`procedure Write_Eol_Keep_Blanks is`
363			`begin`
364			`Buffer (Next_Col) := ASCII.LF;`
365			`Next_Col := Next_Col + 1;`
366			`Flush_Buffer;`
367			`end Write_Eol_Keep_Blanks;`
368
369			`----------------------`
370			`-- Write_Erase_Char --`
371			`----------------------`
372
373			`procedure Write_Erase_Char (C : Character) is`
374			`begin`
375			`if Next_Col /= 1 and then Buffer (Next_Col - 1) = C then`
376			`Next_Col := Next_Col - 1;`
377			`end if;`
378			`end Write_Erase_Char;`
379
380			`---------------`
381			`-- Write_Int --`
382			`---------------`
383
384			`procedure Write_Int (Val : Int) is`
385			`begin`
386			`if Val < 0 then`
387			`Write_Char ('-');`
388			`Write_Int (-Val);`
389
390			`else`
391			`if Val > 9 then`
392			`Write_Int (Val / 10);`
393			`end if;`
394
395			`Write_Char (Character'Val ((Val mod 10) + Character'Pos ('0')));`
396			`end if;`
397			`end Write_Int;`
398
399			`----------------`
400			`-- Write_Line --`
401			`----------------`
402
403			`procedure Write_Line (S : String) is`
404			`begin`
405			`Write_Str (S);`
406			`Write_Eol;`
407			`end Write_Line;`
408
409			`------------------`
410			`-- Write_Spaces --`
411			`------------------`
412
413			`procedure Write_Spaces (N : Nat) is`
414			`begin`
415			`for J in 1 .. N loop`
416			`Write_Char (' ');`
417			`end loop;`
418			`end Write_Spaces;`
419
420			`---------------`
421			`-- Write_Str --`
422			`---------------`
423
424			`procedure Write_Str (S : String) is`
425			`begin`
426			`for J in S'Range loop`
427			`Write_Char (S (J));`
428			`end loop;`
429			`end Write_Str;`
430
431			`end Output;`