/*
 * SCFIS.C - FORTRAN usable string handling facilities
 *         - there is a convention is some applications in which
 *         - FORTRAN strings are blank filled to the end and this
 *         - implies the possibliity of computing string length by
 *         - finding the position of the last non-blank character
 *         - and using that as the string length
 *
 * Source Version: 2.0
 * Software Release #92-0043
 *
 */

#include "cpyright.h"

#include "score.h"

#define CAT(_d, _s, _n, _m)                                                  \
   {if (_n + strlen(_s) >= _m)                                               \
       return;                                                               \
    strcat(_d, _s);                                                          \
    _n = strlen(_d);}

/*--------------------------------------------------------------------------*/
/*--------------------------------------------------------------------------*/

/* _SC_STRLEN - helper to find string length in the F77 convention */

int _SC_strlen(s, nx)
   char *s;
   int nx;
   {int n;

    for (n = nx-1; n >= 0; n--)
        if (s[n] != ' ')
	   break;

    s[++n] = '\0';

    return(n);}

/*--------------------------------------------------------------------------*/
/*--------------------------------------------------------------------------*/

/* SCSTLN - F77 string length function
 *        - looks from end for first non-blank character in S
 *        - this is simply a convention but one used by some other codes
 *        - NX is the length of the character array
 */

FIXNUM F77_ID(scstln_, scstln, SCSTLN)(s, pnx)
   F77_string s;
   FIXNUM *pnx;
   {int n, nx;
    char *t;

    t  = SC_F77_C_STRING(s);
    nx = *pnx;

    n = _SC_strlen(t, nx);

    return(n);}

/*--------------------------------------------------------------------------*/
/*--------------------------------------------------------------------------*/

/* SCSTTK - return the first token of S in D
 *        - both S and D are character arrays PNC long
 *        - and points S to the next element in the string
 */

void F77_ID(scsttk_, scsttk, SCSTTK)(pnc, d, s, pnd, dl)
   FIXNUM *pnc;
   F77_string d, s, dl;
   {int j, n, nc, flag;
    char *dst, *src, *delim;
    char c;

    nc    = *pnc;
    dst   = SC_F77_C_STRING(d);
    src   = SC_F77_C_STRING(s);
    delim = SC_F77_C_STRING(dl);

    n = _SC_strlen(s, nc);

/* clear D */
    memset(dst, ' ', nc);

    flag = FALSE;
    for (; n > 0; n--)
        {c = *src;

/* if the character c is not a delimiter record it */
	 if (strchr(delim, c) == NULL)
	    {*dst++ = c;
	     flag   = TRUE;}

/* if we hit another delimiter we're done */
	 else if (flag)
	    break;

	 for (j = 1; j < n; j++)
	     src[j-1] = src[j];

	 src[j-1] = ' ';};

    return;}

/*--------------------------------------------------------------------------*/
/*--------------------------------------------------------------------------*/

/* SCSPNT - FORTRAN version of sprintf
 *        - PNC is the length of the character array D
 *        - and is taken to be the character array length of any strings
 *        - implied in the argument list
 */

#ifdef ANSI

void F77_ID(scspnt_, scspnt, SCSPNT)(FIXNUM *pnc, F77_string d,
				     F77_string f, ...)
#else

void F77_ID(scspnt_, scspnt, SCSPNT)(pnc, d, f, va_alist)
   FIXNUM *pnc;
   F77_string d, f;
   va_dcl

#endif

   {int c, nc, nd;
    char s[MAXLINE], local[MAXLINE];
    char *fmt, *le, *lb, *pt, *dst;
    FIXNUM *lv;
    REAL *dv;
    F77_string sv;

    nc     = (int) *pnc;
    fmt    = SC_F77_C_STRING(f);
    dst    = SC_F77_C_STRING(d);
    dst[0] = '\0';

    SC_VA_START(f);

    nd = 0;
    while (TRUE)
       {for (pt = local; (((c = *fmt++) != '%') && (c != '\0')); pt++)
            {if (c == '\\')
                {switch (c = *fmt++)
                    {case 't' :
		          *pt = '\t';
			  break;
                     case 'r' :
		          *pt = '\r';
			  break;
                     case 'n' :
		          *pt = '\n';
			  break;
                     default :
		          *pt = c;
			  break;};}
             else
                *pt = c;};

        *pt = '\0';

/* don't exceed the return buffer size */
	CAT(dst, local, nd, nc);

        if (c == '\0')
           break;

/* copy from the % to the type specifier to get the format descriptor for
 * this item
 */
        le = strpbrk(fmt, "sdouxXfeEgGc%");
        local[0] = '%';
        for (lb = &local[1]; le != fmt; *lb++ = *fmt++);
        fmt++;
        *lb++ = *le;
        *lb = '\0';

/* jump on the type spec to pull the correct arg type off the stack */
        switch (*le)
           {case 's' :
	         sv = SC_VA_ARG(F77_string);
		 SC_FORTRAN_STR_C(s, sv, nc);
		 nc = _SC_strlen(s, nc);
		 CAT(dst, s, nd, nc);
                 break;

            case 'c' :
	         sv = SC_VA_ARG(F77_string);
		 SC_FORTRAN_STR_C(s, sv, 1);
		 CAT(dst, s, nd, 1);
                 break;

            case 'i' :
            case 'X' :
            case 'x' :
            case 'o' :
            case 'd' :
            case 'u' :
	         lv = SC_VA_ARG(FIXNUM *);
		 sprintf(s, local, (long) *lv);
		 CAT(dst, s, nd, 1);
                 break;

            case 'f' : 
            case 'e' :
            case 'E' : 
            case 'g' : 
            case 'G' :
	         dv = SC_VA_ARG(REAL *);
		 sprintf(s, local, (double) *dv);
		 CAT(dst, s, nd, 1);
                 break;

            case '%' :
                 CAT(dst, "%", nd, 1);
                 break;};};

    SC_VA_END;

    return;}

/*--------------------------------------------------------------------------*/
/*--------------------------------------------------------------------------*/

