assign.c
1 //! @file assign.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 //! Compile assignment statements.
25
26 #include <vif.h>
27
28 void assign (EXPR * reg)
29 {
30 #define ASSIGN_ERROR(s) {\
31 RECORD str;\
32 _srecordf (str, "%s = %s", qtype (&(lhs.mode)), qtype (&(rhs.mode)));\
33 ERROR (101, (s), str);\
34 return;\
35 }
36 int_4 rc;
37 EXPR lhs, rhs;
38 memset (&lhs, 0, sizeof (lhs));
39 memset (&rhs, 0, sizeof (rhs));
40 lhs_factor = TRUE;
41 factor (&lhs);
42 lhs_factor = FALSE;
43 if (lhs.variant != EXPR_VAR && lhs.variant != EXPR_SLICE && lhs.variant != EXPR_SUBSTR) {
44 ERROR (102, "invalid lhs in assignment", lhs.str);
45 skip_card (FALSE);
46 return;
47 }
48 if (lhs.variant == EXPR_VAR) {
49 IDENT *idf = impl_decl (lhs.str, NO_MODE);
50 if (idf != NO_IDENT && IS_ROW (idf->mode)) {
51 ERROR (103, "cannot assign to dimensioned variable", curlex);
52 skip_card (FALSE);
53 return;
54 }
55 }
56 rc = scan (EXPECT_NONE);
57 if (TOKEN ("=")) {
58 rc = scan (EXPECT_NONE);
59 exprio (&rhs, 1, TRUE);
60 (void) fold_expr (&rhs, rhs.mode.type);
61 rc = scan (EXPECT_NONE);
62 } else {
63 EXPECT (104, "=");
64 }
65 // Warn for precision loss.
66 if (lhs.mode.type == REAL && rhs.mode.type == REAL) {
67 if (lhs.mode.len < rhs.mode.len) {
68 PRECISION_LOSS (105, qtype (&(rhs.mode)), qtype (&(lhs.mode)));
69 }
70 }
71 if (lhs.mode.type == COMPLEX && rhs.mode.type == COMPLEX) {
72 if (lhs.mode.len < rhs.mode.len) {
73 PRECISION_LOSS (106, qtype (&(rhs.mode)), qtype (&(lhs.mode)));
74 }
75 }
76 if (lhs.mode.type == COMPLEX && rhs.mode.type == REAL) {
77 if (lhs.mode.len < 2 * rhs.mode.len) {
78 PRECISION_LOSS (107, qtype (&(rhs.mode)), qtype (&(lhs.mode)));
79 }
80 }
81 // Assign.
82 if (strcmp (lhs.str, rhs.str) == 0) {
83 // Peephole.
84 _srecordf (reg->str, "/* %s = %s */", lhs.str, rhs.str);
85 } else if (lhs.mode.type == CHARACTER && rhs.mode.type == CHARACTER) {
86 // character*n = character*m; m <= n
87 if (lhs.variant == EXPR_SUBSTR) {
88 _srecordf (reg->str, "bufrep (%s, %s)", lhs.str, rhs.str);
89 } else if (lhs.mode.len == 0) {
90 // _srecordf (reg->str, "bufcpy (%s, %s, MAX_STRLEN)", lhs.str, rhs.str);
91 _srecordf (reg->str, "strcpy (%s, %s)", lhs.str, rhs.str);
92 } else {
93 _srecordf (reg->str, "bufcpy (%s, %s, %d)", lhs.str, rhs.str, lhs.mode.len);
94 }
95 } else if (lhs.mode.type == rhs.mode.type && lhs.mode.len == rhs.mode.len) {
96 // same type, length assignment
97 _srecordf (reg->str, "%s = %s", lhs.str, rhs.str);
98 } else if (rhs.variant == EXPR_CONST && rhs.mode.type == INTEGER && lhs.mode.type == INTEGER) {
99 // INTEGER length denotations overlap.
100 factor_integer_number (&rhs, rhs.str);
101 if (rhs.mode.len > lhs.mode.len) {
102 MODE_ERROR (108, qtype (&(rhs.mode)), qtype (&(lhs.mode)));
103 }
104
105 /*
106 int_8 val = strtoll (rhs.str, NO_REF_TEXT, 10);
107 int_4 lenval;
108 if (val >= SHRT_MIN && val <= SHRT_MAX) {
109 lenval = 2;
110 } else if (val >= INT_MIN && val <= INT_MAX) {
111 lenval = 4;
112 } else if (val >= LLONG_MIN && val <= LLONG_MAX) {
113 lenval = 8;
114 }
115 if (lenval > lhs.mode.len) {
116 MODE_ERROR (108, qtype (&(rhs.mode)), qtype (&(lhs.mode)));
117 }
118 */
119 _srecordf (reg->str, "%s = %s", lhs.str, rhs.str);
120 } else if (lhs.mode.type == REAL && lhs.mode.len == 32) {
121 if (rhs.mode.type == REAL) {
122 // real*32 = real
123 if (rhs.variant == EXPR_CONST) {
124 _srecordf (rhs.str, "_dc_%d", code_real_32_const (pretty_float (rhs.str)));
125 _srecordf (reg->str, "%s = %s", lhs.str, rhs.str);
126 } else {
127 switch (rhs.mode.len) {
128 case 4: _srecordf (reg->str, "%s = flttox (%s)", lhs.str, rhs.str); break;
129 case 8: _srecordf (reg->str, "%s = dbltox (%s)", lhs.str, rhs.str); break;
130 case 16: _srecordf (reg->str, "%s = _quadtox (%s)", lhs.str, rhs.str); break;
131 }
132 }
133 } else if (rhs.mode.type == INTEGER) {
134 // real*32 = integer
135 switch (rhs.mode.len) {
136 case 2: _srecordf (reg->str, "%s = inttox (%s)", lhs.str, rhs.str); break;
137 case 4: _srecordf (reg->str, "%s = inttox (%s)", lhs.str, rhs.str); break;
138 case 8: _srecordf (reg->str, "%s = _quadtox (%s)", lhs.str, rhs.str); break;
139 }
140 } else {
141 ASSIGN_ERROR ("incompatible assignment")
142 }
143 } else if (lhs.mode.type == COMPLEX && lhs.mode.len == 64) {
144 if (rhs.mode.type == COMPLEX) {
145 // complex*64 = complex
146 switch (rhs.mode.len) {
147 case 8: _srecordf (reg->str, "%s = cxdbl (%s)", lhs.str, rhs.str); break;
148 case 16: _srecordf (reg->str, "%s = cxdbl (%s)", lhs.str, rhs.str); break;
149 case 32: _srecordf (reg->str, "%s = cxquad (%s)", lhs.str, rhs.str); break;
150 }
151 } else if (rhs.mode.type == REAL) {
152 // complex*64 = real
153 switch (rhs.mode.len) {
154 case 4: _srecordf (reg->str, "%s = cxdbl (CMPLX (%s, 0.0))", lhs.str, rhs.str); break;
155 case 8: _srecordf (reg->str, "%s = cxdbl (CMPLX (%s, 0.0))", lhs.str, rhs.str); break;
156 case 16: _srecordf (reg->str, "%s = cxquad (CMPLXQ (%s, 0.0q))", lhs.str, rhs.str); break;
157 case 32: _srecordf (reg->str, "%s = cxreal32 (%s)", lhs.str, rhs.str); break;
158 }
159 } else if (rhs.mode.type == INTEGER) {
160 // complex*64 = integer
161 switch (rhs.mode.len) {
162 case 2:
163 case 4: _srecordf (reg->str, "%s = cxdbl (CMPLX (%s, 0.0))", lhs.str, rhs.str); break;
164 case 8: _srecordf (reg->str, "%s = cxquad (CMPLXQ (%s, 0.0q))", lhs.str, rhs.str); break;
165 }
166 } else {
167 ASSIGN_ERROR ("incompatible assignment")
168 }
169 } else if (rhs.mode.type == REAL && rhs.mode.len == 32) {
170 if (lhs.mode.type == COMPLEX) {
171 // complex = real*32
172 switch (lhs.mode.len) {
173 case 8: _srecordf (reg->str, "%s = xtoflt (%s)", lhs.str, rhs.str); break;
174 case 16: _srecordf (reg->str, "%s = xtodbl (%s)", lhs.str, rhs.str); break;
175 case 32: _srecordf (reg->str, "%s = _xtoquad (%s)", lhs.str, rhs.str); break;
176 }
177 } else if (lhs.mode.type == REAL) {
178 // real = real*32
179 switch (lhs.mode.len) {
180 case 4: _srecordf (reg->str, "%s = xtoflt (%s)", lhs.str, rhs.str); break;
181 case 8: _srecordf (reg->str, "%s = xtodbl (%s)", lhs.str, rhs.str); break;
182 case 16: _srecordf (reg->str, "%s = _xtoquad (%s)", lhs.str, rhs.str); break;
183 }
184 } else if (lhs.mode.type == INTEGER) {
185 // integer = real*32
186 switch (lhs.mode.len) {
187 case 2: _srecordf (reg->str, "%s = (int_2) _xint8 (%s)", lhs.str, rhs.str); break;
188 case 4: _srecordf (reg->str, "%s = (int_4) _xint8 (%s)", lhs.str, rhs.str); break;
189 case 8: _srecordf (reg->str, "%s = _xint8 (%s)", lhs.str, rhs.str); break;
190 }
191 } else {
192 ASSIGN_ERROR ("incompatible assignment")
193 }
194 } else if (lhs.mode.type == INTEGER && lhs.mode.len == 4 && rhs.mode.type == CHARACTER) {
195 _srecordf (reg->str, "%s = _str_to_int4 (%s)", lhs.str, rhs.str);
196 } else if (lhs.mode.type == REAL && lhs.mode.len == 8 && rhs.mode.type == CHARACTER) {
197 _srecordf (reg->str, "%s = _str_to_real8 (%s)", lhs.str, rhs.str);
198 } else {
199 _srecordf (reg->str, "%s = %s", lhs.str, rhs.str);
200 // ASSIGN_ERROR ("incompatible assignment")
201 }
202 skip_card (TRUE);
203 (void) rc;
204 }
|
© 2002-2025 J.M. van der Veer (jmvdveer@xs4all.nl)
|
