rts-format.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 formatted 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 // __scale__ is set by nP in formats.
36
37 int_4 __scale__ = 1;
38
39 void _fclose (int_4 k)
40 {
41 if (_ffile[k].unit != NO_FILE) {
42 (void) fclose (_ffile[k].unit);
43 _ffile[k].unit = NO_FILE;
44 }
45 }
46
47 static char *plusab (char *buf, char c)
48 {
49 char z[2];
50 z[0] = c;
51 z[1] = '\0';
52 bufcat (buf, z, RECLN);
53 return buf;
54 }
55
56 static char *plusto (char ch, char *buf)
57 {
58 memmove (&buf[1], &buf[0], strlen(buf) + 1);
59 buf[0] = ch;
60 return buf;
61 }
62
63 static char *leading_spaces (char *buf, int_4 width)
64 {
65 if (width > 0) {
66 int_4 j = ABS (width) - (int_4) strlen (buf);
67 while (--j >= 0) {
68 (void) plusto (' ', buf);
69 }
70 }
71 return buf;
72 }
73
74 static char *error_chars (char *buf, int_4 n)
75 {
76 int_4 k = (n != 0 ? ABS (n) : 1);
77 buf[k] = '\0';
78 while (--k >= 0) {
79 buf[k] = ERROR_CHAR;
80 }
81 return buf;
82 }
83
84 static char digchar (int_4 k)
85 {
86 char *tab = "0123456789abcdefghijklmnopqrstuvwxyz";
87 if (k >= 0 && k < (int_4) strlen (tab)) {
88 return tab[k];
89 } else {
90 return ERROR_CHAR;
91 }
92 }
93
94 // INTEGER*8
95
96 char *intnot (char *buf, int_8 k, int_4 width)
97 {
98 int_8 n = ABS (k);
99 buf[0] = '\0';
100 do {
101 (void) plusto (digchar (n % 10), buf);
102 n /= 10;
103 } while (n != 0);
104 if (k < 0) {
105 (void) plusto ('-', buf);
106 }
107 if (width > 0 && strlen (buf) > width) {
108 (void) error_chars (buf, width);
109 } else {
110 (void) leading_spaces (buf, width);
111 }
112 return buf;
113 }
114
115 // REAL*32
116
117 void xsprintfmt (char *buffer, const char *fmt, ...)
118 {
119 NEW_RECORD (ibuff);
120 va_list ap;
121 va_start (ap, fmt);
122 vsprintf (ibuff, fmt, ap);
123 va_end (ap);
124 strcat (buffer, ibuff);
125 }
126
127 static int_4 special_value (char *s, real_32 u, int_4 sign)
128 {
129 if ((xis_pinf (&u))) {
130 if (sign != 0) {
131 *s++ = '+';
132 }
133 strcpy (s, "Inf");
134 return 1;
135 } else if ((xis_minf (&u))) {
136 strcpy (s, "-Inf");
137 return 1;
138 } else if ((xis_nan (&u))) {
139 if (sign != 0) {
140 *s++ = '\?';
141 }
142 strcpy (s, "NaN");
143 return 1;
144 } else {
145 return 0;
146 }
147 }
148
149 char *xsubfixed (char *buffer, real_32 v, logical_4 sign, int_4 digs)
150 {
151 RECCLR (buffer);
152 if ((special_value (buffer, v, sign))) {
153 return buffer;
154 }
155 real_32 u = v;
156 digs = _min (_abs (digs), FLT256_DIG);
157 // Put sign and take abs value.
158 char *p = buffer;
159 if (xlt (u, X_0)) {
160 u = xneg (u);
161 *(p++) = '-';
162 } else if (sign) {
163 *(p++) = '+';
164 } else {
165 *(p++) = ' ';
166 }
167 // Round fraction
168 real_32 eps = xmul(X_1_OVER_2, xtenup (-digs));
169 u = xsum (u, eps);
170 //
171 int_4 before;
172 if (xlt (u, X_10)) {
173 before = 1;
174 } else if (xlt (u, X_100)) {
175 before = 2;
176 } else if (xlt (u, X_1000)) {
177 before = 3;
178 } else {
179 before = (int_4) ceil (xtodbl (xlog10 (u)));
180 }
181 // Integral part.
182 u = xdiv (u, xtenup (before));
183 while (xge (u, X_1)) {
184 u = xdiv (u, X_10);
185 before++;
186 }
187 for (int_4 k = 0; k < before; ++k) {
188 u = xmul (X_10, u);
189 int_4 dig;
190 u = xsfmod (u, &dig);
191 *(p++) = (char) '0' + dig;
192 }
193 // Fraction.
194 *(p++) = '.';
195 for (int_4 k = 0; k < digs; ++k) {
196 u = xmul (X_10, u);
197 int_4 dig;
198 u = xsfmod (u, &dig);
199 *(p++) = (char) '0' + dig;
200 }
201 return buffer;
202 }
203
204 char *xfixed (char *buf, real_32 x, int_4 width, int_4 digs, int_4 precision)
205 {
206 width = _abs (width);
207 digs = _min (abs (digs), precision);
208 xsubfixed (buf, x, FALSE, digs);
209 if (width > 0 && strlen (buf) > width) {
210 return error_chars (buf, width);
211 } else {
212 return leading_spaces (buf, width);
213 }
214 }
215
216 char *xfloat (char *buf, real_32 z, int_4 width, int_4 digs, int_4 expos, int_4 mult, int_4 precision, char sym)
217 {
218 buf[0] = '\0';
219 width = _abs (width);
220 digs = _min (abs (digs), precision);
221 expos = _abs (expos);
222 if (expos > 5) {
223 return error_chars (buf, width);
224 }
225 // Scientific notation mult = 1, Engineering notation mult = 3
226 mult = _max (1, mult);
227 // Default __scale__ is 1.
228 int_4 q = 1;
229 char *max = "1";
230 real_32 x = xabs (z), lwb, upb;
231 //
232 if (__scale__ < 0 || __scale__ > 3) {
233 __scale__ = 1;
234 }
235 if (mult == 1) {
236 if (__scale__ == 0) {
237 lwb = X_1_OVER_10;
238 upb = X_1;
239 q = 1;
240 max = "0.1";
241 } else if (__scale__ == 1) {
242 lwb = X_1;
243 upb = X_10;
244 q = 0;
245 max = "1";
246 } else if (__scale__ == 2) {
247 lwb = X_10;
248 upb = X_100;
249 q = -1;
250 max = "10";
251 } else if (__scale__ == 3) {
252 lwb = X_100;
253 upb = X_1000;
254 max = "100";
255 q = -2;
256 }
257 }
258 // Standardize.
259 int_4 p = 0;
260 if (xnot0 (&x)) {
261 p = (int_4) round (xtodbl (xlog10 (xabs(x)))) + q;
262 x = xdiv (x, xtenup (p));
263 if (xle (x, lwb)) {
264 x = xmul (x, X_10);
265 p--;
266 }
267 if (xge (x, upb)) {
268 x = xdiv (x, X_10);
269 p++;
270 }
271 while (p % mult != 0) {
272 x = xmul (x, X_10);
273 p--;
274 }
275 }
276 // Form number.
277 NEW_RECORD (mant);
278 xsubfixed (mant, x, FALSE, digs);
279 // Correction of rounding issue by which |mant| equals UPB.
280 if (strchr (mant, '*') == NO_TEXT && xge (xabs (strtox (mant, NO_REF_TEXT)), upb)) {
281 if (mant[0] == ' ' || mant[0] == '+') {
282 _srecordf (mant, "%c%s", mant[0], max);
283 } else {
284 _srecordf (mant, "%s", max);
285 }
286 if (digs > 0) {
287 plusab (mant, '.');
288 for (int_4 k = 0; k < digs; k++) {
289 plusab (mant, '0');
290 }
291 }
292 p++;
293 }
294 //
295 NEW_RECORD (fmt);
296 if (xsgn (&z) < 0) {
297 mant[0] = '-';
298 }
299 _srecordf (fmt, "%%s%c%%+0%dd", sym, expos);
300 _srecordf (buf, fmt, mant, p);
301 if (width > 0 && (strchr (buf, '*') != NO_TEXT || strlen (buf) > width)) {
302 if (digs > 0) {
303 return xfloat (buf, z, width, digs - 1, expos, mult, precision, sym);
304 } else {
305 return error_chars (buf, width);
306 }
307 } else {
308 return leading_spaces (buf, width);
309 }
310 }
311
312 void _fprintf_int_8 (char *str, char *fmt, int_8 elem)
313 {
314 int_4 len = 0;
315 if (fmt[0] == '%') {
316 fmt++;
317 }
318 if (isdigit (fmt[0])) {
319 len = strtol (fmt, NO_REF_TEXT, 10);
320 }
321 intnot (str, elem, len);
322 }
323
324 void _fprintf_real_32 (char *buf, char *fmt, real_32 item, int_4 expw, int_4 precision)
325 {
326 int_4 dec = 0, len = 0, expos = 0;
327 if (fmt[0] == '%') {
328 fmt++;
329 }
330 char expo_char = fmt[strlen (fmt) - 1];
331 if (expo_char == 'n') {
332 expo_char = 'e';
333 } else if (expo_char == 'N') {
334 expo_char = 'E';
335 }
336 char *p1, *p2, *expo;
337 if (fmt[0] == '.') {
338 fmt++;
339 dec = strtol (fmt, &p2, 10);
340 } else {
341 len = strtol (fmt, &p1, 10);
342 dec = strtol (&p1[1], &p2, 10);
343 }
344 if (tolower (expo_char) == 'e') {
345 int_4 ee = strtol (&p2[1], &expo, 10);
346 expos = (ee == 0 ? expw : ee);
347 }
348 if (tolower (expo_char) == 'f') {
349 xfixed (buf, item, len, dec, precision);
350 } else if (tolower (expo[0]) == 'n') {
351 xfloat (buf, item, len, dec, expos, 3, precision, expo_char);
352 } else {
353 xfloat (buf, item, len, dec, expos, 1, precision, expo_char);
354 }
355 return;
356 }
357
358 int_4 _vif_printf (int_4 unit, char *fmt, void *elem, int_4 type, int_4 len)
359 {
360 FTNFILE *_f = &_ffile[unit];
361 if (fmt == NO_TEXT) {
362 return ERR;
363 }
364 if (fmt == FMT_TERM) {
365 return 1;
366 }
367 if (strlen (fmt) == 0) {
368 return 1;
369 }
370 if (strcmp (fmt, "\n") == 0) {
371 fprintf (_f->unit, "\n");
372 return 1;
373 }
374 if (fmt != NO_TEXT && type == NOTYPE) {
375 if (strcmp (fmt, "0") == 0) {
376 __scale__ = 0;
377 } else if (strcmp (fmt, "1") == 0) {
378 __scale__ = 1;
379 } else if (strcmp (fmt, "2") == 0) {
380 __scale__ = 2;
381 } else if (strcmp (fmt, "3") == 0) {
382 __scale__ = 3;
383 } else {
384 fprintf (_f->unit, fmt);
385 }
386 return 1;
387 }
388 //
389 char mod = tolower (fmt[strlen (fmt) - 1]);
390 if (mod == 's') {
391 if (type == NOTYPE) {
392 fprintf (_f->unit, fmt);
393 return 1;
394 } else if (type == CHARACTER) {
395 fprintf (_f->unit, fmt, (char *) elem);
396 return 1;
397 } else if (type == LOGICAL) {
398 fprintf (_f->unit, fmt, (*(int_4 *) elem ? 't' : 'f'));
399 return 1;
400 } else if (type == INTEGER && len == 4) {
401 int_4 awid = len, width;
402 if (sscanf (fmt, "%%%ds", &width) == 1) {
403 awid = _abs (width);
404 }
405 int_4 sum = *(int_4 *) elem;
406 for (int_4 k = 0; k < len && k < awid; k++) {
407 char ch = sum % (UCHAR_MAX + 1);
408 fprintf (_f->unit, "%c", ch);
409 sum /= (UCHAR_MAX + 1);
410 }
411 return 1;
412 } else if (type == REAL && len == 8) {
413 int_4 awid = len, width;
414 if (sscanf (fmt, "%%%ds", &width) == 1) {
415 awid = _abs (width);
416 }
417 real_8 sum = *(real_8 *) elem;
418 for (int_4 k = 0; k < len && k < awid; k++) {
419 char ch = (int_4) fmod (sum, (UCHAR_MAX + 1));
420 fprintf (_f->unit, "%c", ch);
421 sum = floor (sum / (UCHAR_MAX + 1));
422 }
423 return 1;
424 } else {
425 return ERR;
426 }
427 } else if (mod == 'c') {
428 if (type == LOGICAL) {
429 fprintf (_f->unit, fmt, (*(int_4 *) elem ? 't' : 'f'));
430 } else {
431 return ERR;
432 }
433 return 1;
434 } else if (mod == 'd') {
435 // INTEGER
436 if (type == INTEGER && len == 2) {
437 NEW_RECORD (buf);
438 _fprintf_int_8 (buf, fmt, (int_8) *(int_2 *) elem);
439 fprintf (_f->unit, "%s", buf);
440 } else if (type == INTEGER && len == 4) {
441 NEW_RECORD (buf);
442 _fprintf_int_8 (buf, fmt, (int_8) *(int_4 *) elem);
443 fprintf (_f->unit, "%s", buf);
444 } else if (type == INTEGER && len == 8) {
445 NEW_RECORD (buf);
446 _fprintf_int_8 (buf, fmt, (int_8) *(int_8 *) elem);
447 fprintf (_f->unit, "%s", buf);
448 } else if (type == INTEGER && len == 16) {
449 NEW_RECORD (buf);
450 _fprintf_int_8 (buf, fmt, (int_8) *(int_8 *) elem);
451 fprintf (_f->unit, "%s", buf);
452 } else {
453 return ERR;
454 }
455 return 1;
456 } else if (mod == 'e' || mod == 'n' || mod == 'f') {
457 // REAL and COMPLEX
458 NEW_RECORD (buf);
459 if (type == INTEGER && len == 2) {
460 _fprintf_real_32 (buf, fmt, flttox ((real_4) *(int_2 *) elem), 4, FLT_DIG);
461 fprintf (_f->unit, "%s", buf);
462 } else if (type == INTEGER && len == 4) {
463 _fprintf_real_32 (buf, fmt, dbltox ((real_8) *(int_4 *) elem), 4, FLT_DIG);
464 fprintf (_f->unit, "%s", buf);
465 } else if (type == INTEGER && len == 8) {
466 _fprintf_real_32 (buf, fmt, dbltox ((real_8) *(int_8 *) elem), 4, FLT_DIG);
467 fprintf (_f->unit, "%s", buf);
468 } else if (type == REAL && len == 4) {
469 _fprintf_real_32 (buf, fmt, flttox (*(real_4 *) elem), 4, FLT_DIG);
470 fprintf (_f->unit, "%s", buf);
471 } else if (type == REAL && len == 8) {
472 _fprintf_real_32 (buf, fmt, dbltox (*(real_8 *) elem), 4, DBL_DIG);
473 fprintf (_f->unit, "%s", buf);
474 } else if (type == REAL && len == 16) {
475 _fprintf_real_32 (buf, fmt, quadtox (*(real_16 *) elem), 5, FLT128_DIG);
476 fprintf (_f->unit, "%s", buf);
477 } else if (type == REAL && len == 32) {
478 _fprintf_real_32 (buf, fmt, *(real_32 *) elem, 5, FLT256_DIG);
479 fprintf (_f->unit, "%s", buf);
480 } else if (type == COMPLEX && len == 8) {
481 real_4 z = crealf (*(complex_8 *) elem);
482 _vif_printf (unit, fmt, &z, REAL, 4);
483 } else if (type == COMPLEX && len == -8) {
484 real_4 z = cimagf (*(complex_8 *) elem);
485 _vif_printf (unit, fmt, &z, REAL, 4);
486 } else if (type == COMPLEX && len == 16) {
487 real_8 z = creal (*(complex_16 *) elem);
488 _vif_printf (unit, fmt, &z, REAL, 8);
489 } else if (type == COMPLEX && len == -16) {
490 real_8 z = cimag (*(complex_16 *) elem);
491 _vif_printf (unit, fmt, &z, REAL, 8);
492 } else if (type == COMPLEX && len == 32) {
493 real_16 z = crealq (*(complex_32 *) elem);
494 _vif_printf (unit, fmt, &z, REAL, 16);
495 } else if (type == COMPLEX && len == -32) {
496 real_16 z = cimagq (*(complex_32 *) elem);
497 _vif_printf (unit, fmt, &z, REAL, 16);
498 } else if (type == COMPLEX && len == 64) {
499 real_32 z = cxreal (*(complex_64 *) elem);
500 _vif_printf (unit, fmt, &z, REAL, 32);
501 } else if (type == COMPLEX && len == -64) {
502 real_32 z = cximag (*(complex_64 *) elem);
503 _vif_printf (unit, fmt, &z, REAL, 32);
504 } else {
505 return ERR;
506 }
507 return 1;
508 }
509 return ERR;
510 }
511
512 void _fscanf_real (char *str, FTNFILE * _f, int_4 width, int_4 buflen)
513 {
514 while (_f->buff_pos < buflen && _f->buff[_f->buff_pos] == ' ') {
515 _f->buff_pos++;
516 }
517 for (int_4 k = 0; k < width && _f->buff_pos < buflen && _f->buff[_f->buff_pos] != ' '; k++) {
518 str[k] = _f->buff[_f->buff_pos++];
519 str[k + 1] = '\0';
520 }
521 }
522
523 int_4 _vif_scanf (int_4 unit, char *fmt, void *elem, int_4 type, int_4 len)
524 {
525 int_4 width = 0, rc = 0, N = 0;
526 FTNFILE *_f = &_ffile[unit];
527 // A NOP.
528 if (fmt == FMT_TERM) {
529 return 1;
530 }
531 // Re-init on next call.
532 if (fmt == NO_TEXT) {
533 _f->buff_init = FALSE;
534 return 1;
535 }
536 if (strlen (fmt) == 0) {
537 return 1;
538 }
539 // (Re)init if needed.
540 if (!_f->buff_init) {
541 _init_file_buffer (unit);
542 }
543 if (strcmp (fmt, "\n") == 0) {
544 // Reading newline just reinits the buffer.
545 _init_file_buffer (unit);
546 return 1;
547 }
548 // Textual strings are skipped and not checked.
549 if (fmt != NO_TEXT && type == NOTYPE) {
550 int_4 awid = strlen (fmt);
551 if (_f->buff_pos + awid < _f->buff_len) {
552 _f->buff_pos += awid;
553 }
554 return 1;
555 }
556 // Fortran items A, D, E, F, I and Q.
557 char mod = fmt[strlen (fmt) - 1];
558 if (mod == 's' && sscanf (fmt, "%%%ds", &width) == 1) {
559 int_4 awid = _abs (width);
560 if (type == NOTYPE || elem == NO_TEXT) {
561 if (_f->buff_pos + awid > _f->buff_len) {
562 return ERR;
563 }
564 _f->buff_pos += awid; // Just skip it. Fortran would check.
565 return 1;
566 }
567 if (type == CHARACTER) {
568 char *str = (char *) elem;
569 for (int_4 k = 0; k < awid && _f->buff_pos < _f->buff_len; k++) {
570 str[k] = _f->buff[_f->buff_pos++];
571 }
572 // In VIF trailing space is cut.
573 for (int_4 k = strlen (str) - 1; k > 0 && str[k] == ' '; k--) {
574 str[k] = '\0';
575 }
576 return 1;
577 } else if (type == INTEGER && len == 4) {
578 NEW_RECORD (str);
579 int_4 k;
580 for (k = 0; k < awid && _f->buff_pos < _f->buff_len; k++) {
581 str[k] = _f->buff[_f->buff_pos++];
582 }
583 str[k] = '\0';
584 *(int_4 *) elem = _str_to_int4 (str);
585 return 1;
586 } else if (type == REAL && len == 8) {
587 NEW_RECORD (str);
588 int_4 k;
589 for (k = 0; k < awid && _f->buff_pos < _f->buff_len; k++) {
590 str[k] = _f->buff[_f->buff_pos++];
591 }
592 str[k] = '\0';
593 *(real_8 *) elem = _str_to_real8 (str);
594 return 1;
595 }
596 return 0;
597 }
598 if (mod == 'c' && strcmp (fmt, "%c") == 0) {
599 NEW_RECORD (nfmt);
600 if (len == 4) {
601 char ch;
602 _srecordf (nfmt, "%%c%%n");
603 rc = sscanf (&_f->buff[_f->buff_pos], nfmt, (char *) &ch, &N);
604 *(logical_4 *) elem = (ch == 't');
605 }
606 _f->buff_pos += N;
607 return rc;
608 }
609 if (mod == 'd' && strcmp (fmt, "%d") == 0) {
610 NEW_RECORD (nfmt);
611 if (len == 2) {
612 int_4 i;
613 _srecordf (nfmt, "%%d%%n");
614 rc = sscanf (&_f->buff[_f->buff_pos], nfmt, (int_4 *) &i, &N);
615 *(int_2 *) elem = i;
616 } else if (len == 4) {
617 _srecordf (nfmt, "%%d%%n");
618 rc = sscanf (&_f->buff[_f->buff_pos], nfmt, (int_4 *) elem, &N);
619 } else if (len == 8) {
620 _srecordf (nfmt, "%%lld%%nn");
621 rc = sscanf (&_f->buff[_f->buff_pos], nfmt, (int_8 *) elem, &N);
622 }
623 _f->buff_pos += N;
624 return rc;
625 }
626 if (mod == 'd' && type == INTEGER && sscanf (fmt, "%%%dd", &width) == 1) {
627 NEW_RECORD (nfmt);
628 int_4 awid = _abs (width);
629 if (_f->buff_pos + awid > _f->buff_len) {
630 return ERR;
631 }
632 // Vintage Fortran reads blanks as zero.
633 char *q = &_f->buff[_f->buff_pos];
634 int_4 k = width - 1;
635 while (k >= 0) {
636 if (q[k] == ' ') {
637 q[k] = '0';
638 } else if (!isdigit(q[k])) {
639 break;
640 }
641 k--;
642 }
643 //
644 if (len == 2) {
645 int_4 i;
646 _srecordf (nfmt, "%%%dd", width);
647 rc = sscanf (&_f->buff[_f->buff_pos], nfmt, (int_4 *) &i);
648 *(int_2 *) elem = i;
649 } else if (len == 4) {
650 _srecordf (nfmt, "%%%dd", width);
651 rc = sscanf (&_f->buff[_f->buff_pos], nfmt, (int_4 *) elem);
652 } else if (len == 8) {
653 _srecordf (nfmt, "%%%dlld", width);
654 rc = sscanf (&_f->buff[_f->buff_pos], nfmt, (int_8 *) elem);
655 }
656 _f->buff_pos += awid;
657 return rc;
658 }
659 // REAL, standard format
660 if (type == REAL && strcmp (fmt, "%e") == 0) {
661 if (len == 4) {
662 NEW_RECORD (nfmt);
663 _srecordf (nfmt, "%%e%%n");
664 rc = sscanf (&_f->buff[_f->buff_pos], nfmt, (real_4 *) elem, &N);
665 _f->buff_pos += N;
666 return rc;
667 } else if (len == 8) {
668 NEW_RECORD (nfmt);
669 _srecordf (nfmt, "%%le%%n");
670 rc = sscanf (&_f->buff[_f->buff_pos], nfmt, (real_8 *) elem, &N);
671 _f->buff_pos += N;
672 return rc;
673 } else if (len == 16) {
674 NEW_RECORD (str);
675 _fscanf_real (str, _f, RECLN - 1, _f->buff_len);
676 *(real_16 *) (elem) = _strtoquad (str, NO_REF_TEXT);
677 return 1;
678 } else if (len == 32) {
679 NEW_RECORD (str);
680 _fscanf_real (str, _f, RECLN - 1, _f->buff_len);
681 *(real_32 *) (elem) = strtox (str, NO_REF_TEXT);
682 return 1;
683 }
684 }
685 // REAL, format, note that only width can be specified.
686 if ((mod == 'e' || mod == 'f') && type == REAL && sscanf (fmt, "%%%d", &width) == 1) {
687 int_4 awid = _abs (width);
688 if (_f->buff_pos + awid > _f->buff_len) {
689 return ERR;
690 }
691 if (len == 4) {
692 rc = sscanf (&_f->buff[_f->buff_pos], fmt, (real_4 *) elem);
693 _f->buff_pos += width;
694 } else if (len == 8) {
695 NEW_RECORD (nfmt);
696 _srecordf (nfmt, "%%%dl%c", width, mod);
697 rc = sscanf (&_f->buff[_f->buff_pos], nfmt, (real_8 *) elem);
698 _f->buff_pos += width;
699 } else if (len == 16) {
700 NEW_RECORD (str);
701 _fscanf_real (str, _f, (awid > RECLN - 1 ? RECLN - 1 : awid), _f->buff_len);
702 *(real_16 *) (elem) = _strtoquad (str, NO_REF_TEXT);
703 return 1;
704 } else if (len == 32) {
705 NEW_RECORD (str);
706 _fscanf_real (str, _f, (awid > RECLN - 1 ? RECLN - 1 : awid), _f->buff_len);
707 *(real_32 *) (elem) = strtox (str, NO_REF_TEXT);
708 return 1;
709 }
710 return rc;
711 }
712 // COMPLEX, standard
713 if (mod == 'e' && type == COMPLEX && strcmp (fmt, "%e") == 0) {
714 if (_abs (len) == 8) {
715 NEW_RECORD (nfmt);
716 real_4 x;
717 complex_8 *z = (complex_8 *) elem;
718 _srecordf (nfmt, "%%e%%n");
719 rc = sscanf (&_f->buff[_f->buff_pos], nfmt, &x, &N);
720 _f->buff_pos += N;
721 if (len > 0) {
722 *z = CMPLXF (x, 0);
723 } else {
724 *z = CMPLXF (crealf (*z), x);
725 }
726 return rc;
727 } else if (_abs (len) == 16) {
728 NEW_RECORD (nfmt);
729 real_8 x;
730 complex_16 *z = (complex_16 *) elem;
731 _srecordf (nfmt, "%%le%%n");
732 rc = sscanf (&_f->buff[_f->buff_pos], nfmt, &x, &N);
733 _f->buff_pos += N;
734 if (len > 0) {
735 *z = CMPLX (x, 0);
736 } else {
737 *z = CMPLX (creal (*z), x);
738 }
739 return rc;
740 } else if (_abs (len) == 32) {
741 NEW_RECORD (str);
742 complex_32 *z = (complex_32 *) elem;
743 _fscanf_real (str, _f, RECLN - 1, _f->buff_len);
744 if (len > 0) {
745 *z = CMPLXQ (_strtoquad (str, NO_REF_TEXT), 0.0q);
746 } else {
747 *z = CMPLXQ (crealq (*z), _strtoquad (str, NO_REF_TEXT));
748 }
749 return 1;
750 } else if (_abs (len) == 64) {
751 NEW_RECORD (str);
752 complex_64 *z = (complex_64 *) elem;
753 _fscanf_real (str, _f, RECLN - 1, _f->buff_len);
754 if (len > 0) {
755 z->re = strtox (str, NO_REF_TEXT);
756 } else {
757 z->im = strtox (str, NO_REF_TEXT);
758 }
759 return 1;
760 }
761 }
762 // COMPLEX, format, note that only width can be specified.
763 if ((mod == 'e' || mod == 'f') && type == COMPLEX && sscanf (fmt, "%%%de", &width) == 1) {
764 int_4 awid = _abs (width);
765 if (_f->buff_pos + awid > _f->buff_len) {
766 return ERR;
767 }
768 if (_abs (len) == 8) {
769 real_4 x;
770 complex_8 *z = (complex_8 *) elem;
771 rc = sscanf (&_f->buff[_f->buff_pos], fmt, &x);
772 _f->buff_pos += width;
773 if (len > 0) {
774 *z = CMPLXF (x, 0);
775 } else {
776 *z = CMPLXF (crealf (*z), x);
777 }
778 return rc;
779 } else if (_abs (len) == 16) {
780 real_8 x;
781 complex_16 *z = (complex_16 *) elem;
782 NEW_RECORD (nfmt);
783 _srecordf (nfmt, "%%%dl%c", width, mod);
784 rc = sscanf (&_f->buff[_f->buff_pos], nfmt, &x);
785 _f->buff_pos += width;
786 if (len > 0) {
787 *z = CMPLX (x, 0);
788 } else {
789 *z = CMPLX (creal (*z), x);
790 }
791 return rc;
792 } else if (_abs (len) == 32) {
793 NEW_RECORD (str);
794 complex_32 *z = (complex_32 *) elem;
795 _fscanf_real (str, _f, (awid > RECLN - 1 ? RECLN - 1 : awid), _f->buff_len);
796 if (len > 0) {
797 *z = CMPLXQ (_strtoquad (str, NO_REF_TEXT), 0.0q);
798 } else {
799 *z = CMPLXQ (crealq (*z), _strtoquad (str, NO_REF_TEXT));
800 }
801 return 1;
802 } else if (_abs (len) == 64) {
803 NEW_RECORD (str);
804 complex_64 *z = (complex_64 *) elem;
805 _fscanf_real (str, _f, (awid > RECLN - 1 ? RECLN - 1 : awid), _f->buff_len);
806 if (len > 0) {
807 z->re = strtox (str, NO_REF_TEXT);
808 } else {
809 z->im = strtox (str, NO_REF_TEXT);
810 }
811 return 1;
812 }
813 }
814 // No conversion :-(
815 return ERR;
816 }
|
© 2002-2025 J.M. van der Veer (jmvdveer@xs4all.nl)
|
