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-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 //! 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
31 #define _GNU_SOURCE
32
33 #include <complex.h>
34 #include <ctype.h>
35 #include <endian.h>
36 #include <errno.h>
37 #include <float.h>
38 #include <inttypes.h>
39 #include <libgen.h>
40 #include <limits.h>
41 #include <math.h>
42 #include <quadmath.h>
43 #include <signal.h>
44 #include <stdarg.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 STDF_IN 5
60 #define STDF_OUT 6
61 #define STDF_PUN 6
62 #define STDF_ERR 7
63
64 typedef char *FORMAT;
65
66 // Flags for gcc when compiling generated code from FORTRAN.
67
68 #if defined (BOOTSTRAP)
69 #define CFLAGS "-pipe -ggdb -I. -Isrc/include -L. -I../include -Wno-implicit-function-declaration -Wno-incompatible-pointer-types -fdiagnostics-plain-output -fdiagnostics-show-location=once"
70 #define LD_FLAGS "-rdynamic -Lsrc/lib -L../lib -lvif -lquadmath -lm"
71 #else
72 #define CFLAGS "-pipe -ggdb -I. -Isrc/include -L. -I../include -Wno-implicit-function-declaration -Wno-incompatible-pointer-types -fdiagnostics-plain-output -fdiagnostics-show-location=once"
73 #define LD_FLAGS "-rdynamic -L./src/lib -lvif -lquadmath -lm"
74 #endif
75 #define OFLAGS "-O2"
76
77 enum {NOTYPE, ETYPE, INTEGER, LOGICAL, REAL, COMPLEX, CHARACTER};
78 enum {UNFORMATTED = 1, STDFORMAT, FORMATTED };
79 enum {SOURCE = 0, TEMP, MACRO };
80 enum {HEADER = 0, BANNER, LIST, MESSAGES, SYMBOLS, CONSTANTS, STRINGS, PARAMETERS, TYPEDEF, FREQ, COMMON, PROTOTYPE, STAT, TITLE, PRE, DECL, REFDECL, EQUIV, FMT, DATA, BODY, POST, MAXPHA };
81 enum {EXPR_OTHER = 0, EXPR_VAR, EXPR_CONST, EXPR_SLICE, EXPR_SUBSTR };
82 enum {LEXEME = 0, DECLAR, WORD, LABEL, INT_NUMBER, FLT_NUMBER, TEXT };
83 enum {STATIC = 0, AUTOMATIC };
84
85 // Shorthands to improve code legibility.
86
87 #define int_2 int16_t
88 #define int_4 int32_t
89 #define int_8 int64_t
90
91 #define unt_2 uint16_t
92 #define unt_4 uint32_t
93 #define unt_8 uint64_t
94 #define unt_16 unsigned __int128
95
96 #define logical_4 unsigned
97
98 #define real_4 float
99 #define real_8 double
100 #define real_16 __float128
101
102 #define complex_8 float complex
103 #define complex_16 double complex
104 #define complex_32 __complex128
105
106 // MAX_STRLEN = 2 ** MAX_STRLENS - 1
107 #define MAX_STRLEN 4095
108 #define MAX_STRLENS 12
109 extern logical_4 strlens[MAX_STRLENS];
110
111 #define ERR (-32)
112 #define SKIP //
113 #define TRUE 1
114 #define FALSE 0
115 #define MAX_LRECL 32760
116 #define MAX_NEST 9
117 #define INCREMENT 500
118 #define INDENT 2
119 #define LINES_PER_PAGE 50
120 #define LINE_WIDTH 122
121 #define MAX_ARGS 16
122 #define MAX_COMMONS 100
123 #define MAX_DIMS 6
124 #define MAX_IDENTS 1000
125 #define MAX_LABELS 1000
126 #define MAX_MODULES 5000
127 #define MAX_PRIO 9
128 #define MAX_ERROR 5
129 #define MAX_WARNS MAX_ERROR
130 #define RETURN "goto _l0;\n"
131 #define M_LOG10_2 0.30102999566398119521373889472449q
132
133 #define WITHIN (curret != END_OF_LINE && curret != END_OF_MODULE)
134
135 #define END_OF_MODULE (-3)
136 #define END_OF_LINE (-2)
137 #define START_OF_LINE (-1)
138 #define LOCAL 0
139 #define EXTERN 1
140 #define ARG TRUE
141 #define NOARG FALSE
142 #define CONST TRUE
143 #define NOCONST FALSE
144 #define FUN TRUE
145 #define NOFUN FALSE
146 #define UNIQ TRUE
147 #define NOUNIQ FALSE
148 #define NOPATCH 0
149 #define NOTYPE 0
150 #define NOLEN 0
151 #define FORMAL TRUE
152 #define ACTUAL FALSE
153 #define CAST TRUE
154 #define NOCAST FALSE
155 #define PROTEST TRUE
156 #define QUIET FALSE
157
158 #define ABS(n) ((n) > 0 ? (n) : -(n))
159 #define IS_COMMENT(c) (strchr ("cd*!/#", tolower (c)) != NULL)
160 #define IS_VAR(n) (isalpha(n[0]) || n[0] == '_' || n[0] == '$')
161 #define UNSCAN {curlin = prelin; curcol = precol; strcpy (curlex, prelex); curret = preret;}
162 #define SAVE_POS int_4 _l_ = curlin, _c_ = curcol;
163 #define SAVE_PRE int_4 _l_ = prelin, _c_ = precol;
164 #define RESTORE_POS {curlin = _l_; curcol = _c_;}
165 #define _EXPCHAR(n) (tolower (n) != '\0' && strchr ("edlqx", tolower (n)) != NULL)
166
167 #define MSG(sev, num, text, info)\
168 if (prelin < 1) {\
169 message (&source[curlin], curcol, (sev), (num), (text), (info));\
170 } else {\
171 message (&source[prelin], precol, (sev), (num), (text), (info));\
172 }
173
174 extern void _vif_backtr(int_4);
175
176 #define ERROR(num, s, t) {MSG ("error", (num), (s), (t));}
177 #define MODE_ERROR(num, s, t) {\
178 RECORD _txt_;\
179 _srecordf(_txt_, "cannot convert %s to %s", (s), (t));\
180 ERROR (num, "error", _txt_);\
181 }
182 #define SYNTAX(num, s) {ERROR ((num), "invalid syntax", (s));}
183 #define EXPECT(num, s) {ERROR ((num), "expected", (s));}
184 #define ADJACENT(num, s) {ERROR ((num), "adjacent tokens", (s));}
185 #define WARNING(num, s, t) {MSG ("warning", (num), (s), (t));}
186 #define ECHO(num, s, t) {MSG ("info", (num), (s), (t));}
187 #define SCANER(num, s, t) {MSG ("fatal", (num), (s), (t)); exit (EXIT_FAILURE);}
188 #define FATAL(num, s, t) {message (NULL, ERR, "fatal", (num), (s), (t)); exit (EXIT_FAILURE);}
189 #define OVERFLOW(num, t) {_vif_backtr (0); fprintf (stderr, "\n** exception ** f%d: fatal: overflow, (%s)\n", (num), (t)); exit (EXIT_FAILURE);}
190
191 #define TOKEN(s) EQUAL (curlex, (s))
192 #define CHECKPOINT(num, s) {if (!EQUAL (curlex, (s))) {EXPECT ((num), (s));}}
193 #define CHECKDIGIT(num, s) {if (!isdigit (s)) {EXPECT ((num), "digit");}}
194 #define IS_NUMBER(u) ((u) == INT_NUMBER || (u) == FLT_NUMBER)
195
196 #define FMT_TEXT ((char *) 1)
197 #define FMT_INT ((char *) 2)
198 #define FMT_REAL ((char *) 3)
199 #define FMT_LOGICAL ((char *) 4)
200 #define FMT_CHAR ((char *) 5)
201
202 // REAL*32
203
204 #define FLT128_LEN 7 // Do NOT change this!
205 #define FLT256_LEN 15 // Do NOT change this!
206 #define FLT256_GUARD 2 // Guard digits.
207 #define FLT256_DIG (72 - FLT256_GUARD) // 240 * log10 (2) minus guard digits.
208
209 typedef unt_2 REAL16[8];
210 typedef unt_2 REAL32[FLT256_LEN + 1]; // One for exponent.
211
212 struct __real_32__
213 {
214 REAL32 value;
215 };
216 typedef struct __real_32__ real_32;
217
218 struct __complex_64__
219 {
220 struct __real_32__ re, im;
221 };
222 typedef struct __complex_64__ complex_64;
223
224 #define xsub(a, b) xadd (a, b, 1)
225 #define xsum(a, b) xadd (a, b, 0)
226
227 extern complex_64 cxcos (complex_64);
228 extern complex_64 cxdbl(complex_16);
229 extern complex_64 cxexp (complex_64);
230 extern complex_64 cxlog (complex_64);
231 extern complex_64 cxreal32(real_32);
232 extern complex_64 cxquad(complex_32);
233 extern complex_64 cxsin (complex_64);
234 extern complex_64 cxsqrt (complex_64);
235 extern complex_64 cxtan (complex_64);
236 extern complex_64 _coctotop (complex_64 *, real_32);
237 extern complex_64 _cquadtop (complex_64 *, complex_32);
238 extern int_4 xeq (real_32, real_32);
239 extern int_4 xge (real_32, real_32);
240 extern int_4 xgt (real_32, real_32);
241 extern int_4 xis0 (const real_32 *);
242 extern int_4 xisMinf (const real_32 *);
243 extern int_4 xisNaN (const real_32 *);
244 extern int_4 xisPinf (const real_32 *);
245 extern int_4 xle (real_32, real_32);
246 extern int_4 xlt (real_32, real_32);
247 extern int_4 xneq (real_32, real_32);
248 extern int_4 xnot0 (const real_32 *);
249 extern int_4 xsgn (const real_32 *);
250 extern real_32 atox (char *);
251 extern real_32 cxim (complex_64);
252 extern real_32 cxre (complex_64);
253 extern complex_64 cxneg (complex_64);
254 extern complex_64 cxsum (complex_64, complex_64);
255 extern complex_64 cxsub (complex_64, complex_64);
256 extern complex_64 cxmul (complex_64, complex_64);
257 extern complex_64 cxdiv (complex_64, complex_64);
258 extern real_32 dbltox (real_8);
259 extern real_32 flttox (real_4);
260 extern real_32 inttox (int_4);
261 extern real_32 strtox (char *, char **);
262 extern real_32 xabs (real_32);
263 extern real_32 xacos (real_32);
264 extern real_32 xacotan (real_32);
265 extern real_32 xadd (real_32, real_32, int_4);
266 extern real_32 xasin (real_32);
267 extern real_32 xatan2 (real_32, real_32);
268 extern real_32 xatan (real_32);
269 extern real_32 xacosh (real_32);
270 extern real_32 xcosh (real_32);
271 extern real_32 xcos (real_32);
272 extern real_32 xcotan (real_32);
273 extern real_32 xdiv (real_32, real_32);
274 extern real_32 xexp (real_32);
275 extern real_32 xlog10 (real_32);
276 extern real_32 xlog (real_32);
277 extern real_32 xmul (real_32, real_32);
278 extern real_32 xneg (real_32);
279 extern real_32 xpwr (real_32, int_4);
280 extern real_32 xround (real_32);
281 extern real_32 xsfmod (real_32, int_4 *);
282 extern real_32 xasinh (real_32);
283 extern real_32 xsinh (real_32);
284 extern real_32 xsin (real_32);
285 extern real_32 xsqrt (real_32);
286 extern real_32 xatanh (real_32);
287 extern real_32 xtanh (real_32);
288 extern real_32 xtan (real_32);
289 extern real_32 xtrunc (real_32);
290 extern real_32 xfrac (real_32);
291 extern real_32 xtenup (int_4);
292 extern real_4 xtoflt (real_32);
293 extern real_8 xtodbl (real_32);
294
295 // In Fortran, only EQUIVALENCE can alias names.
296
297 #define _p_ * restrict
298
299 //
300
301 #define RECLN 4095
302 typedef char RECORD[RECLN + 1];
303 #define RECCLR(z) memset ((z), 0, RECLN + 1)
304
305 typedef struct FTNFILE FTNFILE;
306 struct FTNFILE {
307 FILE *unit;
308 char *name, *form, *action, *disp, *buff;
309 int_4 lrecl, vers, buff_init, buff_pos, buff_len;
310 };
311
312 #define NEW_FTN_FILE(fp, fmt, act, recl)\
313 ((FTNFILE) {.unit = fp, .form = fmt, .action = act, .lrecl = recl})
314
315 #define MAX_SOURCE_FILES 1500
316 #define MAX_FILES 100
317
318 extern FTNFILE _ffile[MAX_FILES];
319
320 typedef struct CALLS CALLS;
321 struct CALLS {
322 char *name;
323 int_8 calls;
324 };
325
326 typedef struct C_SRC C_SRC;
327 struct C_SRC
328 {
329 int_4 proc, phase;
330 char *text;
331 };
332 extern C_SRC *object;
333
334 typedef struct FTN_LINE FTN_LINE;
335 struct FTN_LINE
336 {
337 FTN_LINE *file;
338 int_4 num, inc, isn, len, label, diag, proc, cpp;
339 char *text;
340 };
341 extern FTN_LINE *source, *files;
342 extern int_4 MAX_FTN_LINES;
343
344 typedef struct MODE MODE;
345 struct MODE
346 {
347 int_4 type, len, dim, save, fun;
348 };
349 #define PLAIN_MODE(t, l) ((MODE) {.type = type, .len = len, .dim = 0, .fun = FALSE})
350 #define TYPE(z, t, l) ((z)->mode.type == t && (z)->mode.len == l)
351
352 typedef struct IDENT IDENT;
353 struct IDENT
354 {
355 char *name, *fname, *parm;
356 int_4 arg, call, common, const_ref, external, intrinsic, line, macro, nest, save, source, used, variable;
357 IDENT *alias, *equiv;
358 MODE mode;
359 int_4 patch1, patch2;
360 char *lwb[MAX_DIMS], *upb[MAX_DIMS], *len[MAX_DIMS];
361 char *size;
362 };
363 #define CID(z) ((z)->name)
364 #define FID(z) ((z)->fname)
365
366 typedef struct IMPLICIT IMPLICIT;
367 struct IMPLICIT
368 {
369 MODE mode;
370 };
371
372 typedef struct LBL LBL;
373 struct LBL
374 {
375 int_4 index, num, line, jumped, patch, nonexe, data, format;
376 };
377 extern LBL *lbl;
378
379 typedef struct EXPR EXPR;
380 struct EXPR
381 {
382 RECORD str;
383 int_4 variant, value, base_elem, opt;
384 IDENT *idf;
385 MODE mode;
386 };
387
388 typedef struct INTRINS INTRINS;
389 struct INTRINS
390 {
391 char *ffun, *cfun;
392 int_4 spec, rtyp, rlen, alen;
393 int_4 anum, atyp;
394 real_32 (*f1) (real_32);
395 real_32 (*f2) (real_32, real_32);
396 complex_64 (*f3) (complex_64);
397 };
398
399 extern char *action_default;
400 extern char *action_read;
401 extern char *action_write;
402 extern char *action_readwrite;
403 extern char *form_formatted;
404 extern char *form_unformatted;
405 extern char *disp_new;
406 extern char *disp_old;
407 extern char *disp_delete;
408 extern char *disp_keep;
409
410 extern IDENT globals[], locals[];
411 extern char *commons[], *modules[];
412 extern IMPLICIT implic[];
413 extern LBL labels[];
414 extern int_4 optimise, keep, pretty;
415 extern int_4 hollerith;
416 extern int_4 end_statements;
417 extern int_4 syntax_only;
418 extern int_4 MAX_C_SRC;
419 extern int_4 macro_nest;
420 extern int_4 lhs_factor;
421 extern int_4 MAX_C_SRC;
422 extern int_4 MAX_FTN_LINES;
423 extern int_4 pnprocs, nprocs, nglobals, nlocals, nlabels, nftnlines, nfiles;
424 extern int_4 nloctmps, nglobtmps, func;
425 extern int_4 prelin, precol;
426 extern int_4 curlin, curcol;
427 extern int_4 nerrors, merrors, nwarns;
428 extern int_4 page, line, ncommons, nmodules;
429 extern int_4 n_c_src;
430 extern int_4 indent;
431 extern int_4 curret, preret;
432 extern int_4 abend;
433 extern int_4 compile_only;
434 extern int_4 implicit_r8;
435 extern int_4 f4_do_loops;
436 extern int_4 gcc_ftn_lines;
437 extern int_4 quiet_mode;
438 extern int_4 trace;
439 extern int_4 no_warnings;
440 extern RECORD curlex, prelex;
441 extern RECORD libnam, modnam, procnam;
442 extern RECORD retnam;
443 extern RECORD stat_start;
444 extern RECORD program, block;
445 extern RECORD hmodule, hsection;
446 extern RECORD hdate;
447
448 #if defined (_ROW_MAJOR_)
449 extern void code_index (RECORD, IDENT *, int_4 *, int_4 *);
450 #else
451 extern void code_index (RECORD, IDENT *, int_4, int_4 *);
452 #endif
453
454 extern char *bufcat (char *, char *, int_4);
455 extern char *bufcpy (char *, char *, int_4);
456 extern char *bufrep (char *, char *);
457 extern char *_bufsub (char *, char *, int_4, int_4);
458 extern char *c_name (char *);
459 extern char *concat (char *, char *, char *);
460 extern char *edit_f (char *);
461 extern char *edit_fmt (int_4);
462 extern char *edit_tmp (int_4);
463 extern char *edit_unit (int_4);
464 extern char *edit_v (char *);
465 extern char *edit_vn (char *, int_4);
466 extern char *encode (char *, char *);
467 extern char *f2c_type (char *, MODE *, int_4, int_4);
468 extern char *get_uniq_str (char *, char *);
469 extern char *intnot (char *, int_8, int_4);
470 extern char *newpage (char *, char *);
471 extern char *pretty_float (char *);
472 extern char *ptr_to_array (IDENT *, int_4, int_4, int_4);
473 extern char *qtype (MODE *);
474 extern char *strallocat (char *, char *);
475 extern char *stralloc (char *);
476 extern char *strlower (char *);
477 extern char *wtype (MODE *, int_4, int_4);
478 extern char *xfixed (char *, real_32, int_4, int_4, int_4);
479 extern char *xfloat (char *, real_32, int_4, int_4, int_4, int_4, int_4, char);
480 extern char *xsubfixed (char *, real_32, logical_4, int_4);
481 extern char *xtoa (char *, real_32, int_4);
482 extern IDENT *add_local (char *, int_4, int_4, int_4, int_4, int_4, int_4, int_4);
483 extern IDENT *add_nest (char *, int_4, MODE *);
484 extern IDENT *extf_decl (char *, MODE *);
485 extern IDENT *find_local (char *, MODE *);
486 extern IDENT *impl_decl (char *, MODE *);
487 extern IDENT *void_decl (char *, MODE *);
488 extern int_4 accept_mode (int_4, int_4, int_4, int_4);
489 extern int_4 add_block (char *);
490 extern int_4 code (int_4, int_4, char *);
491 extern int_4 code_real_32_const (char *);
492 extern int_4 code_uniq_str (char *);
493 extern int_4 express (EXPR *, int_4, int_4);
494 extern int_4 find_module (char *);
495 extern int_4 fold_expr (EXPR *, int_4);
496 extern int_4 fold_intrinsic (INTRINS *, EXPR *, EXPR *);
497 extern int_4 format_str (char *str);
498 extern int_4 impl_do (void);
499 extern int_4 intrinsic_call (char *, EXPR *);
500 extern int_4 is_array (MODE);
501 extern int_4 isint_4 (char *, int_4 *);
502 extern int_4 is_intrins (char *);
503 extern int_4 is_specific (char *);
504 extern int_4 mix_len (EXPR *, EXPR *);
505 extern int_4 ord (char);
506 extern int_4 patch (int_4, char *);
507 extern int_4 reserved (char *);
508 extern int_4 same_name (char *, char *);
509 extern int_4 scan (char *);
510 extern int_4 scan_fmt (void);
511 extern int_4 scan_fmt (void);
512 extern int_4 valid_expr (EXPR *);
513 extern int new_charlen (int_4);
514 extern LBL *find_label (char *);
515 extern void banner (int_4, int_4, char *);
516 extern void call (void);
517 extern void code_arrlen (IDENT *);
518 extern void code_comment (void);
519 extern void code_common (void);
520 extern void code_exts (IDENT *, int_4, int_4, int_4, int_4);
521 extern void code_idfs (IDENT *, int_4, int_4, int_4, int_4);
522 extern void code_parms (RECORD);
523 extern void common (void);
524 extern void common (void);
525 extern void cpp_direct (int_4, int_4, int_4);
526 extern void decl_autosave (void);
527 extern void decl_data (void);
528 extern void decl_equiv (void);
529 extern void decl_macros (void);
530 extern void default_impl (void);
531 extern void diagnostic (int_4, char *);
532 extern void dimension (void);
533 extern void do_data (int_4 *);
534 extern void do_io (char *, int_4 *);
535 extern void equivalence (void);
536 extern void executable (void);
537 extern void exprio (EXPR *, int_4, logical_4);
538 extern void factor (EXPR *);
539 extern void *f_malloc (size_t);
540 extern void fold_int_4 (char *, char *);
541 extern void format (LBL *);
542 extern void *f_realloc (void *, size_t);
543 extern void function_call (EXPR *, RECORD);
544 extern void gen_statements (LBL *, int_4);
545 extern void get_decls (void);
546 extern void get_dims (IDENT *, int_4);
547 extern void get_impl (void);
548 extern void get_source (char *, int_4);
549 extern void idfs_impl (void);
550 extern void idfs_unused (void);
551 extern void implicit (void);
552 extern void impl_type (char *, MODE *);
553 extern void inline_args (RECORD *, int_4 *);
554 extern void jump (void);
555 extern void macro (EXPR *, IDENT *);
556 extern void merge_commons (void);
557 extern void message (FTN_LINE *, int_4, char *, int_4, char *, char *);
558 extern void norm_mode (MODE *);
559 extern void option (char *);
560 extern void parameter (void);
561 extern void patch_args (void);
562 extern void patch_args (void);
563 extern void assign (EXPR *);
564 extern void proc_listing (int_4);
565 extern void recursion (EXPR *, RECORD, IDENT *);
566 extern void relabel (char *);
567 extern void RTE (const char *, const char *);
568 extern void RTW (const char *, const char *);
569 extern void scan_modules (void);
570 extern void skip_card_expr (void);
571 extern void skip_card (void);
572 extern void slice_char (EXPR *, IDENT *);
573 extern void slice (EXPR *, IDENT *);
574 extern void subprograms (void);
575 extern void variable (EXPR *, IDENT *, MODE *, RECORD);
576 extern void vif_close (void);
577 extern void vif_open (void);
578 extern void vif_rewind (void);
579 extern void write_object (char *);
580
581 // ++++ MACROS
582
583 #define ln(x) log(x)
584
585 static int_4 EQUAL (char *s, char *t)
586 {
587 if (s == NULL || t == NULL) {
588 return s == t;
589 } else {
590 return strcasecmp (s, t) == 0;
591 }
592 }
593
594 static int_4 LEQUAL (char *s, char *t)
595 {
596 if (s == NULL || t == NULL) {
597 return s == t;
598 } else {
599 return strncasecmp (s, t, strlen (s)) == 0;
600 }
601 }
602
603 static inline void BUG (char *s)
604 {
605 fprintf (stderr, "%d %s\n", curlin, source[curlin].text);
606 message (NULL, ERR, "fatal", 4001, "compiler bug", (s));
607 exit (EXIT_FAILURE);
608 }
609
610 #define _write_err(rc, funit, action)\
611 fflush (_ffile[(funit)].unit);\
612 if ((rc) < 1 || ferror (_ffile[(funit)].unit)) {\
613 action;\
614 }
615
616 #define _read_err(rc, funit, action_end, action_err)\
617 if (feof (_ffile[(funit)].unit)) {\
618 action_end;\
619 }\
620 if ((rc) < 1 || ferror (_ffile[(funit)].unit)) {\
621 action_err;\
622 }
623
624 #define _write_eol(funit) {\
625 (void) _vifprintf ((funit), "\n", NULL, NOTYPE, 0);\
626 fflush (_ffile[(funit)].unit);\
627 }
628
629 #define _read_eol(funit) {\
630 (void) _vifscanf ((funit), NULL, NULL, NOTYPE, 0);\
631 }
632
633 #define _abs(a) ({__typeof__ (a) _u = (a); _u >= 0 ? _u : -_u;})
634 #define _dim(a, b) ({__typeof__ (a) _a = (a); __typeof__ (b) _b = (b); _a > _b ? _a - _b : 0;})
635 #define _max(a, b) ({__typeof__ (a) _a = (a); __typeof__ (b) _b = (b); _a > _b ? _a : _b;})
636 #define _min(a, b) ({__typeof__ (a) _a = (a); __typeof__ (b) _b = (b); _a < _b ? _a : _b;})
637 #define _mod(a, b) ({__typeof__ (a) _a = (a), _b = (b), _q = (_a / _b); _q = (_q >= 0 ? floor (_q) : -floor (-_q)); _a - _q * _b;})
638 #define _sign(a, b) ({__typeof__ (a) _a = _abs (a); b >= 0 ? _a : -_a;})
639
640 #define _ichar(s) ((int_4) ((s)[0]))
641
642 // AINT
643 static inline real_4 _aintf (real_4 x) {return truncf (x);}
644 static inline real_8 _aintd (real_8 x) {return trunc (x);}
645 static inline real_16 _aintq (real_16 x) {return truncq (x);}
646
647 // NINT
648 static inline int_4 _nintf (real_4 x) {return (int_4) (x) >= 0.0 ? floorf (x + 0.5) : -floorf (0.5 - x);}
649 static inline int_4 _nintd (real_8 x) {return (int_4) (x >= 0.0 ? floor (x + 0.5) : -floor (0.5 - x));}
650 static inline int_4 _nintq (real_16 x) {return (int_4) (x >= 0.0q ? floorq (x + 0.5q) : -floorq (0.5q - x));}
651
652 // ANINT
653 static inline real_4 _anintf (real_4 x) {return (x) >= 0.0 ? floorf (x + 0.5) : -floorf (0.5 - x);}
654 static inline real_8 _anintd (real_8 x) {return (x >= 0.0 ? floor (x + 0.5) : -floor (0.5 - x));}
655 static inline real_16 _anintq (real_8 x) {return (x >= 0.0q ? floor (x + 0.5q) : -floor (0.5q - x));}
656
657 // COMPLEX*32
658
659 static inline complex_32 CMPLXQ (real_16 re, real_16 im) {complex_32 z; __real__ z = re; __imag__ z = im; return z;}
660
661 // COMPLEX*64
662
663 #define CMPLXX(re, im) (complex_64){re, im}
664
665 // RTS
666
667 extern char *_char (int);
668 extern char *__strtok_r (char *, const char *, char **);
669 extern char *_strupper (char *);
670 extern char **_vif_jit (char *, char *);
671 extern complex_16 _dcmplxq (complex_32);
672 extern complex_16 _up_complex (complex_16, int_4);
673 extern complex_32 _qcmplxd (complex_16);
674 extern complex_32 _up_complex_32 (complex_32, int_4);
675 extern complex_8 _cmplxd (complex_16);
676 extern complex_8 _up_complex_8 (complex_8, int_4);
677 extern int_4 _i1mach (int_4 *);
678 extern int_4 _int4 (char *);
679 extern int_4 _srecordf (char *, const char *, ...);
680 extern int_4 _up_int_4 (int_4, int_4);
681 extern int_4 _vifprintf (int_4, char*, void*, int_4, int_4);
682 extern int_4 _vifscanf (int_4, char*, void*, int_4, int_4);
683 extern int_4 _xerclr (void);
684 extern int_4 _xermsg (char *, char *, char *, int_4 *, int_4 *);
685 extern int_4 _xgetf (int_4 *);
686 extern int_4 _xint4 (real_32);
687 extern int_4 _xnint4 (real_32);
688 extern int_4 _xsetf (int_4 *);
689 extern int_8 _up_int_8 (int_8, int_4);
690 extern int_8 _xint8 (real_32);
691 extern int_8 _xnint8 (real_32);
692 extern real_16 _acotanq (real_16);
693 extern real_16 cotanq (real_16);
694 extern real_16 _qext (real_8);
695 extern real_16 _up_real_16 (real_16, int_4);
696 extern real_16 _xtoquad (real_32);
697 extern real_16 _zabs_32 (real_16 re, real_16 im);
698 extern real_32 _quadtox (real_16);
699 extern real_32 _quadtop (real_32 *, real_16);
700 extern real_32 _xerf (real_32);
701 extern real_32 _xint (real_32);
702 extern real_32 _xI (real_32);
703 extern real_32 _xmod (real_32, real_32);
704 extern real_32 _xnint (real_32);
705 extern real_32 _zabs_64 (real_32 re, real_32 im);
706 extern real_4 _acotanf (real_4);
707 extern real_4 cotanf (real_4);
708 extern real_4 _up_real_4 (real_4, int_4);
709 extern real_4 _zabs_8 (real_4 re, real_4 im);
710 extern real_8 _acotan (real_8);
711 extern real_8 cotan (real_8);
712 extern real_8 _drand48 (void);
713 extern real_8 _up_real_8 (real_8, int_4);
714 extern real_8 _zabs_16 (real_8 re, real_8 im);
715 extern void _cputim (real_8 *);
716 extern void _cputyd (int_4 *);
717 extern void _fcheck (char *, int_4, char *, char *);
718 extern void _fclose (int_4);
719 extern void _fprintf_real_32 (char *, char *, real_32, int_4, int_4);
720 extern void _fregister (char *, int_4, int_4, char *, char *, char *, char *);
721 extern void _funregister (char *, int_4);
722 extern void _ioend_read (char *, int_4);
723 extern void _ioerr (char *, int_4);
724 extern void _ioerr_read (char *, int_4);
725 extern void _ioerr_write (char *, int_4);
726 extern void _merfi (real_8 *, real_8 *, int_4 *);
727 extern void _qhex (real_16 *);
728 extern void _skip_eol (FILE *);
729 extern void _srand48 (int_4 *);
730 extern void _vif_exit (void);
731 extern void _vif_freq (CALLS *);
732 extern void _vif_init (void);
733 extern void _xhex (real_32 *);
734
735 // ++++ INTRINSIC functions
736
737 extern complex_16 _cdcos (complex_16 *);
738 extern complex_16 _cdexp (complex_16 *);
739 extern complex_16 _cdlog (complex_16 *);
740 extern complex_16 _cdsin (complex_16 *);
741 extern complex_16 _cdsqrt (complex_16 *);
742 extern complex_16 _cdtan (complex_16 *);
743 extern complex_32 _cqcos (complex_32 *);
744 extern complex_32 _cqexp (complex_32 *);
745 extern complex_32 _cqlog (complex_32 *);
746 extern complex_32 _cqsin (complex_32 *);
747 extern complex_32 _cqsqrt (complex_32 *);
748 extern complex_32 _cqtan (complex_32 *);
749 extern complex_64 _cxcos (complex_64 *);
750 extern complex_64 _cxexp (complex_64 *);
751 extern complex_64 _cxlog (complex_64 *);
752 extern complex_64 _cxsin (complex_64 *);
753 extern complex_64 _cxsqrt (complex_64 *);
754 extern complex_64 _cxtan (complex_64 *);
755 extern complex_8 _ccos (complex_8 *);
756 extern complex_8 _cexp (complex_8 *);
757 extern complex_8 _clog (complex_8 *);
758 extern complex_8 _csin (complex_8 *);
759 extern complex_8 _csqrt (complex_8 *);
760 extern complex_8 _ctan (complex_8 *);
761 extern real_16 _qacos (real_16 *);
762 extern real_16 _qasin (real_16 *);
763 extern real_16 _qatan2 (real_16 *, real_16 *);
764 extern real_16 _qatan (real_16 *);
765 extern real_16 _qcosh (real_16 *);
766 extern real_16 _qcos (real_16 *);
767 extern real_16 _qcotan (real_16 *);
768 extern real_16 _qexp (real_16 *);
769 extern real_16 _qint (real_16);
770 extern real_16 _qlog10 (real_16 *);
771 extern real_16 _qlog (real_16 *);
772 extern real_16 _qnint (real_16);
773 extern real_16 _qsinh (real_16 *);
774 extern real_16 _qsin (real_16 *);
775 extern real_16 _qsqrt (real_16 *);
776 extern real_16 _qtanh (real_16 *);
777 extern real_16 _qtan (real_16 *);
778 extern real_16 _strtoquad (char *, char **);
779 extern real_32 _xacos (real_32 *);
780 extern real_32 _xasin (real_32 *);
781 extern real_32 _xatan2 (real_32 *, real_32 *);
782 extern real_32 _xatan (real_32 *);
783 extern real_32 _xcosh (real_32 *);
784 extern real_32 _xcos (real_32 *);
785 extern real_32 _xcotan (real_32 *);
786 extern real_32 _xexp (real_32 *);
787 extern real_32 _xlog10 (real_32 *);
788 extern real_32 _xlog (real_32 *);
789 extern real_32 _xsinh (real_32 *);
790 extern real_32 _xsin (real_32 *);
791 extern real_32 _xsqrt (real_32 *);
792 extern real_32 _xtanh (real_32 *);
793 extern real_32 _xtan (real_32 *);
794 extern real_4 _acosf (real_4 *);
795 extern real_4 _aint (real_4);
796 extern real_4 _anint (real_4);
797 extern real_4 _atan2f (real_4 *, real_4 *);
798 extern real_4 _atanf (real_4 *);
799 extern real_4 _cosf (real_4 *);
800 extern real_4 _coshf (real_4 *);
801 extern real_4 _cotanf (real_4 *);
802 extern real_4 _expf (real_4 *);
803 extern real_4 _log10f (real_4 *);
804 extern real_4 _logf (real_4 *);
805 extern real_4 _sinf (real_4 *);
806 extern real_4 _sinhf (real_4 *);
807 extern real_4 _sqrtf (real_4 *);
808 extern real_4 _tanf (real_4 *);
809 extern real_4 _tanhf (real_4 *);
810 extern real_8 _dacos (real_8 *);
811 extern real_8 _dasin (real_8 *);
812 extern real_8 _datan2 (real_8 *, real_8 *);
813 extern real_8 _datan (real_8 *);
814 extern real_8 _dcosh (real_8 *);
815 extern real_8 _dcos (real_8 *);
816 extern real_8 _dcotan (real_8 *);
817 extern real_8 _dexp (real_8 *);
818 extern real_8 _dint (real_8);
819 extern real_8 _dlog10 (real_8 *);
820 extern real_8 _dlog (real_8 *);
821 extern real_8 _dnint (real_8);
822 extern real_8 _dsinh (real_8 *);
823 extern real_8 _dsin (real_8 *);
824 extern real_8 _dsqrt (real_8 *);
825 extern real_8 _dtanh (real_8 *);
826 extern real_8 _dtan (real_8 *);
827 extern void _pi16 (real_16 *);
828 extern void _pi32 (real_32 *);
829 extern void _pi4 (real_4 *);
830 extern void _pi8 (real_8 *);
831
832 #endif
|
© 2002-2024 J.M. van der Veer (jmvdveer@xs4all.nl)
|
