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