/* XLISP/RSX suppport functions and enhancements
 *
 *	Old DECUS C implementation.
 *	New functions to get addicted to.
 * 	By Jan Brittenson UFH  11-Oct-86, 13-Oct-86, 31-Oct-86
 */

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

extern struct node *xlstack;
static struct node *t;
extern int prompt;

/* Global variables */
char xlprompt[32], xlpr2[32];
long xlerr[49], xlwork[256];
FILE *errfile;

/* Local variables */
static int spwbuf[8];


/* Test if space */
isspace(ch)
char ch;
{
	return(ch <= '\040');
}


/* Concatenate strings */
strcat(ach, bch)
char	*ach, *bch;
{
	/* Call DECUS C equivalent */
	concat(ach,ach,bch,0);
}


/* Find character in string */
strchr(str, ch)
char	*str, ch;
{
	int	i;

	/* Loop and see if there */
	for(i=0; str[i] != 0 && str[i] != ch; i++);

	if(str[i] == ch) return(1); else return(0);
}


/* Built-in function time (added 13-Oct-86) */
static struct node *xltime(args)
  struct node *args;
{
	int i, *ip;

	struct node *lptr, *oldstk, *wrk, *wrkl;
	struct	{
		int year, month, day, hour, minute, second, tick, tsec;
		} curtim;

	/* New stack frame */
	/* oldstk = xlsave(NULL); */

	/* Make sure no arguments */
	xllastarg(args);

	/* Get current time parameters */
	rtime(&curtim);

	/* Build new list in format: (YY MM DD HH SS) */
	wrkl = lptr = newnode(LIST);
	ip = (int*) &curtim;

	for(i=0; i<5; i++)
	{
		/* Bind INT node and store value */
		(wrkl->n_listvalue = newnode(INT))->n_int = *ip++;

		/* Bring up a new node if not last entry */
		if (i < 4)
			wrkl = (wrkl->n_listnext = newnode(LIST));
	}

	/* Restore old stack frame */
	xlstack = oldstk;

	/* Return the list */
	return(lptr);
}


/* Change prompt */
static struct node *xlprp(args)
  struct node *args;
{
	char *a;
	struct node *oldstk,arg,*argstr,*arg1;
	
	/* Save stack frame */
	oldstk = xlsave(&arg,NULL);

	/* Get first argument */
	arg.n_ptr = args;
	arg1 = xlevmatch(STR, &arg.n_ptr);

	if(strlen(arg1->n_str) > 31)
		xlfail(39);

	/* Get second argument */
	argstr = xlevmatch(STR, &arg.n_ptr);
	
	if(strlen(argstr->n_str) > 31)
		xlfail(39);

	/* Make sure no more arguments */
	xllastarg(arg.n_ptr);

	/* Copy into prompt buffer */
	strcpy(xlprompt, arg1->n_str);
	strcpy(xlpr2, argstr->n_str);

	/* Restore stack */
	xlstack = oldstk;

	/* Return () */
	return(0);
}


/* Built-in function spawn */
static struct node *xlspawn(args)
  struct node *args;
{
	int tskbuf[16];
	struct node *oldstk,arg,*argstr,*arg1;
	
	/* Save stack frame */
	oldstk = xlsave(&arg,NULL);

	/* Get first argument */
	arg.n_ptr = args;
	arg1 = xlevmatch(STR, &arg.n_ptr);

	/* Spawn command to MCR and await completion */
	ascr50(6, "MCR...", tskbuf);

	spwn(tskbuf,0,3,0,spwbuf,arg1->n_str, strlen(arg1->n_str));
	stse(3);

	/* Restore stack */
	xlstack = oldstk;

	/* Exit */
	return(0);
}


/* Built-in function aheadp */
static struct node *xlrp(args)
  struct node *args;
{
	/* No args */
	xllastarg(args);

	/* Return true if more read-ahead */
	if(prompt) return(NULL);
	else	   return(t);
}


/* Built-in function indent */
static struct node *xlindt(args)
  struct node *args;
{
	int i;
	struct node *oldstk,arg, *rept, *msgp;
	
	/* Save stack frame */
	oldstk = xlsave(&arg,NULL);

	/* Get repeat count */
	arg.n_ptr = args;
	rept = xlevmatch(INT, &arg.n_ptr);

	/* Get string to be repeated */
	msgp = xlevmatch(STR, &arg.n_ptr);

	/* Fail if more arguments */
	xllastarg(arg.n_ptr);

	/* Print string indicated number of times */
	for(i=0; i<rept->n_int; i++)
		printf("%s", msgp->n_str);

	/* Restore stack frame */
	xlstack = oldstk;

	/* Return t */
	return(t);
}


/* Built-in function memb */
static struct node *xlmemb(args)
  struct node *args;
{
	struct node *oldstk,arg,*argstr,*arg1,*arg2,*itmp;
	
	/* Save stack frame */
	oldstk = xlsave(&arg,NULL);

	/* Get arguments (member item list) */
	arg.n_ptr = args;
	arg1 = xlevarg(&arg.n_ptr);
	arg2 = xlevmatch(LIST, &arg.n_ptr);
	xllastarg(arg.n_ptr);
	
	/* Loop and match, return t if found, else () */
	for(itmp=arg2; itmp != NULL; itmp = itmp->n_listnext)
		if(itmp->n_listvalue == arg1)
			break;

	/* Restore stack and return value */
	xlstack = oldstk;

	if(itmp == NULL)	return(NULL);
	else			return(t);
}


/* Built-in function member */
static struct node *member(args)
  struct node *args;
{
	struct node *oldstk,arg,*argstr,*arg1,*arg2,*itmp;
	
	/* Save stack frame */
	oldstk = xlsave(&arg,NULL);

	/* Get arguments (member item list) */
	arg.n_ptr = args;
	arg1 = xlevarg(&arg.n_ptr);
	arg2 = xlevmatch(LIST, &arg.n_ptr);
	xllastarg(arg.n_ptr);
	
	/* Loop and match, return t if found, else () */
	for(itmp=arg2; itmp != NULL; itmp = itmp->n_listnext)
		if(xequal(itmp->n_listvalue,arg1))
			break;

	/* Restore stack and return value */
	xlstack = oldstk;

	if(itmp == NULL)	return(NULL);
	else			return(t);
}

/* Built-in function memcdr */
static struct node *memcdr(args)
  struct node *args;
{
	struct node *oldstk,arg,*argstr,*arg1,*arg2,*itmp,*itmp2;
	
	/* Save stack frame */
	oldstk = xlsave(&arg,NULL);

	/* Get arguments */
	arg.n_ptr = args;
	arg1 = xlevarg(&arg.n_ptr);
	arg2 = xlevmatch(LIST, &arg.n_ptr);
	xllastarg(arg.n_ptr);
	
	/* Loop and match, return caar if found, else () */
	for(itmp=arg2; itmp != NULL; itmp = itmp->n_listnext)
	    for(itmp2=itmp->n_listvalue->n_listnext; itmp2 != NULL;
						itmp2 = itmp2->n_listnext)
		if(xequal(itmp2->n_listvalue, arg1))
			goto outlop;

	outlop:

	/* Restore stack and return value */
	xlstack = oldstk;

	if(itmp == NULL)	return(NULL);
	else			return(itmp->n_listvalue->n_listvalue);
}


/* Built-in function nconc */
static struct node *nconc(args)
  struct node *args;
{
	struct node *oldstk,arg,*argstr,*arg1,*arg2,*itmp,*litp;
	
	/* Save stack frame */
	oldstk = xlsave(&arg,NULL);

	/* Get arguments */
	arg.n_ptr = args;
	arg1 = xlevarg(&arg.n_ptr);
	arg2 = xlevmatch(LIST, &arg.n_ptr);
	xllastarg(arg.n_ptr);
	
	/* Find last atom, set litp to it */
	for(itmp=arg2; itmp != NULL;)
	{
		litp = itmp;
		itmp = itmp->n_listnext;
	}

	/* Make sure it isn't the empty list () */
	if(itmp==arg2)
		xlfail(40);


	/* Replace cdr of cell with arg1 */
	litp->n_listnext = arg1;


	/* Restore stack and return second argument */
	xlstack = oldstk;

	return(arg2);
}


/* Built-in function bang */
static struct node *bang(args)
  struct node *args;
{
	struct node *oldstk,arg;
	int arg1;
	
	/* Save stack frame */
	oldstk = xlsave(&arg,NULL);

	/* Get argument */
	arg.n_ptr = args;
	arg1 = xlevmatch(INT, &arg.n_ptr) -> n_int;
	xllastarg(arg.n_ptr);

	/* Bang */
	xlfail(arg1);
}

/* built-in function fopenx */
static struct node *xopenx(args)
  struct node *args;
{
	struct node *oldstk, arg, *val;
	char *farg, dumbuf[12];
	FILE *fp;
	
	/* Save stack frame */
	oldstk = xlsave(&arg,NULL);

	/* Get arguments */
	arg.n_ptr = args;
	farg = xlevmatch(STR, &arg.n_ptr) -> n_str;
	xllastarg(arg.n_ptr);

	/* Open index file */
	if(openx(farg, &fp, xlwork, dumbuf) ==  NULL)
		val = NULL;
	else
	{
		/* Bind the file pointer */
		val = newnode(FPTR);
		val->n_fp = fp;
	}

	/* Restore previous stack frame */
	xlstack = oldstk;

	/* Return file pointer */
	return(val);
}

/* built-in function getx */
static struct node *xgetx(args)
  struct node *args;
{
	struct node *oldstk,arg,*val;
	FILE *arg1;
	char *tbuf;
	int  index;

	/* Save stack frame */
	oldstk = xlsave(&arg,NULL);

	/* Get arguments */
	arg.n_ptr = args;
	arg1 = xlevmatch(FPTR, &arg.n_ptr)->n_fp;
	index = xlevmatch(INT, &arg.n_ptr)->n_int;
	xllastarg(arg.n_ptr);

	tbuf = stralloc((int) xlwork[1]);

	/* Read index */
	if(getx(arg1, xlwork, index, tbuf) == NULL)
		val = NULL;
	else
	{	/* Build atom to return */
		val = newnode(STR);
		val->n_str = tbuf;
	}

	/* Restore previous stack frame */
	xlstack = oldstk;

	/* Return data just read (or nil) */
	return(val);
}


/* Built-in function getxx */
static struct node *xgetxx(args)
  struct node *args;
{
	struct node *oldstk,arg,*val;
	FILE *arg1;
	char *tbuf;
	int  index;

	/* Save stack frame */
	oldstk = xlsave(&arg,NULL);

	/* Get arguments */
	arg.n_ptr = args;
	arg1 = xlevmatch(FPTR, &arg.n_ptr)->n_fp;
	index = xlevmatch(INT, &arg.n_ptr)->n_int;
	xllastarg(arg.n_ptr);

	tbuf = stralloc((int) xlwork[1]);

	/* Read next by index */
	if(getxx(arg1, xlwork, tbuf, index) == NULL)
		val = NULL;
	else
	{	/* Bind value */
		val = newnode(STR);
		val->n_str = tbuf;
	}

	/* Restore previous frame */
	xlstack = oldstk;
	
	/* Return data just read or nil if none */
	return(val);
}

static struct node *xprx(args)
  struct node *args;
{
	struct node *oldstk, arg, *val;
	FILE *arg1;
	char *tbuf;
	int  index;


	/* Save stack frame */
	oldstk = xlsave(&arg,NULL);

	/* Get arguments */
	arg.n_ptr = args;
	arg1 = xlevmatch(FPTR, &arg.n_ptr)->n_fp;
	index = xlevmatch(INT, &arg.n_ptr)->n_int;
	xllastarg(arg.n_ptr);

	/* Print by index */	
	if(prx(arg1, xlwork, index) == NULL)
		val = NULL;
	else	val = t;

	/* Clean up stack */
	xlstack = oldstk;
	
	/* Return status */
	return(val);
}

/* built-in function memx */
static struct node *memx(args)
  struct node *args;
{
	struct node arg, *lp, *oldstk, *symval, *match, *val,
			*nlp;

	/* Save old stack frame */
	oldstk = xlsave(&arg, NULL);
	
	/* Get arguments */
	arg.n_ptr = args;
	match = xlevarg(&arg.n_ptr);
	lp = xlevmatch(LIST, &arg.n_ptr);
	xllastarg(arg.n_ptr);

	val = NULL;

	/* Loop thru list and check each symbol entry */
	for(; lp != NULL; lp = lp->n_listnext)
	{
		/* Make sure entry is symbol */
		if(lp->n_listvalue->n_type != SYM)
			xlfail(44);

		/* Retrieve value and make sure it is a list */
		symval = lp->n_listvalue->n_symvalue;

		if(symval->n_type != LIST)
			xlfail(45);

		/* Loop through list searching for element */
		for(nlp=symval; nlp != NULL; nlp = nlp->n_listnext)
			if(xequal(nlp->n_listvalue, match))
			{
				/* True, return symbol */
				val = lp->n_listvalue;
	
				/* Restore stack frame */
				xlstack = oldstk;
	
				return(val);
			}
	}
				

	/* Not found, restore stack and return () */
	xlstack = oldstk;
	return(NULL);
}


/* Built-in function remove */
static struct node *remove(args)
  struct node *args;
{
	struct node arg, *oldstk, *match, *lp, *val, *prev;

	/* Create new stack frame */
	oldstk = xlsave(&arg, NULL);
	
	/* Get arguments */
	arg.n_ptr = args;
	match = xlevarg(&arg.n_ptr);
	lp = xlevmatch(LIST, &arg.n_ptr);
	xllastarg(arg.n_ptr);

	val = lp;
	prev = lp;

	/* Loop thru and match, unlink if found */
	for(; lp != NULL; lp = (prev = lp)->n_listnext)
		if(xequal(lp->n_listvalue, match))
		{
			/* Link off, a dirty hack */
			prev->n_listnext = lp->n_listnext;
	
			/* Restore old stack frame */
			xlstack = oldstk;

			/* Return next if first element in list */
			if(prev == lp)
				return(lp->n_listnext);

			/* Otherwise return old list */
			else	return(val);
		}

	/* Return old list */
	xlstack = oldstk;
	return(val);
}


/* built-n function caar */
static struct node *caar(args)
  struct node *args;
{
	struct node arg, *oldstk, *list, *val;

	/* Get argument */
	oldstk = xlsave(&arg, NULL);
	arg.n_ptr = args;
	list = xlevarg(&arg.n_ptr);
	xllastarg(arg.n_ptr);

	/* set val to caar */
	if(list->n_type == LIST)
		if((list = list->n_listvalue)->n_type == LIST)
			val = list->n_listvalue;
		else
			val = list;
	else
		val = list;

	/* Restore stack and exit */
	xlstack = oldstk;
	return(val);
}

/* built-in function cadr */
static struct node *cadr(args)
  struct node *args;
{
	struct node arg, *oldstk, *list, *val;

	/* Get argument */
	oldstk = xlsave(&arg, NULL);
	arg.n_ptr = args;
	list = xlevarg(&arg.n_ptr);
	xllastarg(arg.n_ptr);

	/* set val to cadr */
	if(list->n_type == LIST				&&
	  (list = list->n_listnext)->n_type == LIST	&&
	   (list = list->n_listvalue)->n_type == LIST)
		val = list->n_listvalue;
	else
		val = NULL;

	/* Restore stack and exit */
	xlstack = oldstk;
	return(val);
}


/* built-n function cdar */
static struct node *cdar(args)
  struct node *args;
{
	struct node arg, *oldstk, *list, *val;

	/* Get argument */
	oldstk = xlsave(&arg, NULL);
	arg.n_ptr = args;
	list = xlevarg(&arg.n_ptr);
	xllastarg(arg.n_ptr);

	/* set val to cdar */
	if(list->n_type == LIST)
		if((list = list->n_listvalue)->n_type == LIST)
			val = list->n_listnext;
		else
			val = NULL;
	else
		val = NULL;

	/* Restore stack and exit */
	xlstack = oldstk;
	return(val);
}


/* built-in function cddr */
static struct node *cddr(args)
  struct node *args;
{
	struct node arg, *oldstk, *list, *val;

	/* Get argument */
	oldstk = xlsave(&arg, NULL);
	arg.n_ptr = args;
	list = xlevarg(&arg.n_ptr);
	xllastarg(arg.n_ptr);

	/* set val to cddr */
	if(list->n_type == LIST				&&
	  (list = list->n_listnext)->n_type == LIST)
		val = list->n_listnext;
	else
		val = NULL;

	/* Restore stack and exit */
	xlstack = oldstk;
	return(val);
}


/* Internal structure copy */
static struct node *cplst(src)
  struct node *src;
{
	struct node *sp, *new, *ssp, *newdst, *first, *old;

	first = NULL;

	for(sp = src; sp != NULL; sp = sp->n_listnext)
	{
		/* Create new node and link it up */
		old = new;
		new = newnode(LIST);

		if(first == NULL)
			first = new;
		else	old->n_listnext = new;

		/* Copy list element */
		new->n_listvalue =
			((ssp=sp->n_listvalue)->n_type == LIST ?
				cplst(ssp) : ssp);
	}

	/* Return start of new list */
	return(first);
}


/* Copy entire list structure */
static struct node *copy(args)
  struct node *args;
{
	struct node *oldstk, arg, *sp, *dp, *val;

	/* Save stack frame */
	oldstk = xlsave(&arg, NULL);
	
	/* Get argument */
	arg.n_ptr = args;
	sp = xlevarg(&arg.n_ptr);
	xllastarg(arg.n_ptr);

	/* Return it if not list */
	if(sp->n_type != LIST)
		return(sp);

	/* Copy structure */
	dp = cplst(sp);

	/* Return new structure */
	xlstack = oldstk;
	return(dp);
}


/* Initialize this module */
xlhinit()
{
	char dumbuf[12];

	/* Open error message index */
	if(openx("[1,1]XLERR", &errfile, xlerr, dumbuf) == NULL)
	{
		printf("Index file open error\n");
		exit();
	}

	/* Set default prompt */
	strcpy(xlprompt, ">");
	strcpy(xlpr2, "%d>");

	t = xlenter("t");
	
	/* Add built-in functions */
	xlsubr("time", xltime);
	xlsubr("prompt", xlprp);
	xlsubr("aheadp", xlrp);
	xlsubr("mcr", xlspawn);		/* RSX */
	xlsubr("rept", xlindt);
	xlsubr("memb", xlmemb);
	xlsubr("member", member);
	xlsubr("memof", memx);
	xlsubr("memcdr", memcdr);
	xlsubr("nconc", nconc);
	xlsubr("remove", remove);
	xlsubr("caar", caar);
	xlsubr("cadr", cadr);
	xlsubr("cdar", cdar);
	xlsubr("cddr", cddr);
	xlsubr("copy", copy);
	xlsubr("bang", bang);
	xlsubr("openx", xopenx);
	xlsubr("getx", xgetx);
	xlsubr("getxx", xgetxx);
	xlsubr("prinx", xprx);
}