vif.h
1 //! @file vif.h
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-2026 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 //! VIF include file.
25
26 // This is a monolithic include file to avoid cluttering the installation directory.
27
28 #if ! defined (__VIF_H__)
29 #define __VIF_H__
30 #define HAVE_LINUX
31 #define _GNU_SOURCE
32 #include <complex.h>
33 #include <ctype.h>
34 #include <endian.h>
35 #include <errno.h>
36 #include <float.h>
37 #include <inttypes.h>
38 #include <libgen.h>
39 #include <limits.h>
40 #include <math.h>
41 #include <quadmath.h>
42 #include <signal.h>
43 #include <stdarg.h>
44 #include <stddef.h>
45 #include <stdint.h>
46 #include <stdio.h>
47 #include <stdlib.h>
48 #include <string.h>
49 #include <sys/stat.h>
50 #include <sys/time.h>
51 #include <sys/utsname.h>
52 #include <time.h>
53 #include <unistd.h>
54
55 #define prototype
56
57 #define PACKAGE "vif"
58
59 #define NO_IDENT ((IDENT *) NULL)
60 #define NO_INTRINS ((INTRINS *) NULL)
61 #define NO_LABEL ((LBL *) NULL)
62 #define NO_MODE ((MODE *) NULL)
63 #define NO_TEXT ((char *) NULL)
64 #define NO_FUN NULL
65 #define NO_FTN_FILE ((FTN_FILE *) NULL)
66 #define NO_FTN_LINE ((FTN_LINE *) NULL)
67 #define NO_FILE ((FILE *) NULL)
68 #define NO_REF_INTEGER ((int_4 *) NULL)
69 #define NO_EXPR ((EXPR *) NULL)
70 #define NO_REF_TEXT ((char **) NULL)
71
72 #define STDF_IN 5
73 #define STDF_OUT 6
74 #define STDF_PUN 6
75 #define STDF_ERR 7
76
77 #define ALLOW_CONT (TRUE)
78 #define DENY_CONT (FALSE)
79
80 typedef char *FORMAT;
81
82 // Flags for gcc when compiling generated code from FORTRAN.
83
84 #if defined (BOOTSTRAP)
85 #if defined (HAVE_FREEBSD)
86 #define CFLAGS "-pipe -ggdb -I. -Isrc/include -L. -I../include -I../../include -fdiagnostics-plain-output -fdiagnostics-show-location=once"
87 #define LD_FLAGS "-rdynamic -Lsrc/lib -L../lib -lvif -lquadmath -lm -lexecinfo"
88 #elif defined (HAVE_LINUX)
89 #define CFLAGS "-pipe -ggdb -I. -Isrc/include -L. -I../include -I../../include -fdiagnostics-plain-output -fdiagnostics-show-location=once"
90 #define LD_FLAGS "-rdynamic -Lsrc/lib -L../lib -lvif -lquadmath -lm"
91 #else
92 #error "undefined OS"
93 #endif
94 #else
95 #if defined (HAVE_FREEBSD)
96 #define CFLAGS "-pipe -ggdb -I. -Isrc/include -L. -I../include -I../../include -fdiagnostics-plain-output -fdiagnostics-show-location=once -z execstack"
97 #define LD_FLAGS "-rdynamic -L./src/lib -lvif -lquadmath -lm -lexecinfo"
98 #elif defined (HAVE_LINUX)
99 #define CFLAGS "-pipe -ggdb -I. -Isrc/include -L. -I../include -I../../include -fdiagnostics-plain-output -fdiagnostics-show-location=once -z execstack"
100 #define LD_FLAGS "-rdynamic -L./src/lib -lvif -lquadmath -lm"
101 #else
102 #error "undefined OS"
103 #endif
104 #endif
105 #define OFLAGS "-O2"
106
107 enum {NOTYPE, ETYPE, INTEGER, LOGICAL, REAL, COMPLEX, CHARACTER};
108 enum {UNFORMATTED = 1, STDFORMAT, FORMATTED };
109 enum {SOURCE = 0, TEMP, MACRO };
110 enum {HEADER = 0, BANNER, LIST, MESSAGES, JCL, SYMBOLS, CONSTANTS, STRINGS, PARAMETERS, TYPEDEF, FREQ, COMMON, PROTOTYPE, STAT, TITLE, PRE, DECL, REFDECL, EQUIV, FMT, DATA, NESTED, BODY, POST, MAXPHA };
111 enum {EXPR_OTHER = 0, EXPR_VAR, EXPR_CONST, EXPR_SLICE, EXPR_SUBSTR };
112 enum {LEXEME = 0, DECLAR, WORD, LABEL, INT_NUMBER, FLT_NUMBER, TEXT };
113 enum {STATIC = 0, AUTOMATIC };
114
115 // Shorthands to improve code legibility.
116
117 #define int_2 int16_t
118 #define int_4 int32_t
119 #define int_8 int64_t
120
121 #define unt_2 uint16_t
122 #define unt_4 uint32_t
123 #define unt_8 uint64_t
124 #define unt_16 unsigned __int128
125
126 #define logical_4 unsigned
127
128 #define real_4 float
129 #define real_8 double
130 #define real_16 __float128
131
132 #define complex_8 float complex
133 #define complex_16 double complex
134 #define complex_32 __complex128
135
136 // MAX_STRLEN = 2 ** MAX_STRLENS - 1
137 #define MAX_STRLEN 4095
138 #define MAX_STRLENS 12
139 extern int_4 strlens[MAX_STRLENS];
140
141 #define ERR (-32)
142 #define SKIP /* SKIP */
143 #define TRUE 1
144 #define FALSE 0
145 #define MAX_LRECL 32760
146 #define MAX_MACRO_DEPTH 25
147 #define MAX_NEST 9
148 #define INCREMENT 500
149 #define INDENT 2
150 #define LINES_PER_PAGE 50
151 #define LINE_WIDTH 122
152 #define MAX_ARGS 16
153 #define MAX_COMMONS 100
154 #define MAX_DIMS 6
155 #define MAX_IDENTS 1000
156 #define MAX_LABELS 1000
157 #define MAX_MODULES 5000
158 #define MAX_PRIO 9
159 #define MAX_ERROR 5
160 #define MAX_WARNS MAX_ERROR
161 #define RETURN "goto _l0;\n"
162 #define M_LOG10_2 0.30102999566398119521373889472449q
163
164 #define NOT_LOCAL(idf) ((idf)->common != LOCAL)
165 #define LOCAL 0
166 #define EXTERN 1
167
168 #define WITHIN (curret != END_OF_LINE && curret != END_OF_MODULE)
169
170 #define NOT_ASSIGNMENT 0
171 #define MACRO_DECLARATION 1
172 #define ASSIGNMENT 2
173
174 #define IS_NOT_ASSIGNMENT (statement_type () == NOT_ASSIGNMENT)
175 #define IS_MACRO_DECLARATION (statement_type () == MACRO_DECLARATION)
176 #define IS_ASSIGNMENT (statement_type () == ASSIGNMENT)
177
178 #define END_OF_MODULE (-3)
179 #define END_OF_LINE (-2)
180 #define EXPECT_NONE (NULL)
181 #define START_OF_LINE (-1)
182 #define ARG TRUE
183 #define NOARG FALSE
184 #define CONST TRUE
185 #define NOCONST FALSE
186 #define FUN TRUE
187 #define NOFUN FALSE
188 #define UNIQ TRUE
189 #define NOUNIQ FALSE
190 #define NOPATCH 0
191 #define NOTYPE 0
192 #define NOLEN 0
193 #define FORMAL TRUE
194 #define ACTUAL FALSE
195 #define CAST TRUE
196 #define NOCAST FALSE
197 #define PROTEST TRUE
198 #define QUIET FALSE
199
200 #define EXPECT_LABEL "label"
201 #define INTERNAL_CONSISTENCY "internal consistency"
202
203 #define ABS(n) ((n) > 0 ? (n) : -(n))
204 #define MAXIMISE(u, v) ((u) = _max (u, v))
205 #define MINIMISE(u, v) ((u) = _min (u, v))
206
207 #define IS_JCL(c) (c == '/' || CUR_LIN.jcl)
208 #define IS_COMMENT(c) (strchr ("cd*!#", tolower (c)) != NULL || IS_JCL (c))
209 #define IS_VAR(n) (isalpha(n[0]) || n[0] == '_' || n[0] == '$')
210 #define _EXPCHAR(n) (tolower (n) != '\0' && strchr ("edqx", tolower (n)) != NULL)
211 #define _IDFCHAR(n) (tolower (n) != '\0' && strchr ("abcdefghijklmnopqrstuvwxyz0123456789_ $", tolower (n)) != NULL)
212 #define CUR_LIN (source[curlin])
213 #define POS(n) (tolower (CUR_LIN.text[n]))
214 #define EXPONENT(n) _EXPCHAR (POS (n))
215 #define CUR_COL (POS (curcol))
216
217 #define UNSCAN {curlin = prelin; curcol = precol; strcpy (curlex, prelex); curret = preret;}
218
219 #define SAVE_POS(n)\
220 int_4 _cl_##n= curlin, _cc_##n= curcol;\
221 int_4 _pl_##n= prelin, _pc_##n= precol;\
222 int_4 _pr_##n= preret, _cr_##n= curret;\
223 NEW_RECORD (_clr_##n); RECCPY (_clr_##n, curlex);\
224 NEW_RECORD (_cpr_##n); RECCPY (_cpr_##n, prelex);
225
226 #define RESTORE_POS(n) {\
227 curlin = _cl_##n;\
228 curcol = _cc_##n;\
229 prelin = _pl_##n;\
230 precol = _pc_##n;\
231 preret = _pr_##n;\
232 curret = _cr_##n;\
233 RECCPY (curlex, _clr_##n);\
234 RECCPY (prelex, _cpr_##n);\
235 }
236
237 #define MSG(sev, num, text, info)\
238 if (prelin < 1) {\
239 message (&source[curlin], curcol, (sev), (num), (text), (info));\
240 } else {\
241 message (&source[prelin], precol, (sev), (num), (text), (info));\
242 }
243
244 extern int_4 _srecordf (char *, const char *, ...);
245 extern void _vif_backtr(int_4);
246
247 #define ERROR(num, s, t) {MSG ("error", (num), (s), (t));}
248 #define MODE_ERROR(num, s, t) {\
249 RECORD _txt_;\
250 _srecordf(_txt_, "%s to %s", (s), (t));\
251 ERROR (num, "cannot convert", _txt_);\
252 }
253 #define PRECISION_LOSS(num, s, t) {\
254 RECORD _txt_;\
255 _srecordf(_txt_, "%s to %s", (s), (t));\
256 WARNING (num, "possible precision loss", _txt_);\
257 }
258 #define SYNTAX(num, s) {ERROR ((num), "syntax", (s));}
259 #define EXPECT(num, s) {ERROR ((num), "expected", (s));}
260 #define ADJACENT(num, s) {ERROR ((num), "adjacent", (s));}
261 #define WARNING(num, s, t) {MSG ("warning", (num), (s), (t));}
262 #define ECHO(num, s, t) {MSG ("info", (num), (s), (t));}
263 #define SCANER(num, s, t) {MSG ("fatal", (num), (s), (t)); exit (EXIT_FAILURE);}
264 #define FATAL(num, s, t) {message (NULL, ERR, "fatal", (num), (s), (t)); exit (EXIT_FAILURE);}
265 #define OVERFLOW(num, t) {fprintf (stderr, "\n** exception ** f%d: fatal: overflow, (%s)\n", (num), (t)); _vif_backtr (SIGTERM);}
266
267 #define TOKEN(s) EQUAL (curlex, (s))
268 #define CHECKPOINT(num, s) {if (!EQUAL (curlex, (s))) {EXPECT ((num), (s));}}
269 #define CHECKDIGIT(num, s) {if (!isdigit (s)) {EXPECT ((num), "digit");}}
270 #define IS_NUMBER(u) ((u) == INT_NUMBER || (u) == FLT_NUMBER)
271
272 #define FMT_TEXT ((char *) 1)
273 #define FMT_INT ((char *) 2)
274 #define FMT_REAL ((char *) 3)
275 #define FMT_LOGICAL ((char *) 4)
276 #define FMT_CHAR ((char *) 5)
277 #define FMT_TERM ((char *) 6)
278 extern int_4 __scale__;
279
280 // REAL*32
281
282 #define FLT128_LEN 7 // Do NOT change this!
283 #define FLT256_LEN 15 // Do NOT change this!
284 #define FLT256_GUARD 2 // Guard digits.
285 #define FLT256_DIG (72 - FLT256_GUARD) // 240 * log10 (2) minus guard digits.
286
287 typedef unt_2 REAL16[8];
288 typedef unt_2 REAL32[FLT256_LEN + 1]; // One for exponent.
289
290 struct __real_32__
291 {
292 REAL32 value;
293 };
294 typedef struct __real_32__ real_32;
295
296 struct __complex_64__
297 {
298 struct __real_32__ re, im;
299 };
300 typedef struct __complex_64__ complex_64;
301
302 #define xsub(a, b) xadd (a, b, 1)
303 #define xsum(a, b) xadd (a, b, 0)
304
305 // In Fortran, only EQUIVALENCE can alias names.
306
307 #define _p_ * restrict
308
309 //
310
311 #define RECLN 2048
312 typedef char RECORD[RECLN + 1];
313 #define RECCLR(z) memset ((z), '\0', RECLN + 1)
314 #define RECCPY(dst, src) bufcpy (dst, src, RECLN);
315 #define NEW_RECORD(z) RECORD z; RECCLR(z)
316 #define NEW_STATIC_RECORD(z) static RECORD z; RECCLR(z)
317
318 typedef struct FTN_FILE FTN_FILE;
319 struct FTN_FILE {
320 FILE *unit;
321 char *name, *form, *action, *disp, *buff, *rewind;
322 int_4 lrecl, vers, in_stream, record, records, redirect, buff_init, buff_pos, buff_len, memopen_len;
323 };
324
325 #define NEW_FTN_FILE(fp, fmt, act, recl)\
326 ((FTN_FILE) {.unit = fp, .form = fmt, .action = act, .lrecl = recl, .in_stream = FALSE})
327
328 #define MAX_SOURCE_FILES 1500
329
330 // MAX_FTN_FILES should be 100.
331 #define MAX_FTN_FILES 100
332
333 extern FTN_FILE _ffile[MAX_FTN_FILES];
334
335 typedef struct CALLS CALLS;
336 struct CALLS {
337 char *name;
338 int_8 calls;
339 };
340
341 typedef struct C_SRC C_SRC;
342 struct C_SRC
343 {
344 int_4 proc, phase;
345 char *text;
346 };
347 extern C_SRC *object;
348
349 typedef struct FTN_LINE FTN_LINE;
350 struct FTN_LINE
351 {
352 FTN_LINE *file;
353 int_4 num, isn, len, label, jcl, diag, proc, cpp;
354 char *text;
355 };
356 extern FTN_LINE *source, *files;
357 extern int_4 MAX_FTN_LINES;
358
359 typedef struct MODE MODE;
360 struct MODE
361 {
362 int_4 type, len, dim, save, fun;
363 };
364
365 #define PLAIN_MODE(t, l) ((MODE) {.type = type, .len = len, .dim = 0, .fun = FALSE})
366 #define TYPE(z, t, l) ((z)->mode.type == t && (z)->mode.len == l)
367 #define IS_ROW(m) ((m).dim > 0)
368 #define IS_SCALAR(m) ((m).dim == 0)
369
370 typedef struct IDENT IDENT;
371 struct IDENT
372 {
373 char *name, *var_name, *parm;
374 int_4 arg, call, common, const_ref, external, intrinsic, line, macro, nest, save, source, used, variable;
375 IDENT *alias, *equiv;
376 MODE mode;
377 int_4 patch1, patch2;
378 char *lwb[MAX_DIMS], *upb[MAX_DIMS], *len[MAX_DIMS];
379 char *size;
380 };
381 #define C_NAME(z) ((z)->name)
382 #define F_NAME(z) ((z)->var_name)
383
384 typedef struct IMPLICIT IMPLICIT;
385 struct IMPLICIT
386 {
387 MODE mode;
388 };
389
390 typedef struct LBL LBL;
391 struct LBL
392 {
393 int_4 index, num, line, jumped, patch, nonexe, data, format, renum;
394 };
395 extern LBL *lbl;
396
397 typedef struct EXPR EXPR;
398 struct EXPR
399 {
400 RECORD str, elem;
401 int_4 variant, value, opt;
402 IDENT *idf;
403 MODE mode;
404 };
405
406 typedef struct INTRINS INTRINS;
407 struct INTRINS
408 {
409 char *ffun, *bfun, *cfun;
410 int_4 rtyp, rlen, alen;
411 int_4 anum, atyp;
412 real_32 (*f1) (real_32);
413 real_32 (*f2) (real_32, real_32);
414 complex_64 (*f3) (complex_64);
415 };
416
417 extern char *action_default;
418 extern char *action_read;
419 extern char *action_readwrite;
420 extern char *action_write;
421 extern char *commons[], *modules[];
422 extern char *disp_delete;
423 extern char *disp_keep;
424 extern char *disp_new;
425 extern char *disp_old;
426 extern char *form_formatted;
427 extern char *form_unformatted;
428
429 extern IDENT globals[], locals[];
430
431 extern IMPLICIT implic[];
432
433 extern int_4 curlin, curcol;
434 extern int_4 curret, preret;
435 extern int_4 end_statements;
436 extern int_4 indent;
437 extern int_4 jcllin;
438 extern int_4 lhs_factor;
439 extern int_4 macro_depth;
440 extern int_4 macro_nest;
441 extern int_4 MAX_C_SRC;
442 extern int_4 MAX_C_SRC;
443 extern int_4 MAX_FTN_LINES;
444 extern int_4 n_c_src;
445 extern int_4 nerrors, merrors, nwarns;
446 extern int_4 nloctmps, nglobtmps, func;
447 extern int_4 optimise;
448 extern int_4 page, line, ncommons, nmodules;
449 extern int_4 pnprocs, nprocs, nglobals, nlocals, nlabels, nftnlines, nfiles;
450 extern int_4 prelin, precol;
451
452 extern LBL labels[];
453
454 extern logical_4 abend;
455 extern logical_4 brief;
456 extern logical_4 column_72;
457 extern logical_4 compile_only;
458 extern logical_4 f4_do_loops;
459 extern logical_4 gcc_ftn_lines;
460 extern logical_4 hollerith;
461 extern logical_4 implicit_r8;
462 extern logical_4 keep;
463 extern logical_4 no_source;
464 extern logical_4 no_warnings;
465 extern logical_4 pretty;
466 extern logical_4 quiet_mode;
467 extern logical_4 renum;
468 extern logical_4 syntax_only;
469 extern logical_4 tidy;
470 extern logical_4 trace;
471 extern logical_4 use_strcasecmp;
472
473 extern RECORD curlex, prelex;
474 extern RECORD hdate;
475 extern RECORD hmodule, hsection;
476 extern RECORD libnam, modnam, procnam;
477 extern RECORD program, block;
478 extern RECORD retnam;
479 extern RECORD stat_start;
480
481 extern char *bufcat (char *, char *, int_4);
482 extern char *bufcpy (char *, char *, int_4);
483 extern char *bufrep (char *, char *);
484 extern char *_bufsub (char *, char *, int_4, int_4);
485 extern char *c_name (char *);
486 extern char *concat (char *, char *, char *);
487 extern char *edit_f (char *);
488 extern char *edit_fmt (int_4);
489 extern char *edit_i (char *);
490 extern char *edit_tmp (int_4);
491 extern char *edit_unit (int_4);
492 extern char *edit_v (char *);
493 extern char *edit_vn (char *, int_4);
494 extern char *encode (char *, char *);
495 extern char *f2c_type (char *, MODE *, int_4, int_4);
496 extern char *f_strallocat (char *, char *);
497 extern char *f_stralloc (char *);
498 extern char *get_uniq_str (char *, char *);
499 extern char *idf_full_c_name (RECORD, IDENT *);
500 extern char *intnot (char *, int_8, int_4);
501 extern char *newpage (char *, char *);
502 extern char *pretty_float (char *);
503 extern char *ptr_to_array (IDENT *, int_4, int_4, int_4);
504 extern char *qtype (MODE *);
505 extern char *_strlower (char *);
506 extern char *wtype (MODE *, int_4, int_4);
507 extern char *xfixed (char *, real_32, int_4, int_4, int_4);
508 extern char *xfloat (char *, real_32, int_4, int_4, int_4, int_4, int_4, char);
509 extern char *xsubfixed (char *, real_32, logical_4, int_4);
510 extern char *xtoa (char *, real_32, int_4);
511
512 extern IDENT *add_local (char *, int_4, int_4, int_4, int_4, int_4, int_4, int_4);
513 extern IDENT *add_nest (char *, int_4, MODE *);
514 extern IDENT *extf_decl (char *, MODE *);
515 extern IDENT *find_local (char *, MODE *);
516 extern IDENT *impl_decl (char *, MODE *);
517 extern IDENT *void_decl (char *, MODE *);
518
519 extern int_4 add_block (char *);
520 extern int_4 code (int_4, int_4, char *);
521 extern int_4 code_real_32_const (char *);
522 extern int_4 code_uniq_str (char *);
523 extern int_4 format_str (char *str);
524 extern int_4 impl_do (void);
525 extern int_4 mix_len (EXPR *, EXPR *);
526 extern int_4 new_charlen (int_4);
527 extern int_4 ord (char);
528 extern int_4 patch (int_4, char *);
529 extern int_4 scan (char *);
530 extern int_4 scan_fmt (void);
531 extern int_4 scan_fmt (void);
532 extern int_4 statement_type (void);
533
534 extern LBL *find_label (char *);
535
536 extern logical_4 accept_mode (int_4, int_4, int_4, int_4);
537 extern logical_4 coerce (EXPR *, EXPR *);
538 extern logical_4 express (EXPR *, int_4, int_4);
539 extern logical_4 find_module (char *);
540 extern logical_4 fold_expr (EXPR *, int_4);
541 extern logical_4 fold_intrinsic (INTRINS *, EXPR *, EXPR *);
542 extern logical_4 intrinsic_call (char *, EXPR *);
543 extern logical_4 is_intrins (char *, INTRINS **);
544 extern logical_4 is_int4 (char *, int_4 *);
545 extern logical_4 is_macro_decl (char *);
546 extern logical_4 is_specific (char *);
547 extern logical_4 lookahead (char *);
548 extern logical_4 reserved (char *);
549 extern logical_4 same_name (char *, char *);
550 extern logical_4 valid_expr (EXPR *);
551
552 extern void assign (EXPR *);
553 extern void banner (int_4, int_4, char *);
554 extern void call (void);
555 extern void code_comment (void);
556 extern void code_common (void);
557 extern void code_exts (IDENT *, int_4, int_4, int_4, int_4);
558 extern void code_idfs (IDENT *, int_4, int_4, int_4, int_4);
559 extern void code_index (RECORD, IDENT *, int_4);
560 extern void code_parms (RECORD);
561 extern void code_row_len (IDENT *);
562 extern void common (void);
563 extern void common (void);
564 extern void compute_row_size (RECORD, IDENT *);
565 extern void cpp_direct (int_4, int_4, int_4);
566 extern void decl_autosave (void);
567 extern void decl_data (void);
568 extern void decl_equiv (void);
569 extern void decl_macros (void);
570 extern void default_impl (void);
571 extern void diagnostic (int_4, char *);
572 extern void dimension (void);
573 extern void do_data (int_4 *);
574 extern void do_io (char *, int_4 *);
575 extern void equivalence (void);
576 extern void executable (void);
577 extern void exprio (EXPR *, int_4, logical_4);
578 extern void externals (void);
579 extern void factor (EXPR *);
580 extern void factor_function_call (EXPR *, RECORD);
581 extern void factor_integer_number (EXPR *, char *);
582 extern void factor_slice_char (EXPR *, IDENT *);
583 extern void factor_slice (EXPR *, IDENT *);
584 extern void factor_variable (EXPR *, IDENT *, MODE *, RECORD);
585 extern void *f_malloc (size_t);
586 extern void fold_int_4 (char *, char *);
587 extern void format (LBL *);
588 extern void *f_realloc (void *, size_t);
589 extern void compile_nested_intrinsic (char *);
590 extern void gen_statements (LBL *, int_4);
591 extern void get_decls (void);
592 extern void get_dims (IDENT *, int_4);
593 extern void get_impl (void);
594 extern void get_source (char *, int_4);
595 extern void idfs_impl (void);
596 extern void idfs_unused (void);
597 extern void implicit (void);
598 extern void impl_type (char *, MODE *);
599 extern void inline_args (RECORD *, int_4 *);
600 extern void intrinsics (void);
601 extern void jump (void);
602 extern void macro (EXPR *, IDENT *);
603 extern void merge_commons (void);
604 extern void message (FTN_LINE *, int_4, char *, int_4, char *, char *);
605 extern void norm_mode (MODE *);
606 extern void option (char *);
607 extern void parameter (void);
608 extern void patch_args (void);
609 extern void patch_args (void);
610 extern void proc_listing (int_4);
611 extern void recursion (EXPR *, RECORD, IDENT *);
612 extern void tidy_source (char *);
613 extern void RTE (const char *, const char *);
614 extern void RTW (const char *, const char *);
615 extern void scan_modules (void);
616 extern void skip_card (int_4);
617 extern void subprograms (void);
618 extern void vif_backspace (void);
619 extern void vif_close (void);
620 extern void vif_endfile (void);
621 extern void vif_inquire (void);
622 extern void vif_jcl (void);
623 extern void vif_open (void);
624 extern void vif_rewind (void);
625 extern void write_object (char *);
626 extern void write_tidy (char *);
627
628 // ++++ MACROS
629
630 #define ln(x) log(x)
631
632 static inline logical_4 EQUAL (char *s, char *t)
633 {
634 if (s == NULL || t == NULL) {
635 return s == t;
636 } else {
637 return strcasecmp (s, t) == 0;
638 }
639 }
640
641 static inline logical_4 MATCH (char *t)
642 {
643 if (EQUAL (curlex, t)) {
644 return TRUE;
645 } else {
646 NEW_RECORD (str);
647 _srecordf (str, "\"%s\"", t); // Stringize t
648 return EQUAL (curlex, str);
649 }
650 }
651
652 static logical_4 LEQUAL (char *s, char *t)
653 {
654 if (s == NULL || t == NULL) {
655 return s == t;
656 } else {
657 return strncasecmp (s, t, strlen (s)) == 0;
658 }
659 }
660
661 static inline void BUG (char *s)
662 {
663 fprintf (stderr, "%d %s\n", curlin, source[curlin].text);
664 message (NULL, ERR, "fatal", 4001, "compiler bug", (s));
665 exit (EXIT_FAILURE);
666 }
667
668 #define _write_err(rc, funit, action)\
669 fflush (_ffile[(funit)].unit);\
670 if ((rc) < 1 || ferror (_ffile[(funit)].unit)) {\
671 action;\
672 }
673
674 #define _read_err(rc, funit, action_end, action_err)\
675 if (feof (_ffile[(funit)].unit)) {\
676 action_end;\
677 }\
678 if ((rc) < 1 || ferror (_ffile[(funit)].unit)) {\
679 action_err;\
680 }
681
682 #define _write_eol(funit) {\
683 (void) _vif_printf ((funit), "\n", NULL, NOTYPE, 0);\
684 fflush (_ffile[(funit)].unit);\
685 }
686
687 #define _read_eol(funit) {\
688 (void) _vif_scanf ((funit), NULL, NULL, NOTYPE, 0);\
689 }
690
691 #define _abs(a) ({__typeof__ (a) _u = (a); _u >= 0 ? _u : -_u;})
692 #define _dim_(a, b) ({__typeof__ (a) _a = (a); __typeof__ (b) _b = (b); _a > _b ? _a - _b : 0;})
693 #define _max(a, b) ({__typeof__ (a) _a = (a); __typeof__ (b) _b = (b); _a > _b ? _a : _b;})
694 #define _min(a, b) ({__typeof__ (a) _a = (a); __typeof__ (b) _b = (b); _a < _b ? _a : _b;})
695 #define _imod(a, b) ({__typeof__ (a) _a = (a), _b = (b), _q = (__typeof__ (a)) (_a / _b); (_a - _q * _b);})
696 #define _sign(a, b) ({__typeof__ (a) _a = _abs (a); b >= 0 ? _a : -_a;})
697
698 #define _ichar(s) ((int_4) ((s)[0]))
699
700 // AINT
701 static inline real_4 _aintf (real_4 x) {return truncf (x);}
702 static inline real_8 _aintd (real_8 x) {return trunc (x);}
703 static inline real_16 _aintq (real_16 x) {return truncq (x);}
704
705 // NINT
706 static inline int_4 _nintf (real_4 x) {return (int_4) (x) >= 0.0 ? floorf (x + 0.5) : -floorf (0.5 - x);}
707 static inline int_4 _nintd (real_8 x) {return (int_4) (x >= 0.0 ? floor (x + 0.5) : -floor (0.5 - x));}
708 static inline int_4 _nintq (real_16 x) {return (int_4) (x >= 0.0q ? floorq (x + 0.5q) : -floorq (0.5q - x));}
709
710 // ANINT
711 static inline real_4 _anintf (real_4 x) {return (x) >= 0.0 ? floorf (x + 0.5) : -floorf (0.5 - x);}
712 static inline real_8 _anintd (real_8 x) {return (x >= 0.0 ? floor (x + 0.5) : -floor (0.5 - x));}
713 static inline real_16 _anintq (real_8 x) {return (x >= 0.0q ? floor (x + 0.5q) : -floor (0.5q - x));}
714
715 // COMPLEX*32
716
717 static inline complex_32 CMPLXQ (real_16 re, real_16 im) {complex_32 z; __real__ z = re; __imag__ z = im; return z;}
718 extern complex_32 qxcmplx (real_32, real_32);
719
720 // COMPLEX*64
721
722 #define CMPLXX(re, im) (complex_64){re, im}
723 #define CMPLXZ(re) (complex_64){re, X_0}
724
725 // RTS
726
727 extern char *_char (int);
728 extern char *__strtok_r (char *, const char *, char **);
729 extern char *_strupper (char *);
730 extern char **_vif_jit (char *, char *);
731
732 extern FTN_FILE *_get_ftn_file (char *, int_4);
733
734 extern void _pi4 (real_4 *);
735 extern void _pi8 (real_8 *);
736 extern void _pi16 (real_16 *);
737 extern void _pi32 (real_32 *);
738
739 extern complex_16 _dcmplxq (complex_32);
740 extern complex_16 _up_complex (complex_16, int_4);
741
742 extern complex_32 _qcmplxd (complex_16);
743 extern complex_32 _up_complex_32 (complex_32, int_4);
744
745 extern complex_8 _cmplxd (complex_16);
746 extern complex_8 _up_complex_8 (complex_8, int_4);
747
748 extern int_4 _backspace (char *, int_4);
749 extern int_4 _i1mach (int_4 *);
750 extern int_4 _index (char *, char *);
751 extern int_4 _init_file_buffer (int_4);
752 extern int_4 _rewind (char *, int_4);
753 extern int_4 _set_record (char *, int_4, int_4);
754 extern int_4 _sys (char *, char *, char *, const char *, ...);
755 extern int_4 _str_to_int4 (char *);
756 extern int_4 _up_int_4 (int_4, int_4);
757 extern int_4 _vif_printf (int_4, char *, void *, int_4, int_4);
758 extern int_4 _vif_scanf (int_4, char *, void *, int_4, int_4);
759 extern int_4 _xerclr (void);
760 extern int_4 _xermsg (char *, char *, char *, int_4 *, int_4 *);
761 extern int_4 _xgetf (int_4 *);
762 extern int_4 _xint4 (real_32);
763 extern int_4 _xsetf (int_4 *);
764
765 extern int_8 _up_int_8 (int_8, int_4);
766 extern int_8 _xint8 (real_32);
767 extern int_8 _xnint8 (real_32);
768
769 extern real_16 acotanq (real_16);
770 extern real_16 cotanq (real_16);
771 extern real_16 _qext (real_8);
772 extern real_16 _up_real_16 (real_16, int_4);
773 extern real_16 _strtoquad (char *, char **);
774 extern real_16 xtoquad (real_32);
775 extern real_16 _zabs_32 (real_16 re, real_16 im);
776 extern real_16 cximagq (complex_64);
777 extern real_16 cxrealq (complex_64);
778
779 extern real_32 _quadtop (real_32 *, real_16);
780 extern real_32 quadtox (real_16);
781 extern real_32 _xerf (real_32);
782 extern real_32 _aintx (real_32);
783 extern real_32 _xI (real_32);
784 extern real_32 _xmod (real_32, real_32);
785 extern real_32 _xdimx (real_32, real_32);
786 extern real_32 _anintx (real_32);
787 extern real_32 _zabs_64 (real_32 re, real_32 im);
788
789 extern real_4 acotanf (real_4);
790 extern real_4 cotanf (real_4);
791 extern real_4 _up_real_4 (real_4, int_4);
792 extern real_4 _zabs_8 (real_4 re, real_4 im);
793
794 extern real_8 acotan (real_8);
795 extern real_8 cotan (real_8);
796 extern real_8 _drand48 (void);
797 extern real_8 _seconds (void);
798 extern real_8 _str_to_real8 (char *);
799 extern real_8 _up_real_8 (real_8, int_4);
800 extern real_8 _zabs_16 (real_8 re, real_8 im);
801
802 extern void _cputim (real_8 *);
803 extern void _cputyd (int_4 *);
804 extern void _fcheck (char *, int_4, char *, char *);
805 extern void _fclose (int_4);
806 extern void _fprintf_real_32 (char *, char *, real_32, int_4, int_4);
807 extern void _fregister (char *, int_4, int_4, char *, char *, char *, char *);
808 extern void _funregister (char *, int_4);
809 extern void _ioend_read (char *, int_4);
810 extern void _ioerr (char *, int_4);
811 extern void _ioerr_read (char *, int_4);
812 extern void _ioerr_write (char *, int_4);
813 extern void _merfi (real_8 *, real_8 *, int_4 *);
814 extern void _reset_ftn_file (FTN_FILE *);
815 extern void _qhex (real_16 *);
816 extern void _skip_eol (FILE *);
817 extern void _srand48 (int_4 *);
818 extern void _vif_exit (void);
819 extern void _vif_freq (CALLS *);
820 extern void _vif_init (void);
821 extern void _xhex (real_32 *);
822
823 extern complex_64 _coctotop (complex_64 *, real_32);
824 extern complex_64 _cquadtop (complex_64 *, complex_32);
825 extern complex_64 cxcos (complex_64);
826 extern complex_64 cxflt(complex_8);
827 extern complex_64 cxdbl(complex_16);
828 extern complex_64 cxdiv (complex_64, complex_64);
829 extern complex_64 cxexp (complex_64);
830 extern complex_64 cxlog (complex_64);
831 extern complex_64 cxmul (complex_64, complex_64);
832 extern complex_64 cxneg (complex_64);
833 extern complex_64 cxquad(complex_32);
834 extern complex_64 cxreal32(real_32);
835 extern complex_64 cxsin (complex_64);
836 extern complex_64 cxsqrt (complex_64);
837 extern complex_64 cxsub (complex_64, complex_64);
838 extern complex_64 cxsum (complex_64, complex_64);
839 extern complex_64 cxtan (complex_64);
840
841 extern int_4 xsgn (const real_32 *);
842
843 extern logical_4 xeq (real_32, real_32);
844 extern logical_4 xge (real_32, real_32);
845 extern logical_4 xgt (real_32, real_32);
846 extern logical_4 xis0 (const real_32 *);
847 extern logical_4 xis_minf (const real_32 *);
848 extern logical_4 xis_nan (const real_32 *);
849 extern logical_4 xis_pinf (const real_32 *);
850 extern logical_4 xle (real_32, real_32);
851 extern logical_4 xlt (real_32, real_32);
852 extern logical_4 xneq (real_32, real_32);
853 extern logical_4 xnot0 (const real_32 *);
854
855 extern real_32 atox (char *);
856 extern real_32 cximag (complex_64);
857 extern real_32 cxreal (complex_64);
858 extern real_32 dbltox (real_8);
859 extern real_32 flttox (real_4);
860 extern real_32 inttox (int_4);
861 extern real_32 strtox (char *, char **);
862 extern real_32 xabs (real_32);
863 extern real_32 xacosh (real_32);
864 extern real_32 xacos (real_32);
865 extern real_32 xacotan (real_32);
866 extern real_32 xadd (real_32, real_32, int_4);
867 extern real_32 xasinh (real_32);
868 extern real_32 xasin (real_32);
869 extern real_32 xatan2 (real_32, real_32);
870 extern real_32 xatanh (real_32);
871 extern real_32 xatan (real_32);
872 extern real_32 xcosh (real_32);
873 extern real_32 xcos (real_32);
874 extern real_32 xcotan (real_32);
875 extern real_32 xdiv (real_32, real_32);
876 extern real_32 xexp (real_32);
877 extern real_32 _xhypot (real_32, real_32);
878 extern real_32 xfrac (real_32);
879 extern real_32 xlog10 (real_32);
880 extern real_32 xlog (real_32);
881 extern real_32 xmul (real_32, real_32);
882 extern real_32 xneg (real_32);
883 extern real_32 xpwr (real_32, int_4);
884 extern real_32 xround (real_32);
885 extern real_32 xsfmod (real_32, int_4 *);
886 extern real_32 xsinh (real_32);
887 extern real_32 xsin (real_32);
888 extern real_32 xsqrt (real_32);
889 extern real_32 xtanh (real_32);
890 extern real_32 xtan (real_32);
891 extern real_32 xtenup (int_4);
892 extern real_32 xtrunc (real_32);
893 extern real_4 xtoflt (real_32);
894 extern real_8 xtodbl (real_32);
895
896 // SLATEC message handling routines.
897
898 extern int_4 _j4save (int_4 _p_, int_4 _p_, logical_4 _p_);
899 extern int_4 _xerabt (char _p_, int_4 *);
900 extern int_4 _xerbla (char _p_, int_4 _p_);
901 extern int_4 _xerclr (void);
902 extern int_4 _xerdmp (void);
903 extern int_4 _xermax (int_4 _p_);
904 extern int_4 _xermsg (char _p_, char _p_, char _p_, int_4 _p_, int_4 _p_);
905 extern int_4 _xerprn (char _p_, int_4 _p_, char _p_, int_4 _p_);
906 extern int_4 _xersve (char _p_, char _p_, char _p_, int_4 _p_, int_4 _p_, int_4 _p_, int_4 _p_);
907 extern int_4 _xgetf (int_4 _p_);
908 extern int_4 _xgetua (int_4 _p_, int_4 _p_);
909 extern int_4 _xgetun (int_4 _p_);
910 extern int_4 _xsetf (int_4 _p_);
911 extern int_4 _xsetua (int_4 _p_, int_4 _p_);
912 extern int_4 _xsetun (int_4 _p_);
913 #endif
|
© 2002-2026 J.M. van der Veer (jmvdveer@xs4all.nl)
|
