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-2018, 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
32package 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
142end Interfaces.Fortran;
143