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