#include "apl.h"

char	*continu = "continue";

execute(s)
char *s;
{
	register i;
	register data *dp;
	register struct item *p;
	struct item *p1;
	int j;
	data (*f)(), d;

#ifdef SOMED
	if(debug)
		dump(s);
#endif

loop:
	i = *s++;
#ifdef FULLD
	if(debug) {
	    extern char *opname[];
		if(i==-1)
			aprintf("exec eof\n");
		else if(0<=i&&i<103) {
			aprintf("exec "); aprintf(opname[i]); aputchar('\n');
		   } else
			aprintf("exec %d\n",i);
	}
#endif
#ifdef SHORTD
	if(debug)
		aprintf("exec %d\n", i);
#endif
	switch(i) {

	default:
		error("exec B");

	case EOF:
		return;

	case EOL:
		pop();
		goto loop;

	case COMNT:
		push(newdat(DA,1,0));
		goto loop;

	case ADD:
	case SUB:
	case MUL:
	case DIV:
	case MOD:
	case MIN:
	case MAX:
	case PWR:
	case LOG:
	case CIR:
	case COMB:
	case AND:
	case OR:
	case NAND:
	case NOR:
	case LT:
	case LE:
	case EQ:
	case GE:
	case GT:
	case NE:
		f = exop[i];
		p = fetch2();
		p1 = sp[-2];
		if(p->type!=DA||p1->type!=DA) {
			if(p->type==CH&&p1->type==CH) {
				charfun(i, p, p1);
				goto loop;
			} else
				error("dyadic T E");
		}
		if(!p->rank||p->rank==1&&p->size==1) {
			d = p->datap[0];
			pop();
			p = p1;
			dp = p->datap;
			for(i=0; i<p->size; i++) {
				*dp = (*f)(d, *dp);
				dp++;
			}
			goto loop;
		}
		if(!p1->rank||p1->rank==1&&p1->size==1) {
			sp--;
			d = p1->datap[0];
			pop();
			push(p);
			dp = p->datap;
			for(i=0; i<p->size; i++) {
				*dp = (*f)(*dp, d);
				dp++;
			}
			goto loop;
		}
		if(p1->rank != p->rank)
			error("dyadic C E");
		for(i=0; i<p->rank; i++)
			if(p->dim[i] != p1->dim[i])
				error("dyadic C E");
		dp = p1->datap;
		for(i=0; i<p->size; i++) {
			*dp = (*f)(p->datap[i], *dp);
			dp++;
		}
		pop();
		goto loop;



	case PLUS:
	case MINUS:
	case SGN:
	case RECIP:
	case ABS:
	case FLOOR:
	case CEIL:
	case EXP:
	case LOGE:
	case PI:
	case RAND:
	case FAC:
	case NOT:
		f = exop[i];
		p = fetch1();
		if(p->type != DA)
			error("monadic T E");
		dp = p->datap;
		for(i=0; i<p->size; i++) {
			*dp = (*f)(*dp);
			dp++;
		}
		goto loop;

	case MEPS:      /*      execute         */
	case MENC:      /*      monadic encode  */
	case DRHO:
	case DIOT:
	case EPS:
	case REP:
	case BASE:
	case DEAL:
	case DTRN:
	case CAT:
	case CATK:
	case TAKE:
	case DROP:
	case DDOM:
	case MDOM:
	case GDU:
	case GDUK:
	case GDD:
	case GDDK:
	case COM:
	case COM0:
	case COMK:
	case EXD:
	case EXD0:
	case EXDK:
	case ROT:
	case ROT0:
	case ROTK:
	case MRHO:
	case MTRN:
	case RAV:
	case RAVK:
	case RED:
	case RED0:
	case REDK:
	case SCAN:
	case SCANK:
	case SCAN0:
	case REV:
	case REV0:
	case REVK:
	case ASGN:
	case INDEX:
	case ELID:
	case IPROD:
	case OPROD:
	case IMMED:
	case HPRINT:
	case PRINT:
	case MIOT:
	case MIBM:
	case DIBM:
	case BRAN0:
	case BRAN:
	case FUN:
	case ARG1:
	case ARG2:
	case AUTO:
	case REST:
		pcp = s;
		(*exop[i])();
		s = pcp;
		goto loop;

	case NAME:
		s += copy(IN, s, sp, 1);
		sp++;
		if(sp>staktop)
			newstak();
		goto loop;

	case QUOT:
		j = CH;
		goto con;

	case CONST:
		j = DA;

	con:
		i = *s++;
		p = newdat(j, i==1?0:1, i);
		s += copy(j, s, p->datap, i);
		push(p);
		goto loop;

	case QUAD:
		push(newdat(QD,0,0));
		goto loop;

	case QQUAD:
		push(newdat(QQ,0,0));
		goto loop;

	case CQUAD:
		push(newdat(QC,0,0));
		goto loop;
	}
}

static int comop;

charfun(op, p, p1)
struct	item *p, *p1;
{
register char c, *cxi;
register double *dxi;
	 int i;

	comop = op;
	switch(op) {
	   default:
		error("Y D E");
	   case LT:
	   case LE:
	   case EQ:
	   case GE:
	   case GT:
	   case NE:
		/* OK */;
	}
	if(!p->rank) {
		c = *((char*)(p->datap));
		cxi = (char*)(p1->datap);
		push(newdat(DA,p1->rank,p1->size));
		copy(IN, p1->dim, sp[-1]->dim, p1->rank);
		dxi = sp[-1]->datap;
		for(i=0; i<p1->size; i++)
			*dxi++ = (double)charcom(c,*cxi++);
		goto done;
	}
	if(!p1->rank) {
		c = ((char*)(p1->datap))[0];
		cxi = (char*)(p->datap);
		push(newdat(DA,p->rank,p->size));
		copy(IN, p->dim, sp[-1]->dim, p->rank);
		dxi = sp[-1]->datap;
		for(i=0; i<p->size; i++)
			*dxi++ = (double)charcom(*cxi++,c);
		goto done;
	}
	if(p1->rank != p->rank)
		error("dyadic Y C E");
	for(i=0; i<p->rank; i++)
		if(p->dim[i]!=p1->dim[i])
			error("dyadic Y C E");
	cxi = (char*)(p1->datap);
	push(newdat(DA,p->rank,p->size));
	copy(IN, p->dim, sp[-1]->dim, p->rank);
	dxi = sp[-1]->datap;
	for(i=0; i<p->size; i++)
		*dxi++ = (double)charcom(((char*)(p->datap))[i],*cxi++);
done:	dealloc(sp[-2]);
	dealloc(sp[-3]);
	sp[-3] = sp[-1];
	sp -= 2;
	return;
}

charcom(c1, c2)
register char c1, c2;
{
	switch(comop) {
	   case LE:
		return c1<=c2;
	   case LT:
		return c1<c2;
	   case EQ:
		return c1==c2;
	   case NE:
		return c1!=c2;
	   case GT:
		return c1>c2;
	   case GE:
		return c1>=c2;
	}
	error("Y B");		/*  "Cannot happen"  */
}

int	ex_add(),	ex_plus(),	ex_sub(),	ex_minus(),
	ex_mul(),	ex_sgn(),	ex_div(),	ex_recip(),
	ex_mod(),	ex_abs(),	ex_min(),	ex_floor(),
	ex_max(),	ex_ceil(),	ex_pwr(),	ex_exp(),
	ex_log(),	ex_loge(),	ex_cir(),	ex_pi(),
	ex_comb(),	ex_fac(),	ex_deal(),	ex_rand(),
	ex_drho(),	ex_mrho(),	ex_diot(),	ex_miot(),
	ex_rot0(),	ex_rev0(),	ex_dtrn(),	ex_mtrn(),
	ex_dibm(),	ex_mibm(),	ex_gdu(),	ex_gduk(),
	ex_gdd(),	ex_gddk(),	ex_exd(),	ex_scan(),
	ex_exdk(),	ex_scnk(),	ex_iprod(),	ex_oprod(),
	ex_br0(),	ex_br(),	ex_ddom(),	ex_mdom(),
	ex_com(),	ex_red(),	ex_comk(),	ex_redk(),
	ex_rot(),	ex_rev(),	ex_rotk(),	ex_revk(),
	ex_cat(),	ex_rav(),	ex_catk(),	ex_ravk(),
	ex_print(),	ex_elid(),	ex_index(),	ex_hprint(),
	ex_lt(),	ex_le(),	ex_gt(),	ex_ge(),
	ex_eq(),	ex_ne(),	ex_and(),	ex_or(),
	ex_nand(),	ex_nor(),	ex_not(),	ex_eps(),
	ex_meps(),	ex_rep(),	ex_take(),	ex_drop(),
	ex_exd0(),	ex_asgn(),	ex_immed(),	ex_fun(),
	ex_arg1(),	ex_arg2(),	ex_auto(),	ex_rest(),
	ex_com0(),	ex_red0(),	ex_exd0(),	ex_scn0(),
	ex_base(),	ex_menc();

int (*exop[])() =
{
	0,		/* 0 */
	ex_add,		/* 1 */
	ex_plus,	/* 2 */
	ex_sub,		/* 3 */
	ex_minus,	/* 4 */
	ex_mul,		/* 5 */
	ex_sgn,		/* 6 */
	ex_div,		/* 7 */
	ex_recip,	/* 8 */
	ex_mod,		/* 9 */
	ex_abs,		/* 10 */
	ex_min,		/* 11 */
	ex_floor,	/* 12 */
	ex_max,		/* 13 */
	ex_ceil,	/* 14 */
	ex_pwr,		/* 15 */
	ex_exp,		/* 16 */
	ex_log,		/* 17 */
	ex_loge,	/* 18 */
	ex_cir,		/* 19 */
	ex_pi,		/* 20 */
	ex_comb,	/* 21 */
	ex_fac,		/* 22 */
	ex_deal,	/* 23 */
	ex_rand,	/* 24 */
	ex_drho,	/* 25 */
	ex_mrho,	/* 26 */
	ex_diot,	/* 27 */
	ex_miot,	/* 28 */
	ex_rot0,	/* 29 */
	ex_rev0,	/* 30 */
	ex_dtrn,	/* 31 */
	ex_mtrn,	/* 32 */
	ex_dibm,	/* 33 */
	ex_mibm,	/* 34 */
	ex_gdu,		/* 35 */
	ex_gduk,	/* 36 */
	ex_gdd,		/* 37 */
	ex_gddk,	/* 38 */
	ex_exd,		/* 39 */
	ex_scan,	/* 40 */
	ex_exdk,	/* 41 */
	ex_scnk,	/* 42 */
	ex_iprod,	/* 43 */
	ex_oprod,	/* 44 */
	0,		/* 45 */
	0,		/* 46 */
	ex_br0,		/* 47 */
	ex_br,		/* 48 */
	ex_ddom,	/* 49 */
	ex_mdom,	/* 50 */
	ex_com,		/* 51 */
	ex_red,		/* 52 */
	ex_comk,	/* 53 */
	ex_redk,	/* 54 */
	ex_rot,		/* 55 */
	ex_rev,		/* 56 */
	ex_rotk,	/* 57 */
	ex_revk,	/* 58 */
	ex_cat,		/* 59 */
	ex_rav,		/* 60 */
	ex_catk,	/* 61 */
	ex_ravk,	/* 62 */
	ex_print,	/* 63 */
	0,		/* 64 */
	ex_elid,	/* 65 */
	0,		/* 66 */
	0,		/* 67 */
	ex_index,	/* 68 */
	ex_hprint,	/* 69 */
	0,		/* 70 */
	ex_lt,		/* 71 */
	ex_le,		/* 72 */
	ex_gt,		/* 73 */
	ex_ge,		/* 74 */
	ex_eq,		/* 75 */
	ex_ne,		/* 76 */
	ex_and,		/* 77 */
	ex_or,		/* 78 */
	ex_nand,	/* 79 */
	ex_nor,		/* 80 */
	ex_not,		/* 81 */
	ex_eps,		/* 82 */
	ex_meps,	/* 83 */
	ex_rep,		/* 84 */
	ex_take,	/* 85 */
	ex_drop,	/* 86 */
	ex_exd0,	/* 87 */
	ex_asgn,	/* 88 */
	ex_immed,	/* 89 */
	0,		/* 90 */
	0,		/* 91 */
	ex_fun,		/* 92 */
	ex_arg1,	/* 93 */
	ex_arg2,	/* 94 */
	ex_auto,	/* 95 */
	ex_rest,	/* 96 */
	ex_com0,	/* 97 */
	ex_red0,	/* 98 */
	ex_exd0,	/* 99 */
	ex_scn0,	/*100 */
	ex_base,	/*101 */
	ex_menc,        /*102 */        /*      monadic encod   */
};