code.c
1 //! @file code.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 //! Routines to emit C object code.
25
26 #include <vif.h>
27
28 #undef LIST_IMPLICIT
29
30 #define MAX_UNIQ_STR 5000
31 static char *uniq_str[MAX_UNIQ_STR];
32 static int_4 uniq_index[MAX_UNIQ_STR];
33 static int_4 n_uniq_str = 0;
34 static int_4 n_dc = 0;
35
36 int_4 code_uniq_str (char *nstr)
37 {
38 int_4 k;
39 for (k = 0; k < n_uniq_str; k++) {
40 if (strcmp (nstr, uniq_str[k]) == 0) {
41 return uniq_index[k];
42 }
43 }
44 if (k == MAX_UNIQ_STR) {
45 OVERFLOW (501, "code_uniq_str");
46 }
47 RECORD idf, str;
48 int_4 rc = n_dc;
49 uniq_index[n_uniq_str] = rc;
50 _srecordf (idf, "_dc_%d", n_dc++);
51 _srecordf (str, "#define %s %s", idf, nstr);
52 code (0, STRINGS, str);
53 code (0, STRINGS, "\n");
54 uniq_str[n_uniq_str++] = stralloc (nstr);
55 return rc;
56 }
57
58 char *get_uniq_str (char *dc, char *buf)
59 {
60 for (int_4 k = 0; k < n_uniq_str; k++) {
61 RECORD idf;
62 _srecordf (idf, "_dc_%d", uniq_index[k]);
63 if (strcmp (idf, dc) == 0) {
64 int_4 j;
65 for (j = 1; j < strlen (uniq_str[k]) - 1; j++) {
66 buf[j - 1] = uniq_str[k][j];
67 }
68 buf[j] = '\0';
69 return buf;
70 }
71 }
72 return NULL;
73 }
74
75 int_4 code_real_32_const (char *num)
76 {
77 RECORD str;
78 int_4 rc = n_dc;
79 _srecordf (str, "real_32 _dc_%d = { // %s\n", n_dc++, curlex);
80 code (0, CONSTANTS, str);
81 real_32 x = atox (num);
82 for (int_4 k = 0; k <= FLT256_LEN; k++) {
83 if (k < FLT256_LEN) {
84 _srecordf (str, "0x%04x,", (x.value)[k]);
85 } else {
86 _srecordf (str, "0x%04x", (x.value)[k]);
87 }
88 code (0, CONSTANTS, str);
89 if ((k + 1) % 4 == 0) {
90 code (0, CONSTANTS, "\n");
91 }
92 }
93 code (0, CONSTANTS, "};");
94 code (0, CONSTANTS, "\n");
95 code (0, CONSTANTS, "\n");
96 return rc;
97 }
98
99 int_4 code (int_4 proc, int_4 phase, char *str)
100 {
101 if (n_c_src >= MAX_C_SRC) {
102 MAX_C_SRC += INCREMENT;
103 object = (C_SRC *) f_realloc (object, MAX_C_SRC * sizeof (C_SRC));
104 }
105 // Add to list.
106 C_SRC *lin = &object[n_c_src];
107 int_4 patch = n_c_src;
108 lin->text = stralloc (str);
109 lin->phase = phase;
110 lin->proc = proc;
111 n_c_src++;
112 return patch;
113 }
114
115 void cpp_direct (int_4 proc, int_4 lin, int_4 phase)
116 {
117 if (!gcc_ftn_lines) {
118 return;
119 }
120 if (source[lin].cpp == FALSE) {
121 RECORD str;
122 char *q = source[lin].text;
123 if (q != NULL) {
124 for (int_4 k = 0; q[k] != '\0' && k < 5; k++) {
125 q++;
126 }
127 while (q[0] != '\0' && q[0] == ' ') {
128 q++;
129 }
130 RECORD edit;
131 int_4 n = 0, m = 0;
132 while (q[n] != '\0') {
133 if (q[n] == '"') {
134 edit[m++] = '\\';
135 } else if (q[n] == '%') {
136 edit[m++] = '%';
137 }
138 edit[m++] = q[n++];
139 }
140 edit[m] = '\0';
141 RECORD loc;
142 _srecordf (loc, "** %-10s ** isn %d %s", modnam, source[lin].isn, edit);
143 _srecordf (str, "# line %d \"%s\"", source[lin].num, loc);
144 code (proc, phase, str);
145 if (trace) {
146 _srecordf (str, "~fprintf (stderr, \"%s\\n\");", loc);
147 code (proc, phase, str);
148 code (proc, phase, "\n");
149 }
150 }
151 source[lin].cpp = TRUE;
152 }
153 }
154
155 static int_4 idf_code (IDENT *idf, int_4 save, int_4 src)
156 {
157 // Must we declare this identifier?
158 if (idf == NULL) {
159 return FALSE; // Oops!
160 }
161 if (idf->mode.save != save || idf->source != src) {
162 return FALSE; // Wrong category
163 }
164 if (idf->parm != NULL) {
165 return FALSE; // Parameter to subprogram
166 }
167 if (idf->external || idf->intrinsic) {
168 return FALSE; // Otherwise declared
169 }
170 if (idf->nest > 0) {
171 return FALSE; // Macro parameter, declared inline
172 }
173 return TRUE;
174 }
175
176 void code_one_type (IDENT * table, int_4 M, int_4 type, int_4 len, int_4 blck, int_4 proc, int_4 save, int_4 src, int_4 phase)
177 {
178 int_4 k, N;
179 for (k = 0, N = 0; k < M; k++) {
180 IDENT *idf = &table[k];
181 if (idf_code (idf, save, src)) {
182 if (idf->const_ref) {
183 ;
184 } else if (idf->alias != NULL && idf->mode.type == type && idf->mode.len == len) {
185 N++;
186 } else if (!idf->arg && idf->mode.type == type && idf->mode.len == len && idf->common == blck) {
187 N++;
188 }
189 }
190 }
191 if (N > 0) {
192 RECORD str;
193 MODE mode = (MODE) {.type = type,.len = len,.dim = 0 };
194 if (table == locals && (save == STATIC && src == SOURCE)) {
195 _srecordf (str, "static %s ", wtype (&mode, NOARG, NOFUN));
196 } else {
197 _srecordf (str, "%s ", wtype (&mode, NOARG, NOFUN));
198 }
199 code (proc, phase, str);
200 for (k = 0; k < M; k++) {
201 IDENT *idf = &table[k];
202 if (idf_code (idf, save, src)) {
203 if (idf->const_ref) {
204 ;
205 } else if (idf->alias != NULL && idf->mode.type == type && idf->mode.len == len) {
206 code (proc, phase, ptr_to_array (idf, NOCONST, NOCAST, ACTUAL));
207 if (--N > 0) {
208 code (proc, phase, ", ");
209 }
210 } else if (!idf->arg && idf->mode.type == type && idf->mode.len == len && idf->common == blck) {
211 str[0] = '\0';
212 if (idf->mode.dim > 0) {
213 RECORD buf;
214 str[0] = '\0';
215 for (int_4 n = 0; n < idf->mode.dim; n++) {
216 if (EQUAL (idf->len[n], "VARY")) {
217 ERROR (502, "only argument arrays can vary", NULL);
218 buf[0] = '\0';
219 } else {
220 fold_int_4 (buf, idf->len[n]);
221 }
222 if (isint_4 (buf, NULL)) {
223 bufcat (str, buf, RECLN);
224 } else {
225 bufcat (str,"(", RECLN);
226 bufcat (str, buf, RECLN);
227 bufcat (str,")", RECLN);
228 }
229 if (n < idf->mode.dim - 1) {
230 bufcat (str, " * ", RECLN);
231 }
232 }
233 fold_int_4 (buf, str);
234 _srecordf (str, "%s[%s]", CID (idf), buf);
235 code (proc, phase, str);
236 } else {
237 code (proc, phase, CID (idf));
238 }
239 if (--N > 0) {
240 code (proc, phase, ", ");
241 }
242 }
243 }
244 }
245 code (proc, phase, ";\n");
246 }
247 }
248
249 void code_idfs (IDENT * table, int_4 M, int_4 blck, int_4 proc, int_4 phase)
250 {
251 for (int_4 n = STATIC; n <= AUTOMATIC; n++) {
252 for (int_4 m = SOURCE; m <= TEMP; m++) {
253 code_one_type (table, M, INTEGER, 2, blck, proc, n, m, phase);
254 code_one_type (table, M, INTEGER, 4, blck, proc, n, m, phase);
255 code_one_type (table, M, INTEGER, 8, blck, proc, n, m, phase);
256 code_one_type (table, M, LOGICAL, 4, blck, proc, n, m, phase);
257 code_one_type (table, M, REAL, 4, blck, proc, n, m, phase);
258 code_one_type (table, M, REAL, 8, blck, proc, n, m, phase);
259 code_one_type (table, M, REAL, 16, blck, proc, n, m, phase);
260 code_one_type (table, M, REAL, 32, blck, proc, n, m, phase);
261 code_one_type (table, M, COMPLEX, 8, blck, proc, n, m, phase);
262 code_one_type (table, M, COMPLEX, 16, blck, proc, n, m, phase);
263 code_one_type (table, M, COMPLEX, 32, blck, proc, n, m, phase);
264 code_one_type (table, M, COMPLEX, 64, blck, proc, n, m, phase);
265 for (int_4 k = 0, len = 2; k < MAX_STRLENS; k++, len *= 2) {
266 if (strlens[k]) {
267 code_one_type (table, M, CHARACTER, len - 1, blck, proc, n, m, phase);
268 }
269 }
270 }
271 }
272 }
273
274 void code_common (void)
275 {
276 int_4 k;
277 for (k = EXTERN + 1; k < ncommons; k++) {
278 RECORD name;
279 code (0, COMMON, "\n");
280 _srecordf (name, "// common /%s/\n", commons[k]);
281 code (0, COMMON, name);
282 _srecordf (name, "static struct {\n");
283 code (0, COMMON, name);
284 code_idfs (globals, nglobals, k, 0, COMMON);
285 _srecordf (name, "} %s;\n", commons[k]);
286 code (0, COMMON, name);
287 }
288 }
289
290 void code_exts (IDENT * table, int_4 M, int_4 eblck, int_4 proc, int_4 phase)
291 {
292 int_4 k;
293 (void) eblck;
294 for (k = 0; k < M; k++) {
295 IDENT *idf = &table[k];
296 if (idf->external && idf->arg == NOARG) {
297 if (!find_module (CID (idf))) { // Avoid prototype error.
298 RECORD str;
299 MODE *mode = &(idf->mode);
300 if (!idf->used) {
301 code (proc, phase, "// ");
302 }
303 _srecordf (str, "extern %s %s ();\n", wtype (mode, NOARG, NOFUN), edit_f (CID (idf)));
304 code (proc, phase, str);
305 }
306 }
307 }
308 }
309
310 void code_arrlen (IDENT * idf)
311 {
312 int_4 k, tlen = 1, npack = 0;
313 RECORD pack, str;
314 pack[0] = '\0';
315 for (k = 0; k < idf->mode.dim; k++) {
316 int_4 len;
317 if (EQUAL (idf->len[k], "VARY")) {
318 ERROR (503, "array has varying size", NULL);
319 } else if (isint_4 (idf->len[k], &len)) {
320 tlen *= len;
321 } else {
322 if (npack > 0) {
323 bufcat (pack, " * ", RECLN);
324 }
325 bufcat (pack, "(", RECLN);
326 bufcat (pack, idf->len[k], RECLN);
327 bufcat (pack, ")", RECLN);
328 npack++;
329 }
330 }
331 if (tlen == 1 && npack > 0) {
332 _srecordf (str, "%s", pack);
333 } else if (npack == 0) {
334 _srecordf (str, "%d", tlen);
335 } else {
336 _srecordf (str, "%d * %s", tlen, pack);
337 }
338 code (nprocs, BODY, str);
339 }
340
341 void proc_listing (int_4 proc)
342 {
343 int_4 k, n, l_i, l_f;
344 RECORD lin;
345 code (nprocs, SYMBOLS, newpage (modnam, "symbol-table"));
346 #if defined (LIST_IMPLICIT)
347 // Implicit modes
348 strcpy (lin, "// ");
349 for (k = ord ('a'); k <= ord ('z'); k++) {
350 RECORD str;
351 _srecordf (str, "'%c' %-12s", 'a' + k, qtype (&implic[k].mode));
352 bufcat (lin, str, RECLN);
353 if ((k + 1) % 6 == 0) {
354 bufcat (lin, "\n", RECLN);
355 code (nprocs, SYMBOLS, lin);
356 strcpy (lin, "// ");
357 }
358 }
359 code (nprocs, SYMBOLS, lin);
360 code (nprocs, SYMBOLS, "\n");
361 #endif
362 // Local variables
363 if (nlocals > 0) {
364 for (k = 0; k < nlocals; k++) {
365 IDENT *idf = &locals[k];
366 if (idf->source != SOURCE || idf->external || idf->intrinsic) {
367 continue;
368 }
369 RECORD str;
370 _srecordf (lin, "// line %6d %4s %-12s %-8s", idf->line, (idf->mode.save == STATIC ? "save" : "auto"), qtype (&idf->mode), CID (idf));
371 for (n = 0; n < idf->mode.dim; n++) {
372 _srecordf (str, " (%s, %s)", idf->lwb[n], idf->upb[n]);
373 bufcat (lin, str, RECLN);
374 }
375 if (idf->parm != NULL) {
376 bufcat (lin, " parm", RECLN);
377 } else if (idf->used) {
378 bufcat (lin, " used", RECLN);
379 } else {
380 bufcat (lin, " idle", RECLN);
381 }
382 if (idf->alias != NULL) {
383 _srecordf (str, " aliased to %s", CID (idf->alias));
384 bufcat (lin, str, RECLN);
385 }
386 if (idf->equiv != NULL) {
387 _srecordf (str, " aliased from %s", CID (idf->equiv));
388 bufcat (lin, str, RECLN);
389 }
390 if (idf->parm != NULL) {
391 _srecordf (str, " = %s", idf->parm);
392 bufcat (lin, str, RECLN);
393 }
394 code (nprocs, SYMBOLS, lin);
395 }
396 code (nprocs, SYMBOLS, "\n");
397 }
398 if (nlabels > 0) {
399 for (k = 1; k < nlabels; k++) {
400 LBL *L = &labels[k];
401 if (L->jumped > 0) {
402 _srecordf (lin, "// label %5d %5d in line %5d, goto\n", L->index, L->num, L->line);
403 } else if (L->nonexe) {
404 _srecordf (lin, "// label %5d %5d in line %5d, non-executable\n", L->index, L->num, L->line);
405 } else {
406 _srecordf (lin, "// label %5d %5d in line %5d\n", L->index, L->index, L->line);
407 }
408 code (nprocs, SYMBOLS, lin);
409 }
410 code (nprocs, SYMBOLS, "\n");
411 }
412 // Unclassified comments need a place.
413 int_4 xproc = nprocs;
414 int_4 lisn = curlin;
415 if (source[lisn].isn != 0) {
416 // If there is next module, delay comments after 'END' to the next module.
417 // We assume they belong there.
418 lisn--;
419 while (lisn >= 0 && source[lisn].isn == 0) {
420 source[lisn].proc = 0;
421 lisn--;
422 }
423 }
424 // Now assign comments to a module.
425 for (k = lisn; k >= 0; k--) {
426 FTN_LINE *flin = &source[k];
427 if (xproc > 1 && flin->proc > 0 && flin->proc < xproc) {
428 xproc = flin->proc;
429 }
430 if (flin->text != NULL && IS_COMMENT (flin->text[0]) && flin->proc == 0) {
431 flin->proc = xproc;
432 }
433 }
434 //
435 l_i = l_f = ERR;
436 for (k = 1; k < nftnlines && l_i == ERR; k++) {
437 FTN_LINE *flin = &source[k];
438 if (flin->proc == proc) {
439 l_i = k;
440 }
441 }
442 for (k = nftnlines - 1; k >= 1 && l_f == ERR; k--) {
443 FTN_LINE *flin = &source[k];
444 if (flin->proc == proc) {
445 l_f = k;
446 }
447 }
448 code (nprocs, LIST, newpage (modnam, "source-code"));
449 for (k = l_i; k <= l_f; k++) {
450 FTN_LINE *flin = &source[k];
451 RECORD lrec;
452 if (flin->isn > 0) {
453 if (flin->inc > 0) {
454 _srecordf (lrec, "// %1d%5d %6d %s\n", flin->inc, flin->num, flin->isn, flin->text);
455 } else {
456 _srecordf (lrec, "// %6d %6d %s\n", flin->num, flin->isn, flin->text);
457 }
458 } else {
459 if (flin->inc > 0) {
460 _srecordf (lrec, "// %1d%5d %s\n", flin->inc, flin->num, flin->text);
461 } else {
462 _srecordf (lrec, "// %6d %s\n", flin->num, flin->text);
463 }
464 }
465 code (nprocs, LIST, lrec);
466 }
467 }
468
|
© 2002-2024 J.M. van der Veer (jmvdveer@xs4all.nl)
|
