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 RECORD idf, 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 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 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 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 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 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 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 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 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 RECORD str;
298 MODE *mode = &(idf->mode);
299 if (!idf->used) {
300 code (proc, phase, "// ");
301 }
302 _srecordf (str, "extern %s %s ();\n", wtype (mode, NOARG, NOFUN), edit_f (C_NAME (idf)));
303 code (proc, phase, str);
304 }
305 }
306 }
307 }
308
309 void code_row_len (IDENT * idf)
310 {
311 int_4 k, tlen = 1, npack = 0;
312 RECORD pack, str;
313 pack[0] = '\0';
314 for (k = 0; k < idf->mode.dim; k++) {
315 int_4 len;
316 if (EQUAL (idf->len[k], "VARY")) {
317 ERROR (503, "array has varying size", NO_TEXT);
318 } else if (isint_4 (idf->len[k], &len)) {
319 tlen *= len;
320 } else {
321 if (npack > 0) {
322 bufcat (pack, " * ", RECLN);
323 }
324 bufcat (pack, "(", RECLN);
325 bufcat (pack, idf->len[k], RECLN);
326 bufcat (pack, ")", RECLN);
327 npack++;
328 }
329 }
330 if (tlen == 1 && npack > 0) {
331 _srecordf (str, "%s", pack);
332 } else if (npack == 0) {
333 _srecordf (str, "%d", tlen);
334 } else {
335 _srecordf (str, "%d * %s", tlen, pack);
336 }
337 code (nprocs, BODY, str);
338 }
339
340 void proc_listing (int_4 proc)
341 {
342 int_4 k, n, l_i, l_f;
343 RECORD lin;
344 code (nprocs, SYMBOLS, newpage (modnam, "symbol-table"));
345 #if defined (LIST_IMPLICIT)
346 // Implicit modes
347 strcpy (lin, "// ");
348 for (k = ord ('a'); k <= ord ('z'); k++) {
349 RECORD str;
350 _srecordf (str, "'%c' %-12s", 'a' + k, qtype (&implic[k].mode));
351 bufcat (lin, str, RECLN);
352 if ((k + 1) % 6 == 0) {
353 bufcat (lin, "\n", RECLN);
354 code (nprocs, SYMBOLS, lin);
355 strcpy (lin, "// ");
356 }
357 }
358 code (nprocs, SYMBOLS, lin);
359 code (nprocs, SYMBOLS, "\n");
360 #endif
361 // Local variables
362 if (nlocals > 0) {
363 for (k = 0; k < nlocals; k++) {
364 IDENT *idf = &locals[k];
365 if (idf->source != SOURCE || idf->external || idf->intrinsic) {
366 continue;
367 }
368 RECORD str;
369 _srecordf (lin, "// line %6d %4s %-12s %-8s", idf->line, (idf->mode.save == STATIC ? "save" : "auto"), qtype (&idf->mode), C_NAME (idf));
370 for (n = 0; n < idf->mode.dim; n++) {
371 _srecordf (str, " (%s, %s)", idf->lwb[n], idf->upb[n]);
372 bufcat (lin, str, RECLN);
373 }
374 if (idf->parm != NO_TEXT) {
375 bufcat (lin, " parm", RECLN);
376 } else if (idf->used) {
377 bufcat (lin, " used", RECLN);
378 } else {
379 bufcat (lin, " idle", RECLN);
380 }
381 if (idf->alias != NO_IDENT) {
382 _srecordf (str, " aliased to %s", C_NAME (idf->alias));
383 bufcat (lin, str, RECLN);
384 }
385 if (idf->equiv != NO_IDENT) {
386 _srecordf (str, " aliased by %s", C_NAME (idf->equiv));
387 bufcat (lin, str, RECLN);
388 }
389 if (idf->parm != NO_TEXT) {
390 _srecordf (str, " = %s", idf->parm);
391 bufcat (lin, str, RECLN);
392 }
393 code (nprocs, SYMBOLS, lin);
394 }
395 code (nprocs, SYMBOLS, "\n");
396 }
397 if (nlabels > 0) {
398 for (k = 1; k < nlabels; k++) {
399 LBL *L = &labels[k];
400 if (L->jumped > 0) {
401 _srecordf (lin, "// label %5d %5d in line %5d, goto\n", L->index, L->num, L->line);
402 } else if (L->nonexe) {
403 _srecordf (lin, "// label %5d %5d in line %5d, non-executable\n", L->index, L->num, L->line);
404 } else {
405 _srecordf (lin, "// label %5d %5d in line %5d\n", L->index, L->index, L->line);
406 }
407 code (nprocs, SYMBOLS, lin);
408 }
409 code (nprocs, SYMBOLS, "\n");
410 }
411 // Unclassified comments need a place.
412 int_4 xproc = nprocs;
413 int_4 lisn = curlin;
414 if (source[lisn].isn != 0) {
415 // If there is next module, delay comments after 'END' to the next module.
416 // We assume they belong there.
417 lisn--;
418 while (lisn >= 0 && source[lisn].isn == 0) {
419 source[lisn].proc = 0;
420 lisn--;
421 }
422 }
423 // Now assign comments to a module.
424 for (k = lisn; k >= 0; k--) {
425 FTN_LINE *flin = &source[k];
426 if (xproc > 1 && flin->proc > 0 && flin->proc < xproc) {
427 xproc = flin->proc;
428 }
429 if (flin->text != NO_TEXT && IS_COMMENT (flin->text[0]) && flin->proc == 0) {
430 flin->proc = xproc;
431 }
432 }
433 //
434 l_i = l_f = ERR;
435 for (k = 1; k < nftnlines && l_i == ERR; k++) {
436 FTN_LINE *flin = &source[k];
437 if (flin->proc == proc) {
438 l_i = k;
439 }
440 }
441 for (k = nftnlines - 1; k >= 1 && l_f == ERR; k--) {
442 FTN_LINE *flin = &source[k];
443 if (flin->proc == proc) {
444 l_f = k;
445 }
446 }
447 code (nprocs, LIST, newpage (modnam, "source-code"));
448 for (k = l_i; k <= l_f; k++) {
449 FTN_LINE *flin = &source[k];
450 if (!flin->jcl) { // JCL is listed elsewhere.
451 RECORD lrec;
452 if (flin->isn > 0) {
453 _srecordf (lrec, "// %6d %6d %s\n", flin->num, flin->isn, flin->text);
454 } else {
455 _srecordf (lrec, "// %6d %s\n", flin->num, flin->text);
456 }
457 code (nprocs, LIST, lrec);
458 }
459 }
460 }
461
|
© 2002-2025 J.M. van der Veer (jmvdveer@xs4all.nl)
|
