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, ERROR_CHAR) == 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 // In the distant past, exponents usually were double-digit at most.
300 if (_abs (p) < 100) {
301 expos = _min (3, expos);
302 } else if (_abs (p) < 1000) {
303 expos = _min (4, expos);
304 }
305 _srecordf (fmt, "%%s%c%%+0%dd", sym, expos);
306 _srecordf (buf, fmt, mant, p);
307 int_4 xs = strlen (buf) - width;
308 if (width > 0 && (strchr (buf, ERROR_CHAR) != NO_TEXT || xs > 0)) {
309 int_4 ndigs = digs - xs;
310 if (ndigs >= 0) {
311 return xfloat (buf, z, width, ndigs, expos, mult, precision, sym);
312 } else {
313 return error_chars (buf, width);
314 }
315 } else {
316 return leading_spaces (buf, width);
317 }
318 }
319
320 void _fprintf_int_8 (char *str, char *fmt, int_8 elem)
321 {
322 int_4 len = 0;
323 if (fmt[0] == '%') {
324 fmt++;
325 }
326 if (isdigit (fmt[0])) {
327 len = strtol (fmt, NO_REF_TEXT, 10);
328 }
329 intnot (str, elem, len);
330 }
331
332 void _fprintf_real_32 (char *buf, char *fmt, real_32 item, int_4 expw, int_4 precision)
333 {
334 int_4 dec = 0, len = 0, expos = 0;
335 if (fmt[0] == '%') {
336 fmt++;
337 }
338 char expo_char = fmt[strlen (fmt) - 1];
339 if (expo_char == 'n') {
340 expo_char = 'e';
341 } else if (expo_char == 'N') {
342 expo_char = 'E';
343 }
344 char *p1, *p2, *expo;
345 if (fmt[0] == '.') {
346 fmt++;
347 dec = strtol (fmt, &p2, 10);
348 } else {
349 len = strtol (fmt, &p1, 10);
350 dec = strtol (&p1[1], &p2, 10);
351 }
352 if (tolower (expo_char) == 'e') {
353 int_4 ee = strtol (&p2[1], &expo, 10);
354 expos = (ee == 0 ? expw : ee);
355 }
356 if (tolower (expo_char) == 'f') {
357 xfixed (buf, item, len, dec, precision);
358 } else if (tolower (expo[0]) == 'n') {
359 xfloat (buf, item, len, dec, expos, 3, precision, expo_char);
360 } else {
361 xfloat (buf, item, len, dec, expos, 1, precision, expo_char);
362 }
363 return;
364 }
365
366 int_4 _vif_printf (int_4 unit, char *fmt, void *elem, int_4 type, int_4 len)
367 {
368 FTN_FILE *_f = _get_ftn_file (NO_TEXT, unit);
369 if (fmt == NO_TEXT) {
370 return ERR;
371 }
372 if (fmt == FMT_TERM) {
373 return 1;
374 }
375 if (strlen (fmt) == 0) {
376 return 1;
377 }
378 if (strcmp (fmt, "\n") == 0) {
379 fprintf (_f->unit, "\n");
380 return 1;
381 }
382 if (fmt != NO_TEXT && type == NOTYPE) {
383 if (strcmp (fmt, "0") == 0) {
384 __scale__ = 0;
385 } else if (strcmp (fmt, "1") == 0) {
386 __scale__ = 1;
387 } else if (strcmp (fmt, "2") == 0) {
388 __scale__ = 2;
389 } else if (strcmp (fmt, "3") == 0) {
390 __scale__ = 3;
391 } else {
392 fprintf (_f->unit, "%s", fmt);
393 }
394 return 1;
395 }
396 //
397 char mod = tolower (fmt[strlen (fmt) - 1]);
398 if (mod == 's') {
399 if (type == NOTYPE) {
400 fprintf (_f->unit, "%s", fmt);
401 return 1;
402 } else if (type == CHARACTER) {
403 fprintf (_f->unit, fmt, (char *) elem);
404 return 1;
405 } else if (type == LOGICAL) {
406 fprintf (_f->unit, fmt, (*(int_4 *) elem ? 't' : 'f'));
407 return 1;
408 } else if (type == INTEGER && len == 4) {
409 int_4 awid = len, width;
410 if (sscanf (fmt, "%%%ds", &width) == 1) {
411 awid = _abs (width);
412 }
413 int_4 sum = *(int_4 *) elem;
414 for (int_4 k = 0; k < len && k < awid; k++) {
415 char ch = sum % (UCHAR_MAX + 1);
416 fprintf (_f->unit, "%c", ch);
417 sum /= (UCHAR_MAX + 1);
418 }
419 return 1;
420 } else if (type == REAL && len == 8) {
421 int_4 awid = len, width;
422 if (sscanf (fmt, "%%%ds", &width) == 1) {
423 awid = _abs (width);
424 }
425 real_8 sum = *(real_8 *) elem;
426 for (int_4 k = 0; k < len && k < awid; k++) {
427 char ch = (int_4) fmod (sum, (UCHAR_MAX + 1));
428 fprintf (_f->unit, "%c", ch);
429 sum = floor (sum / (UCHAR_MAX + 1));
430 }
431 return 1;
432 } else {
433 return ERR;
434 }
435 } else if (mod == 'c') {
436 if (type == LOGICAL) {
437 fprintf (_f->unit, fmt, (*(int_4 *) elem ? 't' : 'f'));
438 } else {
439 return ERR;
440 }
441 return 1;
442 } else if (mod == 'd') {
443 // INTEGER
444 if (type == INTEGER && len == 2) {
445 NEW_RECORD (buf);
446 _fprintf_int_8 (buf, fmt, (int_8) *(int_2 *) elem);
447 fprintf (_f->unit, "%s", buf);
448 } else if (type == INTEGER && len == 4) {
449 NEW_RECORD (buf);
450 _fprintf_int_8 (buf, fmt, (int_8) *(int_4 *) elem);
451 fprintf (_f->unit, "%s", buf);
452 } else if (type == INTEGER && len == 8) {
453 NEW_RECORD (buf);
454 _fprintf_int_8 (buf, fmt, (int_8) *(int_8 *) elem);
455 fprintf (_f->unit, "%s", buf);
456 } else if (type == INTEGER && len == 16) {
457 NEW_RECORD (buf);
458 _fprintf_int_8 (buf, fmt, (int_8) *(int_8 *) elem);
459 fprintf (_f->unit, "%s", buf);
460 } else {
461 return ERR;
462 }
463 return 1;
464 } else if (mod == 'e' || mod == 'n' || mod == 'f') {
465 // REAL and COMPLEX
466 NEW_RECORD (buf);
467 if (type == INTEGER && len == 2) {
468 _fprintf_real_32 (buf, fmt, flttox ((real_4) *(int_2 *) elem), 4, FLT_DIG);
469 fprintf (_f->unit, "%s", buf);
470 } else if (type == INTEGER && len == 4) {
471 _fprintf_real_32 (buf, fmt, dbltox ((real_8) *(int_4 *) elem), 4, FLT_DIG);
472 fprintf (_f->unit, "%s", buf);
473 } else if (type == INTEGER && len == 8) {
474 _fprintf_real_32 (buf, fmt, dbltox ((real_8) *(int_8 *) elem), 4, FLT_DIG);
475 fprintf (_f->unit, "%s", buf);
476 } else if (type == REAL && len == 4) {
477 _fprintf_real_32 (buf, fmt, flttox (*(real_4 *) elem), 4, FLT_DIG);
478 fprintf (_f->unit, "%s", buf);
479 } else if (type == REAL && len == 8) {
480 _fprintf_real_32 (buf, fmt, dbltox (*(real_8 *) elem), 4, DBL_DIG);
481 fprintf (_f->unit, "%s", buf);
482 } else if (type == REAL && len == 16) {
483 _fprintf_real_32 (buf, fmt, quadtox (*(real_16 *) elem), 5, FLT128_DIG);
484 fprintf (_f->unit, "%s", buf);
485 } else if (type == REAL && len == 32) {
486 _fprintf_real_32 (buf, fmt, *(real_32 *) elem, 5, FLT256_DIG);
487 fprintf (_f->unit, "%s", buf);
488 } else if (type == COMPLEX && len == 8) {
489 real_4 z = crealf (*(complex_8 *) elem);
490 _vif_printf (unit, fmt, &z, REAL, 4);
491 } else if (type == COMPLEX && len == -8) {
492 real_4 z = cimagf (*(complex_8 *) elem);
493 _vif_printf (unit, fmt, &z, REAL, 4);
494 } else if (type == COMPLEX && len == 16) {
495 real_8 z = creal (*(complex_16 *) elem);
496 _vif_printf (unit, fmt, &z, REAL, 8);
497 } else if (type == COMPLEX && len == -16) {
498 real_8 z = cimag (*(complex_16 *) elem);
499 _vif_printf (unit, fmt, &z, REAL, 8);
500 } else if (type == COMPLEX && len == 32) {
501 real_16 z = crealq (*(complex_32 *) elem);
502 _vif_printf (unit, fmt, &z, REAL, 16);
503 } else if (type == COMPLEX && len == -32) {
504 real_16 z = cimagq (*(complex_32 *) elem);
505 _vif_printf (unit, fmt, &z, REAL, 16);
506 } else if (type == COMPLEX && len == 64) {
507 real_32 z = cxreal (*(complex_64 *) elem);
508 _vif_printf (unit, fmt, &z, REAL, 32);
509 } else if (type == COMPLEX && len == -64) {
510 real_32 z = cximag (*(complex_64 *) elem);
511 _vif_printf (unit, fmt, &z, REAL, 32);
512 } else {
513 return ERR;
514 }
515 return 1;
516 }
517 return ERR;
518 }
519
520 void _fscanf_real (char *str, FTN_FILE * _f, int_4 width, int_4 buflen)
521 {
522 while (_f->buff_pos < buflen && _f->buff[_f->buff_pos] == ' ') {
523 _f->buff_pos++;
524 }
525 for (int_4 k = 0; k < width && _f->buff_pos < buflen && _f->buff[_f->buff_pos] != ' '; k++) {
526 str[k] = _f->buff[_f->buff_pos++];
527 str[k + 1] = '\0';
528 }
529 }
530
531 int_4 _vif_scanf (int_4 unit, char *fmt, void *elem, int_4 type, int_4 len)
532 {
533 int_4 width = 0, rc = 0, N = 0;
534 FTN_FILE *_f = _get_ftn_file (NO_TEXT, unit);
535 // A NOP.
536 if (fmt == FMT_TERM) {
537 return 1;
538 }
539 // Re-init on next call.
540 if (fmt == NO_TEXT) {
541 _f->buff_init = FALSE;
542 return 1;
543 }
544 if (strlen (fmt) == 0) {
545 return 1;
546 }
547 // (Re)init if needed.
548 if (!_f->buff_init) {
549 _init_file_buffer (unit);
550 }
551 if (strcmp (fmt, "\n") == 0) {
552 // Reading newline just reinits the buffer.
553 _init_file_buffer (unit);
554 return 1;
555 }
556 // Textual strings are skipped and not checked.
557 if (fmt != NO_TEXT && type == NOTYPE) {
558 int_4 awid = strlen (fmt);
559 if (_f->buff_pos + awid < _f->buff_len) {
560 _f->buff_pos += awid;
561 }
562 return 1;
563 }
564 // Fortran items A, D, E, F, I and Q.
565 char mod = fmt[strlen (fmt) - 1];
566 if (mod == 's' && sscanf (fmt, "%%%ds", &width) == 1) {
567 int_4 awid = _abs (width);
568 if (type == NOTYPE || elem == NO_TEXT) {
569 if (_f->buff_pos + awid > _f->buff_len) {
570 return ERR;
571 }
572 _f->buff_pos += awid; // Just skip it. Fortran would check.
573 return 1;
574 }
575 if (type == CHARACTER) {
576 char *str = (char *) elem;
577 for (int_4 k = 0; k < awid && _f->buff_pos < _f->buff_len; k++) {
578 str[k] = _f->buff[_f->buff_pos++];
579 }
580 // In VIF trailing space is cut.
581 for (int_4 k = strlen (str) - 1; k > 0 && str[k] == ' '; k--) {
582 str[k] = '\0';
583 }
584 return 1;
585 } else if (type == INTEGER && len == 4) {
586 NEW_RECORD (str);
587 int_4 k;
588 for (k = 0; k < awid && _f->buff_pos < _f->buff_len; k++) {
589 str[k] = _f->buff[_f->buff_pos++];
590 }
591 str[k] = '\0';
592 *(int_4 *) elem = _str_to_int4 (str);
593 return 1;
594 } else if (type == REAL && len == 8) {
595 NEW_RECORD (str);
596 int_4 k;
597 for (k = 0; k < awid && _f->buff_pos < _f->buff_len; k++) {
598 str[k] = _f->buff[_f->buff_pos++];
599 }
600 str[k] = '\0';
601 *(real_8 *) elem = _str_to_real8 (str);
602 return 1;
603 }
604 return 0;
605 }
606 if (mod == 'c' && strcmp (fmt, "%c") == 0) {
607 NEW_RECORD (nfmt);
608 if (len == 4) {
609 char ch;
610 _srecordf (nfmt, "%%c%%n");
611 rc = sscanf (&_f->buff[_f->buff_pos], nfmt, (char *) &ch, &N);
612 *(logical_4 *) elem = (ch == 't');
613 }
614 _f->buff_pos += N;
615 return rc;
616 }
617 if (mod == 'd' && strcmp (fmt, "%d") == 0) {
618 NEW_RECORD (nfmt);
619 if (len == 2) {
620 int_4 i;
621 _srecordf (nfmt, "%%d%%n");
622 rc = sscanf (&_f->buff[_f->buff_pos], nfmt, (int_4 *) &i, &N);
623 *(int_2 *) elem = i;
624 } else if (len == 4) {
625 _srecordf (nfmt, "%%d%%n");
626 rc = sscanf (&_f->buff[_f->buff_pos], nfmt, (int_4 *) elem, &N);
627 } else if (len == 8) {
628 _srecordf (nfmt, "%%lld%%nn");
629 rc = sscanf (&_f->buff[_f->buff_pos], nfmt, (int_8 *) elem, &N);
630 }
631 _f->buff_pos += N;
632 return rc;
633 }
634 if (mod == 'd' && type == INTEGER && sscanf (fmt, "%%%dd", &width) == 1) {
635 NEW_RECORD (nfmt);
636 int_4 awid = _abs (width);
637 if (_f->buff_pos + awid > _f->buff_len) {
638 return ERR;
639 }
640 // Vintage Fortran reads blanks as zero.
641 char *q = &_f->buff[_f->buff_pos];
642 int_4 k = width - 1;
643 while (k >= 0) {
644 if (q[k] == ' ') {
645 q[k] = '0';
646 } else if (!isdigit(q[k])) {
647 break;
648 }
649 k--;
650 }
651 //
652 if (len == 2) {
653 int_4 i;
654 _srecordf (nfmt, "%%%dd", width);
655 rc = sscanf (&_f->buff[_f->buff_pos], nfmt, (int_4 *) &i);
656 *(int_2 *) elem = i;
657 } else if (len == 4) {
658 _srecordf (nfmt, "%%%dd", width);
659 rc = sscanf (&_f->buff[_f->buff_pos], nfmt, (int_4 *) elem);
660 } else if (len == 8) {
661 _srecordf (nfmt, "%%%dlld", width);
662 rc = sscanf (&_f->buff[_f->buff_pos], nfmt, (int_8 *) elem);
663 }
664 _f->buff_pos += awid;
665 return rc;
666 }
667 // REAL, standard format
668 if (type == REAL && strcmp (fmt, "%e") == 0) {
669 if (len == 4) {
670 NEW_RECORD (nfmt);
671 _srecordf (nfmt, "%%e%%n");
672 rc = sscanf (&_f->buff[_f->buff_pos], nfmt, (real_4 *) elem, &N);
673 _f->buff_pos += N;
674 return rc;
675 } else if (len == 8) {
676 NEW_RECORD (nfmt);
677 _srecordf (nfmt, "%%le%%n");
678 rc = sscanf (&_f->buff[_f->buff_pos], nfmt, (real_8 *) elem, &N);
679 _f->buff_pos += N;
680 return rc;
681 } else if (len == 16) {
682 NEW_RECORD (str);
683 _fscanf_real (str, _f, RECLN - 1, _f->buff_len);
684 *(real_16 *) (elem) = _strtoquad (str, NO_REF_TEXT);
685 return 1;
686 } else if (len == 32) {
687 NEW_RECORD (str);
688 _fscanf_real (str, _f, RECLN - 1, _f->buff_len);
689 *(real_32 *) (elem) = strtox (str, NO_REF_TEXT);
690 return 1;
691 }
692 }
693 // REAL, format, note that only width can be specified.
694 if ((mod == 'e' || mod == 'f') && type == REAL && sscanf (fmt, "%%%d", &width) == 1) {
695 int_4 awid = _abs (width);
696 if (_f->buff_pos + awid > _f->buff_len) {
697 return ERR;
698 }
699 if (len == 4) {
700 rc = sscanf (&_f->buff[_f->buff_pos], fmt, (real_4 *) elem);
701 _f->buff_pos += width;
702 } else if (len == 8) {
703 NEW_RECORD (nfmt);
704 _srecordf (nfmt, "%%%dl%c", width, mod);
705 rc = sscanf (&_f->buff[_f->buff_pos], nfmt, (real_8 *) elem);
706 _f->buff_pos += width;
707 } else if (len == 16) {
708 NEW_RECORD (str);
709 _fscanf_real (str, _f, (awid > RECLN - 1 ? RECLN - 1 : awid), _f->buff_len);
710 *(real_16 *) (elem) = _strtoquad (str, NO_REF_TEXT);
711 return 1;
712 } else if (len == 32) {
713 NEW_RECORD (str);
714 _fscanf_real (str, _f, (awid > RECLN - 1 ? RECLN - 1 : awid), _f->buff_len);
715 *(real_32 *) (elem) = strtox (str, NO_REF_TEXT);
716 return 1;
717 }
718 return rc;
719 }
720 // COMPLEX, standard
721 if (mod == 'e' && type == COMPLEX && strcmp (fmt, "%e") == 0) {
722 if (_abs (len) == 8) {
723 NEW_RECORD (nfmt);
724 real_4 x;
725 complex_8 *z = (complex_8 *) elem;
726 _srecordf (nfmt, "%%e%%n");
727 rc = sscanf (&_f->buff[_f->buff_pos], nfmt, &x, &N);
728 _f->buff_pos += N;
729 if (len > 0) {
730 *z = CMPLXF (x, 0);
731 } else {
732 *z = CMPLXF (crealf (*z), x);
733 }
734 return rc;
735 } else if (_abs (len) == 16) {
736 NEW_RECORD (nfmt);
737 real_8 x;
738 complex_16 *z = (complex_16 *) elem;
739 _srecordf (nfmt, "%%le%%n");
740 rc = sscanf (&_f->buff[_f->buff_pos], nfmt, &x, &N);
741 _f->buff_pos += N;
742 if (len > 0) {
743 *z = CMPLX (x, 0);
744 } else {
745 *z = CMPLX (creal (*z), x);
746 }
747 return rc;
748 } else if (_abs (len) == 32) {
749 NEW_RECORD (str);
750 complex_32 *z = (complex_32 *) elem;
751 _fscanf_real (str, _f, RECLN - 1, _f->buff_len);
752 if (len > 0) {
753 *z = CMPLXQ (_strtoquad (str, NO_REF_TEXT), 0.0q);
754 } else {
755 *z = CMPLXQ (crealq (*z), _strtoquad (str, NO_REF_TEXT));
756 }
757 return 1;
758 } else if (_abs (len) == 64) {
759 NEW_RECORD (str);
760 complex_64 *z = (complex_64 *) elem;
761 _fscanf_real (str, _f, RECLN - 1, _f->buff_len);
762 if (len > 0) {
763 z->re = strtox (str, NO_REF_TEXT);
764 } else {
765 z->im = strtox (str, NO_REF_TEXT);
766 }
767 return 1;
768 }
769 }
770 // COMPLEX, format, note that only width can be specified.
771 if ((mod == 'e' || mod == 'f') && type == COMPLEX && sscanf (fmt, "%%%de", &width) == 1) {
772 int_4 awid = _abs (width);
773 if (_f->buff_pos + awid > _f->buff_len) {
774 return ERR;
775 }
776 if (_abs (len) == 8) {
777 real_4 x;
778 complex_8 *z = (complex_8 *) elem;
779 rc = sscanf (&_f->buff[_f->buff_pos], fmt, &x);
780 _f->buff_pos += width;
781 if (len > 0) {
782 *z = CMPLXF (x, 0);
783 } else {
784 *z = CMPLXF (crealf (*z), x);
785 }
786 return rc;
787 } else if (_abs (len) == 16) {
788 real_8 x;
789 complex_16 *z = (complex_16 *) elem;
790 NEW_RECORD (nfmt);
791 _srecordf (nfmt, "%%%dl%c", width, mod);
792 rc = sscanf (&_f->buff[_f->buff_pos], nfmt, &x);
793 _f->buff_pos += width;
794 if (len > 0) {
795 *z = CMPLX (x, 0);
796 } else {
797 *z = CMPLX (creal (*z), x);
798 }
799 return rc;
800 } else if (_abs (len) == 32) {
801 NEW_RECORD (str);
802 complex_32 *z = (complex_32 *) elem;
803 _fscanf_real (str, _f, (awid > RECLN - 1 ? RECLN - 1 : awid), _f->buff_len);
804 if (len > 0) {
805 *z = CMPLXQ (_strtoquad (str, NO_REF_TEXT), 0.0q);
806 } else {
807 *z = CMPLXQ (crealq (*z), _strtoquad (str, NO_REF_TEXT));
808 }
809 return 1;
810 } else if (_abs (len) == 64) {
811 NEW_RECORD (str);
812 complex_64 *z = (complex_64 *) elem;
813 _fscanf_real (str, _f, (awid > RECLN - 1 ? RECLN - 1 : awid), _f->buff_len);
814 if (len > 0) {
815 z->re = strtox (str, NO_REF_TEXT);
816 } else {
817 z->im = strtox (str, NO_REF_TEXT);
818 }
819 return 1;
820 }
821 }
822 // No conversion :-(
823 return ERR;
824 }
|
© 2002-2025 J.M. van der Veer (jmvdveer@xs4all.nl)
|
