rts.c
1 //! @file rts.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 //! Runtime support.
25
26 #include <vif.h>
27 #include <execinfo.h>
28
29 void _vif_backtr (int_4 signal)
30 {
31 void *array[10];
32 (void) signal;
33 fprintf (stderr, "\n** exception ** f%d: address error: generating stack dump\n", 3201);
34 size_t size = backtrace(array, 10);
35 backtrace_symbols_fd(array, size, STDERR_FILENO);
36 exit (EXIT_FAILURE);
37 }
38
39 void *f_malloc (size_t size)
40 {
41 void *p = malloc (size);
42 if (p == NULL) {
43 OVERFLOW (3202, "f_malloc");
44 }
45 return p;
46 }
47
48 void *f_realloc (void *q, size_t size)
49 {
50 void *p = realloc (q, size);
51 if (p == NULL) {
52 OVERFLOW (3203, "f_realloc");
53 }
54 return p;
55 }
56
57 char *strlower (char *s)
58 {
59 // We use a circular buffer for collateral calls.
60 #define BUFS 10
61 static int_4 buf = 0;
62 static RECORD zb[BUFS];
63 if (buf == BUFS) {
64 buf = 0;
65 }
66 char *z = (char *) &zb[buf++];
67 strncpy (z, s, RECLN);
68 for (int_4 k = 0; k < (int_4) strlen (z); k++) {
69 z[k] = tolower (z[k]);
70 }
71 return z;
72 #undef BUFS
73 }
74
75 char *_strupper (char *s)
76 {
77 // We use a circular buffer for collateral calls.
78 #define BUFS 10
79 static int_4 buf = 0;
80 static RECORD zb[BUFS];
81 if (buf == BUFS) {
82 buf = 0;
83 }
84 char *z = (char *) &zb[buf++];
85 strncpy (z, s, RECLN);
86 for (int_4 k = 0; k < (int_4) strlen (z); k++) {
87 z[k] = toupper (z[k]);
88 }
89 return z;
90 #undef BUFS
91 }
92
93 void RTE (const char *where, const char *text)
94 {
95 if (where != NULL) {
96 fprintf (stderr, "%s: ", where);
97 }
98 if (errno == 0) {
99 fprintf (stderr, "runtime error: %s.\n", text);
100 } else {
101 fprintf (stderr, "runtime error: %s: %s.\n", text, strerror (errno));
102 }
103 _vif_exit ();
104 exit (EXIT_FAILURE);
105 }
106
107 void RTW (const char *where, const char *text)
108 {
109 if (where != NULL) {
110 fprintf (stderr, "%s: ", where);
111 }
112 if (errno == 0) {
113 fprintf (stderr, "runtime warning: %s.\n", text);
114 } else {
115 fprintf (stderr, "runtime warning: %s: %s.\n", text, strerror (errno));
116 }
117 }
118
119 void _vif_init (void)
120 {
121 signal (SIGSEGV, _vif_backtr);
122 for (int_4 k = 0; k < MAX_FILES; k++) {
123 _ffile[k] = (FTNFILE) {
124 .unit = NULL,.name = NULL,.form = NULL,.action = NULL,.disp = NULL,.vers = 0,.buff = NULL,.buff_init = FALSE,.buff_pos = 0,.buff_len = 0};
125 }
126 }
127
128 void _vif_exit (void)
129 {
130 for (int_4 k = 0; k < MAX_FILES; k++) {
131 if (_ffile[k].unit == NULL) {
132 } else if (_ffile[k].unit == stdin) {
133 } else if (_ffile[k].unit == stdout) {
134 } else if (_ffile[k].unit == stderr) {
135 } else {
136 fclose (_ffile[k].unit);
137 }
138 }
139 }
140
141 void _cputim (real_8 *s)
142 {
143 struct timeval t;
144 static real_8 start_cpu_time = -1;
145 real_8 hand;
146 gettimeofday (&t, NULL);
147 hand = (real_8) t.tv_sec + t.tv_usec * 1e-6;
148 if (start_cpu_time < 0) {
149 start_cpu_time = hand;
150 }
151 *s = hand - start_cpu_time;
152 }
153
154 void _cputyd (int_4 *i)
155 {
156 // In a resolution of 100 us
157 struct timeval t;
158 static real_8 start_cpu_time = -1;
159 real_8 hand;
160 gettimeofday (&t, NULL);
161 hand = (real_8) t.tv_sec + t.tv_usec * 1e-6;
162 if (start_cpu_time < 0) {
163 start_cpu_time = hand;
164 }
165 *i = (int_4) (10000 * (hand - start_cpu_time));
166 }
167
168 void _vif_freq (CALLS *c)
169 {
170 for (int_4 k = 0; c[k].name != NULL; k++) {
171 printf ("%s %ld\n", c[k].name, c[k].calls);
172 }
173 }
174
175 char *__strtok_r (char *s, const char *delim, char **save_ptr)
176 {
177 // Based on code from the GNU C library.
178 char *end;
179 if (s == NULL) {
180 s = *save_ptr;
181 }
182 if (*s == '\0') {
183 *save_ptr = s;
184 return NULL;
185 }
186 // Scan leading delimiters.
187 s += strspn (s, delim);
188 if (*s == '\0') {
189 *save_ptr = s;
190 return NULL;
191 }
192 // Find the end of the token.
193 end = s + strcspn (s, delim);
194 if (*end == '\0') {
195 *save_ptr = end;
196 return s;
197 }
198 // Terminate the token and make *SAVE_PTR point_4 past it.
199 *end = '\0';
200 *save_ptr = end + 1;
201 return s;
202 }
203
204 // CHARACTER*n
205
206 int_4 _srecordf (char *s, const char *format, ...)
207 {
208 size_t N = RECLN;
209 va_list ap;
210 va_start (ap, format);
211 int_4 vsnprintf (char *, size_t, const char *, va_list);
212 // Print in new string, just in case 's' is also an argument!
213 int_4 M = N + 16; // A bit longer so we trap too long prints.
214 char *t = f_malloc (M);
215 int_4 Np = vsnprintf (t, M, format, ap);
216 va_end (ap);
217 if (Np >= N) {
218 free (t);
219 OVERFLOW (3204, "_srecordf");
220 } else {
221 strcpy (s, t);
222 free (t);
223 }
224 return Np;
225 }
226
227 char *bufcpy (char *dst, char *src, int_4 len)
228 {
229 // Fortran string lengths are len+1, last one is for null.
230 memset (dst, 0, len + 1);
231 strncpy (dst, src, len + 1);
232 return dst;
233 }
234
235 char *bufcat (char *dst, char *src, int_4 len)
236 {
237 // Fortran string lengths are len+1, last one is for null.
238 int_4 N = len - (int_4) strlen (dst);
239 if (N > 0) {
240 strncat (dst, src, N);
241 dst[len] = '\0';
242 }
243 return dst;
244 }
245
246 char *bufrep (char *dst, char *src)
247 {
248 // Replace first chars of dst with src without its null char.
249 // A(I:J) = B
250 while (src[0] != 0 && dst[0] != 0) {
251 (dst++)[0] = (src++)[0];
252 }
253 return dst;
254 }
255
256 char *_bufsub(char *dst, char *src, int_4 i, int_4 f)
257 {
258 int_4 N = f - i + 1;
259 if (N > 0 && i >= 1) {
260 bufcpy (dst, &src[i - 1], N);
261 dst[N] = '\0';
262 } else {
263 dst[0] = '\0';
264 }
265 return dst;
266 }
267
268 char *concat (char *dst, char *lhs, char *rhs)
269 {
270 // Fortran // operator.
271 strcpy (dst, lhs);
272 strcat (dst, rhs);
273 return dst;
274 }
275
276 char *_char (int c)
277 {
278 #define N_CHARS 256
279 static char _ch[N_CHARS][2];
280 int N = c % N_CHARS;
281 _ch[N][0] = (char) N;
282 _ch[N][1] = '\0';
283 return &_ch[N][0];
284 #undef N_CHARS
285 }
286
287 void _srand48 (int_4 *seed)
288 {
289 srand48 (*seed);
290 }
291
292 real_8 _drand48 (void)
293 {
294 return drand48 ();
295 }
|
© 2002-2024 J.M. van der Veer (jmvdveer@xs4all.nl)
|
