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

Subversion Repositories openrisc

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

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 
--                   I N T E R F A C E S . F O R T R A N                    --
6 
--                                                                          --
7 
--                                 B o d y                                  --
8 
--                                                                          --
9 
--          Copyright (C) 1992-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 
package body Interfaces.Fortran is
33 
 
34 
   ------------
35 
   -- To_Ada --
36 
   ------------
37 
 
38 
   --  Single character case
39 
 
40 
   function To_Ada (Item : Character_Set) return Character is
41 
   begin
42 
      return Character (Item);
43 
   end To_Ada;
44 
 
45 
   --  String case (function returning converted result)
46 
 
47 
   function To_Ada (Item : Fortran_Character) return String is
48 
      T : String (1 .. Item'Length);
49 
 
50 
   begin
51 
      for J in T'Range loop
52 
         T (J) := Character (Item (J - 1 + Item'First));
53 
      end loop;
54 
 
55 
      return T;
56 
   end To_Ada;
57 
 
58 
   --  String case (procedure copying converted string to given buffer)
59 
 
60 
   procedure To_Ada
61 
     (Item   : Fortran_Character;
62 
      Target : out String;
63 
      Last   : out Natural)
64 
   is
65 
   begin
66 
      if Item'Length = 0 then
67 
         Last := 0;
68 
         return;
69 
 
70 
      elsif Target'Length = 0 then
71 
         raise Constraint_Error;
72 
 
73 
      else
74 
         Last := Target'First - 1;
75 
 
76 
         for J in Item'Range loop
77 
            Last := Last + 1;
78 
 
79 
            if Last > Target'Last then
80 
               raise Constraint_Error;
81 
            else
82 
               Target (Last) := Character (Item (J));
83 
            end if;
84 
         end loop;
85 
      end if;
86 
   end To_Ada;
87 
 
88 
   ----------------
89 
   -- To_Fortran --
90 
   ----------------
91 
 
92 
   --  Character case
93 
 
94 
   function To_Fortran (Item : Character) return Character_Set is
95 
   begin
96 
      return Character_Set (Item);
97 
   end To_Fortran;
98 
 
99 
   --  String case (function returning converted result)
100 
 
101 
   function To_Fortran (Item : String) return Fortran_Character is
102 
      T : Fortran_Character (1 .. Item'Length);
103 
 
104 
   begin
105 
      for J in T'Range loop
106 
         T (J) := Character_Set (Item (J - 1 + Item'First));
107 
      end loop;
108 
 
109 
      return T;
110 
   end To_Fortran;
111 
 
112 
   --  String case (procedure copying converted string to given buffer)
113 
 
114 
   procedure To_Fortran
115 
     (Item   : String;
116 
      Target : out Fortran_Character;
117 
      Last   : out Natural)
118 
   is
119 
   begin
120 
      if Item'Length = 0 then
121 
         Last := 0;
122 
         return;
123 
 
124 
      elsif Target'Length = 0 then
125 
         raise Constraint_Error;
126 
 
127 
      else
128 
         Last := Target'First - 1;
129 
 
130 
         for J in Item'Range loop
131 
            Last := Last + 1;
132 
 
133 
            if Last > Target'Last then
134 
               raise Constraint_Error;
135 
            else
136 
               Target (Last) := Character_Set (Item (J));
137 
            end if;
138 
         end loop;
139 
      end if;
140 
   end To_Fortran;
141 
 
142 
end Interfaces.Fortran;

powered by: WebSVN 2.1.0

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