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

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [ada/] [g-cgideb.adb] - Blame information for rev 801

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


------------------------------------------------------------------------------
--                                                                          --
--                         GNAT COMPILER COMPONENTS                         --
--                                                                          --
--                        G N A T . C G I . D E B U G                       --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--                     Copyright (C) 2000-2010, AdaCore                     --
--                                                                          --
-- 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.      --
--                                                                          --
------------------------------------------------------------------------------
 
with Ada.Strings.Unbounded;
 
package body GNAT.CGI.Debug is
 
   use Ada.Strings.Unbounded;
 
   --  Define the abstract type which act as a template for all debug IO modes.
   --  To create a new IO mode you must:
   --     1. create a new package spec
   --     2. create a new type derived from IO.Format
   --     3. implement all the abstract routines in IO
 
   package IO is
 
      type Format is abstract tagged null record;
 
      function Output (Mode : Format'Class) return String;
 
      function Variable
        (Mode  : Format;
         Name  : String;
         Value : String) return String is abstract;
      --  Returns variable Name and its associated value
 
      function New_Line (Mode : Format) return String is abstract;
      --  Returns a new line such as this concatenated between two strings
      --  will display the strings on two lines.
 
      function Title (Mode : Format; Str : String) return String is abstract;
      --  Returns Str as a Title. A title must be alone and centered on a
      --  line. Next output will be on the following line.
 
      function Header
        (Mode : Format;
         Str  : String) return String is abstract;
      --  Returns Str as an Header. An header must be alone on its line. Next
      --  output will be on the following line.
 
   end IO;
 
   ----------------------
   -- IO for HTML Mode --
   ----------------------
 
   package HTML_IO is
 
      --  See IO for comments about these routines
 
      type Format is new IO.Format with null record;
 
      function Variable
        (IO    : Format;
         Name  : String;
         Value : String) return String;
 
      function New_Line (IO : Format) return String;
 
      function Title (IO : Format; Str : String) return String;
 
      function Header (IO : Format; Str : String) return String;
 
   end HTML_IO;
 
   ----------------------------
   -- IO for Plain Text Mode --
   ----------------------------
 
   package Text_IO is
 
      --  See IO for comments about these routines
 
      type Format is new IO.Format with null record;
 
      function Variable
        (IO    : Format;
         Name  : String;
         Value : String) return String;
 
      function New_Line (IO : Format) return String;
 
      function Title (IO : Format; Str : String) return String;
 
      function Header (IO : Format; Str : String) return String;
 
   end Text_IO;
 
   --------------
   -- Debug_IO --
   --------------
 
   package body IO is
 
      ------------
      -- Output --
      ------------
 
      function Output (Mode : Format'Class) return String is
         Result : Unbounded_String;
 
      begin
         Result :=
           To_Unbounded_String
             (Title (Mode, "CGI complete runtime environment")
              & Header (Mode, "CGI parameters:")
              & New_Line (Mode));
 
         for K in 1 .. Argument_Count loop
            Result := Result
              & Variable (Mode, Key (K), Value (K))
              & New_Line (Mode);
         end loop;
 
         Result := Result
           & New_Line (Mode)
           & Header (Mode, "CGI environment variables (Metavariables):")
           & New_Line (Mode);
 
         for P in Metavariable_Name'Range loop
            if Metavariable_Exists (P) then
               Result := Result
                 & Variable (Mode,
                             Metavariable_Name'Image (P),
                             Metavariable (P))
                 & New_Line (Mode);
            end if;
         end loop;
 
         return To_String (Result);
      end Output;
 
   end IO;
 
   -------------
   -- HTML_IO --
   -------------
 
   package body HTML_IO is
 
      NL : constant String := (1 => ASCII.LF);
 
      function Bold (S : String) return String;
      --  Returns S as an HTML bold string
 
      function Italic (S : String) return String;
      --  Returns S as an HTML italic string
 
      ----------
      -- Bold --
      ----------
 
      function Bold (S : String) return String is
      begin
         return "<b>" & S & "</b>";
      end Bold;
 
      ------------
      -- Header --
      ------------
 
      function Header (IO : Format; Str : String) return String is
         pragma Unreferenced (IO);
      begin
         return "<h2>" & Str & "</h2>" & NL;
      end Header;
 
      ------------
      -- Italic --
      ------------
 
      function Italic (S : String) return String is
      begin
         return "<i>" & S & "</i>";
      end Italic;
 
      --------------
      -- New_Line --
      --------------
 
      function New_Line (IO : Format) return String is
         pragma Unreferenced (IO);
      begin
         return "<br>" & NL;
      end New_Line;
 
      -----------
      -- Title --
      -----------
 
      function Title (IO : Format; Str : String) return String is
         pragma Unreferenced (IO);
      begin
         return "<p align=center><font size=+2>" & Str & "</font></p>" & NL;
      end Title;
 
      --------------
      -- Variable --
      --------------
 
      function Variable
        (IO    : Format;
         Name  : String;
         Value : String) return String
      is
         pragma Unreferenced (IO);
      begin
         return Bold (Name) & " = " & Italic (Value);
      end Variable;
 
   end HTML_IO;
 
   -------------
   -- Text_IO --
   -------------
 
   package body Text_IO is
 
      ------------
      -- Header --
      ------------
 
      function Header (IO : Format; Str : String) return String is
      begin
         return "*** " & Str & New_Line (IO);
      end Header;
 
      --------------
      -- New_Line --
      --------------
 
      function New_Line (IO : Format) return String is
         pragma Unreferenced (IO);
      begin
         return String'(1 => ASCII.LF);
      end New_Line;
 
      -----------
      -- Title --
      -----------
 
      function Title (IO : Format; Str : String) return String is
         Spaces : constant Natural := (80 - Str'Length) / 2;
         Indent : constant String (1 .. Spaces) := (others => ' ');
      begin
         return Indent & Str & New_Line (IO);
      end Title;
 
      --------------
      -- Variable --
      --------------
 
      function Variable
        (IO    : Format;
         Name  : String;
         Value : String) return String
      is
         pragma Unreferenced (IO);
      begin
         return "   " & Name & " = " & Value;
      end Variable;
 
   end Text_IO;
 
   -----------------
   -- HTML_Output --
   -----------------
 
   function HTML_Output return String is
      HTML : HTML_IO.Format;
   begin
      return IO.Output (Mode => HTML);
   end HTML_Output;
 
   -----------------
   -- Text_Output --
   -----------------
 
   function Text_Output return String is
      Text : Text_IO.Format;
   begin
      return IO.Output (Mode => Text);
   end Text_Output;
 
end GNAT.CGI.Debug;

Browse

Tools

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [ada/] [g-cgideb.adb] - Blame information for rev 801

Line No.	Rev	Author	Line
1	706	jeremybenn	`------------------------------------------------------------------------------`
2			`-- --`
3			`-- GNAT COMPILER COMPONENTS --`
4			`-- --`
5			`-- G N A T . C G I . D E B U G --`
6			`-- --`
7			`-- B o d y --`
8			`-- --`
9			`-- Copyright (C) 2000-2010, AdaCore --`
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			`with Ada.Strings.Unbounded;`
33
34			`package body GNAT.CGI.Debug is`
35
36			`use Ada.Strings.Unbounded;`
37
38			`-- Define the abstract type which act as a template for all debug IO modes.`
39			`-- To create a new IO mode you must:`
40			`-- 1. create a new package spec`
41			`-- 2. create a new type derived from IO.Format`
42			`-- 3. implement all the abstract routines in IO`
43
44			`package IO is`
45
46			`type Format is abstract tagged null record;`
47
48			`function Output (Mode : Format'Class) return String;`
49
50			`function Variable`
51			`(Mode : Format;`
52			`Name : String;`
53			`Value : String) return String is abstract;`
54			`-- Returns variable Name and its associated value`
55
56			`function New_Line (Mode : Format) return String is abstract;`
57			`-- Returns a new line such as this concatenated between two strings`
58			`-- will display the strings on two lines.`
59
60			`function Title (Mode : Format; Str : String) return String is abstract;`
61			`-- Returns Str as a Title. A title must be alone and centered on a`
62			`-- line. Next output will be on the following line.`
63
64			`function Header`
65			`(Mode : Format;`
66			`Str : String) return String is abstract;`
67			`-- Returns Str as an Header. An header must be alone on its line. Next`
68			`-- output will be on the following line.`
69
70			`end IO;`
71
72			`----------------------`
73			`-- IO for HTML Mode --`
74			`----------------------`
75
76			`package HTML_IO is`
77
78			`-- See IO for comments about these routines`
79
80			`type Format is new IO.Format with null record;`
81
82			`function Variable`
83			`(IO : Format;`
84			`Name : String;`
85			`Value : String) return String;`
86
87			`function New_Line (IO : Format) return String;`
88
89			`function Title (IO : Format; Str : String) return String;`
90
91			`function Header (IO : Format; Str : String) return String;`
92
93			`end HTML_IO;`
94
95			`----------------------------`
96			`-- IO for Plain Text Mode --`
97			`----------------------------`
98
99			`package Text_IO is`
100
101			`-- See IO for comments about these routines`
102
103			`type Format is new IO.Format with null record;`
104
105			`function Variable`
106			`(IO : Format;`
107			`Name : String;`
108			`Value : String) return String;`
109
110			`function New_Line (IO : Format) return String;`
111
112			`function Title (IO : Format; Str : String) return String;`
113
114			`function Header (IO : Format; Str : String) return String;`
115
116			`end Text_IO;`
117
118			`--------------`
119			`-- Debug_IO --`
120			`--------------`
121
122			`package body IO is`
123
124			`------------`
125			`-- Output --`
126			`------------`
127
128			`function Output (Mode : Format'Class) return String is`
129			`Result : Unbounded_String;`
130
131			`begin`
132			`Result :=`
133			`To_Unbounded_String`
134			`(Title (Mode, "CGI complete runtime environment")`
135			`& Header (Mode, "CGI parameters:")`
136			`& New_Line (Mode));`
137
138			`for K in 1 .. Argument_Count loop`
139			`Result := Result`
140			`& Variable (Mode, Key (K), Value (K))`
141			`& New_Line (Mode);`
142			`end loop;`
143
144			`Result := Result`
145			`& New_Line (Mode)`
146			`& Header (Mode, "CGI environment variables (Metavariables):")`
147			`& New_Line (Mode);`
148
149			`for P in Metavariable_Name'Range loop`
150			`if Metavariable_Exists (P) then`
151			`Result := Result`
152			`& Variable (Mode,`
153			`Metavariable_Name'Image (P),`
154			`Metavariable (P))`
155			`& New_Line (Mode);`
156			`end if;`
157			`end loop;`
158
159			`return To_String (Result);`
160			`end Output;`
161
162			`end IO;`
163
164			`-------------`
165			`-- HTML_IO --`
166			`-------------`
167
168			`package body HTML_IO is`
169
170			`NL : constant String := (1 => ASCII.LF);`
171
172			`function Bold (S : String) return String;`
173			`-- Returns S as an HTML bold string`
174
175			`function Italic (S : String) return String;`
176			`-- Returns S as an HTML italic string`
177
178			`----------`
179			`-- Bold --`
180			`----------`
181
182			`function Bold (S : String) return String is`
183			`begin`
184			`return "<b>" & S & "</b>";`
185			`end Bold;`
186
187			`------------`
188			`-- Header --`
189			`------------`
190
191			`function Header (IO : Format; Str : String) return String is`
192			`pragma Unreferenced (IO);`
193			`begin`
194			`return "<h2>" & Str & "</h2>" & NL;`
195			`end Header;`
196
197			`------------`
198			`-- Italic --`
199			`------------`
200
201			`function Italic (S : String) return String is`
202			`begin`
203			`return "<i>" & S & "</i>";`
204			`end Italic;`
205
206			`--------------`
207			`-- New_Line --`
208			`--------------`
209
210			`function New_Line (IO : Format) return String is`
211			`pragma Unreferenced (IO);`
212			`begin`
213			`return "<br>" & NL;`
214			`end New_Line;`
215
216			`-----------`
217			`-- Title --`
218			`-----------`
219
220			`function Title (IO : Format; Str : String) return String is`
221			`pragma Unreferenced (IO);`
222			`begin`
223			`return "<p align=center><font size=+2>" & Str & "</font></p>" & NL;`
224			`end Title;`
225
226			`--------------`
227			`-- Variable --`
228			`--------------`
229
230			`function Variable`
231			`(IO : Format;`
232			`Name : String;`
233			`Value : String) return String`
234			`is`
235			`pragma Unreferenced (IO);`
236			`begin`
237			`return Bold (Name) & " = " & Italic (Value);`
238			`end Variable;`
239
240			`end HTML_IO;`
241
242			`-------------`
243			`-- Text_IO --`
244			`-------------`
245
246			`package body Text_IO is`
247
248			`------------`
249			`-- Header --`
250			`------------`
251
252			`function Header (IO : Format; Str : String) return String is`
253			`begin`
254			`return "*** " & Str & New_Line (IO);`
255			`end Header;`
256
257			`--------------`
258			`-- New_Line --`
259			`--------------`
260
261			`function New_Line (IO : Format) return String is`
262			`pragma Unreferenced (IO);`
263			`begin`
264			`return String'(1 => ASCII.LF);`
265			`end New_Line;`
266
267			`-----------`
268			`-- Title --`
269			`-----------`
270
271			`function Title (IO : Format; Str : String) return String is`
272			`Spaces : constant Natural := (80 - Str'Length) / 2;`
273			`Indent : constant String (1 .. Spaces) := (others => ' ');`
274			`begin`
275			`return Indent & Str & New_Line (IO);`
276			`end Title;`
277
278			`--------------`
279			`-- Variable --`
280			`--------------`
281
282			`function Variable`
283			`(IO : Format;`
284			`Name : String;`
285			`Value : String) return String`
286			`is`
287			`pragma Unreferenced (IO);`
288			`begin`
289			`return " " & Name & " = " & Value;`
290			`end Variable;`
291
292			`end Text_IO;`
293
294			`-----------------`
295			`-- HTML_Output --`
296			`-----------------`
297
298			`function HTML_Output return String is`
299			`HTML : HTML_IO.Format;`
300			`begin`
301			`return IO.Output (Mode => HTML);`
302			`end HTML_Output;`
303
304			`-----------------`
305			`-- Text_Output --`
306			`-----------------`
307
308			`function Text_Output return String is`
309			`Text : Text_IO.Format;`
310			`begin`
311			`return IO.Output (Mode => Text);`
312			`end Text_Output;`
313
314			`end GNAT.CGI.Debug;`