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