/* xlstruct.c - the defstruct facility */
/*		Copyright (c) 1988, by David Michael Betz
		All Rights Reserved
		Permission is granted for unrestricted non-commercial use		*/

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

/* external variables */
extern LVAL xlenv,xlfenv;
extern LVAL s_lambda,s_quote,lk_key,true;
extern char buf[];

/* forward declarations */
#ifdef ANSI
void addslot(LVAL slotname,LVAL defexpr,int slotn,LVAL *pargs, LVAL *pbody);
void updateslot(LVAL args,LVAL slotname,LVAL defexpr);
#else
FORWARD void addslot();
FORWARD void updateslot();
#endif

/* local variables */
static  char prefix[STRMAX+1];

/* xmkstruct - the '%make-struct' function */
LVAL xmkstruct()
{
	LVAL type,val;
	int i;

	/* get the structure type */
	type = xlgasymbol();

	/* make the structure */
	val = newstruct(type,xlargc);

	/* store each argument */
	for (i = 1; moreargs(); ++i)
		setelement(val,i,nextarg());
	xllastarg();

	/* return the structure */
	return (val);
}

/* xcpystruct - the '%copy-struct' function */
LVAL xcpystruct()
{
	LVAL str,val;
	int size,i;
	str = xlgastruct();
	xllastarg();
	size = getsize(str);
	val = newstruct(getelement(str,0),size-1);
	for (i = 1; i < size; ++i)
		setelement(val,i,getelement(str,i));
	return (val);
}

/* xstrref - the '%struct-ref' function */
LVAL xstrref()
{
	LVAL str,val;
	int i;
	str = xlgastruct();
	val = xlgafixnum(); i = (int)getfixnum(val);
	xllastarg();
	if (i >= getsize(str)) /* wrong structure TAA MOD fix*/
		xlerror("Bad structure reference",str);
	return (getelement(str,i));
}

/* xstrset - the '%struct-set' function */
LVAL xstrset()
{
	LVAL str,val;
	int i;
	str = xlgastruct();
	val = xlgafixnum(); i = (int)getfixnum(val);
	val = xlgetarg();
	xllastarg();
	if (i >= getsize(str)) /* wrong structure TAA MOD fix*/
		xlerror("Bad structure reference",str);
	setelement(str,i,val);
	return (val);
}

/* xstrtypep - the '%struct-type-p' function */
LVAL xstrtypep()
{
	LVAL type,val;
	type = xlgasymbol();
	val = xlgetarg();
	xllastarg();
	return (structp(val) && getelement(val,0) == type ? true : NIL);
}

/* xdefstruct - the 'defstruct' special form */
LVAL xdefstruct()
{
	LVAL structname,slotname,defexpr,sym,tmp,args,body;
	LVAL options,oargs,slots;
	char *pname;
	int slotn;

	/* protect some pointers */
	xlstkcheck(6);
	xlsave(structname);
	xlsave(slotname);
	xlsave(defexpr);
	xlsave(args);
	xlsave(body);
	xlsave(tmp);

	/* initialize */
	args = body = NIL;
	slotn = 0;

	/* get the structure name */
	tmp = xlgetarg();
	if (symbolp(tmp)) {
		structname = tmp;
		strcpy(prefix,(char *)getstring(getpname(structname)));
		strcat(prefix,"-");
	}

	/* get the structure name and options */
	else if (consp(tmp) && symbolp(car(tmp))) {
		structname = car(tmp);
		strcpy(prefix,(char *)getstring(getpname(structname)));
		strcat(prefix,"-");

		/* handle the list of options */
		for (options = cdr(tmp); consp(options); options = cdr(options)) {

			/* get the next argument */
			tmp = car(options);

			/* handle options that don't take arguments */
			if (symbolp(tmp)) {
				pname = (char *)getstring(getpname(tmp));
				xlerror("unknown option",tmp);
			}

			/* handle options that take arguments */
			else if (consp(tmp) && symbolp(car(tmp))) {
				pname = (char *)getstring(getpname(car(tmp)));
				oargs = cdr(tmp);

				/* check for the :CONC-NAME keyword */
				if (strcmp(pname,":CONC-NAME") == 0) {

					/* get the name of the structure to include */
					if (!consp(oargs) || !symbolp(car(oargs)))
						xlerror("expecting a symbol",oargs);

					/* save the prefix */
					strcpy(prefix,(char *)getstring(getpname(car(oargs))));
				}

				/* check for the :INCLUDE keyword */
				else if (strcmp(pname,":INCLUDE") == 0) {

					/* get the name of the structure to include */
					if (!consp(oargs) || !symbolp(car(oargs)))
						xlerror("expecting a structure name",oargs);
					tmp = car(oargs);
					oargs = cdr(oargs);

					/* add each slot from the included structure */
					slots = xlgetprop(tmp,xlenter("*STRUCT-SLOTS*"));
					for (; consp(slots); slots = cdr(slots)) {
						if (consp(car(slots)) && consp(cdr(car(slots)))) {

							/* get the next slot description */
							tmp = car(slots);

							/* create the slot access functions */
							addslot(car(tmp),car(cdr(tmp)),++slotn,&args,&body);
						}
					}

					/* handle slot initialization overrides */
					for (; consp(oargs); oargs = cdr(oargs)) {
						tmp = car(oargs);
						if (symbolp(tmp)) {
							slotname = tmp;
							defexpr = NIL;
						}
						else if (consp(tmp) && symbolp(car(tmp))) {
							slotname = car(tmp);
							defexpr = (consp(cdr(tmp)) ? car(cdr(tmp)) : NIL);
						}
						else
							xlerror("bad slot description",tmp);
						updateslot(args,slotname,defexpr);
					}
				}
				else
					xlerror("unknown option",tmp);
			}
			else
				xlerror("bad option syntax",tmp);
		}
	}

	/* get each of the structure members */
	while (moreargs()) {

		/* get the slot name and default value expression */
		tmp = xlgetarg();
		if (symbolp(tmp)) {
			slotname = tmp;
			defexpr = NIL;
		}
		else if (consp(tmp) && symbolp(car(tmp))) {
			slotname = car(tmp);
			defexpr = (consp(cdr(tmp)) ? car(cdr(tmp)) : NIL);
		}
		else
			xlerror("bad slot description",tmp);

		/* create a closure for non-trival default expressions */
		if (defexpr != NIL) {
			tmp = newclosure(NIL,s_lambda,xlenv,xlfenv);
			setbody(tmp,cons(defexpr,NIL));
			tmp = cons(tmp,NIL);
			defexpr = tmp;
		}

		/* create the slot access functions */
		addslot(slotname,defexpr,++slotn,&args,&body);
	}

	/* store the slotnames and default expressions */
	xlputprop(structname,args,xlenter("*STRUCT-SLOTS*"));

	/* enter the MAKE-xxx symbol */
	sprintf(buf,"MAKE-%s",getstring(getpname(structname)));
	sym = xlenter(buf);

	/* make the MAKE-xxx function */
	args = cons(lk_key,args);
	tmp = cons(structname,NIL);
	tmp = cons(s_quote,tmp);
	body = cons(tmp,body);
	body = cons(xlenter("%MAKE-STRUCT"),body);
	body = cons(body,NIL);
	setfunction(sym,
				xlclose(sym,s_lambda,args,body,xlenv,xlfenv));

	/* enter the xxx-P symbol */
	sprintf(buf,"%s-P",getstring(getpname(structname)));
	sym = xlenter(buf);

	/* make the xxx-P function */
	args = cons(xlenter("X"),NIL);
	body = cons(xlenter("X"),NIL);
	tmp = cons(structname,NIL);
	tmp = cons(s_quote,tmp);
	body = cons(tmp,body);
	body = cons(xlenter("%STRUCT-TYPE-P"),body);
	body = cons(body,NIL);
	setfunction(sym,
				xlclose(sym,s_lambda,args,body,NIL,NIL));

	/* enter the COPY-xxx symbol */
	sprintf(buf,"COPY-%s",getstring(getpname(structname)));
	sym = xlenter(buf);

	/* make the COPY-xxx function */
	args = cons(xlenter("X"),NIL);
	body = cons(xlenter("X"),NIL);
	body = cons(xlenter("%COPY-STRUCT"),body);
	body = cons(body,NIL);
	setfunction(sym,
				xlclose(sym,s_lambda,args,body,NIL,NIL));

	/* restore the stack */
	xlpopn(6);

	/* return the structure name */
	return (structname);
}

/* xlrdstruct - convert a list to a structure (used by the reader) */
/* Modified by TAA to quote arguments and accept leading colons on keys */
LVAL xlrdstruct(list)
  LVAL list;
{
    LVAL structname,slotname,expr,last,val;

    /* protect the new structure */
    xlsave1(expr);

    /* get the structure name */
    if (!consp(list) || !symbolp(car(list)))
	xlerror("bad structure initialization list",list);
    structname = car(list);
    list = cdr(list);

    /* enter the MAKE-xxx symbol */
    sprintf(buf,"MAKE-%s",getstring(getpname(structname)));

    /* initialize the MAKE-xxx function call expression */
    expr = cons(xlenter(buf),NIL);
    last = expr;

    /* turn the rest of the initialization list into keyword arguments */
    while (consp(list) && consp(cdr(list))) {

	/* get the slot keyword name */
	slotname = car(list);
	if (!symbolp(slotname))
	    xlerror("expecting a slot name",slotname);


	/* add the slot keyword */
	if (*(getstring(getpname(slotname))) != ':') { /* add colon */
		sprintf(buf,":%s",getstring(getpname(slotname)));
		rplacd(last,cons(xlenter(buf),NIL));
	}
	else {
		rplacd(last,cons(slotname,NIL));
	}
	last = cdr(last);
	list = cdr(list);

	/* add the value expression  -- QUOTED (TAA MOD) */
	rplacd(last,cons(NIL,NIL));
	last = cdr(last);
	rplaca(last, (slotname = cons(s_quote,NIL)));
	rplacd(slotname, cons(car(list), NIL));
	list = cdr(list);
    }

    /* make sure all of the initializers were used */
    if (consp(list))
	xlerror("bad structure initialization list",list);

    /* invoke the creation function */
    val = xleval(expr);

    /* restore the stack */
    xlpop();

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

/* xlprstruct - print a structure (used by printer) */
void xlprstruct(fptr,vptr,flag)
 LVAL fptr,vptr; int flag;
{
	LVAL next;
	int i,n;
	xlputstr(fptr,"#S(");	/* TAA MOD */
	xlprint(fptr,getelement(vptr,0),flag);
	next = xlgetprop(getelement(vptr,0),xlenter("*STRUCT-SLOTS*"));
	for (i = 1, n = getsize(vptr) - 1; i <= n && consp(next); ++i) {
		if (consp(car(next))) { /* should always succeed */
			xlputstr(fptr," :");	/* TAA MOD, colons should show */
			xlprint(fptr,car(car(next)),flag);
			xlputc(fptr,' ');
			xlprint(fptr,getelement(vptr,i),flag);
		}
		next = cdr(next);
	}
	xlputc(fptr,')');
}

/* addslot - make the slot access functions */
LOCAL void addslot(slotname,defexpr,slotn,pargs,pbody)
 LVAL slotname,defexpr; int slotn; LVAL *pargs,*pbody;
{
	LVAL sym,args,body,tmp;

	/* protect some pointers */
	xlstkcheck(4);
	xlsave(sym);
	xlsave(args);
	xlsave(body);
	xlsave(tmp);

	/* construct the update function name */
	sprintf(buf,"%s%s",prefix,getstring(getpname(slotname)));
	sym = xlenter(buf);

	/* make the access function */
	args = cons(xlenter("S"),NIL);
	body = cons(cvfixnum((FIXTYPE)slotn),NIL);
	body = cons(xlenter("S"),body);
	body = cons(xlenter("%STRUCT-REF"),body);
	body = cons(body,NIL);
	setfunction(sym,
				xlclose(sym,s_lambda,args,body,NIL,NIL));

	/* make the update function */
	args = cons(xlenter("V"),NIL);
	args = cons(xlenter("S"),args);
	body = cons(xlenter("V"),NIL);
	body = cons(cvfixnum((FIXTYPE)slotn),body);
	body = cons(xlenter("S"),body);
	body = cons(xlenter("%STRUCT-SET"),body);
	body = cons(body,NIL);
	xlputprop(sym,
			  xlclose(NIL,s_lambda,args,body,NIL,NIL),
			  xlenter("*SETF*"));

	/* add the slotname to the make-xxx keyword list */
	tmp = cons(defexpr,NIL);
	tmp = cons(slotname,tmp);
	tmp = cons(tmp,NIL);
	if ((args = *pargs) == NIL)
		*pargs = tmp;
	else {
		while (cdr(args) != NIL)
			args = cdr(args);
		rplacd(args,tmp);
	}

	/* add the slotname to the %make-xxx argument list */
	tmp = cons(slotname,NIL);
	if ((body = *pbody) == NIL)
		*pbody = tmp;
	else {
		while (cdr(body) != NIL)
			body = cdr(body);
		rplacd(body,tmp);
	}

	/* restore the stack */
	xlpopn(4);
}

/* updateslot - update a slot definition */
LOCAL void updateslot(args,slotname,defexpr)
 LVAL args,slotname,defexpr;
{
	LVAL tmp;
	for (; consp(args); args = cdr(args))
		if (slotname == car(car(args))) {
			if (defexpr != NIL) {
				xlsave1(tmp);
				tmp = newclosure(NIL,s_lambda,xlenv,xlfenv);
				setbody(tmp,cons(defexpr,NIL));
				tmp = cons(tmp,NIL);
				defexpr = tmp;
				xlpop();
			}
			rplaca(cdr(car(args)),defexpr);
			break;
		}
	if (args == NIL)
		xlerror("unknown slot name",slotname);
}

#endif