/* xlsys.c - xlisp builtin system functions */
/* Copyright (c) 1989, by David Michael Betz.                            */
/* You may give out copies of this software; for conditions see the file */
/* COPYING included with this distribution.                              */

#include "xlisp.h"
#include "osdef.h"
#ifdef ANSI
#include "xlproto.h"
#include "osproto.h"
#else
#include "xlfun.h"
#include "osfun.h"
#endif ANSI
#include "xlvar.h"
#include "xlsvar.h"

/* xload - read and evaluate expressions from a file */
LVAL xload()
{
    unsigned char *name;
    int vflag,pflag;
    LVAL arg;

    /* get the file name */
    name = getstring(xlgetfname());

    /* get the :verbose flag */
    if (xlgetkeyarg(k_verbose,&arg))
	vflag = (arg != NIL);
    else
	vflag = TRUE;

    /* get the :print flag */
    if (xlgetkeyarg(k_print,&arg))
	pflag = (arg != NIL);
    else
	pflag = FALSE;

    /* load the file */
    return (xlload(name,vflag,pflag) ? true : NIL);
}

/* xtranscript - open or close a transcript file */
LVAL xtranscript()
{
    unsigned char *name;

    /* get the transcript file name */
    name = (moreargs() ? getstring(xlgetfname()) : NULL);
    xllastarg();

    /* close the current transcript */
    if (tfp) osclose(tfp);

    /* open the new transcript */
    tfp = (name ? osaopen(name,"w") : NULL);

    /* return T if a transcript is open, NIL otherwise */
    return (tfp ? true : NIL);
}

/* xtype - return type of a thing */
LVAL xtype()
{
    LVAL arg;

    if (!(arg = xlgetarg()))
	return (NIL);

    switch (ntype(arg)) {
    case SUBR:		return (a_subr);
    case FSUBR:		return (a_fsubr);
    case CONS:		return (a_cons);
    case SYMBOL:	return (a_symbol);
    case FIXNUM:	return (a_fixnum);
    case FLONUM:	return (a_flonum);
    case STRING:	return (a_string);
    case OBJECT:	return (a_object);
    case STREAM:	return (a_stream);
    case VECTOR:	return (s_vector);
    case CLOSURE:	return (a_closure);
    case CHAR:		return (a_char);
    case USTREAM:	return (a_ustream);
    case COMPLEX:	return (a_complex);      /* L. Tierney */
    case DISPLACED_ARRAY:return (a_array);       /* L. Tierney */
    case STRUCT:	return (getelement(arg,0));
    default:		xlfail("bad node type");
    }
}

/* xbaktrace - print the trace back stack */
LVAL xbaktrace()
{
    LVAL num;
    int n;

    if (moreargs()) {
	num = xlgafixnum();
	n = getfixnum(num);
    }
    else
	n = -1;
    xllastarg();
    xlbaktrace(n);
    return (NIL);
}

/* xexit - get out of xlisp */
LVAL xexit()
{
    xllastarg();
    wrapup();
	return(NIL);  /* to keep compilers happy - L. Tierney */
}

/* xpeek - peek at a location in memory */
LVAL xpeek()
{
    LVAL num;
    int *adr;

    /* get the address */
    num = xlgafixnum(); adr = (int *)getfixnum(num);
    xllastarg();

    /* return the value at that address */
    return (cvfixnum((FIXTYPE)*adr));
}

/* xpoke - poke a value into memory */
LVAL xpoke()
{
    LVAL val;
    int *adr;

    /* get the address and the new value */
    val = xlgafixnum(); adr = (int *)getfixnum(val);
    val = xlgafixnum();
    xllastarg();

    /* store the new value */
    *adr = (int)getfixnum(val);

    /* return the new value */
    return (val);
}

/* xaddrs - get the address of an XLISP node */
LVAL xaddrs()
{
    LVAL val;

    /* get the node */
    val = xlgetarg();
    xllastarg();

    /* return the address of the node */
    return (cvfixnum((FIXTYPE)val));
}