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