/* xlsys.c - xlisp builtin system functions */
/*		Copyright (c) 1985, by David Michael Betz
		All Rights Reserved
		Permission is granted for unrestricted non-commercial use		*/

#include "xlisp.h"
#include <string.h>

/* external variables */
extern FILE *tfp;

/* external symbols */
extern LVAL a_subr,a_fsubr,a_cons,a_symbol;
extern LVAL a_fixnum,a_flonum,a_string,a_object,a_stream;
extern LVAL a_vector,a_closure,a_char,a_ustream;
extern LVAL k_verbose,k_print;
extern LVAL true;


/* xload - read and evaluate expressions from a file */
LVAL xload()
{
	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()
{
	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()) == 0)
		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 (a_vector);
	case CLOSURE:		return (a_closure);
	case CHAR:			return (a_char);
	case USTREAM:		return (a_ustream);
#ifdef STRUCTS
	case STRUCT:		return (getelement(arg,0));
#endif
	default:			xlfail("bad node type");
						return (NIL); /* eliminate warning message */
	}
}

#ifdef COMMONLISP
int xlcvttype(arg)	/* find type of argument and return it */
LVAL arg;
{
	if (arg == a_subr)		return SUBR;
	if (arg == a_fsubr)		return FSUBR;
	if (arg == a_cons)		return CONS;
	if (arg == a_symbol)	return SYMBOL;
	if (arg == a_fixnum)	return FIXNUM;
	if (arg == a_flonum)	return FLONUM;
	if (arg == a_string)	return STRING;
	if (arg == a_object)	return OBJECT;
	if (arg == a_stream)	return STREAM;
	if (arg == a_vector)	return VECTOR;
	if (arg == a_closure)	return CLOSURE;
	if (arg == a_char)		return CHAR;
	if (arg == a_ustream)	return USTREAM;
	return 0;
}

#ifdef ANSI
static LVAL listify(LVAL arg)	/* arg must be vector or string */
#else
LOCAL LVAL listify(arg)	/* arg must be vector or string */
LVAL arg;
#endif
{
	LVAL val;
	int i;
	
	xlsave1(val);
	
	if (ntype(arg) == VECTOR) {
		for (i = getsize(arg); i-- > 0; ) 
			val = cons(getelement(arg,i),val);
	}
	else {	/* a string */
		for (i = getslength(arg)-1; i-- > 0; )
			val = cons(cvchar(getstringch(arg,i)),val);
	}
	
	xlpop();
	return (val);
}

#ifdef ANSI
static LVAL vectify(LVAL arg)	/* arg must be string or cons */
#else
LOCAL LVAL vectify(arg)	/* arg must be string or cons */
LVAL arg;
#endif
{
	LVAL val,temp;
	int i,l;
	
	if (ntype(arg) == STRING) {
		l = getslength(arg)-1;
		val = newvector(l);
		for (i=0; i < l; i++) setelement(val,i,cvchar(getstringch(arg,i)));
	}
	else {	/* a cons */
		val = arg;
		for (l = 0; consp(val); l++) val = cdr(val); /* get length */
		val = newvector(l);
		temp = arg;
		for (i = 0; i < l; i++) {
			setelement(val,i,car(temp));
			temp = cdr(temp);
		}
	}
		return val;
}

#ifdef ANSI
static LVAL stringify(LVAL arg)
#else
LOCAL LVAL stringify(arg)	/* arg must be vector or cons */
LVAL arg;
#endif
{
	LVAL val,temp;
	int i,l;
	
	if (ntype(arg) == VECTOR) {
		l = getsize(arg);
		val = newstring(l+1);
		for (i=0; i < l; i++) {
			temp = getelement(arg,i);
			if (ntype(temp) != CHAR) goto failed;
			val->n_string[i] = getchcode(temp);
		}
		val->n_string[l] = 0;
		return val;
	}
	else {	/* must be cons */
		val = arg;
		for (l = 0; consp(val); l++) {
			if (ntype(car(val)) != CHAR) goto failed;
			val = cdr(val); /* get length */
		}

		val = newstring(l+1);
		temp = arg;
		for (i = 0; i < l; i++) {
			val->n_string[i] = getchcode(car(temp));
			temp = cdr(temp);
		}
		val->n_string[l] = 0;
		return val;
	}
failed:
	xlerror("cannot make into string", arg);
	return (NIL);	/* avoid compiler warnings */
}



/* coerce function */
LVAL xcoerce()
{
	LVAL type, arg, temp;
	int newtype,oldtype;

	arg = xlgetarg();
	type = xlgetarg();
	xllastarg();
	
	if ((newtype = xlcvttype(type)) == 0) goto badconvert;

	oldtype = ntype(arg);
	if (oldtype == newtype) return (arg);	/* easy case! */
	
	switch (newtype) {
		case CONS: if ((oldtype == STRING)|(oldtype == VECTOR))
			return (listify(arg));
			break;
		case STRING: if ((oldtype == CONS)|(oldtype == VECTOR))
			return (stringify(arg));
			break;
		case VECTOR: if ((oldtype == STRING) | (oldtype == CONS))
			return (vectify(arg));
			break;
		case CHAR:
			if (oldtype == FIXNUM) return cvchar((int)getfixnum(arg));
			else if ((oldtype == STRING) && (getslength(arg) == 2))
				return cvchar(getstringch(arg,0));
			else if (oldtype == SYMBOL) {
				temp = getpname(arg);
				if (getslength(temp) == 2) return cvchar(getstringch(temp,0));
			}
			break;
		case FLONUM:
			if (oldtype == FIXNUM) return (cvflonum(1.0*(int)getfixnum(arg)));
			break;
	}


badconvert:
	xlerror("illegal coersion",arg);
	return (NIL);	/* avoid compiler warnings */
}


#endif


#ifdef ADDEDTAA
/* xgeneric - get generic representation of thing */
/* TAA addition */
LVAL xgeneric()
{
	LVAL arg,acopy;
	
	arg = xlgetarg();
	xllastarg();
	if (arg == NIL)  return (NIL);
	
	switch (ntype(arg)) {
	case CONS: case USTREAM:
		return (cons(car(arg),cdr(arg)));
	case SYMBOL: case OBJECT: case VECTOR: case CLOSURE:
#ifdef STRUCTS
	case STRUCT:
#endif
		acopy = newvector(getsize(arg));
		memcpy(acopy->n_vdata, arg->n_vdata, getsize(arg)*sizeof(LVAL));
		return (acopy);
	case STRING: /* make a copy of the string */
		acopy = newstring(getslength(arg));
		memcpy(getstring(acopy), getstring(arg), getslength(arg));
		return (acopy);
	case FIXNUM: case FLONUM: case CHAR:
		return (arg); /* it hardly matters to copy these */
	default:	xlbadtype(arg);
		return (NIL);	/* avoid compiler warnings */
	}
}


/* xtime - report execution time */
/* TAA addition */
#include <time.h>

#ifdef NDP386
LVAL xtime()
{
	LVAL expr;
	
	double t1, t2;
	
	expr = xlgetarg();
	xllastarg();
	t1 = sec_100_();
	xleval(expr);
	t2 = sec_100_();
	return(cvflonum((t2-t1)*100.0));
}
#else
LVAL xtime()
{
	LVAL expr;
	
	clock_t t1, t2;
	
	expr = xlgetarg();
	xllastarg();
	t1 = clock();
	xleval(expr);
	t2 = clock();
	return(cvflonum(((t2-t1)*1.0)/CLK_TCK));
}
#endif
#endif

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

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

/* xexit - get out of xlisp */
LVAL xexit()
{
	xllastarg();
	wrapup();
	return (NIL); /* never returns */
}

/* 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));
}