coerce.c
1 //! @file coerce.c
2 //! @author J. Marcel van der Veer
3 //
4 //! @section Copyright
5 //
6 // This file is part of VIF - vintage FORTRAN compiler.
7 // Copyright 2020-2025 J. Marcel van der Veer <algol68g@xs4all.nl>.
8 //
9 //! @section License
10 //
11 // This program is free software; you can redistribute it and/or modify it
12 // under the terms of the GNU General Public License as published by the
13 // Free Software Foundation; either version 3 of the License, or
14 // (at your option) any later version.
15 //
16 // This program is distributed in the hope that it will be useful, but
17 // WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
18 // or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for
19 // more details. You should have received a copy of the GNU General Public
20 // License along with this program. If not, see <http://www.gnu.org/licenses/>.
21
22 //! @section Synopsis
23 //!
24 //! Type conversions for assignments and function statements.
25
26 #include <vif.h>
27
28 logical_4 coerce (EXPR * lhs, EXPR * rhs)
29 {
30 // Sensible defaults.
31 RECCPY (lhs->str, rhs->str);
32 // Oftentimes, no action is required.
33 if (lhs->mode.type == rhs->mode.type && lhs->mode.len == rhs->mode.len) {
34 return TRUE;
35 }
36 // Warn for possible precision loss.
37 if (lhs->mode.type == REAL && rhs->mode.type == REAL) {
38 if (lhs->mode.len < rhs->mode.len) {
39 PRECISION_LOSS (601, qtype (&(rhs->mode)), qtype (&(lhs->mode)));
40 }
41 }
42 if (lhs->mode.type == COMPLEX && rhs->mode.type == COMPLEX) {
43 if (lhs->mode.len < rhs->mode.len) {
44 PRECISION_LOSS (602, qtype (&(rhs->mode)), qtype (&(lhs->mode)));
45 }
46 }
47 if (lhs->mode.type == COMPLEX && rhs->mode.type == REAL) {
48 if (lhs->mode.len < 2 * rhs->mode.len) {
49 PRECISION_LOSS (603, qtype (&(rhs->mode)), qtype (&(lhs->mode)));
50 }
51 }
52 if (lhs->mode.type == REAL && rhs->mode.type == COMPLEX) {
53 if (2 * lhs->mode.len < rhs->mode.len) {
54 PRECISION_LOSS (604, qtype (&(rhs->mode)), qtype (&(lhs->mode)));
55 }
56 }
57 // Insert coercions.
58 if (lhs->mode.type == REAL && lhs->mode.len == 32) {
59 if (rhs->mode.type == REAL) {
60 switch (rhs->mode.len) {
61 case 4: _srecordf (lhs->str, "flttox (%s)", rhs->str); break;
62 case 8: _srecordf (lhs->str, "dbltox (%s)", rhs->str); break;
63 case 16: _srecordf (lhs->str, "quadtox (%s)", rhs->str); break;
64 }
65 return TRUE;
66 } else if (rhs->mode.type == INTEGER) {
67 switch (rhs->mode.len) {
68 case 2: _srecordf (lhs->str, "inttox (%s)", rhs->str); break;
69 case 4: _srecordf (lhs->str, "inttox (%s)", rhs->str); break;
70 case 8: _srecordf (lhs->str, "quadtox (%s)", rhs->str); break;
71 }
72 return TRUE;
73 } else {
74 return FALSE;
75 }
76 } else if (lhs->mode.type == COMPLEX && lhs->mode.len == 64) {
77 if (rhs->mode.type == COMPLEX) {
78 switch (rhs->mode.len) {
79 case 8: _srecordf (lhs->str, "cxflt (%s)", rhs->str); break;
80 case 16: _srecordf (lhs->str, "cxdbl (%s)", rhs->str); break;
81 case 32: _srecordf (lhs->str, "cxquad (%s)", rhs->str); break;
82 }
83 return TRUE;
84 } else if (rhs->mode.type == REAL) {
85 switch (rhs->mode.len) {
86 case 4: _srecordf (lhs->str, "cxdbl (CMPLX (%s, 0.0))", rhs->str); break;
87 case 8: _srecordf (lhs->str, "cxdbl (CMPLX (%s, 0.0))", rhs->str); break;
88 case 16: _srecordf (lhs->str, "cxquad (CMPLXQ (%s, 0.0q))", rhs->str); break;
89 case 32: _srecordf (lhs->str, "cxreal32 (%s)", rhs->str); break;
90 }
91 return TRUE;
92 } else if (rhs->mode.type == INTEGER) {
93 switch (rhs->mode.len) {
94 case 2: _srecordf (lhs->str, "%s = cxdbl (CMPLX (%s, 0.0))", rhs->str); break;
95 case 4: _srecordf (lhs->str, "%s = cxdbl (CMPLX (%s, 0.0))", rhs->str); break;
96 case 8: _srecordf (lhs->str, "%s = cxquad (CMPLXQ (%s, 0.0q))", rhs->str); break;
97 }
98 return TRUE;
99 } else {
100 return FALSE;
101 }
102 } else if (rhs->mode.type == REAL && rhs->mode.len == 32) {
103 if (lhs->mode.type == COMPLEX) {
104 switch (lhs->mode.len) {
105 case 8: _srecordf (lhs->str, "xtoflt (%s)", rhs->str); break;
106 case 16: _srecordf (lhs->str, "xtodbl (%s)", rhs->str); break;
107 case 32: _srecordf (lhs->str, "xtoquad (%s)", rhs->str); break;
108 }
109 return TRUE;
110 } else if (lhs->mode.type == REAL) {
111 switch (lhs->mode.len) {
112 case 4: _srecordf (lhs->str, "xtoflt (%s)", rhs->str); break;
113 case 8: _srecordf (lhs->str, "xtodbl (%s)", rhs->str); break;
114 case 16: _srecordf (lhs->str, "xtoquad (%s)", rhs->str); break;
115 }
116 return TRUE;
117 } else if (lhs->mode.type == INTEGER) {
118 switch (lhs->mode.len) {
119 case 2: _srecordf (lhs->str, "(int_2) _xint8 (%s)", rhs->str); break;
120 case 4: _srecordf (lhs->str, "(int_4) _xint8 (%s)", rhs->str); break;
121 case 8: _srecordf (lhs->str, "_xint8 (%s)", rhs->str); break;
122 }
123 return TRUE;
124 } else {
125 return FALSE;
126 }
127 } else if (rhs->mode.type == COMPLEX && rhs->mode.len == 64) {
128 if (lhs->mode.type == COMPLEX) {
129 switch (lhs->mode.len) {
130 case 8: _srecordf (lhs->str, "CMPLX (xtodbl (cxreal (%s)), xtodbl (cximag (%s)))", rhs->str, rhs->str); break;
131 case 16: _srecordf (lhs->str, "CMPLX (xtodbl (cxreal (%s)), xtodbl (cximag (%s)))", rhs->str, rhs->str); break;
132 case 32: _srecordf (lhs->str, "CMPLXQ (xtoquad (cxreal (%s)), xtoquad (cximag (%s)))", rhs->str, rhs->str); break;
133 }
134 return TRUE;
135 } else if (lhs->mode.type == REAL) {
136 switch (lhs->mode.len) {
137 case 4: _srecordf (lhs->str, "xtoflt (cxreal (%s))", rhs->str); break;
138 case 8: _srecordf (lhs->str, "xtodbl (cxreal (%s))", rhs->str); break;
139 case 16: _srecordf (lhs->str, "xtoquad (cxreal (%s))", rhs->str); break;
140 }
141 return TRUE;
142 } else if (lhs->mode.type == INTEGER) {
143 switch (lhs->mode.len) {
144 case 2: _srecordf (lhs->str, "(int_2) _xint8 (cxreal (%s))", rhs->str); break;
145 case 4: _srecordf (lhs->str, "(int_4) _xint8 (cxreal (%s))", rhs->str); break;
146 case 8: _srecordf (lhs->str, "_xint8 (cxreal (%s))", rhs->str); break;
147 }
148 return TRUE;
149 } else {
150 return FALSE;
151 }
152 } else if (rhs->mode.type == COMPLEX && rhs->mode.len == 32) {
153 if (lhs->mode.type == COMPLEX) {
154 switch (lhs->mode.len) {
155 case 64: _srecordf (lhs->str, "CMPLXX (xtoquad (crealq (%s)), xtoquad (cimagq (%s)))", rhs->str, rhs->str); break;
156 }
157 return TRUE;
158 } else if (lhs->mode.type == REAL) {
159 switch (lhs->mode.len) {
160 case 4: _srecordf (lhs->str, "(real_4) (crealq (%s))", rhs->str); break;
161 case 8: _srecordf (lhs->str, "(real_8) (crealq (%s))", rhs->str); break;
162 case 16: _srecordf (lhs->str, "crealq (%s)", rhs->str); break;
163 }
164 return TRUE;
165 } else if (lhs->mode.type == INTEGER) {
166 switch (lhs->mode.len) {
167 case 2: _srecordf (lhs->str, "(int_2) (crealq (%s))", rhs->str); break;
168 case 4: _srecordf (lhs->str, "(int_4) (crealq (%s))", rhs->str); break;
169 case 8: _srecordf (lhs->str, "(int_8) (crealq (%s))", rhs->str); break;
170 }
171 return TRUE;
172 } else {
173 return FALSE;
174 }
175 } else if (rhs->mode.type == COMPLEX && rhs->mode.len == 16) {
176 if (lhs->mode.type == COMPLEX) {
177 switch (lhs->mode.len) {
178 case 64: _srecordf (lhs->str, "CMPLXX (_xtodbl (creal (%s)), _xtodbl (cimag (%s)))", rhs->str, rhs->str); break;
179 }
180 return TRUE;
181 } else if (lhs->mode.type == REAL) {
182 switch (lhs->mode.len) {
183 case 4: _srecordf (lhs->str, "(real_4) (creal (%s))", rhs->str); break;
184 case 8: _srecordf (lhs->str, "(real_8) (creal (%s))", rhs->str); break;
185 case 16: _srecordf (lhs->str, "creal (%s)", rhs->str); break;
186 }
187 return TRUE;
188 } else if (lhs->mode.type == INTEGER) {
189 switch (lhs->mode.len) {
190 case 2: _srecordf (lhs->str, "(int_2) (creal (%s))", rhs->str); break;
191 case 4: _srecordf (lhs->str, "(int_4) (creal (%s))", rhs->str); break;
192 case 8: _srecordf (lhs->str, "(int_8) (creal (%s))", rhs->str); break;
193 }
194 return TRUE;
195 } else {
196 return FALSE;
197 }
198 } else if (rhs->mode.type == COMPLEX && rhs->mode.len == 8) {
199 if (lhs->mode.type == COMPLEX) {
200 switch (lhs->mode.len) {
201 case 64: _srecordf (lhs->str, "CMPLXX (_xtoflt (crealf (%s)), _xtoflt (cimagf (%s)))", rhs->str, rhs->str); break;
202 }
203 return TRUE;
204 } else if (lhs->mode.type == REAL) {
205 switch (lhs->mode.len) {
206 case 4: _srecordf (lhs->str, "(real_4) (crealf (%s))", rhs->str); break;
207 case 8: _srecordf (lhs->str, "(real_8) (crealf (%s))", rhs->str); break;
208 case 16: _srecordf (lhs->str, "(real_16) (crealf (%s))", rhs->str); break;
209 }
210 return TRUE;
211 } else if (lhs->mode.type == INTEGER) {
212 switch (lhs->mode.len) {
213 case 2: _srecordf (lhs->str, "(int_2) (crealf (%s))", rhs->str); break;
214 case 4: _srecordf (lhs->str, "(int_4) (crealf (%s))", rhs->str); break;
215 case 8: _srecordf (lhs->str, "(int_8) (crealf (%s))", rhs->str); break;
216 }
217 return TRUE;
218 } else {
219 return FALSE;
220 }
221 } else if (lhs->mode.type == INTEGER && lhs->mode.len == 4 && rhs->mode.type == CHARACTER) {
222 _srecordf (lhs->str, "_str_to_int4 (%s)", rhs->str);
223 return TRUE;
224 } else if (lhs->mode.type == REAL && lhs->mode.len == 8 && rhs->mode.type == CHARACTER) {
225 _srecordf (lhs->str, "_str_to_real8 (%s)", rhs->str);
226 return TRUE;
227 }
228 return TRUE; // Assume no action required.
229 }
|
© 2002-2025 J.M. van der Veer (jmvdveer@xs4all.nl)
|
