/*Copyright (C) 1992, 1995 by Thomas Glen Smith.  All Rights Reserved.*/
/* execqfx APL2 V1.0.0 *************************************************
* Function establishment is called from aplcpyc, apledfx, and execmonq.*
* The argument must be an APL character matrix representing a          *
* user-defined function.                                               *
***********************************************************************/
#define INCLUDES APLCB+APLFUNCI+APLTOKEN+STRING+TREE
#include "includes.h"
Aplcb execqfx(rite)
Aplcb rite;
{
	Assign; Chrvect; Errinit; Errstop; Execqfxa; Execqfxb; Execqfxf;
	Execqfxi; Execqfxl; Execqfxm; Expunge; Nestchar; Treenode;
	extern int aplerr;
	Apltoken nametok;
	Aplcb cb,*cbp,out;
	Aplfunc fp=NULL,oldfunc;
	int datatype,stmtcnt;

	for(;;) { /* Lets me use break. */
		if (errinit()) break; /* Error. */
		datatype = rite->aplflags & (APLCHAR | APLAPL);
		if (0 == rite->aplcount)
			aplerr = 90; /* Bad input. */
		else if (datatype == APLCHAR) {
			if (2 != rite->aplrank)
				aplerr = 90; /* Bad input. */
		} else if (datatype == APLAPL) {
			if (1 != rite->aplrank)
				aplerr = 90; /* Bad input. */
			else {
				cbp = rite->aplptr.aplapl;
				stmtcnt = rite->aplcount;
				while(stmtcnt-- && aplerr == 0) {
					cb = *cbp++;
					datatype = cb->aplflags & APLCHAR;
					if (datatype != APLCHAR ||
						cb->aplrank > 1 || cb->aplcount == 0)
						aplerr = 90; /* Bad input. */
				}
			}
			if (aplerr) break;
			rite = nestchar(rite); /* Convert to character matrix. */
		}
		if (aplerr) break; /* Error. */
		fp = execqfxa(rite); /* go initialize function structure */
		rite = NULL; /* Execqfxa disposes of rite, if necessary. */
		if (aplerr) break; /* Error. */
		execqfxb(fp); /* Go do initial parsing. */
		if (aplerr) break; /* Error */
		nametok = execqfxl(fp); /* function name token */
		if (aplerr) break;
		return(execqfxm(nametok,fp)); /* Clean tree, do assign. */
	}
	if (fp) {
		expunge(fp); /* Free, we had an error */
		rite = NULL; /* Expunge will've freed. */
	}
	return(errstop(0,NULL,rite,NULL));
}