File : i-fortra.adb
1 ------------------------------------------------------------------------------
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 -- --
19 -- --
20 -- --
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;