/*
 * SHLARG.C - support for the functions of the Scheme
 *          - not in the SMALL (core) Scheme
 *
 * Source Version: 4.0
 * Software Release #92-0043
 *
 */

#include "cpyright.h"

#include "scheme.h"

static void
 SC_DECLARE(_SS_rl_hash_table, (object *obj)),
 SC_DECLARE(_SS_rl_hashel, (object *obj)),
 SC_DECLARE(_SS_wr_hash_table, (object *obj, object *strm)),
 SC_DECLARE(_SS_wr_hashel, (object *obj, object *strm));

static object
 *SC_DECLARE(SS_print_env, (object *obj)),
 *SC_DECLARE(SS_wall_clock_time, (byte)),
 *SC_DECLARE(SS_mem_usg, (byte)),
 *SC_DECLARE(SS_mem_trace, (byte)),
 *SC_DECLARE(SS_mem_map, (object *arg)),
 *SC_DECLARE(SS_strnum, (object *argl)),
 *SC_DECLARE(SS_strchr, (object *argl)),
 *SC_DECLARE(SS_strtok, (object *argl));

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

/* SS_INST_LRG - install the primitives making up the LARGE Scheme */

void SS_inst_lrg()
   {
    SS_install("call-with-input-file",
               "Procedure: open the named file and eval a procedure using the port for input",
               SS_nargs,
               SS_call_if, SS_PR_PROC);

    SS_install("call-with-output-file",
               "Procedure: open the named file and eval a procedure using the port for output",
               SS_nargs,
               SS_call_of, SS_PR_PROC);

    SS_install("char?",
               "Procedure: Returns #t iff the object is of type char",
               SS_sargs,
               SS_charp, SS_PR_PROC);

    SS_install("char=?",
               "Procedure: Returns #t iff the chars are the same",
               SS_nargs,
               SS_chreq, SS_PR_PROC);

    SS_install("char>=?",
               "Procedure: Returns #t iff the first character is 'greater than or equal to' the second",
               SS_nargs,
               SS_chrge, SS_PR_PROC);

    SS_install("char>?",
               "Procedure: Returns #t iff the first character is 'greater than' the second",
               SS_nargs,
               SS_chrgt, SS_PR_PROC);

    SS_install("char<=?",
               "Procedure: Returns #t iff the first character is 'less than or equal to' the second",
               SS_nargs,
               SS_chrle, SS_PR_PROC);

    SS_install("char<?",
               "Procedure: Returns #t iff the first character is 'less than' the second",
               SS_nargs,
               SS_chrlt, SS_PR_PROC);

    SS_install("char->integer",
               "Procedure: Returns the integer representation of the given integer",
               SS_sargs,
               SS_chrint, SS_PR_PROC);

    SS_install("wall-clock-time",
               "Procedure: Returns the accumulated wall clock time in seconds",
               SS_zargs,
               SS_wall_clock_time, SS_PR_PROC);

    SS_install("current-input-port",
               "Procedure: Returns the current default input port",
               SS_zargs,
               SS_curr_ip, SS_PR_PROC);

    SS_install("current-output-port",
               "Procedure: Returns the current default output port",
               SS_zargs,
               SS_curr_op, SS_PR_PROC);

    SS_install("define-global",
               "Special Form: defines variables and procedures in the global environment",
               SS_nargs,
               SS_define_global, SS_UE_MACRO);

    SS_install("define-global-macro",
               "Special Form: defines variables and procedures in the global environment",
               SS_nargs,
               SS_define_global, SS_UE_MACRO);

    SS_install("env",
               "Procedure: print the specified environment frame",
               SS_sargs,
               SS_print_env, SS_PR_PROC);

    SS_install("hash-dump",
               "Procedure: Return a list of the names in the given hash table",
               SS_nargs,
               SS_hash_dump, SS_PR_PROC);

    SS_install("hash-info",
               "Procedure: Return (<size> <#-elements> <doc?>) for given hash table",
               SS_sargs,
               SS_hash_info, SS_PR_PROC);

    SS_install("hash-element?",
               "Procedure: Return #t if the object is a hash-element",
               SS_sargs,
               SS_hashelp, SS_PR_PROC);

    SS_install("hash-install",
               "Procedure: Install the given object in the given hash table",
               SS_nargs,
               SS_hash_install, SS_PR_PROC);

    SS_install("hash-lookup",
               "Procedure: Look up and return the named object in the given hash table",
               SS_nargs,
               SS_hash_lookup, SS_PR_PROC);

    SS_install("hash-remove",
               "Procedure: Remove the named object from the given hash table",
               SS_nargs,
               SS_hash_remove, SS_PR_PROC);

    SS_install("hash-table?",
               "Procedure: Return #t if the object is a hash-table",
               SS_sargs,
               SS_hashtabp, SS_PR_PROC);

    SS_install("integer->char",
               "Procedure: Returns the character representation of the given integer",
               SS_sargs,
               SS_intchr, SS_PR_PROC);

    SS_install("list->string",
               "Procedure: Returns a string constructed from a list of characters",
               SS_nargs,
               SS_lststr, SS_PR_PROC);

    SS_install("list->vector",
               "Procedure: Returns a vector whose elements are the same as the lists",
               SS_sargs,
               SS_lstvct, SS_PR_PROC);

    SS_install("make-vector",
               "Procedure: Return a new vector whose length is specified by the argument",
               SS_sargs,
               SS_mkvect, SS_PR_PROC);

    SS_install("make-hash-table",
               "Procedure: Return a new hash table",
               SS_sargs,
               SS_make_hash_table, SS_PR_PROC);

    SS_install("memory-usage",
               "Procedure: Returns the number of bytes allocated, freed, and diff",
               SS_zargs,
               SS_mem_usg, SS_PR_PROC);

    SS_install("memory-map",
               "Procedure: print a memory map to the given port",
               SS_sargs,
               SS_mem_map, SS_PR_PROC);

    SS_install("memory-trace",
               "Procedure: return the number of allocated memory blocks",
               SS_zargs,
               SS_mem_trace, SS_PR_PROC);

    SS_install("read-char",
               "Procedure: Read and return a single character",
               SS_nargs,
               SS_rd_chr, SS_PR_PROC);

    SS_install("read-line",
               "Procedure: Read a line of text and return a string",
               SS_nargs,
               SS_rd_line, SS_PR_PROC);

    SS_install("string=?",
               "Procedure: Returns #t iff the strings are the same (length too)",
               SS_nargs,
               SS_streq, SS_PR_PROC);

    SS_install("string>=?",
               "Procedure: Returns #t iff the first string is 'greater than or equal to' the second",
               SS_nargs,
               SS_strge, SS_PR_PROC);

    SS_install("string>?",
               "Procedure: Returns #t iff the first string is 'greater than' the second",
               SS_nargs,
               SS_strgt, SS_PR_PROC);

    SS_install("string<=?",
               "Procedure: Returns #t iff the first string is 'less than or equal to' the second",
               SS_nargs,
               SS_strle, SS_PR_PROC);

    SS_install("string<?",
               "Procedure: Returns #t iff the first string is 'less than' the second",
               SS_nargs,
               SS_strlt, SS_PR_PROC);

    SS_install("string->list",
               "Procedure: construct a list of the characters in the given string",
               SS_sargs,
               SS_strlst, SS_PR_PROC);

    SS_install("string->number",
               "Procedure: return the number represented by the given string",
               SS_sargs,
               SS_strnum, SS_PR_PROC);

    SS_install("string->port",
               "Procedure: encapsulate a string as a pseudo input-port for reading",
               SS_sargs,
               SS_strprt, SS_PR_PROC);

    SS_install("string->symbol",
               "Procedure: make a new variable with name given by the string",
               SS_sargs,
               SS_strsym, SS_PR_PROC);

    SS_install("string-append",
               "Procedure: Append the argument strings together into a new string and return it",
               SS_nargs,
               SS_strapp, SS_PR_PROC);

    SS_install("string-length",
               "Procedure: Returns the number of characters in the given string",
               SS_sargs,
               SS_strlen, SS_PR_PROC);

    SS_install("string-ref",
               "Procedure: Returns the nth character in the given string",
               SS_nargs,
               SS_strref, SS_PR_PROC);

    SS_install("strtok",
               "Procedure: Extract the next token from the string ala SC_firsttok",
               SS_nargs,
               SS_strtok, SS_PR_PROC);

    SS_install("strchr",
               "Procedure: Like the C function",
               SS_nargs,
               SS_strchr, SS_PR_PROC);

    SS_install("substring",
               "Procedure: Extract the substring zero-origin indexed by the last two args",
               SS_nargs,
               SS_strsub, SS_PR_PROC);

    SS_install("symbol->string",
               "Procedure: make a new string out of the given variable name",
               SS_sargs,
               SS_symstr, SS_PR_PROC);

    SS_install("up-case",
               "Procedure: return a string containing only upper case char made from input",
               SS_sargs,
               SS_upcase, SS_PR_PROC);

    SS_install("down-case",
               "Procedure: return a string containing only lower case char made from input",
               SS_sargs,
               SS_dncase, SS_PR_PROC);

    SS_install("vector?",
               "Procedure: Returns #t iff the object is of type vector",
               SS_sargs,
               SS_vectp, SS_PR_PROC);

    SS_install("vector",
               "Procedure: Analog to list procedure for vectors",
               SS_nargs,
               SS_vector, SS_PR_PROC);

    SS_install("vector-length",
               "Procedure: Returns the number of elements in the specified vector",
               SS_sargs,
               SS_vctlen, SS_PR_PROC);

    SS_install("vector->list",
               "Procedure: Returns a list whose elements are the same as the vectors",
               SS_sargs,
               SS_vctlst, SS_PR_PROC);

    SS_install("vector-ref",
               "Procedure: Returns the nth element of the given vector",
               SS_nargs,
               SS_vctref, SS_PR_PROC);

    SS_install("vector-set!",
               "Procedure: Sets the nth element of the given vector",
               SS_nargs,
               SS_vctset, SS_PR_PROC);

    SS_install("write-char",
               "Procedure: Write a single character to the specified port",
               SS_nargs,
               SS_wr_chr, SS_PR_PROC);

    SS_install_cf("interactive",
                  "Variable: Controls display of ouput data in functions\n     Usage: interactive <on|off>",
                  SS_acc_int,
                  &SS_interactive);

    SS_install_cf("lines-page",
                  "Variable: Controls the number of lines per page for selected printing commands\n     Usage: lines-page <integer>",
                  SS_acc_int,
                  &SS_lines_page);

    SS_scheme_symtab = SS_mk_hash_table(SS_symtab);
    SC_install("system-hash-table", SS_scheme_symtab, SS_POBJECT_S, SS_symtab);
    SS_UNCOLLECT(SS_scheme_symtab);

    return;}

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

/*                         PREDICATE PROCEDURES                             */

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

/* SS_CHARP - function version of SS_charobjp macro */

object *SS_charp(obj)
   object *obj;
   {return(SS_charobjp(obj) ? SS_t : SS_f);}

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

/* SS_VECTP - function version of SS_vectorp macro */

object *SS_vectp(obj)
   object *obj;
   {return(SS_vectorp(obj) ? SS_t : SS_f);}

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

/*                             VECTOR ROUTINES                              */

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

/* SS_MKVECT - make-vector for Scheme */

object *SS_mkvect(arg)
   object *arg;
   {int i;

    if (!SS_integerp(arg))
       SS_error("ARGUMENT NOT INTEGER - MAKE-VECTOR", arg);

    i = (int) SS_INTEGER_VALUE(arg);
    return(SS_mk_vector(i));}

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

/* SS_VECTOR - vector for Scheme */

object *SS_vector(argl)
   object *argl;
   {return(SS_lstvct(argl));}

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

/* SS_VCTLEN - vector-length for Scheme */

object *SS_vctlen(arg)
   object *arg;
   {int i;

    if (!SS_vectorp(arg))
       SS_error("ARGUMENT NOT VECTOR - VECTOR-LENGTH", arg);

    i = SS_VECTOR_LENGTH(arg);
    return(SS_mk_integer((long) i));}

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

/* SS_VCTREF - vector-ref for Scheme */

object *SS_vctref(argl)
   object *argl;
   {int i, k;
    object *arg, *num, **va;

    if (!SS_vectorp(arg = SS_car(argl)))
       SS_error("FIRST ARGUMENT NOT VECTOR - VECTOR-REF", arg);
    if (!SS_integerp(num = SS_cadr(argl)))
       SS_error("ARGUMENT NOT INTEGER - VECTOR-REF", arg);

    i  = SS_VECTOR_LENGTH(arg);
    va = SS_VECTOR_ARRAY(arg);
    k  = (int) SS_INTEGER_VALUE(num) - 1;
    if (k >= i)
       SS_error("BAD INDEX - VECTOR-REF", num);

    return(va[k]);}

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

/* SS_VCTSET - vector-set! for Scheme */

object *SS_vctset(argl)
   object *argl;
   {int i, k;
    object *arg, *num, **va, *obj;

    if (!SS_vectorp(arg = SS_car(argl)))
       SS_error("FIRST ARGUMENT NOT VECTOR - VECTOR-SET", arg);
    if (!SS_integerp(num = SS_cadr(argl)))
       SS_error("ARGUMENT NOT INTEGER - VECTOR-SET", arg);
    obj = SS_caddr(argl);

    i  = SS_VECTOR_LENGTH(arg);
    va = SS_VECTOR_ARRAY(arg);
    k  = (int) SS_INTEGER_VALUE(num);
    if (k >= i)
       SS_error("BAD INDEX - VECTOR-SET", num);

    SS_Assign(va[k], obj);

    return(va[k]);}

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

/* SS_VCTLST - vector->list for Scheme */

object *SS_vctlst(arg)
   object *arg;
   {int i, k;
    object **va, *ret;

    if (!SS_vectorp(arg))
       SS_error("ARGUMENT NOT VECTOR - VECTOR->LIST", arg);

    k   = SS_VECTOR_LENGTH(arg);
    va  = SS_VECTOR_ARRAY(arg);
    ret = SS_null;
    for (i = 0; i < k; i++)
        ret = SS_mk_cons(va[i], ret);

    return(SS_reverse(ret));}

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

/* SS_LSTVCT - list->vector for Scheme */

object *SS_lstvct(arg)
   object *arg;
   {int i, k;
    object **va, *vct;

    if (!SS_consp(arg))
       SS_error("ARGUMENT NOT LIST - LIST->VECTOR", arg);

    k   = _SS_length(arg);
    vct = SS_mk_vector(k);
    va  = SS_VECTOR_ARRAY(vct);

    for (i = 0; i < k; i++)
        {SS_Assign(va[i], SS_car(arg));
         arg = SS_cdr(arg);};

    return(vct);}

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

/*                              HASH ROUTINES                               */

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

/* SS_HASH_INSTALL - install at Scheme level
 *                 - (hash-install <name> <object> <table>)
 */

object *SS_hash_install(argl)
   object *argl;
   {object *obj;
    char *name;
    hashel *hp;
    HASHTAB *tab;

    name = NULL;
    obj  = SS_null;
    tab  = SS_symtab;
    SS_args(argl,
	    SC_STRING_I, &name,
	    SS_OBJECT_I, &obj,
	    HASH_TABLE, &tab,
	    0);

    hp = SC_install(name, obj, SS_POBJECT_S, tab);

/* the hash table has one reference and the object will have another
 * without this the hashel can be freed when obj is GC'd - NOT GOOD!
 */
    SC_mark(hp, 1);

    obj = SS_mk_hash_element(hp);

    return(obj);}

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

/* SS_HASH_LOOKUP - lookup at the Scheme level */

object *SS_hash_lookup(argl)
   object *argl;
   {char *name;
    HASHTAB *tab;
    byte *vr;

    name = NULL;
    tab  = SS_symtab;
    SS_args(argl,
	    SC_STRING_I, &name,
	    HASH_TABLE, &tab,
	    0);

    vr = SC_def_lookup(name, tab);
    if (vr == NULL)
       return(SS_f);

    return(SS_mk_cons(SS_car(argl), vr));}

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

/* SS_HASH_REMOVE - remove at the Scheme level */

object *SS_hash_remove(argl)
   object *argl;
   {object *obj;
    char *name;
    HASHTAB *tab;

    name = NULL;
    tab  = SS_symtab;
    SS_args(argl,
	    SC_STRING_I, &name,
	    HASH_TABLE, &tab,
	    0);

/* lookup up the object and do a SS_GC on it */
    if (tab == SS_symtab)
       {obj = (object *) SC_def_lookup(name, tab);
	if (obj != NULL)
	   SS_GC(obj);};

/* now remove it */
    obj = (SC_hash_rem(name, tab)) ? SS_t : SS_f;

    return(obj);}

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

/* SS_HASH_DUMP - hash-dump at the Scheme level */

object *SS_hash_dump(argl)
   object *argl;
   {object *obj, *sort;
    HASHTAB *tab;
    int i, nnames;
    char **names, *name, *patt;

    tab  = SS_symtab;
    patt = NULL;
    sort = SS_t;
    SS_args(argl,
            HASH_TABLE, &tab,
	    SC_STRING_I, &patt,
	    SS_OBJECT_I, &sort,
            0);

    if ((patt != NULL) && (strcmp(patt, "nil") == 0))
       patt = NULL;

/* get the names */
    names  = SC_dump_hash(tab, patt, SS_true(sort));
    nnames = SC_arrlen(names)/sizeof(char *) - 1;

/* listify the names and release them */
    obj = SS_null;
    for (i = nnames-1; i >= 0; i--)
        if ((name = names[i]) != NULL)
           {SS_Assign(obj, SS_mk_cons(SS_mk_string(name), obj));};

/* release the pointers */
    SFREE(names);

    return(obj);}

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

/* SS_HASH_INFO - hash-info at the Scheme level */

object *SS_hash_info(arg)
   object *arg;
   {object *obj, *flg;
    HASHTAB *tab;

    tab = SS_symtab;
    SS_args(arg,
	    HASH_TABLE, &tab,
	    0);

    flg = (tab->docp) ? SS_t : SS_f;

    obj = SS_mk_cons(SS_mk_integer(tab->size), 
                     SS_mk_cons(SS_mk_integer(tab->nelements),
                                SS_mk_cons(flg, SS_null)));

    return(obj);}

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

/* SS_MAKE_HASH_TABLE - make-hash-table for Scheme */

object *SS_make_hash_table(arg)
   object *arg;
   {int sz;
    HASHTAB *tab;
    object *op;

    switch (SC_arrtype(arg, -1))
       {case SC_INTEGER_I : sz = (int) SS_INTEGER_VALUE(arg);
                            break;
        case SC_FLOAT_I   : sz = (int) SS_FLOAT_VALUE(arg);
                            break;
        default           : SS_error("BAD ARGUMENT - MAKE-HASH-TABLE", arg);};

    tab = SC_make_hash_table(sz, NODOC);
    op  = SS_mk_hash_table(tab);

    return(op);}

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

/* _SS_WR_HASH_TABLE - print a hash_table object */

static void _SS_wr_hash_table(obj, strm)
   object *obj, *strm;
   {HASHTAB *tab;

    tab = SS_GET(HASHTAB, obj);
    PRINT(SS_OUTSTREAM(strm), "<HASH_TABLE|0x%lx|%d>", tab, tab->size);

    return;}

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

/* _SS_RL_HASH_TABLE - clean up a HASH_TABLE */

static void _SS_rl_hash_table(obj)
   object *obj;
   {int i, sz;
    hashel **tb, *np, *nxt;
    HASHTAB *tab;

    tab = SS_GET(HASHTAB, obj);

    sz = tab->size;
    tb = tab->table;
    for (i = 0; i < sz; i++)
        {for (np = tb[i]; np != NULL; np = nxt)
             {nxt = np->next;
              SS_GC((object *) np->def);
              SFREE(np->name);
              SFREE(np);};
         tb[i] = NULL;};

    SFREE(tab->table);
    SFREE(tab);

    SS_rl_object(obj);

    return;}

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

/* SS_MK_HASH_TABLE - make HASH_TABLE object */

object *SS_mk_hash_table(tb)
   HASHTAB *tb;
   {object *op;

    op = SS_mk_object(tb, HASH_TABLE, SELF_EV, NULL);
    op->print   = _SS_wr_hash_table;
    op->release = _SS_rl_hash_table;

    return(op);}

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

/* _SS_WR_HASHEL - print a hashel object */

static void _SS_wr_hashel(obj, strm)
   object *obj, *strm;
   {PRINT(SS_OUTSTREAM(strm),
          "<HASH_ELEMENT|%s>", SS_GET(hashel, obj)->name);

    return;}

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

/* _SS_RL_HASHEL - clean up a HASHEL */

static void _SS_rl_hashel(obj)
   object *obj;
   {hashel *hp;

    hp = SS_GET(hashel, obj);
    SFREE(hp);

    SS_rl_object(obj);

    return;}

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

/* SS_MK_HASH_ELEMENT - make HASH_ELEMENT object */

object *SS_mk_hash_element(hp)
   hashel *hp;
   {object *op;

    SC_mark(hp, 1);

    op = SS_mk_object(hp, HASH_ELEMENT, SELF_EV, hp->name);
    op->print   = _SS_wr_hashel;
    op->release = _SS_rl_hashel;

    return(op);}

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

/* SS_HASHTABP - return #t if the given arg is a HASH_TABLE */

object *SS_hashtabp(arg)
   object *arg;
   {return((SS_hash_tablep(arg)) ? SS_t : SS_f);}

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

/* SS_HASHELP - return #t if the given arg is a HASH_ELEMENT */

object *SS_hashelp(arg)
   object *arg;
   {return((SS_hash_elementp(arg)) ? SS_t : SS_f);}

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

/* SS_DEFINE_GLOBAL - define a variable in the global environment frame */

object *SS_define_global(argl)
   object *argl;
   {object *obj, *val, *t;
    char *s;

    obj  = SS_cdr(argl);
    argl = SS_car(argl);

    if (SS_consp(argl))
       {obj  = SS_mk_cons(SS_cdr(argl), obj);
        argl = SS_car(argl);
        val  = SS_mk_procedure(obj, SS_Global_Env);

        s = SS_PROCEDURE_NAME(val);
        SFREE(s);
        s = SS_VARIABLE_NAME(argl);
        SS_PROCEDURE_NAME(val) = SC_strsavef(s,
                                 "char*:SS_DEFINE_GLOBAL:name");}

    else if (SS_variablep(argl))
       {obj = SS_car(obj);
        val = SS_exp_eval(obj);

/* this preserves things for compound procedures (e.g. autoload) */
        if (SS_procedurep(val))
           {int ptype;

            ptype = SS_PROCEDURE_TYPE(val);
            if ((ptype == SS_PROC) || (ptype == SS_MACRO))
	       {t = SS_proc_env(val);
		SS_MARK(t);
		t = SS_proc_body(val);
		SS_MARK(t);
		t = SS_params(val);};};}

    else
       SS_error("CAN'T DEFINE NON-VARIABLE OBJECT - SS_DEFINE_GLOBAL", argl);

    if (strcmp(SS_PROCEDURE_NAME(SS_Fun), "define-global-macro") == 0)
       SS_PROCEDURE_TYPE(val) = SS_MACRO;

    SS_def_var(argl, val, SS_Global_Env);

    return(argl);}

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

/*                                 RANDOMS                                  */

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

/* SS_PRINT_ENV - print the specified environment frame */

static object *SS_print_env(obj)
   object *obj;
   {int i, n;
    object *penv;
    char bf[MAXLINE];

    n = 0;
    SS_args(obj,
            SC_INTEGER_I, &n,
            0);

    penv = SS_Env;
    for (i = 0; (i < n) && !SS_nullobjp(penv); i++, penv = SS_cdr(penv));

    sprintf(bf, "Environment frame #%d:\n", n+1);
    _SS_print(penv, bf, "\n\n", SS_outdev);

    return(SS_f);}

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

/* SS_WALL_CLOCK_TIME - return the accumulated wall clock time in seconds */

static object *SS_wall_clock_time()
   {return(SS_mk_float(SC_wall_clock_time()));}

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

/* SS_MEM_USG - return the memory usage info */

static object *SS_mem_usg()
   {long a, f, d;

    SC_mem_stats(&a, &f, &d, NULL);

    return(SS_make_list(SC_INTEGER_I, &a,
			SC_INTEGER_I, &f,
			SC_INTEGER_I, &d,
			0));}

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

/* SS_MEM_MAP - wrapper around SC_mem_map */

static object *SS_mem_map(arg)
   object *arg;
   {FILE *fp;

    if (SS_nullobjp(arg))
       arg = SS_outdev;

    else if (!SS_outportp(arg))
       SS_error("BAD PORT - SC_MEM_MAP", arg);

    fp = SS_OUTSTREAM(arg);
    SC_mem_map(fp, FALSE);

    return(SS_f);}

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

/* SS_MEM_TRACE - wrapper around SC_mem_trace */

static object *SS_mem_trace()
   {long nb;

    nb = SC_mem_trace();

    return(SS_mk_integer(nb));}

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

/* SS_STRNUM - return the number represented in the given string */

static object *SS_strnum(argl)
   object *argl;
   {char *text, *pt;

    text  = NULL;
    SS_args(argl,
            SC_STRING_I, &text,
            0);

    if (SC_intstrp(text, Radix))
       return(SS_mk_integer(STRTOL(text, &pt, Radix)));

    if (SC_fltstrp(text))
       return(SS_mk_float(ATOF(text)));

    return(SS_f);}

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

/* SS_STRCHR - do what the C standard library function strchr does */

static object *SS_strchr(argl)
   object *argl;
   {char *text, *delim, *ps;

    text  = NULL;
    delim = NULL;
    SS_args(argl,
            SC_STRING_I, &text,
            SC_STRING_I, &delim,
            0);

    ps = strchr(text, (int) delim[0]);

    return((ps == NULL) ? SS_null : SS_mk_string(ps));}

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

/* SS_STRTOK - tokenize the string via SC_firsttok
 *           - if the optional third arg is #t then use a copy of the
 *           - string (this is useful for quick one shot token grabbing)
 */

static object *SS_strtok(argl)
   object *argl;
   {int c;
    object *obj, *flag;
    char *text, *delim, t[MAXLINE], d[MAXLINE], *ps, *pt;

    text  = NULL;
    delim = NULL;
    flag  = SS_f;
    SS_args(argl,
            SC_STRING_I, &text,
            SC_STRING_I, &delim,
            SS_OBJECT_I, &flag,
            0);

    if (SS_true(flag))
       {strcpy(t, text);
        text = t;}

/* this may look weird but it is correct!!!! */
    else
       {obj  = SS_car(argl);
        if (!SS_stringp(obj))
           SS_error("BAD STRING - SS_STRTOK", obj);

        text = SS_STRING_TEXT(obj);};

    for (ps = delim, pt = d; (c = *ps) != '\0'; ps++)
        {if (c == '\\')
            {c = *(++ps);
	     switch (c)
	        {case 'n' :
		      *pt++ = '\n';
		      break;
                 case 't' :
		      *pt++ = '\t';
		      break;
                 case 'r' :
		      *pt++ = '\r';
		      break;
                 case 'f' :
		      *pt++ = '\f';
		      break;
		 default :
		      *pt++ = c;
		      break;};}
	 else
	    *pt++ = c;};

    *pt = '\0';

    ps = SC_firsttok(text, d);

    return((ps == NULL) ? SS_null : SS_mk_string(ps));}

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