#include <../../nrnconf.h>
/* /local/src/master/nrn/src/oc/code.c,v 1.37 1999/07/03 14:20:21 hines Exp */

#if defined(__GO32__) 
#include <go32.h>
#endif

#include <errno.h>
#include "hoc.h"
#include "code.h"
#include "hocstr.h"
#include "parse.h"
#include "ocfunc.h"
#include "ocmisc.h"
#include "hocparse.h"
#include "equation.h"
#include <math.h>
#include <stdio.h>
#include <stdlib.h>
#include <nrnmpi.h>
#include "nrnfilewrap.h"
#if CABLE
#include "options.h"
#include "section.h"

int bbs_poll_;
extern void bbs_handle(void);
#define BBSPOLL if (--bbs_poll_ == 0) { bbs_handle(); }

int nrn_isecstack();
#else
#define BBSPOLL /**/
#endif

# define	STACKCHK	if (stackp >= stacklast) \
					execerror("Stack too deep.", "Increase with -NSTACK stacksize option");

int tstkchk_actual(int i, int j) {
	int k, l;
	char *s[2];
	if (i != j) {
		for (k =0, l=i; k<2; k++, l=j) {
			switch (l) {
			case NUMBER:
				s[k] = "(double)";
				break;
			case STRING:
				s[k] = "(char *)";
				break;
			case OBJECTVAR:
				s[k] = "(Object **)";
				break;
			case USERINT:
				s[k] = "(int)";
				break;
			case SYMBOL:
				s[k] = "(Symbol)";
				break;
			case VAR:
				s[k] = "(double *)";
				break;
			case OBJECTTMP:	/* would use OBJECT if it existed */
				s[k] = "(Object *)";
				break;
			default:
				s[k] = "(Unknown)";
				break;
			}
		}
		fprintf(stderr, "bad stack access: expecting %s; really %s\n", s[1], s[0]);
		execerror("interpreter stack type error", (char *)0);
	}
	return 0;
}

#define USEMACROS 1

#if USEMACROS
#define pushxm(d)	((stackp++)->val = (d));((stackp++)->i = NUMBER)
#define pushsm(d)	((stackp++)->sym = (d));((stackp++)->i = SYMBOL)
#define xpopm()		(tstkchk((--stackp)->i, NUMBER), (--stackp)->val)
#define spopm()		(tstkchk((--stackp)->i, SYMBOL), (--stackp)->sym)
#define nopopm()	(stackp -= 2)
#define tstkchk(i,j)	(((i)!=(j))?tstkchk_actual(i,j):0)
#else
#define pushxm(d) pushx(d)
#define pushsm(d) pushs(d)
#define xpopm() xpop()
#define spopm()	spop()
#define nopopm() nopop()
#define tstkchk(i,j) tstkchk_actual(i,j)
#endif

#define EPS hoc_epsilon

#define	NSTACK	1000 /* default size */
#define nstack hoc_nstack
static Datum	*stack;	/* the stack */
static Datum	*stackp;	/* next free spot on stack */
static Datum	*stacklast; /* last stack element */

#define	NPROG	50000
Inst	*prog;	/* the machine */
Inst	*progp;		/* next free spot for code generation */
Inst	*pc;		/* program counter during execution */
Inst	*progbase; /* start of current subprogram */
Inst	*prog_parse_recover; /* start after parse error */
int	hoc_returning;	/* 1 if return stmt seen, 2 if break, 3 if continue */
			/* 4 if stop */
typedef struct Frame {	/* proc/func call stack frame */
	Symbol	*sp;	/* symbol table entry */
	Inst	*retpc;	/* where to resume after return */
	Datum	*argn;	/* n-th argument on stack */
	int	nargs;	/* number of arguments */
	Inst	*iter_stmt_begin; /* Iterator statement starts here */
	Object	*iter_stmt_ob;	/* context of Iterator statement */
	Object	*ob;	/* for stack frame debug message */
} Frame;
#define NFRAME	512 /* default size */
#define nframe hoc_nframe
static Frame *frame, *fp, *framelast; /* first, frame pointer, last */

/* temporary object references come from this pool. This allows the
stack to be aware if it is storing a temporary. We are trying to
solve problems of objrefs on the stack changing the object they point
to and also a failure of garbage collection since temporary objrefs have
not, in the past, been reffed or unreffed.
The first problem is easily solved without much efficiency loss
by having the stack store the object pointer instead of the objref pointer.

Garbage collection is implemented by reffing any object that is placed
on the stack via hoc_push_object (and thus borrows the use of the
type OBJECTTMP) It is then the responsibility of everything that
pops an object to determine whether the object should be unreffed.
This is also done on error recovery and when the stack frame is popped.
I hate the efficiency loss but it is not as bad as it could be
since most popping occurs when the stack frame is popped and in this
case it is faster to check for OBJECTTMP than if the returned Object**
is from the pool.
*/
#define DEBUG_GARBAGE 1
#define TOBJ_POOL_SIZE 50
static Object** hoc_temp_obj_pool_;
static int obj_pool_index_;
static int tobj_count; /* how many stack pushes of OBJECTTMP have been reffed*/

/*
Here is the old comment on the function when it was in hoc_oop.c.

At this time we are dealing uniformly with object variables and cannot
deal cleanly with objects.  Eventually it may be possible to put an
object pointer on the stack but not now.  Try to avoid using "functions
which return new objects" as arguments to other functions.  If this is
done then it may happen that when the stack pointer is finally used it
may point to a different object than when it was put on the stack. 
Things are safe when a temp_objvar is finally removed from the stack. 
Memory leakage will occur if a temp_objvar is passed as an arg but never
assigned to a full fledged object variable.  ie its reference count is 0
but unref will never be called on it. 
The danger is illustrated with
	proc p(obj.func_returning_object()) { // $o1 is on the stack
		print $o1	// correct object
		for i=0,100 {
			o = obj.func_returning_different_object()
			print i, $o1  //when i=50 $o1 will be different
		}
	}
In this case one should first assign $o1 to another object variable
and then use that object variable exclusively instead of $o1.
This also prevent leakage of the object pointed to by $o1.

If this ever becomes a problem then it is not too difficult to
implement objects on the stack with garbage collection.
*/

Object** hoc_temp_objptr(obj) Object* obj; {
	Object** tobj;
	obj_pool_index_ = (obj_pool_index_ + 1)%TOBJ_POOL_SIZE;
	tobj = hoc_temp_obj_pool_ + obj_pool_index_;
	*tobj = obj;
	return tobj;
}

/* should be called after finished with pointer from a popobj */

void hoc_tobj_unref(Object** p) {
	if (p >= hoc_temp_obj_pool_ && p < hoc_temp_obj_pool_ + TOBJ_POOL_SIZE) {
		--tobj_count;
		hoc_obj_unref(*p);
	}
}

/*
vec.c.x[0] used freed memory because the temporary vector was unreffed
after the x pointer was put on the stack but before it was evaluated.
The hoc_pop_defer replaces the nopop in in hoc_object_component handling
of a cplus steer method (which pushes a double pointer). The corresponding
hoc_unref_defer takes place in hoc_object_eval after evaluating
the pointer. This should take care of the most common (itself very rare)
problem. However it still would not in general
take care of the purposeless passing
of &vec.c.x[0] as an argument to a function since intervening pop_defer/unref_defer
pairs could take place.
*/
static Object* unref_defer_;
void hoc_unref_defer(void) {
	if (unref_defer_) {
#if 0
		printf("hoc_unref_defer %s %d\n", hoc_object_name(unref_defer_), unref_defer_->refcount);
#endif
		hoc_obj_unref(unref_defer_);
		unref_defer_ = (Object*)0;
	}
}
void hoc_pop_defer(void) {
	Object* obj;
	if (unref_defer_) {
#if 0
		printf("hoc_pop_defer unrefs %s %d\n", hoc_object_name(unref_defer_), unref_defer_->refcount);
#endif
		hoc_unref_defer();
	}
	if (stackp <= stack)
		execerror("stack underflow", (char *) 0);
	if (stackp[-1].i == OBJECTTMP) {
		unref_defer_ = stackp[-2].obj;
		if (unref_defer_) {
			++unref_defer_->refcount;
		}
#if 0
printf("hoc_pop_defer %s %d\n", hoc_object_name(unref_defer_), unref_defer_->refcount);
#endif
	}
	hoc_nopop();
}

/* should be called on each OBJECTTMP on the stack after adjusting the
stack pointer downward */

void hoc_stkobj_unref(Object* o) {
	--tobj_count;
	hoc_obj_unref(o);
}

/* check the args of the frame and unref any of type OBJECTTMP */

static void frameobj_clean(Frame* f) {
	Datum* s;
	int i, narg;
	if (f->nargs == 0) {
		return;
	}
	s = f->argn + 2;
	for (i=f->nargs-1; i >= 0; --i) {
		if ((--s)->i == OBJECTTMP) {
			s->i = 0;
			hoc_stkobj_unref((--s)->obj);
		}else{
			--s;
		}
	}
}

void hoc_init_space(void)	/* create space for stack and code */
{
	if (nframe == 0) {
		nframe = NFRAME;
	}
	if (nstack == 0) {
		nstack = NSTACK;
	}
	stackp = stack = (Datum *)emalloc(sizeof(Datum)*nstack);
	stacklast = stack + nstack;
	progp = progbase = prog = (Inst *)emalloc(sizeof(Inst)*NPROG);
	fp = frame = (Frame *)emalloc(sizeof(Frame)*nframe);
	framelast = frame + nframe;
	hoc_temp_obj_pool_ = (Object**)emalloc(sizeof(Object*)*TOBJ_POOL_SIZE);
}

#define MAXINITFCNS 10
static int maxinitfcns;
static Pfrv initfcns[MAXINITFCNS];

void hoc_prstack(void) {
	int i;
	Datum* s;
	printf("interpreter stack: %ld \n", (stackp - stack)/2);
	for (i=0, s = stackp - 1; s > stack; --s, ++i) {
		if (i > 10) {
			printf("...\n");
			break;
		}
		printf("%d stacktype=%d\n", i, s->i);
		--s;
	}
}

void hoc_on_init_register(Pfrv pf)
{
	/* modules that may have to be cleaned up after an execerror */
	if (maxinitfcns < MAXINITFCNS) {
		initfcns[maxinitfcns++] = pf;
	}else{
		fprintf(stderr, "increase definition for MAXINITFCNS\n");
		nrn_exit(1);
	}
}

void initcode(void)	/* initialize for code generation */
{
	int i;
	errno = 0;
	if (hoc_errno_count > 5) {
fprintf(stderr, "errno set %d times on last execution\n", hoc_errno_count);
	}
	hoc_errno_count = 0;
	prog_parse_recover = progbase = prog;
	progp = progbase;
	hoc_unref_defer();

if (tobj_count) {
	while(fp < frame) {
		frameobj_clean(fp);
		--fp;
	}
#if DEBUG_GARBAGE
	if (tobj_count) {
		printf("initcode failed with %d left\n", tobj_count);
	}
#endif
	tobj_count = 0;
}
	stackp = stack;
	fp = frame;
	free_list(&p_symlist);
	hoc_returning = 0;
	do_equation = 0;
	for (i=0; i < maxinitfcns; ++i) {
		(*initfcns[i])();
	}
#if CABLE
	nrn_initcode(); /* special requirements for NEURON */
#endif
}


static Frame *rframe;
static Datum *rstack;
static const char *parsestr;

void oc_save_code(
	Inst*	*a1,
	Inst*	*a2,
	Datum*	*a3,
	Frame*	*a4,
	int	*a5,
	int	*a6,
	Inst*	*a7,
	Frame*	*a8,
	Datum*	*a9,
	Symlist* *a10,
	Inst*	*a11,
	int	*a12
){
	*a1 = progbase;
	*a2 = progp;
	*a3 = stackp;
	*a4 = fp;
	*a5 = hoc_returning;
	*a6 = do_equation;
	*a7 = pc;
	*a8 = rframe;
	*a9 = rstack;
	*a10 = p_symlist;
	*a11 = prog_parse_recover;
	*a12 = tobj_count;
}

void oc_restore_code(
	Inst*	*a1,
	Inst*	*a2,
	Datum*	*a3,
	Frame*	*a4,
	int	*a5,
	int	*a6,
	Inst*	*a7,
	Frame*	*a8,
	Datum*	*a9,
	Symlist* *a10,
	Inst*	*a11,
	int	*a12
){
	progbase = *a1;
	progp = *a2;
	if (tobj_count > *a12) {
		while(fp > *a4) {
			frameobj_clean(fp);
			--fp;
		}
#if DEBUG_GARBAGE
if (tobj_count != *a12) {
	printf("oc_restore_code tobj_count=%d should be %d\n", tobj_count, *a12);
}
#endif
	}
	stackp = *a3;
	fp = *a4;
	hoc_returning = *a5;
	do_equation = *a6;
	pc = *a7;
	rframe = *a8;
	rstack = *a9;
	p_symlist = *a10;
	prog_parse_recover = *a11;
}

int hoc_strgets_need(void) {
	return strlen(parsestr);
}

char* hoc_strgets(char* cbuf, int nc) {/* getc for a string, used by parser */
	strncpy(cbuf, parsestr, nc);
	if (*parsestr == '\0') {
		return (char *)0;
	}else{
		return cbuf;
	}
}

static void rinitcode(void)	/* initialize for recursive code generation */
{
	errno = 0;
	hoc_errno_count = 0;
	prog_parse_recover = progbase;
	progp = progbase;
	stackp = rstack;
	fp = rframe;
	free_list(&p_symlist);
	if (hoc_returning != 4) {	/* if stop not seen */
		hoc_returning = 0;
	}
	do_equation = 0;
}

int hoc_ParseExec(int yystart) {
	/* can recursively parse and execute what is in cbuf.
	   may parse single tokens. called from hoc_oc(str).
	   All these parse and execute routines should be combined into
	   a single method robust method. The pipeflag method has become
	   encrusted with too many irrelevant mechanisms. There is no longer
	   anything sacred about the cbuf. The only requiremnent is to tell
	   the get line function where to get its string.
	 */
	int yret;
	
	Frame *sframe, *sfp;
	Inst *sprogbase, *sprogp, *spc, *sprog_parse_recover;
	Datum *sstackp, *sstack;
	Symlist *sp_symlist;

	if (yystart) {
		sframe=rframe;sfp=fp;
		sprogbase=progbase; sprogp=progp; spc=pc,
		sprog_parse_recover=prog_parse_recover;
		sstackp=stackp; sstack=rstack;
		sp_symlist=p_symlist;
		rframe = fp;
		rstack = stackp;
		progbase = progp;
		p_symlist = (Symlist *)0;
	}
	
	if (yystart) {
		rinitcode();
	}
	if (hoc_in_yyparse) {
		hoc_execerror("Cannot reenter parser.",
		"Maybe you were in the middle of a direct command.");
	}
	yret = yyparse();
	switch (yret) {
	case 1:
		execute(progbase);
		rinitcode();
		break;
	case 'e':
		hoc_edit();
		for (rinitcode(); hoc_yyparse(); rinitcode()) {
			execute(progbase);
		}
		break;
	case -3 :
		hoc_execerror("incomplete statement parse not allowed\n", (char*)0);
	default:
		break;
	}
	if (yystart) {
		rframe=sframe; fp=sfp;
		progbase=sprogbase; progp=sprogp; pc=spc;
		prog_parse_recover=sprog_parse_recover;
		stackp=sstackp; rstack=sstack; p_symlist=sp_symlist;
	}

	return yret;
}
	
int hoc_xopen_run(Symbol* sp, const char* str) { /*recursively parse and execute for xopen*/
/* if sp != 0 then parse string and save code */
/* without executing. Note str must be a 'list'*/
	int n=0;
	Frame *sframe=rframe, *sfp=fp;
	Inst *sprogbase=progbase, *sprogp=progp, *spc=pc,
		*sprog_parse_recover=prog_parse_recover;
	Datum *sstackp=stackp, *sstack=rstack;
	Symlist *sp_symlist=p_symlist;
	rframe = fp;
	rstack = stackp;
	progbase = progp;
	p_symlist = (Symlist *)0;
	
	if (sp == (Symbol *)0) {
		for (rinitcode(); hoc_yyparse(); rinitcode())
			execute(progbase);
	}else{ int savpipeflag;
		rinitcode();
		savpipeflag = hoc_pipeflag;
		hoc_pipeflag = 2;
		parsestr=str;
		if(!hoc_yyparse()) {
			execerror("Nothing to parse", (char *)0);
		}
		n = (int)(progp-progbase);
		hoc_pipeflag = savpipeflag;
		hoc_define(sp);
		rinitcode();
	}
	rframe=sframe; fp=sfp;
	progbase=sprogbase; progp=sprogp; pc=spc;
	prog_parse_recover=sprog_parse_recover;
	stackp=sstackp; rstack=sstack; p_symlist=sp_symlist;
	return n;
}

static char* stmp[128];
static int istmp = 0;
char** hoc_temp_charptr(void) {
	istmp = (istmp+1)%128;
	return stmp+istmp;
}

int hoc_stack_type(void) {
	return stackp[-1].i;
}

void pushx(double d) {		/* push double onto stack */
	STACKCHK
	(stackp++)->val = d;
	(stackp++)->i = NUMBER;
}

void hoc_pushobj(Object** d) {		/* push pointer to object pointer onto stack */
	STACKCHK
	if (d >= hoc_temp_obj_pool_ && d < (hoc_temp_obj_pool_ + TOBJ_POOL_SIZE)) {
		hoc_push_object(*d);
		return;
	}
	(stackp++)->pobj = d;
	(stackp++)->i = OBJECTVAR;
}

void hoc_push_object(Object* d) {		/* push pointer to object onto stack */
	STACKCHK
	(stackp++)->obj = d;
	(stackp++)->i = OBJECTTMP;	/* would use OBJECT if it existed */
	hoc_obj_ref(d);
	++tobj_count;
}

void hoc_pushstr(char** d) {		/* push pointer to string pointer onto stack */
	STACKCHK
	(stackp++)->pstr = d;
	(stackp++)->i = STRING;
}

void hoc_push_string(void) {	/* code for pushing a symbols string */
	Objectdata* odsav;
	Object* obsav = 0;
	Symlist* slsav;
	Symbol *s;
	s = (pc++)->sym;
	if (!s) {
		hoc_pushstr((char**) 0);
		return;
	}
	if (s->type == CSTRING) {
		hoc_pushstr(&(s->u.cstr));
	}else{
    if (s->public == 2) {
	s = s->u.sym;
	odsav = hoc_objectdata_save();
	obsav = hoc_thisobject;
	slsav = hoc_symlist;
	hoc_objectdata = hoc_top_level_data;
	hoc_thisobject = 0;
	hoc_symlist = hoc_top_level_symlist;
    }
		hoc_pushstr(OPSTR(s));
    if (obsav) {
	hoc_objectdata = hoc_objectdata_restore(odsav);
	hoc_thisobject = obsav;
	hoc_symlist = slsav;
    }
	}
}

void hoc_pushpx(double* d) {		/* push double pointer onto stack */
	STACKCHK
	(stackp++)->pval = d;
	(stackp++)->i = VAR;
}

void pushs(Symbol* d) {		/* push symbol pointer onto stack */
	STACKCHK
	(stackp++)->sym = d;
	(stackp++)->i = SYMBOL;
}
void pushi(int d) {		/* push integer onto stack */
	STACKCHK
	(stackp++)->i = d;
	(stackp++)->i = USERINT;
}

int hoc_stacktype(void) {
	if (stackp <= stack) {
		execerror("stack empty", (char*)0);
	}
	return (stackp - 1)->i;
}

int hoc_argtype(int narg) { /* type of nth arg */
	if (narg > fp->nargs)
		execerror(fp->sp->name, "not enough arguments");
	return(fp->argn[(narg - fp->nargs)*2 + 1].i);
}

int hoc_is_double_arg(int narg) {
	return (hoc_argtype(narg) == NUMBER);
}

int hoc_is_pdouble_arg(int narg) {
	return (hoc_argtype(narg) == VAR);
}

int hoc_is_str_arg(narg) int narg; {
	return (hoc_argtype(narg) == STRING);
}

int hoc_is_object_arg(int narg) {
	int type = hoc_argtype(narg);
	return (type == OBJECTVAR || type == OBJECTTMP);
}

int hoc_is_tempobj_arg(int narg) {
	return (hoc_argtype(narg) == OBJECTTMP);
}

Datum* hoc_look_inside_stack(int i, int type) {/* stack pointer at depth i; i=0 is top */
	tstkchk((stackp - 2*i - 1)->i, type);
	return stackp - 2*(i + 1);
}

Object* hoc_obj_look_inside_stack(int i) { /* stack pointer at depth i; i=0 is top */
	Datum* d = stackp - 2*i - 2;
	int type = d[1].i;
	if (type == OBJECTTMP) {
		return d[0].obj;
	}
	tstkchk(type,  OBJECTVAR);
	return *(d[0].pobj);
}

int hoc_inside_stacktype(int i) { /* 0 is top */
	return (stackp - 2*i - 1)->i;
}

double xpop(void) {	/* pop double and return top elem from stack */
	if (stackp <= stack)
		execerror("stack underflow", (char *) 0);
	--stackp;
	tstkchk(stackp->i, NUMBER);
	return (--stackp)->val;
}

#if 0
void pstack(void) {
	char* hoc_object_name();
	Datum* d;
	int i;
	for (d=stackp; d > stack;) {
		i = (--d)->i;
		--d;
		switch(i) {
			case NUMBER:
				printf("(double)\n");
				break;
			case STRING:
				printf("(char *)\n");
				break;
			case OBJECTVAR:
				printf("(Object **) %s\n", hoc_object_name(*(d->pobj)));
				break;
			case USERINT:
				printf("(int)\n");
				break;
			case SYMBOL:
				printf("(Symbol) %s\n", d->sym);
				break;
			case VAR:
				printf("(double *)\n");
				break;
			case OBJECTTMP:	/* would use OBJECT if it existed */
				printf("(Object *) %s\n", hoc_object_name(d->obj));
				break;
			default:
				printf("(Unknown)\n");
				break;
		}
	}
}
#endif

double* hoc_pxpop(void) {/* pop double pointer and return top elem from stack */
	if (stackp <= stack)
		execerror("stack underflow", (char *) 0);
	--stackp;
	tstkchk(stackp->i, VAR);
	return (--stackp)->pval;
}

Symbol* spop(void) {/* pop symbol pointer and return top elem from stack */
	if (stackp <= stack)
		execerror("stack underflow", (char *) 0);
	--stackp;
	tstkchk(stackp->i, SYMBOL);
	return (--stackp)->sym;
}

/*
When using objpop, after dealing with the pointer, one should call
	hoc_tobj_unref(pobj) in order to prevent memory leakage since
	the object may have been reffed when it was pushed on the stack
*/

Object** hoc_objpop(void) {/* pop pointer to object pointer and return top elem from stack */
	if (stackp <= stack)
		execerror("stack underflow", (char *) 0);
	--stackp;
	if (stackp->i == OBJECTTMP) {
		return hoc_temp_objptr((--stackp)->obj);
	}
	tstkchk(stackp->i, OBJECTVAR);
	return (--stackp)->pobj;
}

Object* hoc_pop_object(void ) {/* pop object and return top elem from stack */
	if (stackp <= stack)
		execerror("stack underflow", (char *) 0);
	--stackp;
	tstkchk(stackp->i, OBJECTTMP);
	return (--stackp)->obj;
}

char** hoc_strpop(void) { /* pop pointer to string pointer and return top elem from stack */
	if (stackp <= stack)
		execerror("stack underflow", (char *) 0);
	--stackp;
	tstkchk(stackp->i, STRING);
	return (--stackp)->pstr;
}

int ipop(void) {/* pop symbol pointer and return top elem from stack */
	if (stackp <= stack)
		execerror("stack underflow", (char *) 0);
	--stackp;
	tstkchk(stackp->i, USERINT);
	return (--stackp)->i;
}

void nopop(void) {/* just pop the stack without returning anything */
	if (stackp <= stack)
		execerror("stack underflow", (char *) 0);
	--stackp;
	if (stackp->i == OBJECTTMP) {
		stackp->i = 0;
		hoc_stkobj_unref((--stackp)->obj);
	}else{
		--stackp;
	}
}

void constpush(void) /* push constant onto stack */
{
	pushxm(*((pc++)->sym)->u.pnum);
}

void pushzero(void) /* push zero onto stack */
{
	pushxm(0.);
}

void varpush(void)	/* push variable onto stack */
{
	pushsm((pc++)->sym);
}

# define	relative(pc)	(pc + (pc)->i)

void forcode(void)
{
	double d;
	Inst *savepc = pc;	/* loop body */
	int isec;

#if CABLE
	isec = nrn_isecstack();
#endif
	execute(savepc+3);	/* condition */
	d = xpopm();
	while (d)
	{
		execute(relative(savepc));	/* body */
#if CABLE
		if (hoc_returning) {nrn_secstack(isec);}
#endif
		if (hoc_returning == 1 || hoc_returning == 4)	/* return or stop */
			break;
		else if (hoc_returning == 2)	/* break */
		{
			hoc_returning = 0;
			break;
		}
		else				/* continue */
			hoc_returning = 0;
		if ((savepc+2)->i)   /* diff between while and for */
			execute(relative(savepc+2)); /* increment */
		execute(savepc+3);
		d = xpopm();
	}
	if (!hoc_returning)
		pc = relative(savepc+1);	/* next statement */
}

void shortfor(void)
{
	Inst *savepc = pc;
	double begin, end, *pval=0;
	Symbol *sym;
	int isec;
	
	end = xpopm() + EPS;
	begin = xpopm();
	sym = spopm();

	switch (sym->type) {
	case UNDEF:
		hoc_execerror(sym->name, "undefined variable");
	case VAR:
if (!ISARRAY(sym)) {
		if (sym->subtype == USERINT) {
			execerror("integer iteration variable", sym->name);
		}else if (sym->subtype == USERDOUBLE) {
			pval = sym->u.pval;
		}else{
			pval = OPVAL(sym);
		}
		break;
} else {
		if (sym->subtype == USERINT)
			execerror("integer iteration variable", sym->name);
		else if (sym->subtype == USERDOUBLE)
			pval = sym->u.pval + araypt(sym, SYMBOL);
		else
			pval = OPVAL(sym) + araypt(sym, OBJECTVAR);
}
		break;
	case AUTO:
		pval = &(fp->argn[sym->u.u_auto*2].val);
		break;
	default:
		execerror("for loop non-variable", sym->name);
	}
#if CABLE
	isec = nrn_isecstack();
#endif
	for (*pval = begin; *pval<=end; *pval += 1.) {
		execute(relative(savepc));
#if CABLE
		if (hoc_returning) {nrn_secstack(isec);}
#endif
		if (hoc_returning == 1 || hoc_returning == 4) {
			break;
		}else if (hoc_returning == 2) {
			hoc_returning = 0;
			break;
		}else{
			hoc_returning = 0;
		}
	}
	if (!hoc_returning)
		pc =relative(savepc+1);
}

void hoc_iterator(void) {
	/* pc is ITERATOR symbol, argcount, stmtbegin, stmtend */
	/* for testing execute stmt once */
	Symbol* sym;
	int argcount;
	Inst* stmtbegin, *stmtend;
	
	sym = (pc++)->sym;
	argcount = (pc++)->i;
	stmtbegin = relative(pc);
	stmtend = relative(pc+1);;
	hoc_iterator_object(sym, argcount, stmtbegin, stmtend, hoc_thisobject);
}

void hoc_iterator_object(
	Symbol* sym,
	int argcount,
	Inst* beginpc,
	Inst* endpc,
	Object* ob
){
	int i;
	fp++;
	if (fp >= framelast) {
		fp--;
		execerror(sym->name, "call nested too deeply, increase with -NFRAME framesize option");
	}
	fp->sp = sym;
	fp->nargs = argcount;
	fp->retpc = endpc;
	fp->argn = stackp - 2;
	stackp += sym->u.u_proc->nauto * 2;
	/* clear the autoobject pointers */
	for (i = sym->u.u_proc->nobjauto; i > 0; --i) {
		stackp[-2*i].obj = (Object*)0;
	}
	fp->iter_stmt_begin = beginpc;
	fp->iter_stmt_ob = ob;
	fp->ob = ob;
	STACKCHK
	execute(sym->u.u_proc->defn.in);
	nopop(); /* 0.0 from the procret() */
	if (hoc_returning != 4) {
		hoc_returning = 0;
	}
}

void hoc_iterator_stmt(void) {
	Inst* pcsav;
	Object* ob;
	Object* obsav;
	Objectdata* obdsav;
	Symlist* slsav;
	int isec;
	Frame* iter_f = fp;		/* iterator frame */
	Frame* ef = fp - 1;	/* iterator statement frame */
	fp++;			/* execution frame */

	fp->sp = iter_f->sp;
	fp->ob = iter_f->ob;
	if (ef != frame) {
		/*SUPPRESS 26*/
		fp->argn = ef->argn;
		fp->nargs = ef->nargs;
	}else{  /* top. only for stack trace */
		fp->argn = 0;
		fp->nargs = 0;
	}

	ob = iter_f->iter_stmt_ob;
	obsav = hoc_thisobject;
	obdsav = hoc_objectdata_save();
	slsav = hoc_symlist;
	hoc_thisobject = ob;
	if (ob) {
		hoc_objectdata = ob->u.dataspace;
		hoc_symlist = ob->template->symtable;
	}else{
		hoc_objectdata = hoc_top_level_data;
		hoc_symlist = hoc_top_level_symlist;
	}

	pcsav = pc;
#if CABLE
	isec = nrn_isecstack();
#endif
	execute(iter_f->iter_stmt_begin);
	pc = pcsav;
	hoc_objectdata = hoc_objectdata_restore(obdsav);
	hoc_thisobject = obsav;
	hoc_symlist = slsav;
	--fp;
#if CABLE
	if (hoc_returning) {nrn_secstack(isec);}
#endif
	switch (hoc_returning) {
	case 1: /* return means not only return from iter but return from
			the procedure containing the iter statement */
hoc_execerror("return from within an iterator statement not allowed.",
"Set a flag and use break.");
	case 2:	/* break means return from iter */
		procret();
		break;
	case 3:	/* continue means go on from iter as though nothing happened*/
		hoc_returning = 0;
		break;
	}

}

static void for_segment2(Symbol* sym, int mode) {
	/* symbol on stack; statement pointed to by pc
	continuation pointed to by pc+1. template used is shortfor in code.c
	of hoc system.
	*/
	
#if CABLE
	int i, imax;
	Inst *savepc = pc;
	double *pval=0, dx;
	int isec;
#if METHOD3
	extern int _method3;
#endif
	
	switch (sym->type) {
	case UNDEF:
		hoc_execerror(sym->name, "undefined variable");
	case VAR:
if (!ISARRAY(sym)) {
		if (sym->subtype == USERINT)
			execerror("integer iteration variable", sym->name);
		else if (sym->subtype == USERDOUBLE)
			pval = sym->u.pval;
		else
			pval = OPVAL(sym);
		break;
} else {
		if (sym->subtype == USERINT)
			execerror("integer iteration variable", sym->name);
		else if (sym->subtype == USERDOUBLE)
			pval = sym->u.pval + araypt(sym, SYMBOL);
		else
			pval = OPVAL(sym) + araypt(sym, OBJECTVAR);
}
		break;
	case AUTO:
		pval = &(fp->argn[sym->u.u_auto*2].val);
		break;
	default:
		execerror("for loop non-variable", sym->name);
	}
	imax = segment_limits(&dx);
#if METHOD3
   if (_method3) {
	for (i=0, *pval=0; i <= imax; i++) {
		if (mode == 0 && (i == imax || i == 0)) { continue; }
		if (i == imax) {
			*pval = 1.;
		} else {
			*pval = i * dx;
		}
		execute(relative(savepc));
		if (hoc_returning == 1 || hoc_returning == 4) {
			break;
		}else if (hoc_returning == 2) {
			hoc_returning = 0;
			break;
		}else{
			hoc_returning = 0;
		}
	}
   }else
#endif
   {
	if (mode == 0) {
		i = 1;
		*pval = dx/2.;
	}else{
		i = 0;
		*pval = 0.;
	}
#if CABLE
	isec = nrn_isecstack();
#endif
	for (; i <= imax; i++) {
		if (i == imax) {
			if (mode == 0) { continue; }
			*pval = 1.;
		}
		execute(relative(savepc));
#if CABLE
		if (hoc_returning) {nrn_secstack(isec);}
#endif
		if (hoc_returning == 1 || hoc_returning == 4) {
			break;
		}else if (hoc_returning == 2) {
			hoc_returning = 0;
			break;
		}else{
			hoc_returning = 0;
		}
		if (i == 0) {
			*pval += dx/2.;
		}
		else if (i < imax) {
			*pval += dx;
		}
	}
   }
	if (!hoc_returning)
		pc =relative(savepc+1);
#else
	execerror("for (var) {stmt} syntax only allowed in CABLE", (char *)0);
#endif
}
	
void for_segment(void) {
	for_segment2(spopm(), 1);
}

void for_segment1(void) {
	Symbol* sym;
	double d;
	int mode;
	d = xpopm();
	sym = spopm();
	mode = (fabs(d)< EPS) ? 0 : 1;
	for_segment2(sym, mode);	
}

void ifcode(void)
{
	double d;
	Inst *savepc = pc;	/* then part */

	execute(savepc+3);	/* condition */
	d = xpopm();
	if (d)
		execute(relative(savepc));
	else if ((savepc+1)->i)	/* else part? */
		execute(relative(savepc+1));
	if (!hoc_returning)
		pc = relative(savepc+2);	/* next stmt */
}

void Break(void)		/* break statement */
{
	hoc_returning = 2;
}

void Continue(void)	/* continue statement */
{
	hoc_returning = 3;
}

void Stop(void)		/* stop statement */
{
	hoc_returning = 4;
}

void hoc_define(Symbol* sp) {	/* put func/proc in symbol table */
	Inst *inst, *newinst;

	if (sp->u.u_proc->defn.in != STOP)
		free((char *) sp->u.u_proc->defn.in);
	free_list(&(sp->u.u_proc->list));
	sp->u.u_proc->list = p_symlist;
	p_symlist = (Symlist *)0;
	sp->u.u_proc->size =(unsigned)(progp - progbase);
	sp->u.u_proc->defn.in = (Inst *) emalloc((unsigned)(progp-progbase)*sizeof(Inst));
	newinst = sp->u.u_proc->defn.in;
	for (inst = progbase; inst != progp; )
		*newinst++ = *inst++;
	progp = progbase;	/* next code starts here */
}

void frame_debug(void)	/* print the call sequence on an execerror */
{
	Frame *f;
	int i, j;
	char id[10];

	if (nrnmpi_numprocs_world > 1) {
		sprintf(id, "%d ", nrnmpi_myid_world);
	}else{
		id[0]='\0';
	}
	for (i=5, f=fp; f != frame && --i; f=f-1) { /* print only to depth of 5 */
		for (j=i; j; j--) {
			IGNORE(fputs("  ",stderr));
		}
		if (f->ob) {
			Fprintf(stderr, "%s%s.%s(", id, hoc_object_name(f->ob), f->sp->name);
		}else{
			Fprintf(stderr, "%s%s(", id, f->sp->name);
		}
		for (j=1; j<=f->nargs;) {
		   switch(f->argn[(j - f->nargs)*2 + 1].i) {
		   case NUMBER:
			Fprintf(stderr, "%g", f->argn[(j - f->nargs)*2].val);
			break;
		   case STRING:
			{
			char* s = *f->argn[(j - f->nargs)*2].pstr;
			if(strlen(s) > 15) {
			   	Fprintf(stderr, "\"%.10s...\"", s);
			}else{
			   	Fprintf(stderr, "\"%s\"", s);
			}
			}
			break;
		   case OBJECTVAR:
Fprintf(stderr, "%s", hoc_object_name(*f->argn[(j - f->nargs)*2].pobj));
			break;
		   default:
		   	Fprintf(stderr, "...");
		   	break;
		   }
			if (++j <= f->nargs) {
				fprintf(stderr, ", ");
			}
		}
		IGNORE(fputs(")\n", stderr));
	}
	if (i <= 0) {
		Fprintf(stderr, "and others\n");
	}
}

void push_frame(Symbol* sp, int narg) { /* helpful for explicit function calls */
	if (++fp >= framelast) {
		--fp;
		execerror(sp->name, "call nested too deeply, increase with -NFRAME framesize option");
	}
	fp->sp = sp;
	fp->nargs = narg;
	fp->argn = stackp - 2;	/* last argument */
	fp->ob = hoc_thisobject;
}

void pop_frame(void) {
	int i;
	frameobj_clean(fp);
	for (i = 0; i < fp->nargs; i++)
		nopopm();	/* pop arguments */
	--fp;
}

void call(void)		/* call a function */
{
	int i, isec;
	Symbol *sp = pc[0].sym;	/* symbol table entry */
					/* for function */
	if (++fp >= framelast) {
		--fp;
		execerror(sp->name, "call nested too deeply, increase with -NFRAME framesize option");
	}
	fp->sp = sp;
	fp->nargs = pc[1].i;
	fp->retpc = pc + 2;
	fp->ob = hoc_thisobject;
	/*SUPPRESS 26*/
	fp->argn = stackp - 2;	/* last argument */
	BBSPOLL
#if CABLE
	isec = nrn_isecstack();
#endif
	if (sp->type == FUN_BLTIN || sp->type == OBJECTFUNC || sp->type == STRINGFUNC) {
		stackp += sp->u.u_proc->nauto * 2;	/* Offset stack for auto space */
		STACKCHK
		(*(sp->u.u_proc->defn.pf))();
		if (hoc_errno_check()) {
			hoc_warning("errno set during call of", sp->name);
		}
	} else if ((sp->type == FUNCTION || sp->type == PROCEDURE || sp->type == HOCOBJFUNCTION)
		&& sp->u.u_proc->defn.in != STOP) {
		stackp += sp->u.u_proc->nauto * 2;	/* Offset stack for auto space */
		STACKCHK
		/* clear the autoobject pointers. */
		for (i = sp->u.u_proc->nobjauto; i > 0; --i) {
			stackp[-2*i].obj = (Object*)0;
		}
		if (sp->public == 2) {
			Objectdata* odsav = hoc_objectdata_save();
			Object* obsav = hoc_thisobject;
			Symlist* slsav = hoc_symlist;

			hoc_objectdata = hoc_top_level_data;
			hoc_thisobject = 0;
			hoc_symlist = hoc_top_level_symlist;

			execute(sp->u.u_proc->defn.in);

			hoc_objectdata = hoc_objectdata_restore(odsav);
			hoc_thisobject = obsav;
			hoc_symlist = slsav;
		}else{
			execute(sp->u.u_proc->defn.in);
		}
		/* the autoobject pointers were unreffed at the ret() */
		
	} else {
		execerror(sp->name, "undefined function");
	}
#if CABLE
	if (hoc_returning) {nrn_secstack(isec);}
#endif
	if (hoc_returning != 4) {	/*if not stopping */
		hoc_returning = 0;
	}
}

void hoc_fake_call(Symbol* s) {
	/*fake it so c code can call functions that ret() */
	/* but these functions better not ask for any arguments */
	/* don't forget a double is left on the stack and returning = 1 */
	/* use the symbol for the function as the argument, only requirement
	   which is always true is that it has no local variables pushed on
	   the stack so nauto=0 and nobjauto=0 */
	++fp;
	fp->sp = s;
	fp->nargs = 0;
	fp->retpc = pc;
	fp->ob = 0;
}

double hoc_call_func(Symbol* s, int narg) {
	/* call the symbol as a function, The args better be pushed on the stack
	first arg first. */
	if (s->type == BLTIN) {
		return (*(s->u.ptr))(xpop());
	}else{
		Inst* pcsav;
		Inst fc[4];
		fc[0].pf = hoc_call;
		fc[1].sym = s;
		fc[2].i = narg;
		fc[3].in = STOP;

		pcsav = hoc_pc;
		hoc_execute(fc);
		hoc_pc = pcsav;
		return hoc_xpop();
	}
}

void hoc_ret(void) {		/* common return from func, proc, or iterator */
	int i;
	/* unref all the auto object pointers */
	for (i = fp->sp->u.u_proc->nobjauto; i > 0; --i) {
		hoc_obj_unref(stackp[-2*i].obj);
	}
	stackp -= fp->sp->u.u_proc->nauto * 2;	/* Pop off the autos */
	frameobj_clean(fp);
	for (i = 0; i < fp->nargs; i++)
		nopopm();	/* pop arguments */
	pc = (Inst *)fp->retpc;
	--fp;
	hoc_returning = 1;
}

void funcret(void)	/* return from a function */
{
	double d;
	if (fp->sp->type != FUNCTION)
		execerror(fp->sp->name, "(proc or iterator) returns value");
	d = xpopm();	/* preserve function return value */
	ret();
	pushxm(d);
}

void procret(void)	/* return from a procedure */
{
	if (fp->sp->type == FUNCTION)
		execerror(fp->sp->name,
			"(func) returns no value");
	if (fp->sp->type == HOCOBJFUNCTION)
		execerror(fp->sp->name,
			"(obfunc) returns no value");
	ret();
	pushxm(0.);	/*will be popped immediately; necessary because caller
					may have compiled it as a function*/
}

void hocobjret(void)	/* return from a hoc level obfunc */
{
	Object** d;
	if (fp->sp->type != HOCOBJFUNCTION)
		execerror(fp->sp->name, "objfunc returns objref");
	d = hoc_objpop();	/* preserve function return value */
	if (*d) { (*d)->refcount++;}
	ret();
	/*make a temp and ref it in case autoobj returned since ret would
	have unreffed it*/
	hoc_push_object(*d);
	
	if (*d) { (*d)->refcount--;}
	hoc_tobj_unref(d);
}

void hoc_Numarg(void)
{
	int narg;
	Frame* f = fp - 1;
	if (f == frame) {
		narg = 0;
	}else{
		narg = f->nargs;
	}
	ret();
	pushxm((double)narg);
}

void hoc_Argtype(void)
{
	int narg, iarg, type, itype=0;
	Frame* f = fp - 1;
	if (f == frame) {
		execerror("argtype can only be called in a func or proc", 0);
	}
	iarg = (int)chkarg(1, -1000., 100000.);
	if (iarg > f->nargs || iarg < 1) {
		itype = -1;
	}else{
		type = (f->argn[(iarg - f->nargs)*2 + 1].i);
		switch (type) {
			case NUMBER: itype = 0; break;
			case OBJECTVAR:
			case OBJECTTMP: itype = 1; break;
			case STRING: itype = 2; break;
			case VAR: itype = 3; break;
		}
	}
	ret();
	pushxm((double)itype);
}

int ifarg(int narg) {	/* true if there is an nth argument */
	if (narg > fp->nargs)
		return 0;
	return 1;
}

Object** hoc_objgetarg(int narg) {/* return pointer to nth argument */
	Datum* d;
	if (narg > fp->nargs)
		execerror(fp->sp->name, "not enough arguments");
	d = fp->argn + (narg - fp->nargs)*2;
	if (d[1].i == OBJECTTMP) {
		return hoc_temp_objptr(d[0].obj);
	}
	tstkchk(d[1].i, OBJECTVAR);
	return d[0].pobj;
}

char** hoc_pgargstr(int narg) {	/* return pointer to nth argument */
	char ** cpp = NULL;
	Symbol *sym;
	int type;
	if (narg > fp->nargs)
		execerror(fp->sp->name, "not enough arguments");
	type = fp->argn[(narg - fp->nargs)*2 + 1].i;
   if (type == STRING) {
	cpp = fp->argn[(narg - fp->nargs)*2].pstr;
   }else if (type != SYMBOL) {
	execerror("Expecting string argument", (char *)0);
   }else{
	sym = fp->argn[(narg - fp->nargs)*2].sym;
	if (sym->type == CSTRING) {
		cpp = &sym->u.cstr;
	}else if (sym->type == STRING) {
		cpp = OPSTR(sym);
	}else{
		execerror("Expecting string argument", (char *)0);
	}
   }
	return cpp;
}

double* hoc_pgetarg(int narg) {	/* return pointer to nth argument */
	if (narg > fp->nargs)
		execerror(fp->sp->name, "not enough arguments");
	tstkchk(fp->argn[(narg - fp->nargs)*2 + 1].i, VAR);
	return fp->argn[(narg - fp->nargs)*2].pval;
}

double* getarg(int narg) {	/* return pointer to nth argument */
	if (narg > fp->nargs)
		execerror(fp->sp->name, "not enough arguments");
#if 1
	tstkchk(fp->argn[(narg - fp->nargs)*2 + 1].i, NUMBER);
#endif
	return &fp->argn[(narg - fp->nargs)*2].val;
}

int hoc_argindex(void) {
	int j;
	j = (int)xpopm();
	if (j < 1) {
		hoc_execerror("arg index i < 1", 0);
	}
	return j;
}

void arg(void)	/* push argument onto stack */
{
	int i;
	i = (pc++)->i;
	if (i == 0) {
		i = hoc_argindex();
	}
	pushxm( *getarg(i));
}

void hoc_stringarg(void) /* push string arg onto stack */
{
	int i;
	i = (pc++)->i;
	if (i == 0) {
		i = hoc_argindex();
	}
	hoc_pushstr(hoc_pgargstr(i));
}

double hoc_opasgn(int op, double dest, double src) {
	switch (op) {
	case '+':
		return dest + src;
	case '*':
		return dest * src;
	case '-':
		return dest - src;
	case '/':
		if (src == 0.) {
			hoc_execerror("Divide by 0", (char*)0);
		}
		return dest / src;
	default:
		return src;
	}
}
void argassign(void)	/* store top of stack in argument */
{
	double d;
	int i, op;
	i = (pc++)->i;
	if (i == 0) {
		i = hoc_argindex();
	}
	op = (pc++)->i;
	d = xpopm();
	if (op) {
		d = hoc_opasgn(op, *getarg(i), d);
	}
	pushxm(d);	/* leave value on stack */
	*getarg(i) = d;
}

void hoc_argrefasgn(void) {
	double d, *pd;
	int i, j, op;
	i = (pc++)->i;
	j = (pc++)->i;
	if (i == 0) {
		i = hoc_argindex();
	}
	op = (pc++)->i;
	d = xpopm();
	if (j) {
		j = (int)(xpopm() + EPS);
	}
	pd = hoc_pgetarg(i);
	if (op) {
		d = hoc_opasgn(op, pd[j], d);
	}
	pushxm(d);	/* leave value on stack */
	pd[j] = d;
}

void hoc_argref(void) {
	int i, j;
	double* pd;
	i = (pc++)->i;
	j = (pc++)->i;
	if (i == 0) {
		i = hoc_argindex();
	}
 	pd = hoc_pgetarg(i);
	if (j) {
		j = (int)(xpopm() + EPS);
	}
 	pushxm(pd[j]);
}

void hoc_argrefarg(void) {
	double* pd;
	int i;
	i = (pc++)->i;
	if (i == 0) {
		i = hoc_argindex();
	}
	pd = hoc_pgetarg(i);
	hoc_pushpx(pd);
}

void bltin(void)		/* evaluate built-in on top of stack */
{
	double d;
	d = xpopm();
	d = (*((pc++)->sym->u.ptr))(d);
	pushxm(d);
}

Symbol* hoc_get_symbol(const char* var) {
	Symlist *sl = (Symlist *)0;
	Symbol *prc, *sym;
	Inst* last;
	prc = hoc_parse_stmt(var, &sl);
	hoc_run_stmt(prc);

	last = (Inst*)prc->u.u_proc->defn.in + prc->u.u_proc->size - 1;
	if (last[-2].pf == eval) {
		sym = last[-3].sym;
	}else if (last[-3].pf == rangepoint || last[-3].pf == rangevareval) {
		sym = last[-2].sym;
	}else if (last[-4].pf == hoc_object_eval) {
		sym = last[-10].sym;
	}else{
		sym = (Symbol*)0;
	}
	free_list(&sl);
	return sym;
}

Symbol* hoc_get_last_pointer_symbol(void) {/* hard to imagine a kludgier function*/
	Symbol* sym = (Symbol*)0;
	Inst* pcv;
	int istop=0;
	for (pcv = pc; pcv; --pcv) {
		if (pcv->pf == hoc_ob_pointer) {
			if (pcv[-2].sym) {
				sym = pcv[-2].sym; /* e.g. &ExpSyn[0].A */
			}else{
				sym = pcv[-6].sym; /* e.g. & Cell[0].soma.v(.5) */
			}
			break;
		}else if (pcv->pf == hoc_evalpointer) {
			sym = pcv[-1].sym;
			break;
		}else if (pcv->pf == rangevarevalpointer) {
			sym = pcv[1].sym;
			break;
		}else if (pcv->in == STOP) {
/* hopefully only got here from python. Give up on second STOP*/
			if (istop++ == 1) {
				break;
			}
		}
	}
	return sym;
}

void hoc_autoobject(void) { /* AUTOOBJ symbol at pc+1. */
		  /* pointer to object pointer left on stack */
	int i;
	Symbol *obs;
	Object **obp;
#if PDEBUG
	printf("code for hoc_autoobject()\n");
#endif
	obs = (pc++)->sym;
	hoc_pushobj(&(fp->argn[obs->u.u_auto*2].obj));
}

void eval(void)			/* evaluate variable on stack */
{
	Objectdata* odsav;
	Object* obsav = 0;
	Symlist* slsav;
	double d=0.0, cable_prop_eval();
	Symbol *sym;
	sym = spopm();
    if (sym->public == 2) {
	sym = sym->u.sym;
	odsav = hoc_objectdata_save();
	obsav = hoc_thisobject;
	slsav = hoc_symlist;
	hoc_objectdata = hoc_top_level_data;
	hoc_thisobject = 0;
	hoc_symlist = hoc_top_level_symlist;
    }
	switch (sym->type)
	{
	case UNDEF:
		execerror("undefined variable", sym->name);
	case VAR:
if (!ISARRAY(sym)) {
		if (do_equation && sym->s_varn > 0
		&& hoc_access[sym->s_varn] == 0)
		{
			hoc_access[sym->s_varn] = var_access;
			var_access = sym->s_varn;
		}
		switch (sym->subtype) {
		case USERDOUBLE:
			d = *(sym->u.pval);
			break;
		case USERINT:
			d = (double)(*(sym->u.pvalint));
			break;
#if	CABLE
		case USERPROPERTY:
			d = cable_prop_eval(sym);
			break;
#endif
		case USERFLOAT:
			d = (double)(*(sym->u.pvalfloat));
			break;
		default:
			d = *(OPVAL(sym));
			break;
		}
}else {
		switch (sym->subtype) {
		case USERDOUBLE:
			d = (sym->u.pval)[araypt(sym, SYMBOL)];
			break;
		case USERINT:
			d = (sym->u.pvalint)[araypt(sym, SYMBOL)];
			break;
		case USERFLOAT:
			d = (sym->u.pvalfloat)[araypt(sym, SYMBOL)];
			break;
#if NEMO
		case NEMONODE:
			hoc_eval_nemonode(sym, xpopm(), &d);
			break;
		case NEMOAREA:
			hoc_eval_nemoarea(sym, xpopm(), &d);
			break;
#endif /*NEMO*/
		default:
			d = (OPVAL(sym))[araypt(sym, OBJECTVAR)];
			break;
		}
}
		break;
	case AUTO:
		d = fp->argn[sym->u.u_auto*2].val;
		break;
	default:
		execerror("attempt to evaluate a non-variable", sym->name);
	}

    if (obsav) {
	hoc_objectdata = hoc_objectdata_restore(odsav);
	hoc_thisobject = obsav;
	hoc_symlist = slsav;
    }
	pushxm(d);
}

void hoc_evalpointer(void)			/* leave pointer to variable on stack */
{
	Objectdata* odsav;
	Object* obsav = 0;
	Symlist* slsav;
	double *d=0, *cable_prop_eval_pointer();
	Symbol *sym;
	sym = spopm();
    if (sym->public == 2) {
	sym = sym->u.sym;
	odsav = hoc_objectdata_save();
	obsav = hoc_thisobject;
	slsav = hoc_symlist;
	hoc_objectdata = hoc_top_level_data;
	hoc_thisobject = 0;
	hoc_symlist = hoc_top_level_symlist;
    }
	switch (sym->type)
	{
	case UNDEF:
		execerror("undefined variable", sym->name);
	case VAR:
if (!ISARRAY(sym)) {
		switch (sym->subtype) {
		case USERDOUBLE:
			d = sym->u.pval;
			break;
		case USERINT:
		case USERFLOAT:
			execerror("can use pointer only to doubles", sym->name);
			break;
#if	CABLE
		case USERPROPERTY:
			d = cable_prop_eval_pointer(sym);
			break;
#endif
		default:
			d = OPVAL(sym);
			break;
		}
}else {
		switch (sym->subtype) {
		case USERDOUBLE:
			d = sym->u.pval + araypt(sym, SYMBOL);
			break;
		case USERINT:
		case USERFLOAT:
#if NEMO
		case NEMONODE:
		case NEMOAREA:
#endif /*NEMO*/
			execerror("can use pointer only to doubles", sym->name);
			break;
		default:
			d = OPVAL(sym) + araypt(sym, OBJECTVAR);
			break;
		}
}
		break;
	case AUTO:
#if 0
		execerror("can't use pointer to local variable", sym->name);
#else
		d = &(fp->argn[sym->u.u_auto*2].val);
#endif
		break;
	default:
		execerror("attempt to evaluate pointer to a non-variable", sym->name);
	}
    if (obsav) {
	hoc_objectdata = hoc_objectdata_restore(odsav);
	hoc_thisobject = obsav;
	hoc_symlist = slsav;
    }
	hoc_pushpx(d);
}

void add(void)		/* add top two elems on stack */
{
	double d1, d2;
	d2 = xpopm();
	d1 = xpopm();
	d1 += d2;
	pushxm(d1);
}

void hoc_sub(void)		/* subtract top two elems on stack */
{
	double d1, d2;
	d2 = xpopm();
	d1 = xpopm();
	d1 -= d2;
	pushxm(d1);
}

void mul(void)		/* multiply top two elems on stack */
{
	double d1, d2;
	d2 = xpopm();
	d1 = xpopm();
	d1 *= d2;
	pushxm(d1);
}

#if _CRAY
/*
  try to do integer division, so that if x is an exact multiple of y
  then we really get an integer as the result.
  Algorithm: find n such that tx = x * 10^n and ty = y * 10^n are both
  integral.  If tx/ty leaves no remainder, then tx/ty is the correct
  answer and is stored in iptr, intdiv returns true.  Otherwise a
  floating point division can be done, intdiv returns false.
*/   

static int intdiv(double x, double y, int* iptr) {
  long ix, iy, iz;
  int done = 0;
  while (!done)
    {
      if (fabs(x) > (1<<62) || fabs(y) > (1<<62))
      return 0;               /* out of range of integers */
      if (x == (long) x && y == (long) y)
      done = 1;
      else
      {
        x *= (long double) 10;
        y *= (long double) 10;
      }
    }
  ix = (long) x;
  iy = (long) y;
  iz = ix/iy;
  if (ix == iz*iy)
    {                         /* no remainder */
      *iptr = (int) iz;
      return 1;
    }
  return 0;
}
#endif

void hoc_div(void)		/* divide top two elems on stack */
{
	double d1, d2;
	d2 = xpopm();
	if (d2 == 0.0)
		execerror("division by zero", (char *) 0);
	d1 = xpopm();
#if _CRAY
      {
        int i;
        if (intdiv(d1, d2, &i))
          d1 = (int) i;       /* result is an integer */
        else
          d1 = d1/d2;         /* result is not an integer */
      }
#else
      d1 /= d2;
#endif
	pushxm(d1);
}

void hoc_cyclic(void)	/* the modulus function */
{
	double d1, d2;
	double r, q;
	d2 = xpopm();
	if (d2 <= 0.)
		execerror("a%b, b<=0", (char *) 0);
	d1 = xpopm();
	r = d1;
	if ( r >= d2) {
		q = floor(d1/d2);
		r = d1 - q*d2;
	}
	else if ( r <= -d2) {
		q = floor(-d1/d2);
		r = d1 + q*d2;
	}
	if (r > d2) {
		r = r - d2;
	}
	if (r < 0.) {
		r = r + d2;
	}

	pushxm(r);
}

void negate(void)		/* negate top element on stack */
{
	double d;
	d = xpopm();
	pushxm(-d);
}

void gt(void)
{
	double d1, d2;
	d2 = xpopm();
	d1 = xpopm();
	d1 = (double)(d1 > d2 + EPS);
	pushxm(d1);
}

void lt(void)
{
	double d1, d2;
	d2 = xpopm();
	d1 = xpopm();
	d1 = (double)(d1 < d2 - EPS);
	pushxm(d1);
}

void ge(void)
{
	double d1, d2;
	d2 = xpopm();
	d1 = xpopm();
	d1 = (double)(d1 >= d2 - EPS);
	pushxm(d1);
}

void le(void)
{
	double d1, d2;
	d2 = xpopm();
	d1 = xpopm();
	d1 = (double)(d1 <= d2 + EPS);
	pushxm(d1);
}

void eq(void)
{
	int t1, t2;
	double d1=0.0, d2;
	t1 = (stackp-1)->i;
	t2 = (stackp-3)->i;
	switch (t2) {
	case NUMBER:
		tstkchk(t1, t2);
		d2 = xpopm();
		d1 = xpopm();
		d1 = (double)(d1 <= d2 + EPS && d1 >= d2 - EPS);
		break;
	case STRING:
		d1 = (double)(strcmp(*hoc_strpop(), *hoc_strpop()) == 0);
		break;
	case OBJECTTMP:
	case OBJECTVAR:
		{ Object** o1, **o2;
		o1 = hoc_objpop();
		o2 = hoc_objpop();
		d1 = (double)(*o1 == *o2);
		hoc_tobj_unref(o1);
		hoc_tobj_unref(o2);
		}
		break;
	default:
		hoc_execerror("don't know how to compare these types", (char*)0);
	}
	pushxm(d1);
}

void ne(void)
{
	int t1, t2;
	double d1=0.0, d2;
	t1 = (stackp-1)->i;
	t2 = (stackp-3)->i;
	switch (t1) {
	case NUMBER:
		tstkchk(t1, t2);
		d2 = xpopm();
		d1 = xpopm();
		d1 = (double)(d1 < d2 - EPS || d1 > d2 + EPS);
		break;
	case STRING:
		d1 = (double)(strcmp(*hoc_strpop(), *hoc_strpop()) != 0);
		break;
	case OBJECTTMP:
	case OBJECTVAR:
		{ Object** o1, **o2;
		o1 = hoc_objpop();
		o2 = hoc_objpop();
		d1 = (double)(*o1 != *o2);
		hoc_tobj_unref(o1);
		hoc_tobj_unref(o2);
		}
		break;
	default:
		hoc_execerror("don't know how to compare these types", (char*)0);
	}
	pushxm(d1);
}

void hoc_and(void)
{
	double d1, d2;
	d2 = xpopm();
	d1 = xpopm();
	d1 = (double)(d1 != 0.0 && d2 != 0.0);
	pushxm(d1);
}

void hoc_or(void)
{
	double d1, d2;
	d2 = xpopm();
	d1 = xpopm();
	d1 = (double)(d1 != 0.0 || d2 != 0.0);
	pushxm(d1);
}

void hoc_not(void)
{
	double d;
	d = xpopm();
	d = (double)(d == 0.0);
	pushxm(d);
}

void power(void)			/* arg1 raised to arg2 */
{
	double d1, d2;
	extern double Pow();
	d2 = xpopm();
	d1 = xpopm();
	d1 = Pow(d1, d2);
	pushxm(d1);
}

void assign(void)	/* assign result of execute to top symbol */
{
	Objectdata* odsav;
	Object* obsav = 0;
	Symlist* slsav;
	int op;
	Symbol *sym;
	double d2;
	op = (pc++)->i;
	sym = spopm();
    if (sym->public == 2) {
	sym = sym->u.sym;
	odsav = hoc_objectdata_save();
	obsav = hoc_thisobject;
	slsav = hoc_symlist;
	hoc_objectdata = hoc_top_level_data;
	hoc_thisobject = 0;
	hoc_symlist = hoc_top_level_symlist;
    }
	d2 = xpopm();
	switch (sym->type)
	{
	case UNDEF:
		hoc_execerror(sym->name, "undefined variable");
	case VAR:
if(!ISARRAY(sym)) {
		switch (sym->subtype) {
		case USERDOUBLE:
			if (op) {
				d2 = hoc_opasgn(op, *(sym->u.pval), d2);
			}
			*(sym->u.pval) = d2;
			break;
		case USERINT:
			if (op) {
				d2 = hoc_opasgn(op, (double)(*(sym->u.pvalint)), d2);
			}
			*(sym->u.pvalint) = (int)(d2 + EPS);
			break;
#if	CABLE
		case USERPROPERTY:
			cable_prop_assign(sym, &d2, op);
			break;
#endif
		case USERFLOAT:
			if (op) {
				d2 = hoc_opasgn(op, (double)(*(sym->u.pvalfloat)), d2);
			}
			*(sym->u.pvalfloat) = (float)(d2);
			break;
		default:
			if (op) {
				d2 = hoc_opasgn(op, *(OPVAL(sym)), d2);
			}
			*(OPVAL(sym)) = d2;
			break;
		}
}else {
		int ind;
		switch (sym->subtype) {
		case USERDOUBLE:
			ind = araypt(sym, SYMBOL);
			if (op) {
				d2 = hoc_opasgn(op, (sym->u.pval)[ind], d2);
			}
			(sym->u.pval)[ind] = d2;
			break;
		case USERINT:
			ind = araypt(sym, SYMBOL);
			if (op) {
				d2 = hoc_opasgn(op, (double)((sym->u.pvalint)[ind]), d2);
			}
			(sym->u.pvalint)[ind] = (int)(d2 + EPS);
			break;
		case USERFLOAT:
			ind = araypt(sym, SYMBOL);
			if (op) {
				d2 = hoc_opasgn(op, (double)((sym->u.pvalfloat)[ind]), d2);
			}
			(sym->u.pvalfloat)[ind] = (float)d2;
			break;
#if NEMO
		case NEMONODE:
			hoc_asgn_nemonode(sym, xpopm(), &d2, op);
			break;
		case NEMOAREA:
			hoc_asgn_nemoarea(sym, xpopm(), &d2, op);
			break;
#endif /*NEMO*/
		default:
			ind = araypt(sym, OBJECTVAR);
			if (op) {
				d2 = hoc_opasgn(op, (OPVAL(sym))[ind], d2);
			}
			(OPVAL(sym))[ind] = d2;
			break;
		}
}
		break;
	case AUTO:
		if (op) {
			d2 = hoc_opasgn(op, fp->argn[sym->u.u_auto*2].val, d2);
		}
		fp->argn[sym->u.u_auto*2].val = d2;
		break;
	default:
		execerror("assignment to non-variable", sym->name);
	}
    if (obsav) {
	hoc_objectdata = hoc_objectdata_restore(odsav);
	hoc_thisobject = obsav;
	hoc_symlist = slsav;
    }
	pushxm(d2);
}

void hoc_assign_str(char** cpp, const char* buf) {
	char* s = *cpp;
	*cpp = (char *)emalloc((unsigned)(strlen(buf) + 1));
	Strcpy(*cpp, buf);
	if (s) {
		hoc_free_string(s);
	}
}

void assstr(void) {	/* assign string on top to stack - 1 */
	char **ps1, **ps2;

	ps1 = hoc_strpop();
	ps2 = hoc_strpop();
	hoc_assign_str(ps2, *ps1);
}

char* hoc_araystr(Symbol* sym, int index, Objectdata* obd) { /* returns array string for multiple dimensions */
	static char name[100];
	char *cp = name+100;
	char buf[20];
	int i, n, j, n1;

	*--cp = '\0';
	if (ISARRAY(sym)) {
		Arrayinfo* a;
		if (sym->subtype == 0) {
			a = obd[sym->u.oboff + 1].arayinfo;
		}else{
			a = sym->arayinfo;
		}
		for (i = a->nsub - 1; i >= 0; --i) {
			n = a->sub[i];
			j = index%n;
			index /= n;
			Sprintf(buf, "%d", j);
			n1 = strlen(buf);
			assert(n1 + 2 < cp - name);
			*--cp = ']';
			for (j = n1-1; j >=0; --j) {
				*--cp = buf[j];
			}
			*--cp = '[';
		}
	}
	return cp;
}

int hoc_array_index(Symbol* sp, Objectdata* od) {  /* subs must be in reverse order on stack */
	int i;
	if (ISARRAY(sp)) {
		if (sp->subtype == 0) {
			Objectdata* sav = hoc_objectdata;
			hoc_objectdata = od;
			i = araypt(sp, OBJECTVAR);
			hoc_objectdata = sav;
		}else{
			i = araypt(sp, 0);
		}
	}else{
		i= 0;
	}
	return i;
}

int araypt(Symbol* sp, int type) {	/* return subscript - subs in reverse order on stack */
	int i, total, varn;
	int d;
	register Arrayinfo *aray;
	if (type == OBJECTVAR) {
		aray = OPARINFO(sp);
	}else{
		aray = sp->arayinfo;
	}

	total = 0;
	for (i = 0; i < aray->nsub; i++)
	{
		tstkchk((stackp - 2*(aray->nsub - i) + 1)->i, NUMBER);
		d = (int)((stackp - 2*(aray->nsub - i))->val + EPS);
		if (d < 0 || d >= aray->sub[i])
			execerror("subscript out of range", sp->name);
		total = total * (aray->sub[i]) + d;
	}
	for (i = 0; i< aray->nsub; i++)
		nopopm();
	if (do_equation && sp->s_varn != 0
	&& (varn = (aray->a_varn)[total]) != 0 && hoc_access[varn] == 0)
	{
		hoc_access[varn] = var_access;
		var_access = varn;
	}
	return total;
}

/* obsolete */
#if CABLE && 0
int nrnpnt_araypt(Symbol* sp, int pi) {
	int i, total;
	int d;
	register Arrayinfo *aray = sp->arayinfo;
	/* the difference is that the first index is for a neuron point
	   process vector, and the remaining incices are normal vector indices.
	   the return value is the parameter index and the first
	   index is returned in pi. return is 0 if not a vector or if element 0.
	*/
	total = 0;
	for (i = 0; i < aray->nsub; i++)
	{
		tstkchk((stackp - 2*(aray->nsub - i) + 1)->i, NUMBER);
		d = (int)((stackp - 2*(aray->nsub - i))->val + EPS);
		if (d < 0 || d >= aray->sub[i])
			execerror("subscript out of range", sp->name);
		total = total * (aray->sub[i]) + d;
		if (i == 0) {
			*pi = total;
			total = 0;
		}
	}
	for (i = 0; i< aray->nsub; i++)
		nopopm();
	return total;
}
#endif

void print(void) /* pop top value from stack, print it */
{
#if defined(__GO32__)
	extern int egagrph;
	if (egagrph) {
		char buf[50];
		sprintf(buf, "\t");
		grx_output_some_chars(buf, strlen(buf));
		prexpr();
		grx_output_some_chars("\n", 1);
	}else
#endif
	{
	nrnpy_pr("\t");
	prexpr();
	nrnpy_pr("\n");
	}
}

void prexpr(void)	/* print numeric value */
{
	static HocStr* s;
	char *hoc_object_name();
	char * ss;
#if CABLE
	char* secaccessname();
#endif
	Object** pob;
	
	if (!s) s = hocstr_create(256);
	switch (hoc_stacktype()) {
	case NUMBER:
		Sprintf(s->buf, "%.8g ", xpopm());
		break;
	case STRING:
		ss = *(hoc_strpop());
		hocstr_resize(s, strlen(ss) + 1);
		Sprintf(s->buf, "%s ", ss);
		break;
	case OBJECTTMP:
	case OBJECTVAR:		
		pob = hoc_objpop();
		Sprintf(s->buf, "%s ", hoc_object_name(*pob));
		hoc_tobj_unref(pob);
		break;
#if 0 && CABLE
	case SECTION:
		Sprintf(s->buf, "%s ", secaccessname());
		break;
#endif
	default:
		hoc_execerror("Don't know how to print this type\n", 0);
	}
	plprint(s->buf);

}

void prstr(void)		/* print string value */
{
	static HocStr* s;
	char **cpp;
	if (!s) s = hocstr_create(256);
	cpp = hoc_strpop();
	hocstr_resize(s, strlen(*cpp)+10);
	Sprintf(s->buf, "%s", *cpp);
	plprint(s->buf);
}

/*-----------------------------------------------------------------*/
void hoc_delete_symbol(void)
                 /* Added 15-JUN-90 by JCW.  This routine deletes a
                 "defined-on-the-fly" variable from the symbol
                 list. */
		/* modified greatly by Hines. Very unsafe in general. */
{
#if 1
                                       /*---- local variables -----*/
    Symbol * doomed,
           * sp;
                                       /*---- start function ------*/

                /* copy address of the symbol that will be deleted */
    doomed = (pc++)->sym;

#endif
/*	hoc_execerror("delete_symbol doesn't work right now.", (char *)0);*/
#if 1
    if (doomed->type == UNDEF)
        fprintf(stderr, "%s: no such variable\n", doomed->name);
    else if (doomed->defined_on_the_fly == 0)
        fprintf(stderr, "%s: can't be deleted\n", doomed->name);
    else {
	hoc_free_symspace(doomed);
    }
#endif
}
/*----------------------------------------------------------*/

void hoc_newline(void)		/* print newline */
{
	plprint("\n");
}

void varread(void)	/* read into variable */
{
	double d=0.0;
	extern NrnFILEWrap *fin;
	Symbol *var = (pc++)->sym;

	assert(var->public != 2);
	if (! ((var->type == VAR || var->type == UNDEF) && !ISARRAY(var)
	       && var->subtype == NOTUSER
	      )
	   ) {
		execerror(var->name, "is not a scalar variable");
	}
  Again:
	switch (nrn_fw_fscanf(fin, "%lf", OPVAL(var)))
	{
	case EOF:
		if (moreinput())
			goto Again;
		d = *(OPVAL(var)) = 0.0;
		break;
	case 0:
		execerror("non-number read into", var->name);
		break;
	default:
		d = 1.0;
		break;
	}
	var->type = VAR;
	pushxm(d);
}


static Inst* codechk(void) {
	if (progp >= prog+NPROG-1)
		execerror("procedure too big", (char *) 0);
	if (zzdebug)
		debugzz(progp);
	return progp++;
}

Inst* Code(Pfrv f) {		/* install one instruction or operand */
	progp->pf = f;
	return codechk();
}

Inst* codei(int f)
{
	progp->i = f;
	return codechk();
}

Inst* hoc_codeptr(void* vp)
{
	progp->ptr = vp;
	return codechk();
}

void codesym(Symbol* f)
{
	progp->sym = f;
	IGNORE(codechk());
}

void codein(Inst* f)
{
	progp->in = f;
	IGNORE(codechk());
}

void insertcode(Inst* begin, Inst* end, Pfrv f)
{
	Inst *i;
	for (i = end - 1; i != begin; i--) {
		*i = *(i - 1);
	}
	begin->pf = f;

	if(zzdebug) {
		Inst* p;
		printf("insert code: what follows is the entire code so far\n");
		for (p = prog; p < progp; ++p) {
			debugzz(p);
		}
		printf("end of insert code debugging\n");
	}
}

#if defined(DOS) || defined(__GO32__) || defined (WIN32) || (MAC && !defined(DARWIN))
static int ntimes;
#endif

void execute(Inst* p)	/* run the machine */
{
	Inst *pcsav;
	
	BBSPOLL
	for (pc = p; pc->in != STOP && !hoc_returning; )
	{
#if defined(DOS)
		if (++ntimes > 10) {
			ntimes = 0;
#if 0
			kbhit(); /* DOS can't capture interrupt when number crunching*/
#endif
		}
#endif
#if defined(__GO32__) || (defined(WIN32) && !defined(CYGWIN))
		if (++ntimes > 10) {
			ntimes = 0;
			hoc_check_intupt(1);
		}
#endif
#if MAC && !defined(DARWIN)
		/* there is significant overhead here */
		if (++ntimes > 100) {
			ntimes = 0;
			hoc_check_intupt(1);
		}
#endif
		if (intset)
			execerror("interrupted", (char *)0);
		/* (*((pc++)->pf))(); DEC 5000 increments pc after the return!*/
		pcsav = pc++;
		(*((pcsav)->pf))();
	}
}
