rts-io.c
1 //! @file rts-io.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 for Fortran IO.
25
26 #include <vif.h>
27 #include <rts-real32.h>
28
29 #define SIGN(z) ((z) == 0 ? 0 : ((z) > 0 ? 1 : 0))
30 #define ERROR_CHAR '*'
31 #define POINT_CHAR '.'
32
33 void xsprintfmt (char *, const char *, ...);
34
35 FTNFILE _ffile[MAX_FILES];
36
37 char *action_default = "action_default";
38 char *action_read = "action_read";
39 char *action_write = "action_write";
40 char *action_readwrite = "action_readwrite";
41 char *form_formatted = "form_formatted";
42 char *form_unformatted = "form_unformatted";
43 char *disp_new = "disp_new";
44 char *disp_old = "disp_old";
45 char *disp_delete = "disp_delete";
46 char *disp_keep = "disp_keep";
47
48 // __scale__ is set by nP in formats.
49
50 int_4 __scale__ = 1;
51
52 void _fclose (int_4 k)
53 {
54 if (_ffile[k].unit != NO_FILE) {
55 (void) fclose (_ffile[k].unit);
56 _ffile[k].unit = NO_FILE;
57 }
58 }
59
60 static char *plusab (char *buf, char c)
61 {
62 char z[2];
63 z[0] = c;
64 z[1] = '\0';
65 bufcat (buf, z, RECLN);
66 return buf;
67 }
68
69 static char *plusto (char ch, char *buf)
70 {
71 memmove (&buf[1], &buf[0], strlen(buf) + 1);
72 buf[0] = ch;
73 return buf;
74 }
75
76 static char *leading_spaces (char *buf, int_4 width)
77 {
78 if (width > 0) {
79 int_4 j = ABS (width) - (int_4) strlen (buf);
80 while (--j >= 0) {
81 (void) plusto (' ', buf);
82 }
83 }
84 return buf;
85 }
86
87 static char *error_chars (char *buf, int_4 n)
88 {
89 int_4 k = (n != 0 ? ABS (n) : 1);
90 buf[k] = '\0';
91 while (--k >= 0) {
92 buf[k] = ERROR_CHAR;
93 }
94 return buf;
95 }
96
97 static char digchar (int_4 k)
98 {
99 char *tab = "0123456789abcdefghijklmnopqrstuvwxyz";
100 if (k >= 0 && k < (int_4) strlen (tab)) {
101 return tab[k];
102 } else {
103 return ERROR_CHAR;
104 }
105 }
106
107 // INTEGER*8
108
109 char *intnot (char *buf, int_8 k, int_4 width)
110 {
111 int_8 n = ABS (k);
112 buf[0] = '\0';
113 do {
114 (void) plusto (digchar (n % 10), buf);
115 n /= 10;
116 } while (n != 0);
117 if (k < 0) {
118 (void) plusto ('-', buf);
119 }
120 if (width > 0 && strlen (buf) > width) {
121 (void) error_chars (buf, width);
122 } else {
123 (void) leading_spaces (buf, width);
124 }
125 return buf;
126 }
127
128 // REAL*32
129
130 void xsprintfmt (char *buffer, const char *fmt, ...)
131 {
132 RECORD ibuff;
133 RECCLR (ibuff);
134 va_list ap;
135 va_start (ap, fmt);
136 vsprintf (ibuff, fmt, ap);
137 va_end (ap);
138 strcat (buffer, ibuff);
139 }
140
141 static int_4 special_value (char *s, real_32 u, int_4 sign)
142 {
143 if ((xis_pinf (&u))) {
144 if (sign != 0) {
145 *s++ = '+';
146 }
147 strcpy (s, "Inf");
148 return 1;
149 } else if ((xis_minf (&u))) {
150 strcpy (s, "-Inf");
151 return 1;
152 } else if ((xis_nan (&u))) {
153 if (sign != 0) {
154 *s++ = '\?';
155 }
156 strcpy (s, "NaN");
157 return 1;
158 } else {
159 return 0;
160 }
161 }
162
163 char *xsubfixed (char *buffer, real_32 v, logical_4 sign, int_4 digs)
164 {
165 RECCLR (buffer);
166 if ((special_value (buffer, v, sign))) {
167 return buffer;
168 }
169 real_32 u = v;
170 digs = _min (_abs (digs), FLT256_DIG);
171 // Put sign and take abs value.
172 char *p = buffer;
173 if (xlt (u, X_0)) {
174 u = xneg (u);
175 *(p++) = '-';
176 } else if (sign) {
177 *(p++) = '+';
178 } else {
179 *(p++) = ' ';
180 }
181 // Round fraction
182 real_32 eps = xmul(X_1_OVER_2, xtenup (-digs));
183 u = xsum (u, eps);
184 //
185 int_4 before;
186 if (xlt (u, X_10)) {
187 before = 1;
188 } else if (xlt (u, X_100)) {
189 before = 2;
190 } else if (xlt (u, X_1000)) {
191 before = 3;
192 } else {
193 before = (int_4) ceil (xtodbl (xlog10 (u)));
194 }
195 // Integral part.
196 u = xdiv (u, xtenup (before));
197 while (xge (u, X_1)) {
198 u = xdiv (u, X_10);
199 before++;
200 }
201 for (int_4 k = 0; k < before; ++k) {
202 u = xmul (X_10, u);
203 int_4 dig;
204 u = xsfmod (u, &dig);
205 *(p++) = (char) '0' + dig;
206 }
207 // Fraction.
208 *(p++) = '.';
209 for (int_4 k = 0; k < digs; ++k) {
210 u = xmul (X_10, u);
211 int_4 dig;
212 u = xsfmod (u, &dig);
213 *(p++) = (char) '0' + dig;
214 }
215 return buffer;
216 }
217
218 char *xfixed (char *buf, real_32 x, int_4 width, int_4 digs, int_4 precision)
219 {
220 width = _abs (width);
221 digs = _min (abs (digs), precision);
222 xsubfixed (buf, x, FALSE, digs);
223 if (width > 0 && strlen (buf) > width) {
224 return error_chars (buf, width);
225 } else {
226 return leading_spaces (buf, width);
227 }
228 }
229
230 char *xfloat (char *buf, real_32 z, int_4 width, int_4 digs, int_4 expos, int_4 mult, int_4 precision, char sym)
231 {
232 buf[0] = '\0';
233 width = _abs (width);
234 digs = _min (abs (digs), precision);
235 expos = _abs (expos);
236 if (expos > 5) {
237 return error_chars (buf, width);
238 }
239 // Scientific notation mult = 1, Engineering notation mult = 3
240 mult = _max (1, mult);
241 // Default __scale__ is 1.
242 int_4 q = 1;
243 char *max = "1";
244 real_32 x = xabs (z), lwb, upb;
245 //
246 if (__scale__ < 0 || __scale__ > 3) {
247 __scale__ = 1;
248 }
249 if (mult == 1) {
250 if (__scale__ == 0) {
251 lwb = X_1_OVER_10;
252 upb = X_1;
253 q = 1;
254 max = "0.1";
255 } else if (__scale__ == 1) {
256 lwb = X_1;
257 upb = X_10;
258 q = 0;
259 max = "1";
260 } else if (__scale__ == 2) {
261 lwb = X_10;
262 upb = X_100;
263 q = -1;
264 max = "10";
265 } else if (__scale__ == 3) {
266 lwb = X_100;
267 upb = X_1000;
268 max = "100";
269 q = -2;
270 }
271 }
272 // Standardize.
273 int_4 p = 0;
274 if (xnot0 (&x)) {
275 p = (int_4) round (xtodbl (xlog10 (xabs(x)))) + q;
276 x = xdiv (x, xtenup (p));
277 if (xle (x, lwb)) {
278 x = xmul (x, X_10);
279 p--;
280 }
281 if (xge (x, upb)) {
282 x = xdiv (x, X_10);
283 p++;
284 }
285 while (p % mult != 0) {
286 x = xmul (x, X_10);
287 p--;
288 }
289 }
290 // Form number.
291 RECORD mant;
292 RECCLR (mant);
293 xsubfixed (mant, x, FALSE, digs);
294 // Correction of rounding issue by which |mant| equals UPB.
295 if (strchr (mant, '*') == NO_TEXT && xge (xabs (strtox (mant, NO_REF_TEXT)), upb)) {
296 if (mant[0] == ' ' || mant[0] == '+') {
297 _srecordf (mant, "%c%s", mant[0], max);
298 } else {
299 _srecordf (mant, "%s", max);
300 }
301 if (digs > 0) {
302 plusab (mant, '.');
303 for (int_4 k = 0; k < digs; k++) {
304 plusab (mant, '0');
305 }
306 }
307 p++;
308 }
309 //
310 RECORD fmt;
311 if (xsgn (&z) < 0) {
312 mant[0] = '-';
313 }
314 _srecordf (fmt, "%%s%c%%+0%dd", sym, expos);
315 _srecordf (buf, fmt, mant, p);
316 if (width > 0 && (strchr (buf, '*') != NO_TEXT || strlen (buf) > width)) {
317 if (digs > 0) {
318 return xfloat (buf, z, width, digs - 1, expos, mult, precision, sym);
319 } else {
320 return error_chars (buf, width);
321 }
322 } else {
323 return leading_spaces (buf, width);
324 }
325 }
326
327 // Fortran IO
328
329 void _fcheck (char *where, int_4 unit, char *action, char *form)
330 {
331 RECORD str;
332 __scale__ = 1;
333 if (unit < 0 || unit >= MAX_FILES) {
334 _srecordf (str, "unit number %d is not valid", unit);
335 RTE (where, str);
336 }
337 if (action == NO_TEXT) {
338 // CLOSE, REWIND
339 return;
340 }
341 if (_ffile[unit].unit == NO_FILE) {
342 // File was not opened yet.
343 RECORD mode, disp;
344 RECCLR (mode);
345 RECCLR (disp);
346 if (_ffile[unit].disp != NO_TEXT) {
347 strcpy (disp, _ffile[unit].disp);
348 } else {
349 strcpy (disp, disp_old);
350 }
351 if (_ffile[unit].action == action_default) {
352 _ffile[unit].action = action;
353 } else if (_ffile[unit].action == action_readwrite) {
354 action = action_readwrite;
355 } else if (_ffile[unit].action != action) {
356 _srecordf (str, "inconsistent action: %s", action);
357 RTE (where, str);
358 }
359 if (_ffile[unit].form == NO_TEXT) {
360 _ffile[unit].form = form;
361 } else if (_ffile[unit].form != form) {
362 _srecordf (str, "inconsistent formatting: %s", form);
363 RTE (where, str);
364 }
365 strcpy (mode, "UNKNOWN");
366 if (form == form_formatted && action == action_read) {
367 strcpy (mode, "r");
368 } else if (form == form_formatted && action == action_write) {
369 strcpy (mode, "w");
370 } else if (form == form_formatted && action == action_readwrite) {
371 if (EQUAL (disp, "disp_old")) {
372 strcpy (mode, "r+");
373 } else if (EQUAL (disp, "disp_new")) {
374 strcpy (mode, "w+");
375 }
376 } else if (form == form_unformatted && action == action_read) {
377 strcpy (mode, "rb");
378 } else if (form == form_unformatted && action == action_write) {
379 strcpy (mode, "wb");
380 } else if (form == form_unformatted && action == action_readwrite) {
381 if (EQUAL (disp, "disp_old")) {
382 strcpy (mode, "r+b");
383 } else if (EQUAL (disp, "disp_new")) {
384 strcpy (mode, "w+b");
385 }
386 } else {
387 _srecordf (str, "error: form=%s, action=%s, disp=%s", form, action, disp);
388 RTE (where, str);
389 }
390 if (_ffile[unit].in_stream) {
391 if ((_ffile[unit].unit = fmemopen (_ffile[unit].buff, strlen (_ffile[unit].buff) + 1, mode)) == NO_FILE) {
392 _srecordf (str, "cannot open unit %d: form=%s, action=%s, disp=%s", unit, form, action, disp);
393 RTE (where, str);
394 }
395 } else {
396 if ((_ffile[unit].unit = fopen (_ffile[unit].name, mode)) == NO_FILE) {
397 _srecordf (str, "cannot open unit %d: form=%s, action=%s, disp=%s", unit, form, action, disp);
398 RTE (where, str);
399 }
400 }
401 rewind (_ffile[unit].unit);
402 } else {
403 // File was opened.
404 if (action == action_read) {
405 if (_ffile[unit].action == action_write) {
406 _srecordf (str, "'unit %d' is not open for 'read'", unit);
407 RTE (where, str);
408 }
409 } else if (action == action_write) {
410 if (_ffile[unit].action == action_read) {
411 _srecordf (str, "'unit %d' is not open for 'write'", unit);
412 RTE (where, str);
413 }
414 }
415 if (_ffile[unit].form != form) {
416 if (form == form_formatted) {
417 _srecordf (str, "'unit %d' is not open for formatted IO", unit);
418 } else {
419 _srecordf (str, "'unit %d' is not open for unformatted IO", unit);
420 }
421 RTE (where, str);
422 }
423 }
424 }
425
426 void _fregister (char *where, int_4 unit, int_4 lrecl, char *fn, char *form, char *action, char *disp)
427 {
428 if (unit >= 0 && unit < MAX_FILES) {
429 int_4 len;
430 if (_ffile[unit].unit != NO_FILE) {
431 RECORD err;
432 _srecordf (err, "'unit %d' already open", unit);
433 RTE (where, err);
434 }
435 if (lrecl <= 0 || lrecl > MAX_LRECL) {
436 lrecl = MAX_LRECL;
437 }
438 _ffile[unit] = (FTNFILE) {
439 .form = form,.action = action,.disp = disp,.lrecl = lrecl};
440 _ffile[unit].buff = (char *) f_malloc (lrecl + 1);
441 if (_ffile[unit].in_stream) {
442 _ffile[unit].buff_init = TRUE;
443 _ffile[unit].action = action_read;
444 } else {
445 _ffile[unit].buff_init = FALSE;
446 }
447 _ffile[unit].buff_pos = 0;
448 if (fn == NO_TEXT) {
449 RECORD buf;
450 _ffile[unit].vers++;
451 _srecordf (buf, "ft%02df%03d", unit, _ffile[unit].vers);
452 len = strlen (buf) + 1;
453 _ffile[unit].name = (char *) f_malloc (len);
454 strcpy (_ffile[unit].name, buf);
455 } else {
456 len = strlen (fn) + 1;
457 _ffile[unit].name = (char *) f_malloc (len);
458 strcpy (_ffile[unit].name, fn);
459 }
460 } else {
461 RTE (where, "unit out of range");
462 }
463 }
464
465 void _funregister (char *where, int_4 unit)
466 {
467 if (unit >= 0 && unit < MAX_FILES) {
468 if (_ffile[unit].unit != NO_FILE) {
469 _fclose (unit);
470 }
471 if (_ffile[unit].disp == disp_delete) {
472 remove (_ffile[unit].name);
473 }
474 if (_ffile[unit].name != NO_TEXT) {
475 free (_ffile[unit].name);
476 }
477 if (_ffile[unit].buff != NO_TEXT) {
478 free (_ffile[unit].buff);
479 }
480 _ffile[unit] = (FTNFILE) {
481 .unit = NO_FILE,.name = NO_TEXT,.form = NO_TEXT,.action = NO_TEXT,.disp = NO_TEXT,.vers = 0,.buff = NO_TEXT,.buff_init = FALSE,.buff_pos = 0,.buff_len = 0};
482 } else {
483 RTE (where, "unit out of range");
484 }
485 }
486
487 void _skip_eol (FILE * f)
488 {
489 while (fgetc (f) != '\n');
490 }
491
492 void _ioerr (char *where, int_4 unit)
493 {
494 RECORD err;
495 _srecordf (err, "'unit %d' IO error", unit);
496 RTE (where, err);
497 }
498
499 void _ioerr_write (char *where, int_4 unit)
500 {
501 RECORD err;
502 _srecordf (err, "'unit %d' IO error while writing", unit);
503 RTE (where, err);
504 }
505
506 void _ioerr_read (char *where, int_4 unit)
507 {
508 RECORD err;
509 _srecordf (err, "'unit %d' IO error while reading", unit);
510 RTE (where, err);
511 }
512
513 void _ioend_read (char *where, int_4 unit)
514 {
515 RECORD err;
516 _srecordf (err, "'unit %d' end of file while reading", unit);
517 RTE (where, err);
518 }
519
520 void _fprintf_int_8 (char *str, char *fmt, int_8 elem)
521 {
522 int_4 len = 0;
523 if (fmt[0] == '%') {
524 fmt++;
525 }
526 if (isdigit (fmt[0])) {
527 len = strtol (fmt, NO_REF_TEXT, 10);
528 }
529 intnot (str, elem, len);
530 }
531
532 void _fprintf_real_32 (char *buf, char *fmt, real_32 item, int_4 expw, int_4 precision)
533 {
534 int_4 dec = 0, len = 0, expos = 0;
535 if (fmt[0] == '%') {
536 fmt++;
537 }
538 char expo_char = fmt[strlen (fmt) - 1];
539 if (expo_char == 'n') {
540 expo_char = 'e';
541 } else if (expo_char == 'N') {
542 expo_char = 'E';
543 }
544 char *p1, *p2, *expo;
545 if (fmt[0] == '.') {
546 fmt++;
547 dec = strtol (fmt, &p2, 10);
548 } else {
549 len = strtol (fmt, &p1, 10);
550 dec = strtol (&p1[1], &p2, 10);
551 }
552 if (tolower (expo_char) == 'e') {
553 int_4 ee = strtol (&p2[1], &expo, 10);
554 expos = (ee == 0 ? expw : ee);
555 }
556 if (tolower (expo_char) == 'f') {
557 xfixed (buf, item, len, dec, precision);
558 } else if (tolower (expo[0]) == 'n') {
559 xfloat (buf, item, len, dec, expos, 3, precision, expo_char);
560 } else {
561 xfloat (buf, item, len, dec, expos, 1, precision, expo_char);
562 }
563 return;
564 }
565
566 int_4 _vifprintf (int_4 unit, char *fmt, void *elem, int_4 type, int_4 len)
567 {
568 FTNFILE *_f = &_ffile[unit];
569 if (fmt == NO_TEXT || strlen (fmt) == 0) {
570 return ERR;
571 }
572 if (strcmp (fmt, "\n") == 0) {
573 fprintf (_f->unit, "\n");
574 return 1;
575 }
576 if (fmt != NO_TEXT && type == NOTYPE) {
577 if (strcmp (fmt, "0") == 0) {
578 __scale__ = 0;
579 } else if (strcmp (fmt, "1") == 0) {
580 __scale__ = 1;
581 } else if (strcmp (fmt, "2") == 0) {
582 __scale__ = 2;
583 } else if (strcmp (fmt, "3") == 0) {
584 __scale__ = 3;
585 } else {
586 fprintf (_f->unit, fmt);
587 }
588 return 1;
589 }
590 //
591 char mod = tolower (fmt[strlen (fmt) - 1]);
592 if (mod == 's') {
593 if (type == NOTYPE) {
594 fprintf (_f->unit, fmt);
595 return 1;
596 } else if (type == CHARACTER) {
597 fprintf (_f->unit, fmt, (char *) elem);
598 return 1;
599 } else if (type == LOGICAL) {
600 fprintf (_f->unit, fmt, (*(int_4 *) elem ? 't' : 'f'));
601 return 1;
602 } else if (type == INTEGER && len == 4) {
603 int_4 awid = len, width;
604 if (sscanf (fmt, "%%%ds", &width) == 1) {
605 awid = _abs (width);
606 }
607 int_4 sum = *(int_4 *) elem;
608 for (int_4 k = 0; k < len && k < awid; k++) {
609 char ch = sum % (UCHAR_MAX + 1);
610 fprintf (_f->unit, "%c", ch);
611 sum /= (UCHAR_MAX + 1);
612 }
613 return 1;
614 } else if (type == REAL && len == 8) {
615 int_4 awid = len, width;
616 if (sscanf (fmt, "%%%ds", &width) == 1) {
617 awid = _abs (width);
618 }
619 real_8 sum = *(real_8 *) elem;
620 for (int_4 k = 0; k < len && k < awid; k++) {
621 char ch = (int_4) fmod (sum, (UCHAR_MAX + 1));
622 fprintf (_f->unit, "%c", ch);
623 sum = floor (sum / (UCHAR_MAX + 1));
624 }
625 return 1;
626 } else {
627 return ERR;
628 }
629 } else if (mod == 'c') {
630 if (type == LOGICAL) {
631 fprintf (_f->unit, fmt, (*(int_4 *) elem ? 't' : 'f'));
632 } else {
633 return ERR;
634 }
635 return 1;
636 } else if (mod == 'd') {
637 // INTEGER
638 if (type == INTEGER && len == 2) {
639 RECORD buf;
640 RECCLR (buf);
641 _fprintf_int_8 (buf, fmt, (int_8) *(int_2 *) elem);
642 fprintf (_f->unit, "%s", buf);
643 } else if (type == INTEGER && len == 4) {
644 RECORD buf;
645 RECCLR (buf);
646 _fprintf_int_8 (buf, fmt, (int_8) *(int_4 *) elem);
647 fprintf (_f->unit, "%s", buf);
648 } else if (type == INTEGER && len == 8) {
649 RECORD buf;
650 RECCLR (buf);
651 _fprintf_int_8 (buf, fmt, (int_8) *(int_8 *) elem);
652 fprintf (_f->unit, "%s", buf);
653 } else if (type == INTEGER && len == 16) {
654 RECORD buf;
655 RECCLR (buf);
656 _fprintf_int_8 (buf, fmt, (int_8) *(int_8 *) elem);
657 fprintf (_f->unit, "%s", buf);
658 } else {
659 return ERR;
660 }
661 return 1;
662 } else if (mod == 'e' || mod == 'n' || mod == 'f') {
663 // REAL and COMPLEX
664 RECORD str;
665 RECCLR (str);
666 if (type == INTEGER && len == 2) {
667 _fprintf_real_32 (str, fmt, flttox ((real_4) *(int_2 *) elem), 4, FLT_DIG);
668 fprintf (_f->unit, "%s", str);
669 } else if (type == INTEGER && len == 4) {
670 _fprintf_real_32 (str, fmt, dbltox ((real_8) *(int_4 *) elem), 4, FLT_DIG);
671 fprintf (_f->unit, "%s", str);
672 } else if (type == INTEGER && len == 8) {
673 _fprintf_real_32 (str, fmt, dbltox ((real_8) *(int_8 *) elem), 4, FLT_DIG);
674 fprintf (_f->unit, "%s", str);
675 } else if (type == REAL && len == 4) {
676 _fprintf_real_32 (str, fmt, flttox (*(real_4 *) elem), 4, FLT_DIG);
677 fprintf (_f->unit, "%s", str);
678 } else if (type == REAL && len == 8) {
679 _fprintf_real_32 (str, fmt, dbltox (*(real_8 *) elem), 4, DBL_DIG);
680 fprintf (_f->unit, "%s", str);
681 } else if (type == REAL && len == 16) {
682 _fprintf_real_32 (str, fmt, _quadtox (*(real_16 *) elem), 5, FLT128_DIG);
683 fprintf (_f->unit, "%s", str);
684 } else if (type == REAL && len == 32) {
685 _fprintf_real_32 (str, fmt, *(real_32 *) elem, 5, FLT256_DIG);
686 fprintf (_f->unit, "%s", str);
687 } else if (type == COMPLEX && len == 8) {
688 real_4 z = crealf (*(complex_8 *) elem);
689 _vifprintf (unit, fmt, &z, REAL, 4);
690 } else if (type == COMPLEX && len == -8) {
691 real_4 z = cimagf (*(complex_8 *) elem);
692 _vifprintf (unit, fmt, &z, REAL, 4);
693 } else if (type == COMPLEX && len == 16) {
694 real_8 z = creal (*(complex_16 *) elem);
695 _vifprintf (unit, fmt, &z, REAL, 8);
696 } else if (type == COMPLEX && len == -16) {
697 real_8 z = cimag (*(complex_16 *) elem);
698 _vifprintf (unit, fmt, &z, REAL, 8);
699 } else if (type == COMPLEX && len == 32) {
700 real_16 z = crealq (*(complex_32 *) elem);
701 _vifprintf (unit, fmt, &z, REAL, 16);
702 } else if (type == COMPLEX && len == -32) {
703 real_16 z = cimagq (*(complex_32 *) elem);
704 _vifprintf (unit, fmt, &z, REAL, 16);
705 } else if (type == COMPLEX && len == 64) {
706 real_32 z = cxre (*(complex_64 *) elem);
707 _vifprintf (unit, fmt, &z, REAL, 32);
708 } else if (type == COMPLEX && len == -64) {
709 real_32 z = cxim (*(complex_64 *) elem);
710 _vifprintf (unit, fmt, &z, REAL, 32);
711 } else {
712 return ERR;
713 }
714 return 1;
715 }
716 return ERR;
717 }
718
719 void _fscanf_real (char *str, FTNFILE * _f, int_4 width, int_4 buflen)
720 {
721 while (_f->buff_pos < buflen && _f->buff[_f->buff_pos] == ' ') {
722 _f->buff_pos++;
723 }
724 for (int_4 k = 0; k < width && _f->buff_pos < buflen && _f->buff[_f->buff_pos] != ' '; k++) {
725 str[k] = _f->buff[_f->buff_pos++];
726 str[k + 1] = '\0';
727 }
728 }
729
730 int_4 _vifscanf (int_4 unit, char *fmt, void *elem, int_4 type, int_4 len)
731 {
732 int_4 buflen, width, rc = 0, N = 0;
733 FTNFILE *_f = &_ffile[unit];
734 // Set to reinit on next call.
735 if (fmt == NO_TEXT) {
736 _f->buff_init = FALSE;
737 return 1;
738 }
739 // (Re)init if needed.
740 if (!_f->buff_init) {
741 if (_f->in_stream) {
742 if (_f->record > 0) {
743 char *q = _f->buff;
744 while (q[0] != '\n') {
745 q++;
746 }
747 _f->buff = &q[1];
748 }
749 } else {
750 (void) fgets (_f->buff, _f->lrecl, _f->unit);
751 }
752 buflen = _f->buff_len = strlen (_f->buff);
753 if (_f->buff[buflen - 1] == '\n') {
754 _f->buff[buflen - 1] = '\0';
755 _f->buff_len--;
756 }
757 _f->buff_init = TRUE;
758 _f->buff_pos = 0;
759 _f->record++;
760 }
761 buflen = _f->buff_len;
762 // Reading newline just reinits the buffer.
763 if (strcmp (fmt, "\n") == 0) {
764 if (_f->in_stream) {
765 if (_f->record > 0) {
766 char *q = _f->buff;
767 while (q[0] != '\n') {
768 q++;
769 }
770 _f->buff = &q[1];
771 }
772 } else {
773 (void) fgets (_f->buff, _f->lrecl, _f->unit);
774 }
775 buflen = _f->buff_len = strlen (_f->buff);
776 if (_f->buff[buflen - 1] == '\n') {
777 _f->buff[buflen - 1] = '\0';
778 _f->buff_len--;
779 }
780 _f->buff_init = TRUE;
781 _f->buff_pos = 0;
782 _f->record++;
783 return 1;
784 }
785 // Textual strings are skipped and not checked.
786 if (fmt != NO_TEXT && type == NOTYPE) {
787 int_4 awid = strlen (fmt);
788 if (_f->buff_pos + awid < buflen) {
789 _f->buff_pos += awid;
790 }
791 return 1;
792 }
793 // Fortran items A, D, E, F, I and Q.
794 char mod = fmt[strlen (fmt) - 1];
795 if (mod == 's' && sscanf (fmt, "%%%ds", &width) == 1) {
796 int_4 awid = _abs (width);
797 if (type == NOTYPE || elem == NO_TEXT) {
798 if (_f->buff_pos + awid > buflen) {
799 return ERR;
800 }
801 _f->buff_pos += awid; // Just skip it. Fortran would check.
802 return 1;
803 }
804 if (type == CHARACTER) {
805 char *str = (char *) elem;
806 for (int_4 k = 0; k < awid && _f->buff_pos < buflen; k++) {
807 str[k] = _f->buff[_f->buff_pos++];
808 }
809 // In VIF trailing space is cut.
810 for (int_4 k = strlen (str) - 1; k > 0 && str[k] == ' '; k--) {
811 str[k] = '\0';
812 }
813 return 1;
814 } else if (type == INTEGER && len == 4) {
815 RECORD str;
816 int_4 k;
817 for (k = 0; k < awid && _f->buff_pos < buflen; k++) {
818 str[k] = _f->buff[_f->buff_pos++];
819 }
820 str[k] = '\0';
821 *(int_4 *) elem = _str_to_int4 (str);
822 return 1;
823 } else if (type == REAL && len == 8) {
824 RECORD str;
825 int_4 k;
826 for (k = 0; k < awid && _f->buff_pos < buflen; k++) {
827 str[k] = _f->buff[_f->buff_pos++];
828 }
829 str[k] = '\0';
830 *(real_8 *) elem = _str_to_real8 (str);
831 return 1;
832 }
833 return 0;
834 }
835 if (mod == 'c' && strcmp (fmt, "%c") == 0) {
836 RECORD nfmt;
837 if (len == 4) {
838 char ch;
839 _srecordf (nfmt, "%%c%%n");
840 rc = sscanf (&_f->buff[_f->buff_pos], nfmt, (char *) &ch, &N);
841 *(logical_4 *) elem = (ch == 't');
842 }
843 _f->buff_pos += N;
844 return rc;
845 }
846 if (mod == 'd' && strcmp (fmt, "%d") == 0) {
847 RECORD nfmt;
848 if (len == 2) {
849 int_4 i;
850 _srecordf (nfmt, "%%d%%n");
851 rc = sscanf (&_f->buff[_f->buff_pos], nfmt, (int_4 *) &i, &N);
852 *(int_2 *) elem = i;
853 } else if (len == 4) {
854 _srecordf (nfmt, "%%d%%n");
855 rc = sscanf (&_f->buff[_f->buff_pos], nfmt, (int_4 *) elem, &N);
856 } else if (len == 8) {
857 _srecordf (nfmt, "%%lld%%nn");
858 rc = sscanf (&_f->buff[_f->buff_pos], nfmt, (int_8 *) elem, &N);
859 }
860 _f->buff_pos += N;
861 return rc;
862 }
863 if (mod == 'd' && type == INTEGER && sscanf (fmt, "%%%dd", &width) == 1) {
864 RECORD nfmt;
865 int_4 awid = _abs (width);
866 if (_f->buff_pos + awid > buflen) {
867 return ERR;
868 }
869 // Vintage Fortran reads blanks as zero.
870 char *q = &_f->buff[_f->buff_pos];
871 int_4 k = width - 1;
872 while (k >= 0) {
873 if (q[k] == ' ') {
874 q[k] = '0';
875 } else if (!isdigit(q[k])) {
876 break;
877 }
878 k--;
879 }
880 //
881 if (len == 2) {
882 int_4 i;
883 _srecordf (nfmt, "%%%dd", width);
884 rc = sscanf (&_f->buff[_f->buff_pos], nfmt, (int_4 *) &i);
885 *(int_2 *) elem = i;
886 } else if (len == 4) {
887 _srecordf (nfmt, "%%%dd", width);
888 rc = sscanf (&_f->buff[_f->buff_pos], nfmt, (int_4 *) elem);
889 } else if (len == 8) {
890 _srecordf (nfmt, "%%%dlld", width);
891 rc = sscanf (&_f->buff[_f->buff_pos], nfmt, (int_8 *) elem);
892 }
893 _f->buff_pos += awid;
894 return rc;
895 }
896 // REAL, standard format
897 if (type == REAL && strcmp (fmt, "%e") == 0) {
898 if (len == 4) {
899 RECORD nfmt;
900 _srecordf (nfmt, "%%e%%n");
901 rc = sscanf (&_f->buff[_f->buff_pos], nfmt, (real_4 *) elem, &N);
902 _f->buff_pos += N;
903 return rc;
904 } else if (len == 8) {
905 RECORD nfmt;
906 _srecordf (nfmt, "%%le%%n");
907 rc = sscanf (&_f->buff[_f->buff_pos], nfmt, (real_8 *) elem, &N);
908 _f->buff_pos += N;
909 return rc;
910 } else if (len == 16) {
911 RECORD str;
912 RECCLR (str);
913 _fscanf_real (str, _f, RECLN - 1, buflen);
914 *(real_16 *) (elem) = _strtoquad (str, NO_REF_TEXT);
915 return 1;
916 } else if (len == 32) {
917 RECORD str;
918 RECCLR (str);
919 _fscanf_real (str, _f, RECLN - 1, buflen);
920 *(real_32 *) (elem) = strtox (str, NO_REF_TEXT);
921 return 1;
922 }
923 }
924 // REAL, format, note that only width can be specified.
925 if ((mod == 'e' || mod == 'f') && type == REAL && sscanf (fmt, "%%%d", &width) == 1) {
926 int_4 awid = _abs (width);
927 if (_f->buff_pos + awid > buflen) {
928 return ERR;
929 }
930 if (len == 4) {
931 rc = sscanf (&_f->buff[_f->buff_pos], fmt, (real_4 *) elem);
932 _f->buff_pos += width;
933 } else if (len == 8) {
934 RECORD nfmt;
935 _srecordf (nfmt, "%%%dl%c", width, mod);
936 rc = sscanf (&_f->buff[_f->buff_pos], nfmt, (real_8 *) elem);
937 _f->buff_pos += width;
938 } else if (len == 16) {
939 RECORD str;
940 RECCLR (str);
941 _fscanf_real (str, _f, (awid > RECLN - 1 ? RECLN - 1 : awid), buflen);
942 *(real_16 *) (elem) = _strtoquad (str, NO_REF_TEXT);
943 return 1;
944 } else if (len == 32) {
945 RECORD str;
946 RECCLR (str);
947 _fscanf_real (str, _f, (awid > RECLN - 1 ? RECLN - 1 : awid), buflen);
948 *(real_32 *) (elem) = strtox (str, NO_REF_TEXT);
949 return 1;
950 }
951 return rc;
952 }
953 // COMPLEX, standard
954 if (mod == 'e' && type == COMPLEX && strcmp (fmt, "%e") == 0) {
955 if (_abs (len) == 8) {
956 RECORD nfmt;
957 real_4 x;
958 complex_8 *z = (complex_8 *) elem;
959 _srecordf (nfmt, "%%e%%n");
960 rc = sscanf (&_f->buff[_f->buff_pos], nfmt, &x, &N);
961 _f->buff_pos += N;
962 if (len > 0) {
963 *z = CMPLXF (x, 0);
964 } else {
965 *z = CMPLXF (crealf (*z), x);
966 }
967 return rc;
968 } else if (_abs (len) == 16) {
969 RECORD nfmt;
970 real_8 x;
971 complex_16 *z = (complex_16 *) elem;
972 _srecordf (nfmt, "%%le%%n");
973 rc = sscanf (&_f->buff[_f->buff_pos], nfmt, &x, &N);
974 _f->buff_pos += N;
975 if (len > 0) {
976 *z = CMPLX (x, 0);
977 } else {
978 *z = CMPLX (creal (*z), x);
979 }
980 return rc;
981 } else if (_abs (len) == 32) {
982 RECORD str;
983 RECCLR (str);
984 complex_32 *z = (complex_32 *) elem;
985 _fscanf_real (str, _f, RECLN - 1, buflen);
986 if (len > 0) {
987 *z = CMPLXQ (_strtoquad (str, NO_REF_TEXT), 0.0q);
988 } else {
989 *z = CMPLXQ (crealq (*z), _strtoquad (str, NO_REF_TEXT));
990 }
991 return 1;
992 } else if (_abs (len) == 64) {
993 RECORD str;
994 RECCLR (str);
995 complex_64 *z = (complex_64 *) elem;
996 _fscanf_real (str, _f, RECLN - 1, buflen);
997 if (len > 0) {
998 z->re = strtox (str, NO_REF_TEXT);
999 } else {
1000 z->im = strtox (str, NO_REF_TEXT);
1001 }
1002 return 1;
1003 }
1004 }
1005 // COMPLEX, format, note that only width can be specified.
1006 if ((mod == 'e' || mod == 'f') && type == COMPLEX && sscanf (fmt, "%%%de", &width) == 1) {
1007 int_4 awid = _abs (width);
1008 if (_f->buff_pos + awid > buflen) {
1009 return ERR;
1010 }
1011 if (_abs (len) == 8) {
1012 real_4 x;
1013 complex_8 *z = (complex_8 *) elem;
1014 rc = sscanf (&_f->buff[_f->buff_pos], fmt, &x);
1015 _f->buff_pos += width;
1016 if (len > 0) {
1017 *z = CMPLXF (x, 0);
1018 } else {
1019 *z = CMPLXF (crealf (*z), x);
1020 }
1021 return rc;
1022 } else if (_abs (len) == 16) {
1023 real_8 x;
1024 complex_16 *z = (complex_16 *) elem;
1025 RECORD nfmt;
1026 _srecordf (nfmt, "%%%dl%c", width, mod);
1027 rc = sscanf (&_f->buff[_f->buff_pos], nfmt, &x);
1028 _f->buff_pos += width;
1029 if (len > 0) {
1030 *z = CMPLX (x, 0);
1031 } else {
1032 *z = CMPLX (creal (*z), x);
1033 }
1034 return rc;
1035 } else if (_abs (len) == 32) {
1036 RECORD str;
1037 RECCLR (str);
1038 complex_32 *z = (complex_32 *) elem;
1039 _fscanf_real (str, _f, (awid > RECLN - 1 ? RECLN - 1 : awid), buflen);
1040 if (len > 0) {
1041 *z = CMPLXQ (_strtoquad (str, NO_REF_TEXT), 0.0q);
1042 } else {
1043 *z = CMPLXQ (crealq (*z), _strtoquad (str, NO_REF_TEXT));
1044 }
1045 return 1;
1046 } else if (_abs (len) == 64) {
1047 RECORD str;
1048 RECCLR (str);
1049 complex_64 *z = (complex_64 *) elem;
1050 _fscanf_real (str, _f, (awid > RECLN - 1 ? RECLN - 1 : awid), buflen);
1051 if (len > 0) {
1052 z->re = strtox (str, NO_REF_TEXT);
1053 } else {
1054 z->im = strtox (str, NO_REF_TEXT);
1055 }
1056 return 1;
1057 }
1058 }
1059 // No conversion :-(
1060 return ERR;
1061 }
|
© 2002-2025 J.M. van der Veer (jmvdveer@xs4all.nl)
|
