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