Mercurial > hg > CbC > CbC_gcc
comparison gcc/ada/libgnat/i-fortra.adb @ 111:04ced10e8804
gcc 7
author | kono |
---|---|
date | Fri, 27 Oct 2017 22:46:09 +0900 |
parents | |
children | 84e7813d76e9 |
comparison
equal
deleted
inserted
replaced
68:561a7518be6b | 111:04ced10e8804 |
---|---|
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-2017, 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; |