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-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 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 != NULL) {
55 (void) fclose (_ffile[k].unit);
56 _ffile[k].unit = NULL;
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 ((xisPinf (&u))) {
144 if (sign != 0) {
145 *s++ = '+';
146 }
147 strcpy (s, "Inf");
148 return 1;
149 } else if ((xisMinf (&u))) {
150 strcpy (s, "-Inf");
151 return 1;
152 } else if ((xisNaN (&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, '*') == NULL && xge (xabs (strtox (mant, NULL)), 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, '*') != NULL || 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 == NULL) {
338 // CLOSE, REWIND
339 return;
340 }
341 if (_ffile[unit].unit == NULL) {
342 // File was not opened yet.
343 RECORD mode, disp;
344 if (_ffile[unit].disp != NULL) {
345 strcpy (disp, _ffile[unit].disp);
346 } else {
347 strcpy (disp, disp_old);
348 }
349 if (_ffile[unit].action == action_default) {
350 _ffile[unit].action = action;
351 } else if (_ffile[unit].action == action_readwrite) {
352 action = action_readwrite;
353 } else if (_ffile[unit].action != action) {
354 _srecordf (str, "inconsistent action: %s", action);
355 RTE (where, str);
356 }
357 if (_ffile[unit].form == NULL) {
358 _ffile[unit].form = form;
359 } else if (_ffile[unit].form != form) {
360 _srecordf (str, "inconsistent formatting: %s", form);
361 RTE (where, str);
362 }
363 strcpy (mode, "UNKNOWN");
364 if (form == form_formatted && action == action_read) {
365 strcpy (mode, "r");
366 } else if (form == form_formatted && action == action_write) {
367 strcpy (mode, "w");
368 } else if (form == form_formatted && action == action_readwrite) {
369 if (EQUAL (disp, "disp_old")) {
370 strcpy (mode, "r+");
371 } else if (EQUAL (disp, "disp_new")) {
372 strcpy (mode, "w+");
373 }
374 } else if (form == form_unformatted && action == action_read) {
375 strcpy (mode, "rb");
376 } else if (form == form_unformatted && action == action_write) {
377 strcpy (mode, "wb");
378 } else if (form == form_unformatted && action == action_readwrite) {
379 if (EQUAL (disp, "disp_old")) {
380 strcpy (mode, "r+b");
381 } else if (EQUAL (disp, "disp_new")) {
382 strcpy (mode, "w+b");
383 }
384 } else {
385 _srecordf (str, "error: form=%s, action=%s, disp=%s", form, action, disp);
386 RTE (where, str);
387 }
388 if ((_ffile[unit].unit = fopen (_ffile[unit].name, mode)) == NULL) {
389 _srecordf (str, "cannot open unit %d: form=%s, action=%s, disp=%s", unit, form, action, disp);
390 RTE (where, str);
391 }
392 rewind (_ffile[unit].unit);
393 } else {
394 // File was opened.
395 if (action == action_read) {
396 if (_ffile[unit].action == action_write) {
397 _srecordf (str, "'unit %d' is not open for 'read'", unit);
398 RTE (where, str);
399 }
400 } else if (action == action_write) {
401 if (_ffile[unit].action == action_read) {
402 _srecordf (str, "'unit %d' is not open for 'write'", unit);
403 RTE (where, str);
404 }
405 }
406 if (_ffile[unit].form != form) {
407 if (form == form_formatted) {
408 _srecordf (str, "'unit %d' is not open for formatted IO", unit);
409 } else {
410 _srecordf (str, "'unit %d' is not open for unformatted IO", unit);
411 }
412 RTE (where, str);
413 }
414 }
415 }
416
417 void _fregister (char *where, int_4 unit, int_4 lrecl, char *fn, char *form, char *action, char *disp)
418 {
419 if (unit >= 0 && unit < MAX_FILES) {
420 int_4 len;
421 if (_ffile[unit].unit != NULL) {
422 RECORD err;
423 _srecordf (err, "'unit %d' already open", unit);
424 RTE (where, err);
425 }
426 if (lrecl <= 0 || lrecl > MAX_LRECL) {
427 lrecl = MAX_LRECL;
428 }
429 _ffile[unit] = (FTNFILE) {
430 .form = form,.action = action,.disp = disp,.lrecl = lrecl};
431 _ffile[unit].buff = (char *) f_malloc (lrecl + 1);
432 _ffile[unit].buff_init = FALSE;
433 _ffile[unit].buff_pos = 0;
434 if (fn == NULL) {
435 RECORD buf;
436 _ffile[unit].vers++;
437 _srecordf (buf, "ft%02df%03d", unit, _ffile[unit].vers);
438 len = strlen (buf) + 1;
439 _ffile[unit].name = (char *) f_malloc (len);
440 strcpy (_ffile[unit].name, buf);
441 } else {
442 len = strlen (fn) + 1;
443 _ffile[unit].name = (char *) f_malloc (len);
444 strcpy (_ffile[unit].name, fn);
445 }
446 } else {
447 RTE (where, "unit out of range");
448 }
449 }
450
451 void _funregister (char *where, int_4 unit)
452 {
453 if (unit >= 0 && unit < MAX_FILES) {
454 if (_ffile[unit].unit != NULL) {
455 _fclose (unit);
456 }
457 if (_ffile[unit].disp == disp_delete) {
458 remove (_ffile[unit].name);
459 }
460 if (_ffile[unit].name != NULL) {
461 free (_ffile[unit].name);
462 }
463 if (_ffile[unit].buff != NULL) {
464 free (_ffile[unit].buff);
465 }
466 _ffile[unit] = (FTNFILE) {
467 .unit = NULL,.name = NULL,.form = NULL,.action = NULL,.disp = NULL,.vers = 0,.buff = NULL,.buff_init = FALSE,.buff_pos = 0,.buff_len = 0};
468 } else {
469 RTE (where, "unit out of range");
470 }
471 }
472
473 void _skip_eol (FILE * f)
474 {
475 while (fgetc (f) != '\n');
476 }
477
478 void _ioerr (char *where, int_4 unit)
479 {
480 RECORD err;
481 _srecordf (err, "'unit %d' IO error", unit);
482 RTE (where, err);
483 }
484
485 void _ioerr_write (char *where, int_4 unit)
486 {
487 RECORD err;
488 _srecordf (err, "'unit %d' IO error while writing", unit);
489 RTE (where, err);
490 }
491
492 void _ioerr_read (char *where, int_4 unit)
493 {
494 RECORD err;
495 _srecordf (err, "'unit %d' IO error while reading", unit);
496 RTE (where, err);
497 }
498
499 void _ioend_read (char *where, int_4 unit)
500 {
501 RECORD err;
502 _srecordf (err, "'unit %d' end of file while reading", unit);
503 RTE (where, err);
504 }
505
506 void _fprintf_int_8 (char *str, char *fmt, int_8 elem)
507 {
508 int_4 len = 0;
509 if (fmt[0] == '%') {
510 fmt++;
511 }
512 if (isdigit (fmt[0])) {
513 len = strtol (fmt, NULL, 10);
514 }
515 intnot (str, elem, len);
516 }
517
518 void _fprintf_real_32 (char *buf, char *fmt, real_32 item, int_4 expw, int_4 precision)
519 {
520 int_4 dec = 0, len = 0, expos = 0;
521 if (fmt[0] == '%') {
522 fmt++;
523 }
524 char expo_char = fmt[strlen (fmt) - 1];
525 if (expo_char == 'n') {
526 expo_char = 'e';
527 } else if (expo_char == 'N') {
528 expo_char = 'E';
529 }
530 char *p1, *p2, *expo;
531 if (fmt[0] == '.') {
532 fmt++;
533 dec = strtol (fmt, &p2, 10);
534 } else {
535 len = strtol (fmt, &p1, 10);
536 dec = strtol (&p1[1], &p2, 10);
537 }
538 if (tolower (expo_char) == 'e') {
539 int_4 ee = strtol (&p2[1], &expo, 10);
540 expos = (ee == 0 ? expw : ee);
541 }
542 if (tolower (expo_char) == 'f') {
543 xfixed (buf, item, len, dec, precision);
544 } else if (tolower (expo[0]) == 'n') {
545 xfloat (buf, item, len, dec, expos, 3, precision, expo_char);
546 } else {
547 xfloat (buf, item, len, dec, expos, 1, precision, expo_char);
548 }
549 return;
550 }
551
552 int_4 _vifprintf (int_4 unit, char *fmt, void *elem, int_4 type, int_4 len)
553 {
554 FTNFILE *_f = &_ffile[unit];
555 if (fmt == NULL || strlen (fmt) == 0) {
556 return ERR;
557 }
558 if (strcmp (fmt, "\n") == 0) {
559 fprintf (_f->unit, "\n");
560 return 1;
561 }
562 if (fmt != NULL && type == NOTYPE) {
563 if (strcmp (fmt, "0") == 0) {
564 __scale__ = 0;
565 } else if (strcmp (fmt, "1") == 0) {
566 __scale__ = 1;
567 } else if (strcmp (fmt, "2") == 0) {
568 __scale__ = 2;
569 } else if (strcmp (fmt, "3") == 0) {
570 __scale__ = 3;
571 } else {
572 fprintf (_f->unit, fmt);
573 }
574 return 1;
575 }
576 //
577 char mod = tolower (fmt[strlen (fmt) - 1]);
578 if (mod == 's') {
579 if (type == NOTYPE) {
580 fprintf (_f->unit, fmt);
581 } else if (type == CHARACTER) {
582 fprintf (_f->unit, fmt, (char *) elem);
583 } else if (type == LOGICAL) {
584 fprintf (_f->unit, fmt, (*(int_4 *) elem ? 't' : 'f'));
585 } else if (type == INTEGER && len == 4) {
586 int_4 awid = len, width;
587 if (sscanf (fmt, "%%%ds", &width) == 1) {
588 awid = _abs (width);
589 }
590 int_4 sum = *(int_4 *) elem;
591 for (int_4 k = 0; k < len && k < awid; k++) {
592 char ch = sum % 256;
593 fprintf (_f->unit, "%c", ch);
594 sum /= 256;
595 }
596 } else {
597 return ERR;
598 }
599 return 1;
600 } else if (mod == 'c') {
601 if (type == LOGICAL) {
602 fprintf (_f->unit, fmt, (*(int_4 *) elem ? 't' : 'f'));
603 } else {
604 return ERR;
605 }
606 return 1;
607 } else if (mod == 'd') {
608 // INTEGER
609 if (type == INTEGER && len == 2) {
610 RECORD buf;
611 RECCLR (buf);
612 _fprintf_int_8 (buf, fmt, (int_8) *(int_2 *) elem);
613 fprintf (_f->unit, "%s", buf);
614 } else if (type == INTEGER && len == 4) {
615 RECORD buf;
616 RECCLR (buf);
617 _fprintf_int_8 (buf, fmt, (int_8) *(int_4 *) elem);
618 fprintf (_f->unit, "%s", buf);
619 } else if (type == INTEGER && len == 8) {
620 RECORD buf;
621 RECCLR (buf);
622 _fprintf_int_8 (buf, fmt, (int_8) *(int_8 *) elem);
623 fprintf (_f->unit, "%s", buf);
624 } else if (type == INTEGER && len == 16) {
625 RECORD buf;
626 RECCLR (buf);
627 _fprintf_int_8 (buf, fmt, (int_8) *(int_8 *) elem);
628 fprintf (_f->unit, "%s", buf);
629 } else {
630 return ERR;
631 }
632 return 1;
633 } else if (mod == 'e' || mod == 'n' || mod == 'f') {
634 // REAL and COMPLEX
635 RECORD str;
636 RECCLR (str);
637 if (type == INTEGER && len == 2) {
638 _fprintf_real_32 (str, fmt, flttox ((real_4) *(int_2 *) elem), 4, FLT_DIG);
639 fprintf (_f->unit, "%s", str);
640 } else if (type == INTEGER && len == 4) {
641 _fprintf_real_32 (str, fmt, dbltox ((real_8) *(int_4 *) elem), 4, FLT_DIG);
642 fprintf (_f->unit, "%s", str);
643 } else if (type == INTEGER && len == 8) {
644 _fprintf_real_32 (str, fmt, dbltox ((real_8) *(int_8 *) elem), 4, FLT_DIG);
645 fprintf (_f->unit, "%s", str);
646 } else if (type == REAL && len == 4) {
647 _fprintf_real_32 (str, fmt, flttox (*(real_4 *) elem), 4, FLT_DIG);
648 fprintf (_f->unit, "%s", str);
649 } else if (type == REAL && len == 8) {
650 _fprintf_real_32 (str, fmt, dbltox (*(real_8 *) elem), 4, DBL_DIG);
651 fprintf (_f->unit, "%s", str);
652 } else if (type == REAL && len == 16) {
653 _fprintf_real_32 (str, fmt, _quadtox (*(real_16 *) elem), 5, FLT128_DIG);
654 fprintf (_f->unit, "%s", str);
655 } else if (type == REAL && len == 32) {
656 _fprintf_real_32 (str, fmt, *(real_32 *) elem, 5, FLT256_DIG);
657 fprintf (_f->unit, "%s", str);
658 } else if (type == COMPLEX && len == 8) {
659 real_4 z = crealf (*(complex_8 *) elem);
660 _vifprintf (unit, fmt, &z, REAL, 4);
661 } else if (type == COMPLEX && len == -8) {
662 real_4 z = cimagf (*(complex_8 *) elem);
663 _vifprintf (unit, fmt, &z, REAL, 4);
664 } else if (type == COMPLEX && len == 16) {
665 real_8 z = creal (*(complex_16 *) elem);
666 _vifprintf (unit, fmt, &z, REAL, 8);
667 } else if (type == COMPLEX && len == -16) {
668 real_8 z = cimag (*(complex_16 *) elem);
669 _vifprintf (unit, fmt, &z, REAL, 8);
670 } else if (type == COMPLEX && len == 32) {
671 real_16 z = crealq (*(complex_32 *) elem);
672 _vifprintf (unit, fmt, &z, REAL, 16);
673 } else if (type == COMPLEX && len == -32) {
674 real_16 z = cimagq (*(complex_32 *) elem);
675 _vifprintf (unit, fmt, &z, REAL, 16);
676 } else if (type == COMPLEX && len == 64) {
677 real_32 z = cxre (*(complex_64 *) elem);
678 _vifprintf (unit, fmt, &z, REAL, 32);
679 } else if (type == COMPLEX && len == -64) {
680 real_32 z = cxim (*(complex_64 *) elem);
681 _vifprintf (unit, fmt, &z, REAL, 32);
682 } else {
683 return ERR;
684 }
685 return 1;
686 }
687 return ERR;
688 }
689
690 void _fscanf_real (char *str, FTNFILE * _f, int_4 width, int_4 buflen)
691 {
692 while (_f->buff_pos < buflen && _f->buff[_f->buff_pos] == ' ') {
693 _f->buff_pos++;
694 }
695 for (int_4 k = 0; k < width && _f->buff_pos < buflen && _f->buff[_f->buff_pos] != ' '; k++) {
696 str[k] = _f->buff[_f->buff_pos++];
697 str[k + 1] = '\0';
698 }
699 }
700
701 int_4 _vifscanf (int_4 unit, char *fmt, void *elem, int_4 type, int_4 len)
702 {
703 int_4 buflen, width, rc = 0, N = 0;
704 FTNFILE *_f = &_ffile[unit];
705 //printf ("\nscan '%s' %d '%s'\n", fmt, type, &_f->buff[_f->buff_pos]);
706 //fflush (stdout);
707 // Set to reinit on next call.
708 if (fmt == NULL) {
709 _f->buff_init = FALSE;
710 return 1;
711 }
712 // (Re)init if needed.
713 if (!_f->buff_init) {
714 (void) fgets (_f->buff, _f->lrecl, _f->unit);
715 buflen = _f->buff_len = strlen (_f->buff);
716 if (_f->buff[buflen - 1] == '\n') {
717 _f->buff[buflen - 1] = '\0';
718 _f->buff_len--;
719 }
720 _f->buff_init = TRUE;
721 _f->buff_pos = 0;
722 }
723 buflen = _f->buff_len;
724 // Reading newline just reinits the buffer.
725 if (strcmp (fmt, "\n") == 0) {
726 (void) fgets (_f->buff, _f->lrecl, _f->unit);
727 buflen = _f->buff_len = strlen (_f->buff);
728 if (_f->buff[buflen - 1] == '\n') {
729 _f->buff[buflen - 1] = '\0';
730 _f->buff_len--;
731 }
732 _f->buff_init = TRUE;
733 _f->buff_pos = 0;
734 return 1;
735 }
736 // Textual strings are skipped and not checked.
737 if (fmt != NULL && type == NOTYPE) {
738 int_4 awid = strlen (fmt);
739 if (_f->buff_pos + awid < buflen) {
740 _f->buff_pos += awid;
741 }
742 return 1;
743 }
744 // Fortran items A, D, E, F, I and Q.
745 char mod = fmt[strlen (fmt) - 1];
746 if (mod == 's' && sscanf (fmt, "%%%ds", &width) == 1) {
747 int_4 awid = _abs (width);
748 if (type == NOTYPE || elem == NULL) {
749 if (_f->buff_pos + awid > buflen) {
750 return ERR;
751 }
752 _f->buff_pos += awid; // Just skip it. Fortran would check.
753 return 1;
754 }
755 if (type == CHARACTER) {
756 char *str = (char *) elem;
757 for (int_4 k = 0; k < awid && _f->buff_pos < buflen; k++) {
758 str[k] = _f->buff[_f->buff_pos++];
759 }
760 // In VIF trailing space is cut.
761 for (int_4 k = strlen (str) - 1; k > 0 && str[k] == ' '; k--) {
762 str[k] = '\0';
763 }
764 } else if (type == INTEGER && len == 4) {
765 RECORD str;
766 int_4 k;
767 for (k = 0; k < awid && _f->buff_pos < buflen; k++) {
768 str[k] = _f->buff[_f->buff_pos++];
769 }
770 str[k] = '\0';
771 *(int_4 *) elem = _int4 (str);
772 }
773 return 1;
774 }
775 if (mod == 'c' && strcmp (fmt, "%c") == 0) {
776 RECORD nfmt;
777 if (len == 4) {
778 char ch;
779 _srecordf (nfmt, "%%c%%n");
780 rc = sscanf (&_f->buff[_f->buff_pos], nfmt, (char *) &ch, &N);
781 *(logical_4 *) elem = (ch == 't');
782 }
783 _f->buff_pos += N;
784 return rc;
785 }
786 if (mod == 'd' && strcmp (fmt, "%d") == 0) {
787 RECORD nfmt;
788 if (len == 2) {
789 int_4 i;
790 _srecordf (nfmt, "%%d%%n");
791 rc = sscanf (&_f->buff[_f->buff_pos], nfmt, (int_4 *) &i, &N);
792 *(int_2 *) elem = i;
793 } else if (len == 4) {
794 _srecordf (nfmt, "%%d%%n");
795 rc = sscanf (&_f->buff[_f->buff_pos], nfmt, (int_4 *) elem, &N);
796 } else if (len == 8) {
797 _srecordf (nfmt, "%%lld%%nn");
798 rc = sscanf (&_f->buff[_f->buff_pos], nfmt, (int_8 *) elem, &N);
799 }
800 _f->buff_pos += N;
801 return rc;
802 }
803 if (mod == 'd' && type == INTEGER && sscanf (fmt, "%%%dd", &width) == 1) {
804 RECORD nfmt;
805 int_4 awid = _abs (width);
806 if (_f->buff_pos + awid > buflen) {
807 return ERR;
808 }
809 if (len == 2) {
810 int_4 i;
811 _srecordf (nfmt, "%%%dd", width);
812 rc = sscanf (&_f->buff[_f->buff_pos], nfmt, (int_4 *) &i);
813 *(int_2 *) elem = i;
814 } else if (len == 4) {
815 _srecordf (nfmt, "%%%dd", width);
816 rc = sscanf (&_f->buff[_f->buff_pos], nfmt, (int_4 *) elem);
817 } else if (len == 8) {
818 _srecordf (nfmt, "%%%dlld", width);
819 rc = sscanf (&_f->buff[_f->buff_pos], nfmt, (int_8 *) elem);
820 }
821 _f->buff_pos += awid;
822 return rc;
823 }
824 // REAL, standard format
825 if (type == REAL && strcmp (fmt, "%e") == 0) {
826 if (len == 4) {
827 RECORD nfmt;
828 _srecordf (nfmt, "%%e%%n");
829 rc = sscanf (&_f->buff[_f->buff_pos], nfmt, (real_4 *) elem, &N);
830 _f->buff_pos += N;
831 return rc;
832 } else if (len == 8) {
833 RECORD nfmt;
834 _srecordf (nfmt, "%%le%%n");
835 rc = sscanf (&_f->buff[_f->buff_pos], nfmt, (real_8 *) elem, &N);
836 _f->buff_pos += N;
837 return rc;
838 } else if (len == 16) {
839 RECORD str;
840 RECCLR (str);
841 _fscanf_real (str, _f, RECLN - 1, buflen);
842 *(real_16 *) (elem) = _strtoquad (str, NULL);
843 return 1;
844 } else if (len == 32) {
845 RECORD str;
846 RECCLR (str);
847 _fscanf_real (str, _f, RECLN - 1, buflen);
848 *(real_32 *) (elem) = strtox (str, NULL);
849 return 1;
850 }
851 }
852 // REAL, format, note that only width can be specified.
853 if ((mod == 'e' || mod == 'f') && type == REAL && sscanf (fmt, "%%%d", &width) == 1) {
854 int_4 awid = _abs (width);
855 if (_f->buff_pos + awid > buflen) {
856 return ERR;
857 }
858 if (len == 4) {
859 rc = sscanf (&_f->buff[_f->buff_pos], fmt, (real_4 *) elem);
860 _f->buff_pos += width;
861 } else if (len == 8) {
862 RECORD nfmt;
863 _srecordf (nfmt, "%%%dl%c", width, mod);
864 rc = sscanf (&_f->buff[_f->buff_pos], nfmt, (real_8 *) elem);
865 _f->buff_pos += width;
866 } else if (len == 16) {
867 RECORD str;
868 RECCLR (str);
869 _fscanf_real (str, _f, (awid > RECLN - 1 ? RECLN - 1 : awid), buflen);
870 *(real_16 *) (elem) = _strtoquad (str, NULL);
871 return 1;
872 } else if (len == 32) {
873 RECORD str;
874 RECCLR (str);
875 _fscanf_real (str, _f, (awid > RECLN - 1 ? RECLN - 1 : awid), buflen);
876 *(real_32 *) (elem) = strtox (str, NULL);
877 return 1;
878 }
879 return rc;
880 }
881 // COMPLEX, standard
882 if (mod == 'e' && type == COMPLEX && strcmp (fmt, "%e") == 0) {
883 if (_abs (len) == 8) {
884 RECORD nfmt;
885 real_4 x;
886 complex_8 *z = (complex_8 *) elem;
887 _srecordf (nfmt, "%%e%%n");
888 rc = sscanf (&_f->buff[_f->buff_pos], nfmt, &x, &N);
889 _f->buff_pos += N;
890 if (len > 0) {
891 *z = CMPLXF (x, 0);
892 } else {
893 *z = CMPLXF (crealf (*z), x);
894 }
895 return rc;
896 } else if (_abs (len) == 16) {
897 RECORD nfmt;
898 real_8 x;
899 complex_16 *z = (complex_16 *) elem;
900 _srecordf (nfmt, "%%le%%n");
901 rc = sscanf (&_f->buff[_f->buff_pos], nfmt, &x, &N);
902 _f->buff_pos += N;
903 if (len > 0) {
904 *z = CMPLX (x, 0);
905 } else {
906 *z = CMPLX (creal (*z), x);
907 }
908 return rc;
909 } else if (_abs (len) == 32) {
910 RECORD str;
911 RECCLR (str);
912 complex_32 *z = (complex_32 *) elem;
913 _fscanf_real (str, _f, RECLN - 1, buflen);
914 if (len > 0) {
915 *z = CMPLXQ (_strtoquad (str, NULL), 0.0q);
916 } else {
917 *z = CMPLXQ (crealq (*z), _strtoquad (str, NULL));
918 }
919 return 1;
920 } else if (_abs (len) == 64) {
921 RECORD str;
922 RECCLR (str);
923 complex_64 *z = (complex_64 *) elem;
924 _fscanf_real (str, _f, RECLN - 1, buflen);
925 if (len > 0) {
926 z->re = strtox (str, NULL);
927 } else {
928 z->im = strtox (str, NULL);
929 }
930 return 1;
931 }
932 }
933 // COMPLEX, format, note that only width can be specified.
934 if ((mod == 'e' || mod == 'f') && type == COMPLEX && sscanf (fmt, "%%%de", &width) == 1) {
935 int_4 awid = _abs (width);
936 if (_f->buff_pos + awid > buflen) {
937 return ERR;
938 }
939 if (_abs (len) == 8) {
940 real_4 x;
941 complex_8 *z = (complex_8 *) elem;
942 rc = sscanf (&_f->buff[_f->buff_pos], fmt, &x);
943 _f->buff_pos += width;
944 if (len > 0) {
945 *z = CMPLXF (x, 0);
946 } else {
947 *z = CMPLXF (crealf (*z), x);
948 }
949 return rc;
950 } else if (_abs (len) == 16) {
951 real_8 x;
952 complex_16 *z = (complex_16 *) elem;
953 RECORD nfmt;
954 _srecordf (nfmt, "%%%dl%c", width, mod);
955 rc = sscanf (&_f->buff[_f->buff_pos], nfmt, &x);
956 _f->buff_pos += width;
957 if (len > 0) {
958 *z = CMPLX (x, 0);
959 } else {
960 *z = CMPLX (creal (*z), x);
961 }
962 return rc;
963 } else if (_abs (len) == 32) {
964 RECORD str;
965 RECCLR (str);
966 complex_32 *z = (complex_32 *) elem;
967 _fscanf_real (str, _f, (awid > RECLN - 1 ? RECLN - 1 : awid), buflen);
968 if (len > 0) {
969 *z = CMPLXQ (_strtoquad (str, NULL), 0.0q);
970 } else {
971 *z = CMPLXQ (crealq (*z), _strtoquad (str, NULL));
972 }
973 return 1;
974 } else if (_abs (len) == 64) {
975 RECORD str;
976 RECCLR (str);
977 complex_64 *z = (complex_64 *) elem;
978 _fscanf_real (str, _f, (awid > RECLN - 1 ? RECLN - 1 : awid), buflen);
979 if (len > 0) {
980 z->re = strtox (str, NULL);
981 } else {
982 z->im = strtox (str, NULL);
983 }
984 return 1;
985 }
986 }
987 // No conversion :-(
988 return ERR;
989 }
|
© 2002-2024 J.M. van der Veer (jmvdveer@xs4all.nl)
|
