/*
 * SCFIA.C - FORTRAN interface routines for SCORE
 *
 * Source Version: 2.0
 * Software Release #92-0043
 *
 */

#include "cpyright.h"

#include "score.h"

SC_THREAD_LOCK(SC_ptr_lock);
SC_THREAD_LOCK(SC_stream_lock);

byte
 **_SC_ptr_list_ = NULL;

static int
 _SC_i_ptrs = 0,
 _SC_n_ptrs = 0,
 _SC_nx_ptrs = 0;

static int
 SC_N_hash_entries = 0,
 _SC_stream_indx = 0,
 _SC_stream_max_indx = 0;

static char
 **SC_hash_entries = NULL;

static SC_lexical_stream
 **_SC_stream_list = NULL;

#ifdef MAC

#define DEFAULT_SCANNER NULL

#else

#ifdef DOS

#define DEFAULT_SCANNER NULL

#else

#define DEFAULT_SCANNER F77_ID(f77lxr_, f77lxr, F77LXR)

#endif
#endif

extern int
 SC_DECLARE(F77_ID(f77lxr_, f77lxr, F77LXR), (byte));

static SC_lexical_stream
 SC_DECLARE(*SC_lex_str_ptr, (int strid));

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

/*                        POINTER MANAGEMENT ROUTINES                       */

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

/* SC_STASH_POINTER - add a pointer to the managed array and return
 *                  - its index
 */

int SC_stash_pointer(p)
   byte *p;
   {int i = -1;

    SC_LOCKON(SC_ptr_lock);
    for (; _SC_i_ptrs < _SC_n_ptrs; _SC_i_ptrs++)
        {if (_SC_ptr_list_[_SC_i_ptrs] == NULL)
            {_SC_ptr_list_[_SC_i_ptrs] = p;
             i = ++_SC_i_ptrs;
             break;};}

    if (i == -1)
       {SC_REMEMBER(byte *, p, _SC_ptr_list_, _SC_n_ptrs, _SC_nx_ptrs, 100);
        i = ++_SC_i_ptrs;}
    SC_LOCKOFF(SC_ptr_lock);

    return(i);}

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

/* SC_POINTER_INDEX - return the index of the stored pointer
 *
 */

int SC_pointer_index(p)
   byte *p;
   {int i;

    SC_LOCKON(SC_ptr_lock);
    for (i = 0; i < _SC_n_ptrs; i++)
        {if ((byte *)_SC_ptr_list_[i] == p)
             break;}

    if (i >= _SC_n_ptrs)
       i = -1;
    else
       i++;
    SC_LOCKOFF(SC_ptr_lock);

    return(i);}
    

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

/* SC_DEL_POINTER - remove a pointer from the managed array
 *                - return the pointer so that somebody can free it maybe
 */

byte *SC_del_pointer(n)
   int n;
   {byte *p;
    
    n--;

    SC_LOCKON(SC_ptr_lock);
    p = _SC_ptr_list_[n];

/* NULL out this slot */
    _SC_ptr_list_[n] = NULL;

/* reset the first avaiable index */
    _SC_i_ptrs = min(_SC_i_ptrs, n);
    SC_LOCKOFF(SC_ptr_lock);

    return(p);}

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

/* SC_FREE_STASH - free the array of stashed pointers */

int SC_free_stash()
   {_SC_i_ptrs  = 0;
    _SC_n_ptrs  = 0;
    _SC_nx_ptrs = 0;

    SFREE(_SC_ptr_list_);

    return(TRUE);}

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

/*                            FORTRAN ROUTINES                              */

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

/* SCVERS - return the PACT version in NAME
 *        - and the number of characters in the version string
 *        - as the return value
 */

FIXNUM F77_ID(scvers_, scvers, SCVERS)(pn, name)
   FIXNUM *pn;
   F77_string name;
   {int n, m, l;

    n = *pn;
    m = strlen(SC_version_string);

    l = min(n, m);

    strncpy(SC_F77_C_STRING(name), SC_version_string, l);

    return((FIXNUM) m);}

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

/* SCALEN - return the length of an array
 *        - this version takes a CRAY pointer (e.g. ipa of pointer (ipa, a))
 *        - WARNING: only for F77 with CRAY pointer extensions
 */

FIXNUM F77_ID(scalen_, scalen, SCALEN)(p)
   byte **p;
   {return((FIXNUM) SC_arrlen(*p));}

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

/* SCELEN - return the length of an array
 *        - this version takes a CRAY pointee (e.g. a of pointer (ipa, a))
 *        - WARNING: only for F77 with CRAY pointer extensions
 */

FIXNUM F77_ID(scelen_, scelen, SCELEN)(p)
   byte *p;
   {return((FIXNUM) SC_arrlen(p));}

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

/* SC_HASH_TO_LIST - build a list out of a hash table */

byte **SC_hash_to_list(table)
   HASHTAB *table;
   {int sz, i;
    hashel *np, **tb;
    byte **list, **plist;

    sz    = table->size;
    tb    = table->table;
    list  = FMAKE_N(byte *, table->nelements + 1, "SC_HASH_TO_LIST:list");
    plist = list;
    for (i = 0; i < sz; i++)
        for (np = tb[i]; np != NULL; np = np->next)
	    *plist++ = np->def;

    *plist = NULL;

    return(list);}

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

/* SC_SET_HASH_DUMP - set up a hash dump for a FORTRAN application
 *                  - some other routine will have to make this call
 *                  - to supply the hash table
 */

int SC_set_hash_dump(tab, fun)
   HASHTAB *tab;
   PFInt fun;
   {int i, sz, n_entries;
    hashel *np, **tb, **entries;

    SC_free_hash_dump();

/* if no function is supplied dump and sort by name alphabetically */
    if (fun == NULL)
       {SC_hash_entries = SC_hash_dump(tab, NULL);
        SC_N_hash_entries = SC_arrlen(SC_hash_entries)/sizeof(char *) - 1;
        for (i = 0; i < SC_N_hash_entries; i++)
            SC_hash_entries[i] = SC_strsavef(SC_hash_entries[i],
                                 "char*:SC_SET_HASH_DUMP:hash_entries");}

    else
       {entries = FMAKE_N(hashel *, tab->nelements,
			  "SC_SET_HASH_DUMP:entries");
        if (entries == NULL)
           return(-1);

/* fill in the list of pointers to names in the hash table */
        sz = tab->size;
        tb = tab->table;
        n_entries = 0;
        for (i = 0; i < sz; i++)
            for (np = tb[i]; np != NULL; np = np->next)
                entries[n_entries++] = np;

/* sort the array of hashel's */
        n_entries = (*fun)(entries, n_entries);

        SC_hash_entries = FMAKE_N(char *, n_entries,
				  "SC_HASH_DUMP:SC_hash_entries");
        if (SC_hash_entries == NULL)
           return(-1);

        for (i = 0; i < n_entries; i++)
            SC_hash_entries[i] = SC_strsavef(entries[i]->name,
                                 "char*:SC_SET_HASH_DUMP:name");

        SC_N_hash_entries = n_entries;

        SFREE(entries);};

    return(SC_N_hash_entries);}

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

/* SC_FREE_HASH_DUMP - free space allocated by call to SC_set_hash_dump */

int SC_free_hash_dump()
   {int i;

    if (SC_hash_entries != NULL)
       {for (i = 0; i < SC_N_hash_entries; i++)
            {SFREE(SC_hash_entries[i]);};
        SFREE(SC_hash_entries);};

    return(TRUE);}

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

/* SC_GET_ENTRY - return the name associated with the nth entry in the
 *              - sorted list of names in the last sorted hash table done
 *              - by SC_set_hash_dump
 */

char *SC_get_entry(n)
   int n;
   {if ((n < 0) || (SC_N_hash_entries <= n))
       return(NULL);
    else
       return(SC_hash_entries[n]);}

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

/* SCMKHT - make a hash table */

FIXNUM F77_ID(scmkht_, scmkht, SCMKHT)(psz, pdoc)
   FIXNUM *psz, *pdoc;
   {int sz, doc;
    HASHTAB *tab;

    sz  = *psz;
    doc = *pdoc;

    tab = SC_make_hash_table(sz, doc);
    if (tab == NULL)
       return((FIXNUM) 0);
    else
       return((FIXNUM) SC_ADD_POINTER(tab));}

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

/* SCRLHT - release a hash table */

FIXNUM F77_ID(scrlht_, scrlht, SCRLHT)(tabid)
   FIXNUM *tabid;
   {HASHTAB *tab;

    tab = SC_DEL_POINTER(HASHTAB, *tabid);

    SC_rl_hash_table(tab);

    *tabid = 0;

    return((FIXNUM) TRUE);}

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

/* SCHCLR - clear a hash table */

FIXNUM F77_ID(schclr_, schclr, SCHCLR)(tabid)
   FIXNUM *tabid;
   {HASHTAB *tab;

    tab = SC_GET_POINTER(HASHTAB, *tabid);

    SC_hash_clr(tab);

    return((FIXNUM) TRUE);}

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

/* SCHINS - install an object in a hash table
 *        - if cp is TRUE make a copy of the object pointed to by pointer
 *        - in this case the type had better be right because it is the
 *        - only info install has to go on
 */

FIXNUM F77_ID(schins_, schins, SCHINS)(pnc, pname, ptr, pnt, ptype,
                                       pcp, tabid)
   FIXNUM *pnc;
   F77_string pname;
   byte *ptr;
   FIXNUM *pnt;
   F77_string ptype;
   FIXNUM *pcp, *tabid;
   {int cp;
    char name[MAXLINE], type[MAXLINE];
    HASHTAB *tab;

    cp  = *pcp;
    tab = SC_GET_POINTER(HASHTAB, *tabid);

    SC_FORTRAN_STR_C(name, pname, *pnc);
    SC_FORTRAN_STR_C(type, ptype, *pnt);

    if (cp)
       {long n;
	void *s;

        n = SIZEOF(type);
        s = SC_alloc_na(1L, n, NULL, FALSE);
        memcpy(s, ptr, n);

        ptr = s;};

    return((FIXNUM) (_SC_install(name, ptr, SC_strsavef(type,
                     "char*:SCHINS:type"), tab, FALSE, TRUE) != NULL));}

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

/* SCHLKP - look up an object in a hash table
 *        - return the object thru P
 */

FIXNUM F77_ID(schlkp_, schlkp, SCHLKP)(p, pnc, pname, tabid)
   byte *p;
   FIXNUM *pnc;
   F77_string pname;
   FIXNUM *tabid;
   {int n;
    char name[MAXLINE];
    hashel *hp;
    HASHTAB *tab;

    tab = SC_GET_POINTER(HASHTAB, *tabid);

    SC_FORTRAN_STR_C(name, pname, *pnc);

    hp = SC_lookup(name, tab);
    if (hp == NULL)
       return((FIXNUM) FALSE);

    n = SIZEOF(hp->type);
    memcpy(p, hp->def, n);

    return((FIXNUM) TRUE);}

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

/* SCHLKU - look up an object in a hash table
 *        - return a pointer to the object thru P
 */

FIXNUM F77_ID(schlku_, schlku, SCHLKU)(p, pnc, pname, tabid)
   byte **p;
   FIXNUM *pnc;
   F77_string pname;
   FIXNUM *tabid;
   {char name[MAXLINE];
    hashel *hp;
    HASHTAB *tab;

    tab = SC_GET_POINTER(HASHTAB, *tabid);

    SC_FORTRAN_STR_C(name, pname, *pnc);

    hp = SC_lookup(name, tab);
    if (hp == NULL)
       return((FIXNUM) FALSE);

    *p = (byte *) hp->def;

    return((FIXNUM) TRUE);}

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

/* SCHREM - remove an object from a hash table */

FIXNUM F77_ID(schrem_, schrem, SCHREM)(pnc, pname, tabid)
   FIXNUM *pnc;
   F77_string pname;
   FIXNUM *tabid;
   {char name[MAXLINE];
    HASHTAB *tab;

    tab = SC_GET_POINTER(HASHTAB, *tabid);

    SC_FORTRAN_STR_C(name, pname, *pnc);

    return((FIXNUM) SC_hash_rem(name, tab));}

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

/* SCPAUS - FORTRAN interface to SC_pause */

FIXNUM F77_ID(scpaus_, scpaus, SCPAUS)()
   {

    SC_pause();

    return((FIXNUM) TRUE);}

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

/* SCFTCS - FORTRAN interface to convert FORTRAN string to C string */

FIXNUM F77_ID(scftcs_, scftcs, SCFTCS)(out, in , pnc)
   F77_string out, in;
   FIXNUM *pnc;
   {

    SC_FORTRAN_STR_C(SC_F77_C_STRING(out), in , *pnc);

    return((FIXNUM) TRUE);}

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

/* SCADVN - FORTRAN interface to SC_advance_name */

FIXNUM F77_ID(scadvn_, scadvn, SCADVN)(pnc, name)
   FIXNUM *pnc;
   F77_string name;
   {char bf[MAXLINE];
    int n;

    n = *pnc;

    SC_FORTRAN_STR_C(bf, name, n);
    SC_advance_name(bf);
    strncpy(SC_F77_C_STRING(name), bf, n);

    return((FIXNUM) TRUE);}

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

/*                       LEXICAL SCANNING ROUTINES                          */

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

/* SC_LEX_STR_PTR - return the SC_lexical_stream pointer associated with
 *                - the index if the index is valid and NULL otherwise
 */

static SC_lexical_stream *SC_lex_str_ptr(strid)
   int strid;
   {if ((strid < 0) || (strid >= _SC_stream_indx))
       return(NULL);

    return(_SC_stream_list[strid]);}

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

/* SCOPLS - open a SC_lexical_stream
 *        - save the SC_lexical_stream pointer in an internal array
 *        - and return an integer index to the pointer if successful
 *        - return -1 otherwise
 */

FIXNUM F77_ID(scopls_, scopls, SCOPLS)(pnchr, name, pinbs, pstrbs, scan, pfl)
   FIXNUM *pnchr;
   F77_string name;
   FIXNUM *pinbs, *pstrbs;
   PFInt scan;
   FIXNUM *pfl;
   {SC_lexical_stream *str;
    char s[MAXLINE];

    SC_FORTRAN_STR_C(s, name, *pnchr);

    if (*pfl == 0)
       scan = DEFAULT_SCANNER;

    if (strcmp(s, "tty") == 0)
       str = SC_open_lexical_stream(NULL, 0, 0, scan,
				    NULL, NULL, NULL, NULL, NULL, NULL);
    else
       str = SC_open_lexical_stream(s, 0, 0, scan,
				    NULL, NULL, NULL, NULL, NULL, NULL);
    if (str == NULL)
       return((FIXNUM) -1);
    else
       {SC_REMEMBER(SC_lexical_stream *, str, _SC_stream_list,
		    _SC_stream_indx,
		    _SC_stream_max_indx,
		    10);

        return((FIXNUM) (_SC_stream_indx - 1));};}
    
/*--------------------------------------------------------------------------*/
/*--------------------------------------------------------------------------*/

/* SCCLLS - close the SC_lexical_stream associated with the integer index
 *        - return TRUE if successful and FALSE otherwise
 */

FIXNUM F77_ID(scclls_, scclls, SCCLLS)(strid)
   FIXNUM *strid;
   {SC_lexical_stream *str;

    str = SC_lex_str_ptr((int) *strid);
    _SC_stream_list[*strid] = NULL;

    SC_close_lexical_stream(str);

    return((FIXNUM) TRUE);}

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

/* SCRDLS - read a line from the SC_lexical_stream associated with
 *        - the integer index
 *        - return TRUE if successful and FALSE otherwise
 */

FIXNUM F77_ID(scrdls_, scrdls, SCRDLS)(strid, pnc, ps)
   FIXNUM *strid, *pnc;
   F77_string ps;
   {SC_lexical_stream *str;
    char *s;
    int n, nr, ni;

    str = SC_lex_str_ptr((int) *strid);

    s = str->in_bf;
    n = SC_arrlen(s);
    GETLN(s, n, str->file);

    ni = *pnc;
    nr = strlen(s);    

    ni = min(ni, nr);

    memset(SC_F77_C_STRING(ps), ' ', ni);
    strncpy(SC_F77_C_STRING(ps), s, ni);

    *pnc = ni;

    return((FIXNUM) TRUE);}

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

/* SCSCAN - scan the given line of text and return arrays of tokens
 *        - the lexical rules are defined by the routine attached to the
 *        - lexical stream when it is opened. However a default set of
 *        - rules implements a FORTRANish syntax.
 *        - The string to be scanned is contained in the lexical stream
 *        - and must be supplied by a call to SCRDLS
 *        - Arguments:
 *        - 
 *        -    STRID  - id number of lexical stream (scalar)
 *        -    PMXTOK - maximum number of tokens to be returned (scalar)
 *        -    PWIDTH - character field width (e.g. char*8 => 8) (scalar)
 *        -    TOK    - character array char*PWIDTH(PMXTOK) for returned
 *        -           - tokens (array)
 *        -    PNTOK  - actual number of tokens available (scalar)
 *        -    NCTOK  - character length of each non-numeric token (array)
 *        -    IXTOK  - index in TOK for each non-numeric token (array)
 *        -    TOKTYP - type for each token (array)
 *        -           - default scanner uses:
 *        -           -  TYPE   NAME         EXAMPLE
 *        -           -     1   DELIMITER    & ( ) , : < = > _ |
 *        -           -     2   ALPHANUM     abc
 *        -           -     3   INTEGER      10
 *        -           -     4   REAL         1.2 6.0e10
 *        -           -     5   OCTAL        17b
 *        -           -     6   HEX          #17
 *        -           -     7   OPERAND      .and.
 *        -           -     8   STRING       "foo"
 *        -           -  1000   HOLLERITH    3hFOO
 *        -    TOKVAL - numerical value for numerical tokens as REAL (array)
 *        -
 *        - return TRUE if successful and FALSE otherwise
 */

FIXNUM F77_ID(scscan_, scscan, SCSCAN)(strid, pmxtok, pwidth, tok, pntok,
                                       nctok, ixtok, toktyp, tokval)
   FIXNUM *strid, *pmxtok, *pwidth;
   F77_string tok;
   FIXNUM *pntok, *nctok, *ixtok, *toktyp;
   REAL *tokval;
   {SC_lexical_stream *str;
    long lval;
    double dval;
    int i, indx, nc;
    int n_tok, n_tok_max, width;
    char *s;

    str = SC_lex_str_ptr((int) *strid);

    SC_scan(str, FALSE);

    n_tok  = str->n_tokens;
    *pntok = (FIXNUM) n_tok;

    width     = *pwidth;
    n_tok_max = *pmxtok;
    n_tok     = min(n_tok, n_tok_max);
    for (indx = 0, i = 0; i < n_tok; i++)
        {toktyp[i] = SC_TOKEN_TYPE(str, i);
	 ixtok[i]  = 0;
	 nctok[i]  = 0;

         switch(toktyp[i])
            {case SC_DINT_TOK :
             case SC_HINT_TOK :
             case SC_OINT_TOK :
                  lval = SC_TOKEN_INTEGER(str, i);
                  tokval[i] = lval;
                  break;

             case SC_REAL_TOK :
                  dval = SC_TOKEN_REAL(str, i);
                  tokval[i] = dval;
                  break;
   
             case SC_STRING_TOK :
	          s  = SC_TOKEN_STRING(str, i);
		  nc = strlen(s);
		  strncpy(SC_F77_C_STRING(tok) + indx*width,
			  s, nc);

		  ixtok[i] = indx;
		  nctok[i] = nc;

		  indx += (nc + width - 1)/width;
                  break;
   
             default :
                  break;};};

    return((FIXNUM) TRUE);}

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

/*                         ASSOCIATION LIST ROUTINES                        */

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

/* SCCHAL - change an item from the given association list
 *        - add the item if necessary
 *        - assumes PV points to static space
 *        - NV then tells how many items are pointed to!
 *        - PTYPE names the type and has one less indirection than PV
 */

FIXNUM F77_ID(scchal_, scchal, SCCHAL)(pal, nn, pname, nt, ptype, nv, pv)
   FIXNUM *pal, *nn;
   F77_string pname;
   FIXNUM *nt;
   F77_string ptype;
   FIXNUM *nv;
   byte *pv;
   {SC_address ad;
    byte *val, *p;
    long nb, ni;
    char lname[MAXLINE], ltype[MAXLINE];

    if (*pal == 0)
       ad.memaddr = NULL;
    else
       ad.memaddr = SC_GET_POINTER(char, *pal);

/* cheap insurance */
    if (ad.memaddr == NULL)
       ad.diskaddr = 0L;

    SC_FORTRAN_STR_C(lname, pname, *nn);
    SC_FORTRAN_STR_C(ltype, ptype, *nt);

/* copy the incoming values */
    nb = SIZEOF(ltype);
    ni = *nv;
    val = SC_alloc_na(ni, nb, "SCCHAL:val", FALSE);
    memcpy(val, pv, ni*nb);

/* add the extra level of indirection needed */
    strcat(ltype, " *");

    ad.memaddr = (char *) SC_change_alist((pcons *) ad.memaddr,
					  lname, ltype, val);
    if (*pal != 0)
       p = SC_DEL_POINTER(byte, *pal);

    *pal = (FIXNUM) SC_ADD_POINTER(ad.memaddr);

    return((FIXNUM) TRUE);}

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

/* SCRMAL - remove an item from the given association list */

FIXNUM F77_ID(scrmal_, scrmal, SCRMAL)(pal, nn, pname)
   FIXNUM *pal, *nn;
   F77_string pname;
   {SC_address ad;
    char lname[MAXLINE];
    byte *p;

    ad.memaddr = SC_GET_POINTER(char, *pal);

/* cheap insurance */
    if (ad.memaddr == NULL)
       return((FIXNUM) FALSE);

    SC_FORTRAN_STR_C(lname, pname, *nn);

    ad.memaddr = (char *) SC_rem_alist((pcons *) ad.memaddr, lname);

    p = SC_DEL_POINTER(byte, *pal);
    *pal = (FIXNUM) SC_ADD_POINTER(ad.memaddr);

    return((FIXNUM) TRUE);}

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

/* SCRLAL - release an association list */

FIXNUM F77_ID(scrlal_, scrlal, SCRLAL)(pal, pl)
   FIXNUM *pal, *pl;
   {SC_address ad;
    byte *p;

    ad.memaddr = SC_GET_POINTER(char, *pal);

/* cheap insurance */
    if (ad.memaddr == NULL)
       return((FIXNUM) FALSE);

    SC_free_alist((pcons *) ad.memaddr, *pl);

    p = SC_DEL_POINTER(byte, *pal);    
    *pal = 0L;

    return((FIXNUM) TRUE);}

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

/* SCAPAL - append the contents of PAL2 to PAL1 */

FIXNUM F77_ID(scapal_, scapal, SCAPAL)(pal1, pal2)
   FIXNUM *pal1, *pal2;
   {SC_address ad1, ad2;
    byte *p;

    ad1.memaddr = SC_GET_POINTER(char, *pal1);
    ad2.memaddr = SC_GET_POINTER(char, *pal2);

    ad2.memaddr = (char *) SC_copy_alist((pcons *) ad2.memaddr);
    ad1.memaddr = (char *) SC_append_alist((pcons *) ad1.memaddr,
					   (pcons *) ad2.memaddr);

    p = SC_DEL_POINTER(byte, *pal1);
    *pal1 = (FIXNUM) SC_ADD_POINTER(ad1.memaddr);

    return((FIXNUM) TRUE);}


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

/*                         TIMING ROUTINES                                  */

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

/* SCCTIM - return the cpu time used in seconds and microseconds
 *          SINCE THE FIRST CALL
 */

FIXNUM F77_ID(scctim_, scctim, SCCTIM)(ptim)
   REAL *ptim;
   {*ptim = (REAL) SC_cpu_time();

    return ((FIXNUM) TRUE);}

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

/* SCWTIM - return the wall clock time in seconds and microseconds
 *          SINCE THE FIRST CALL
 */

FIXNUM F77_ID(scwtim_, scwtim, SCWTIM)(ptim)
   REAL *ptim;
   {*ptim = (REAL) SC_wall_clock_time();

    return ((FIXNUM) TRUE);}

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

/* SCDATE - return a string with the time and date as defined by the
 *          ANSI function ctime
 */

FIXNUM F77_ID(scdate_, scdate, SCDATE)(pnc, date)
   FIXNUM *pnc;
   F77_string date;
   {char *cdate;
    int nc, lc;

    nc    = *pnc;
    cdate = SC_date();
    lc    = strlen(cdate);    
    *pnc  = lc;

    strncpy(SC_F77_C_STRING(date), cdate, nc);
    SFREE(cdate);

    return((FIXNUM) TRUE);}

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

