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-2024 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 ();
46 return;
47 }
48 if (lhs.variant == EXPR_VAR) {
49 IDENT *idf = impl_decl (lhs.str, NULL);
50 if (idf != NULL && idf->mode.dim != 0) {
51 ERROR (103, "cannot assign to dimensioned variable", curlex);
52 skip_card ();
53 return;
54 }
55 }
56 rc = scan (NULL);
57 if (TOKEN ("=")) {
58 rc = scan (NULL);
59 exprio (&rhs, 1, TRUE);
60 (void) fold_expr (&rhs, rhs.mode.type);
61 rc = scan (NULL);
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 WARNING (105, "possible loss of precision", NULL);
69 }
70 }
71 if (lhs.mode.type == COMPLEX && rhs.mode.type == COMPLEX) {
72 if (lhs.mode.len != rhs.mode.len) {
73 WARNING (106, "possible loss of precision", NULL);
74 }
75 }
76 if (lhs.mode.type == COMPLEX && rhs.mode.type == REAL) {
77 if (lhs.mode.len != 2 * rhs.mode.len) {
78 WARNING (107, "possible loss of precision", NULL);
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 (lhs.mode.type == REAL && lhs.mode.len == 32) {
99 if (rhs.mode.type == REAL) {
100 // real*32 = real
101 if (rhs.variant == EXPR_CONST) {
102 _srecordf (rhs.str, "_dc_%d", code_real_32_const (pretty_float (rhs.str)));
103 _srecordf (reg->str, "%s = %s", lhs.str, rhs.str);
104 } else {
105 switch (rhs.mode.len) {
106 case 4: _srecordf (reg->str, "%s = flttox (%s)", lhs.str, rhs.str); break;
107 case 8: _srecordf (reg->str, "%s = dbltox (%s)", lhs.str, rhs.str); break;
108 case 16: _srecordf (reg->str, "%s = _quadtox (%s)", lhs.str, rhs.str); break;
109 }
110 }
111 } else if (rhs.mode.type == INTEGER) {
112 // real*32 = integer
113 switch (rhs.mode.len) {
114 case 2: _srecordf (reg->str, "%s = inttox (%s)", lhs.str, rhs.str); break;
115 case 4: _srecordf (reg->str, "%s = inttox (%s)", lhs.str, rhs.str); break;
116 case 8: _srecordf (reg->str, "%s = _quadtox (%s)", lhs.str, rhs.str); break;
117 }
118 } else {
119 ASSIGN_ERROR ("incompatible assignment")
120 }
121 } else if (lhs.mode.type == COMPLEX && lhs.mode.len == 64) {
122 if (rhs.mode.type == COMPLEX) {
123 // complex*64 = complex
124 switch (rhs.mode.len) {
125 case 8: _srecordf (reg->str, "%s = cxdbl (%s)", lhs.str, rhs.str); break;
126 case 16: _srecordf (reg->str, "%s = cxdbl (%s)", lhs.str, rhs.str); break;
127 case 32: _srecordf (reg->str, "%s = cxquad (%s)", lhs.str, rhs.str); break;
128 }
129 } else if (rhs.mode.type == REAL) {
130 // complex*64 = real
131 switch (rhs.mode.len) {
132 case 4: _srecordf (reg->str, "%s = cxdbl (CMPLX (%s, 0.0))", lhs.str, rhs.str); break;
133 case 8: _srecordf (reg->str, "%s = cxdbl (CMPLX (%s, 0.0))", lhs.str, rhs.str); break;
134 case 16: _srecordf (reg->str, "%s = cxquad (CMPLXQ (%s, 0.0q))", lhs.str, rhs.str); break;
135 case 32: _srecordf (reg->str, "%s = cxreal32 (%s)", lhs.str, rhs.str); break;
136 }
137 } else if (rhs.mode.type == INTEGER) {
138 // complex*64 = integer
139 switch (rhs.mode.len) {
140 case 2:
141 case 4: _srecordf (reg->str, "%s = cxdbl (CMPLX (%s, 0.0))", lhs.str, rhs.str); break;
142 case 8: _srecordf (reg->str, "%s = cxquad (CMPLXQ (%s, 0.0q))", lhs.str, rhs.str); break;
143 }
144 } else {
145 ASSIGN_ERROR ("incompatible assignment")
146 }
147 } else if (rhs.mode.type == REAL && rhs.mode.len == 32) {
148 if (lhs.mode.type == COMPLEX) {
149 // complex = real*32
150 switch (lhs.mode.len) {
151 case 8: _srecordf (reg->str, "%s = xtoflt (%s)", lhs.str, rhs.str); break;
152 case 16: _srecordf (reg->str, "%s = xtodbl (%s)", lhs.str, rhs.str); break;
153 case 32: _srecordf (reg->str, "%s = _xtoquad (%s)", lhs.str, rhs.str); break;
154 }
155 } else if (lhs.mode.type == REAL) {
156 // real = real*32
157 switch (lhs.mode.len) {
158 case 4: _srecordf (reg->str, "%s = xtoflt (%s)", lhs.str, rhs.str); break;
159 case 8: _srecordf (reg->str, "%s = xtodbl (%s)", lhs.str, rhs.str); break;
160 case 16: _srecordf (reg->str, "%s = _xtoquad (%s)", lhs.str, rhs.str); break;
161 }
162 } else if (lhs.mode.type == INTEGER) {
163 // integer = real*32
164 switch (lhs.mode.len) {
165 case 2: _srecordf (reg->str, "%s = (int_2) _xint8 (%s)", lhs.str, rhs.str); break;
166 case 4: _srecordf (reg->str, "%s = (int_4) _xint8 (%s)", lhs.str, rhs.str); break;
167 case 8: _srecordf (reg->str, "%s = _xint8 (%s)", lhs.str, rhs.str); break;
168 }
169 } else {
170 ASSIGN_ERROR ("incompatible assignment")
171 }
172 } else if (lhs.mode.type == INTEGER && lhs.mode.len == 4 && rhs.mode.type == CHARACTER) {
173 _srecordf (reg->str, "%s = _int4 (%s)", lhs.str, rhs.str);
174 } else {
175 _srecordf (reg->str, "%s = %s", lhs.str, rhs.str);
176 // ASSIGN_ERROR ("incompatible assignment")
177 }
178 skip_card_expr ();
179 (void) rc;
180 }
|
© 2002-2024 J.M. van der Veer (jmvdveer@xs4all.nl)
|
