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)