/* $Header:eval.c 12.0$ */
/* $ACIS:eval.c 12.0$ */
/* $Source: /ibm/acis/usr/src/ucb/dbx/RCS/eval.c,v $ */

#ifndef lint
static char *rcsid = "$Header:eval.c 12.0$";
#endif

/* Copyright (c) 1982 Regents of the University of California */

/*
 * Tree evaluation.
 */

#include "defs.h"
#include "tree.h"
#include "operators.h"
#include "debug.h"
#include "eval.h"
#include "events.h"
#include "symbols.h"
#include "scanner.h"
#include "source.h"
#include "object.h"
#include "mappings.h"
#include "process.h"
#include "runtime.h"
#include "machine.h"
#include "version.h"
#include <signal.h>
#include <math.h>
#include <ieee.h>

#ifndef public

#include "machine.h"

#define STACKSIZE 20000

typedef Char Stack;

#define push(type, value) { \
    ((type *) (sp += sizeof(type)))[-1] = (value); \
}

#define pop(type) ( \
    (*((type *) (sp -= sizeof(type)))) \
)

#define popn(n, dest) { \
    sp -= n; \
    bcopy(sp, dest, n); \
}

#define alignstack() { \
    sp = (Stack *) (( ((int) sp) + sizeof(int) - 1)&~(sizeof(int) - 1)); \
}

#endif

public Stack stack[STACKSIZE];
public Stack *sp = &stack[0];
public Boolean useInstLoc = false;

#define chksp() \
{ \
    if (sp < &stack[0]) { \
	panic("stack underflow"); \
    } \
}

#define poparg(n, r, fr) { \
    eval(p->value.arg[n]); \
    if (isreal(p->op)) { \
	if (size(p->value.arg[n]->nodetype) == sizeof(float)) { \
	    fr = pop(float); \
	} else { \
	    fr = pop(double); \
	} \
    } else if (isint(p->op)) { \
	r = popsmall(p->value.arg[n]->nodetype); \
    } \
}

#define Boolrep char	/* underlying representation type for booleans */

/*
 * Command-level evaluation.
 */

public Node topnode;

public topeval (p)
Node p;
{
    if (traceeval) {
	fprintf(stderr, "topeval(");
	prtree(stderr, p);
	fprintf(stderr, ")\n");
	fflush(stderr);
    }
    topnode = p;
    eval(p);
}

/*
 * Evaluate a parse tree leaving the value on the top of the stack.
 */

public eval (p)
register Node p;
{
    long r0, r1;
    double fr0, fr1;
    Address addr;
    long n;
    unsigned len;
    Symbol s;
    Node n1, n2;
    boolean b;
    File file;
    String str;

    checkref(p);
    if (traceeval) {
	fprintf(stderr, "begin eval %s\n", opname(p->op));
    }
    switch (degree(p->op)) {
	case BINARY:
	    poparg(1, r1, fr1);
	    poparg(0, r0, fr0);
	    break;

	case UNARY:
	    poparg(0, r0, fr0);
	    break;

	default:
	    /* do nothing */;
    }
    switch (p->op) {
	case O_SYM:
	    s = p->value.sym;
	    if (s == retaddrsym) {
		push(long, return_addr());
	    } else if (isvariable(s)) {
		if (s != program && !isactive(container(s))) {
		    error("\"%s\" is not active", symname(s));
		}
		addr = address(s, nil);
		if (isvarparam(s) && !isopenarray(s)) {
		    if (s->storage == INREG || preg(s, nil) != -1) {
			pushregvalue(s, addr, nil, sizeof(Address));
		    } else {
			rpush(addr, sizeof(Address));
		    }
		} else {
		    push(Address, addr);
		}
	    } else if (isblock(s)) {
		push(Symbol, s);
	    } else if (isconst(s)) {
		eval(constval(s));
	    } else {
		error("can't evaluate a %s", classname(s));
	    }
	    break;

	case O_LCON:
	case O_CCON:
	    r0 = p->value.lcon;
	    pushsmall(size(p->nodetype), r0);
	    break;

	case O_FCON:
	    push(double, p->value.fcon);
	    break;

	case O_SCON:
	    len = size(p->nodetype);
	    mov(p->value.scon, sp, len);
	    sp += len;
	    break;

	case O_INDEX:
	    s = p->value.arg[0]->nodetype;
	    p->value.arg[0]->nodetype = t_addr;
	    eval(p->value.arg[0]);
	    p->value.arg[0]->nodetype = s;
	    n = pop(Address);
	    eval(p->value.arg[1]);
	    evalindex(s, n, popsmall(p->value.arg[1]->nodetype));
	    break;

	case O_DOT:
	    n1 = p->value.arg[0];
	    n2 = p->value.arg[1];
	    s = n1->nodetype;
	    n = regnum(s);
	    if (n == -1) {
		eval(n1);
	    } else {
		pushregvalue(s, n, nil, size(s));
	    }
	    n = pop(long);
	    r0 = n2->value.sym->symvalue.field.offset >> 3;
	    push(long, n + r0);
	    break;

	/*
	 * Pop an address and push the contents back on the stack.
	 * If the address is actually a register number, then push
	 * the (possibly saved on stack) register value(s).
	 */

	case O_INDIR:
	case O_RVAL:
	    addr = pop(long);
	    s = p->nodetype;
	    len = size(s);
	    if (s->class != REF &&
		(s->storage == INREG || (s->param && preg(s, nil) != -1))
	    ) {
		pushregvalue(s, addr, nil, len);
	    } else {
		if (addr == 0) {
		    error("reference through nil pointer");
		}
		rpush(addr, len);
	    }
	    break;

	case O_TYPERENAME:
	    loophole(size(p->value.arg[0]->nodetype), size(p->nodetype));
	    break;

	case O_COMMA:
	    eval(p->value.arg[0]);
	    if (p->value.arg[1] != nil) {
		eval(p->value.arg[1]);
	    }
	    break;

	case O_ITOF:
	    push(double, (double) r0);
	    break;

	case O_ADD:
	    push(long, r0+r1);
	    break;

	case O_ADDF:
	    push(double, fr0+fr1);
	    break;

	case O_SUB:
	    push(long, r0-r1);
	    break;

	case O_SUBF:
	    push(double, fr0-fr1);
	    break;

	case O_NEG:
	    push(long, -r0);
	    break;

	case O_NEGF:
	    push(double, -fr0);
	    break;

	case O_MUL:
	    push(long, r0*r1);
	    break;

	case O_MULF:
	    push(double, fr0*fr1);
	    break;

	case O_DIVF:
	    if (fr1 == 0) {
		error("error: division by 0");
	    }
	    push(double, fr0 / fr1);
	    break;

	case O_DIV:
	    if (r1 == 0) {
		error("error: div by 0");
	    }
	    push(long, r0 div r1);
	    break;

	case O_MOD:
	    if (r1 == 0) {
		error("error: mod by 0");
	    }
	    push(long, r0 mod r1);
	    break;

	case O_LT:
	    push(Boolrep, r0 < r1);
	    break;

	case O_LTF:
	    push(Boolrep, fr0 < fr1);
	    break;

	case O_LE:
	    push(Boolrep, r0 <= r1);
	    break;

	case O_LEF:
	    push(Boolrep, fr0 <= fr1);
	    break;

	case O_GT:
	    push(Boolrep, r0 > r1);
	    break;

	case O_GTF:
	    push(Boolrep, fr0 > fr1);
	    break;

	case O_EQ:
	    push(Boolrep, r0 == r1);
	    break;

	case O_EQF:
	    push(Boolrep, fr0 == fr1);
	    break;

	case O_NE:
	    push(Boolrep, r0 != r1);
	    break;

	case O_NEF:
	    push(Boolrep, fr0 != fr1);
	    break;

	case O_AND:
	    push(Boolrep, r0 && r1);
	    break;

	case O_OR:
	    push(Boolrep, r0 || r1);
	    break;

	case O_ASSIGN:
	    assign(p->value.arg[0], p->value.arg[1]);
	    break;

	case O_CHFILE:
	    if (p->value.scon == nil) {
		printf("%s\n", cursource);
	    } else {
		file = opensource(p->value.scon);
		if (file == nil) {
		    error("can't read \"%s\"", p->value.scon);
		} else {
		    fclose(file);
		    setsource(p->value.scon);
		}
	    }
	    break;

	case O_CONT:
	    cont(p->value.lcon);
	    printnews();
	    break;

	case O_LIST:
	    list(p);
	    break;

	case O_FUNC:
	    func(p->value.arg[0]);
	    break;

	case O_EXAMINE:
	    eval(p->value.examine.beginaddr);
	    r0 = pop(long);
	    if (p->value.examine.endaddr == nil) {
		n = p->value.examine.count;
		if (n == 0) {
		    printvalue(r0, p->value.examine.mode);
		} else if (streq(p->value.examine.mode, "i")) {
		    printninst(n, (Address) r0);
		} else {
		    printndata(n, (Address) r0, p->value.examine.mode);
		}
	    } else {
		eval(p->value.examine.endaddr);
		r1 = pop(long);
		if (streq(p->value.examine.mode, "i")) {
		    printinst((Address)r0, (Address)r1);
		} else {
		    printdata((Address)r0, (Address)r1, p->value.examine.mode);
		}
	    }
	    break;

	case O_PRINT:
	    for (n1 = p->value.arg[0]; n1 != nil; n1 = n1->value.arg[1]) {
		eval(n1->value.arg[0]);
		printval(n1->value.arg[0]->nodetype);
		putchar(' ');
	    }
	    putchar('\n');
	    break;

	case O_PSYM:
	    if (p->value.arg[0]->op == O_SYM) {
		psym(p->value.arg[0]->value.sym);
	    } else {
		psym(p->value.arg[0]->nodetype);
	    }
	    break;

	case O_QLINE:
	    eval(p->value.arg[1]);
	    break;

	case O_STEP:
	    b = inst_tracing;
	    inst_tracing = (Boolean) (!p->value.step.source);
	    if (p->value.step.skipcalls) {
		next();
	    } else {
		stepc();
	    }
	    inst_tracing = b;
	    useInstLoc = (Boolean) (!p->value.step.source);
	    printnews();
	    break;

	case O_WHATIS:
	    if (p->value.arg[0]->op == O_SYM) {
		printdecl(p->value.arg[0]->value.sym);
	    } else {
		printdecl(p->value.arg[0]->nodetype);
	    }
	    break;

	case O_WHERE:
	    wherecmd();
	    break;

	case O_WHEREIS:
	    if (p->value.arg[0]->op == O_SYM) {
		printwhereis(stdout, p->value.arg[0]->value.sym);
	    } else {
		printwhereis(stdout, p->value.arg[0]->nodetype);
	    }
	    break;

	case O_WHICH:
	    if (p->value.arg[0]->op == O_SYM) {
		printwhich(stdout, p->value.arg[0]->value.sym);
	    } else {
		printwhich(stdout, p->value.arg[0]->nodetype);
	    }
	    putchar('\n');
	    break;

	case O_ALIAS:
	    n1 = p->value.arg[0];
	    n2 = p->value.arg[1];
	    if (n2 == nil) {
		if (n1 == nil) {
		    alias(nil, nil, nil);
		} else {
		    alias(n1->value.name, nil, nil);
		}
	    } else if (n2->op == O_NAME) {
		str = ident(n2->value.name);
		alias(n1->value.name, nil, strdup(str));
	    } else {
		if (n1->op == O_COMMA) {
		    alias(
			n1->value.arg[0]->value.name,
			(List) n1->value.arg[1],
			n2->value.scon
		    );
		} else {
		    alias(n1->value.name, nil, n2->value.scon);
		}
	    }
	    break;

	case O_UNALIAS:
	    unalias(p->value.arg[0]->value.name);
	    break;

	case O_CALLPROC:
	    callproc(p, false);
	    break;

	case O_CALL:
	    callproc(p, true);
	    break;

	case O_CATCH:
	    if (p->value.lcon == 0) {
		printsigscaught(process);
	    } else {
		psigtrace(process, p->value.lcon, true);
	    }
	    break;

	case O_EDIT:
	    edit(p->value.scon);
	    break;

        case O_DEBUG:
            debug(p);
	    break;

	case O_DOWN:
	    checkref(p->value.arg[0]);
	    assert(p->value.arg[0]->op == O_LCON);
	    down(p->value.arg[0]->value.lcon);
	    break;

	case O_DUMP:
	    if (p->value.arg[0] == nil) {
		dumpall();
	    } else {
		s = p->value.arg[0]->value.sym;
		if (s == curfunc) {
		    dump(nil);
		} else {
		    dump(s);
		}
	    }
	    break;

	case O_GRIPE:
	    gripe();
	    break;

	case O_HELP:
	    help();
	    break;

	case O_IGNORE:
	    if (p->value.lcon == 0) {
		printsigsignored(process);
	    } else {
		psigtrace(process, p->value.lcon, false);
	    }
	    break;

	case O_RETURN:
	    if (p->value.arg[0] == nil) {
		rtnfunc(nil);
	    } else {
		assert(p->value.arg[0]->op == O_SYM);
		rtnfunc(p->value.arg[0]->value.sym);
	    }
	    break;

	case O_RUN:
	    run();
	    break;

	case O_SET:
	    set(p->value.arg[0], p->value.arg[1]);
	    break;

	case O_SEARCH:
	    search(p->value.arg[0]->value.lcon, p->value.arg[1]->value.scon);
	    break;

	case O_SOURCE:
	    setinput(p->value.scon);
	    break;

	case O_STATUS:
	    status();
	    break;

	case O_TRACE:
	case O_TRACEI:
	    trace(p);
	    break;

	case O_STOP:
	case O_STOPI:
	    stop(p);
	    break;

	case O_UNSET:
	    undefvar(p->value.arg[0]->value.name);
	    break;

	case O_UP:
	    checkref(p->value.arg[0]);
	    assert(p->value.arg[0]->op == O_LCON);
	    up(p->value.arg[0]->value.lcon);
	    break;

	case O_ADDEVENT:
	    addevent(p->value.event.cond, p->value.event.actions);
	    break;

	case O_DELETE:
	    n1 = p->value.arg[0];
	    while (n1->op == O_COMMA) {
		n2 = n1->value.arg[0];
		assert(n2->op == O_LCON);
		if (!delevent((unsigned int) n2->value.lcon)) {
		    error("unknown event %ld", n2->value.lcon);
		}
		n1 = n1->value.arg[1];
	    }
	    assert(n1->op == O_LCON);
	    if (!delevent((unsigned int) n1->value.lcon)) {
		error("unknown event %ld", n1->value.lcon);
	    }
	    break;

	case O_ENDX:
	    endprogram();
	    break;

	case O_IF:
	    if (cond(p->value.event.cond)) {
		evalcmdlist(p->value.event.actions);
	    }
	    break;

	case O_ONCE:
	    event_once(p->value.event.cond, p->value.event.actions);
	    break;

	case O_PRINTCALL:
	    printcall(p->value.sym, whatblock(return_addr()));
	    break;

	case O_PRINTIFCHANGED:
	    printifchanged(p->value.arg[0]);
	    break;

	case O_PRINTRTN:
	    printrtn(p->value.sym);
	    break;

	case O_PRINTSRCPOS:
	    getsrcpos();
	    if (p->value.arg[0] == nil) {
		printsrcpos();
		putchar('\n');
		printlines(nil, curline, curline);
	    } else if (p->value.arg[0]->op == O_QLINE) {
		if (p->value.arg[0]->value.arg[1]->value.lcon == 0) {
		    printf("tracei: ");
		    printinst(pc, pc);
		} else {
		    if (canReadSource()) {
			printf("trace:  ");
			printlines(nil, curline, curline);
		    }
		}
	    } else {
		printsrcpos();
		printf(": ");
		eval(p->value.arg[0]);
		prtree(stdout, p->value.arg[0]);
		printf(" = ");
		printval(p->value.arg[0]->nodetype);
		putchar('\n');
	    }
	    break;

	case O_PROCRTN:
	    procreturn(p->value.sym);
	    break;

	case O_STOPIFCHANGED:
	    stopifchanged(p->value.arg[0]);
	    break;

	case O_STOPX:
	    isstopped = true;
	    break;

	case O_TRACEON:
	    traceon(p->value.trace.inst, p->value.trace.event,
		p->value.trace.actions);
	    break;

	case O_TRACEOFF:
	    traceoff(p->value.lcon);
	    break;

	default:
	    panic("eval: bad op %d", p->op);
    }
    if (traceeval) { 
	fprintf(stderr, "end eval %s\n", opname(p->op));
    }
}

/*
 * Evaluate a list of commands.
 */

public evalcmdlist (cl)
Cmdlist cl;
{
    Command c;

    foreach (Command, c, cl)
	evalcmd(c);
    endfor
}

/*
 * Push "len" bytes onto the expression stack from address "addr"
 * in the process.  If there isn't room on the stack, print an error message.
 */

public rpush (addr, len)
Address addr;
unsigned len;
{
    if (!canpush(len)) {
	error("expression too large to evaluate");
    } else {
	chksp();
	dread(sp, addr, len);
	sp += len;
    }
}

/*
 * Check if the stack has n bytes available.
 */

public Boolean canpush (n)
Integer n;
{
    return (Boolean) (sp + n < &stack[STACKSIZE]);
}

/*
 * Push a small scalar of the given type onto the stack.
 */

public pushsmall (s, v)
int s;
long v;
{
    switch (s) {
	case sizeof(char):
	    push(char, v);
	    break;

	case sizeof(short):
	    push(short, v);
	    break;

	case sizeof(long):
	    push(long, v);
	    break;

	default:
	    panic("bad size %d in popsmall", s);
    }
}

/*
 * Push a value in a register for the given symbol, perhaps on the stack.
 * If the length (in words) is greater than one, then push
 * consecutive registers.
 */

public pushregvalue (s, r, f, n)
Symbol s;
int r;
Frame f;
unsigned n;
{
    register int i, j, realtype, flreg;
    register Frame frp;
    register Symbol b,t;
    
    int tmpx[3]; /* workspace for converting extended precision fp */
    double tmpd;
    float tmpf;
    int *tmpfp;

    frp = f;
    if (frp == nil) {
	b = s->block;
	while (b != nil && b->class == MODULE) {
	    b = b->block;
	}
	if (b == nil) {
	    frp = nil;
	} else {
	    frp = findframe(b);
	    if (frp == nil) {
		error("[internal error: nil frame for %s]", symname(s));
	    }
	}
    }

    for(t = s; t && t->class == TYPE; t = t->type);
    
    realtype = (t->symvalue.rangev.upper == 0);

    j = r + n / sizeof(Word);
    for (i = r; i < j; i++) {
        if (i > NREG) {
            if (extendedfloats) {
                tmpfp = tmpx;
                flreg = ((i-NREG)*3)+NREG;
                *tmpfp++ = savereg(flreg, frp);
                *tmpfp++ = savereg(flreg+1, frp);
                *tmpfp++ = savereg(flreg+2, frp);
                tmpfp = (int *)(&tmpd);
                xsqz(tmpx, tmpfp);
                if (n/sizeof(Word) > 1) {
                    push(Word, *tmpfp);
                    push(Word, tmpfp[1]);  
                    j--;
                }
                else {
                    tmpf = tmpd;
                    tmpfp = (int *)(&tmpf);

                    push(Word, *tmpfp);
                }
            }
            else {
                flreg = ((i-NREG)*2)+NREG;
	        push(Word, savereg(flreg, frp));
                if (n/sizeof(Word) > 1) {
                    j--;
	            push(Word, savereg(flreg+1, frp));
                }
            }
        }
        else {
	    push(Word, savereg(i, frp));
        }
    }
    j = n % sizeof(Word);
    if (j > 0) {
	pushsmall(j, savereg(i, frp));
    }
}

/*
 * Pop an item of the given type which is assumed to be no larger
 * than a long and return it expanded into a long.
 */

public long popsmall (t)
Symbol t;
{
    register integer n;
    long r;

    n = size(t);
    if (n == sizeof(char)) {
	if (t->class == RANGE && t->symvalue.rangev.lower >= 0) {
	    r = (long) pop(unsigned char);
	} else {
	    r = (long) pop(char);
	}
    } else if (n == sizeof(short)) {
	if (t->class == RANGE && t->symvalue.rangev.lower >= 0) {
	    r = (long) pop(unsigned short);
	} else {
	    r = (long) pop(short);
	}
    } else if (n == sizeof(long)) {
	r = pop(long);
    } else {
	error("[internal error: size %d in popsmall]", n);
    }
    return r;
}

/*
 * Evaluate a conditional expression.
 */

public Boolean cond (p)
Node p;
{
    Boolean b;
    int i;

    if (p == nil) {
	b = true;
    } else {
	eval(p);
	i = pop(Boolrep);
	b = (Boolean) i;
    }
    return b;
}

/*
 * Return the address corresponding to a given tree.
 */

public Address lval (p)
Node p;
{
    if (p->op == O_RVAL) {
	eval(p->value.arg[0]);
    } else {
	eval(p);
    }
    return (Address) (pop(long));
}

/*
 * Process a trace command, translating into the appropriate events
 * and associated actions.
 */

public trace (p)
Node p;
{
    Node exp, place, cond;
    Node left;

    exp = p->value.arg[0];
    place = p->value.arg[1];
    cond = p->value.arg[2];
    if (exp == nil) {
	traceall(p->op, place, cond);
    } else if (exp->op == O_QLINE || exp->op == O_LCON) {
	traceinst(p->op, exp, cond);
    } else if (place != nil && place->op == O_QLINE) {
	traceat(p->op, exp, place, cond);
    } else {
	left = exp;
	if (left->op == O_RVAL || left->op == O_CALL) {
	    left = left->value.arg[0];
	}
	if (left->op == O_SYM && isblock(left->value.sym)) {
	    traceproc(p->op, left->value.sym, place, cond);
	} else {
	    tracedata(p->op, exp, place, cond);
	}
    }
}

/*
 * Set a breakpoint that will turn on tracing.
 */

private traceall (op, place, cond)
Operator op;
Node place;
Node cond;
{
    Symbol s;
    Node event;
    Command action;

    if (place == nil) {
	s = program;
    } else {
	s = place->value.sym;
    }
    event = build(O_EQ, build(O_SYM, procsym), build(O_SYM, s));
    action = build(O_PRINTSRCPOS,
	build(O_QLINE, nil, build(O_LCON, (op == O_TRACE) ? 1 : 0)));
    if (cond != nil) {
	action = build(O_IF, cond, buildcmdlist(action));
    }
    action = build(O_TRACEON, (op == O_TRACEI), buildcmdlist(action));
    action->value.trace.event = addevent(event, buildcmdlist(action));
    if (isstdin()) {
	printevent(action->value.trace.event);
    }
}

/*
 * Set up the appropriate breakpoint for tracing an instruction.
 */

private traceinst (op, exp, cond)
Operator op;
Node exp;
Node cond;
{
    Node event, wh;
    Command action;
    Event e;

    if (exp->op == O_LCON) {
	wh = build(O_QLINE, build(O_SCON, strdup(cursource)), exp);
    } else {
	wh = exp;
    }
    if (op == O_TRACEI) {
	event = build(O_EQ, build(O_SYM, pcsym), wh);
    } else {
	event = build(O_EQ, build(O_SYM, linesym), wh);
    }
    action = build(O_PRINTSRCPOS, wh);
    if (cond) {
	action = build(O_IF, cond, buildcmdlist(action));
    }
    e = addevent(event, buildcmdlist(action));
    if (isstdin()) {
	printevent(e);
    }
}

/*
 * Set a breakpoint to print an expression at a given line or address.
 */

private traceat (op, exp, place, cond)
Operator op;
Node exp;
Node place;
Node cond;
{
    Node event;
    Command action;
    Event e;

    if (op == O_TRACEI) {
	event = build(O_EQ, build(O_SYM, pcsym), place);
    } else {
	event = build(O_EQ, build(O_SYM, linesym), place);
    }
    action = build(O_PRINTSRCPOS, exp);
    if (cond != nil) {
	action = build(O_IF, cond, buildcmdlist(action));
    }
    e = addevent(event, buildcmdlist(action));
    if (isstdin()) {
	printevent(e);
    }
}

/*
 * Construct event for tracing a procedure.
 *
 * What we want here is
 *
 * 	when $proc = p do
 *	    if <condition> then
 *	        printcall;
 *	        once $pc = $retaddr do
 *	            printrtn;
 *	        end;
 *	    end if;
 *	end;
 *
 * Note that "once" is like "when" except that the event
 * deletes itself as part of its associated action.
 */

private traceproc (op, p, place, cond)
Operator op;
Symbol p;
Node place;
Node cond;
{
    Node event;
    Command action;
    Cmdlist actionlist;
    Event e;

    action = build(O_PRINTCALL, p);
    actionlist = list_alloc();
    cmdlist_append(action, actionlist);
    event = build(O_EQ, build(O_SYM, pcsym), build(O_SYM, retaddrsym));
    action = build(O_ONCE, event, buildcmdlist(build(O_PRINTRTN, p)));
    cmdlist_append(action, actionlist);
    if (cond != nil) {
	actionlist = buildcmdlist(build(O_IF, cond, actionlist));
    }
    event = build(O_EQ, build(O_SYM, procsym), build(O_SYM, p));
    e = addevent(event, actionlist);
    if (isstdin()) {
	printevent(e);
    }
}

/*
 * Set up breakpoint for tracing data.
 */

private tracedata (op, exp, place, cond)
Operator op;
Node exp;
Node place;
Node cond;
{
    Symbol p;
    Node event;
    Command action;

    if (size(exp->nodetype) > MAXTRSIZE) {
	error("expression too large to trace (limit is %d bytes)", MAXTRSIZE);
    }
    p = (place == nil) ? tcontainer(exp) : place->value.sym;
    if (p == nil) {
	p = program;
    }
    action = build(O_PRINTIFCHANGED, exp);
    if (cond != nil) {
	action = build(O_IF, cond, buildcmdlist(action));
    }
    action = build(O_TRACEON, (op == O_TRACEI), buildcmdlist(action));
    event = build(O_EQ, build(O_SYM, procsym), build(O_SYM, p));
    action->value.trace.event = addevent(event, buildcmdlist(action));
    if (isstdin()) {
	printevent(action->value.trace.event);
    }
}

/*
 * Setting and unsetting of stops.
 */

public stop (p)
Node p;
{
    Node exp, place, cond, t;
    Symbol s;
    Command action;
    Event e;

    exp = p->value.arg[0];
    place = p->value.arg[1];
    cond = p->value.arg[2];
    if (exp != nil) {
	stopvar(p->op, exp, place, cond);
    } else {
	action = build(O_STOPX);
	if (cond != nil) {
	    action = build(O_IF, cond, buildcmdlist(action));
	}
	if (place == nil || place->op == O_SYM) {
	    if (place == nil) {
		s = program;
	    } else {
		s = place->value.sym;
	    }
	    t = build(O_EQ, build(O_SYM, procsym), build(O_SYM, s));
	    if (cond != nil) {
		action = build(O_TRACEON, (p->op == O_STOPI),
		    buildcmdlist(action));
		e = addevent(t, buildcmdlist(action));
		action->value.trace.event = e;
	    } else {
		e = addevent(t, buildcmdlist(action));
	    }
	    if (isstdin()) {
		printevent(e);
	    }
	} else {
	    stopinst(p->op, place, cond, action);
	}
    }
}

private stopinst (op, place, cond, action)
Operator op;
Node place;
Node cond;
Command action;
{
    Node event;
    Event e;

    if (op == O_STOP) {
	event = build(O_EQ, build(O_SYM, linesym), place);
    } else {
	event = build(O_EQ, build(O_SYM, pcsym), place);
    }
    e = addevent(event, buildcmdlist(action));
    if (isstdin()) {
	printevent(e);
    }
}

/*
 * Implement stopping on assignment to a variable by adding it to
 * the variable list.
 */

private stopvar (op, exp, place, cond)
Operator op;
Node exp;
Node place;
Node cond;
{
    Symbol p;
    Node event;
    Command action;

    if (size(exp->nodetype) > MAXTRSIZE) {
	error("expression too large to trace (limit is %d bytes)", MAXTRSIZE);
    }
    if (place == nil) {
	if (exp->op == O_LCON) {
	    p = program;
	} else {
	    p = tcontainer(exp);
	    if (p == nil) {
		p = program;
	    }
	}
    } else {
	p = place->value.sym;
    }
    action = build(O_STOPIFCHANGED, exp);
    if (cond != nil) {
	action = build(O_IF, cond, buildcmdlist(action));
    }
    action = build(O_TRACEON, (op == O_STOPI), buildcmdlist(action));
    event = build(O_EQ, build(O_SYM, procsym), build(O_SYM, p));
    action->value.trace.event = addevent(event, buildcmdlist(action));
    if (isstdin()) {
	printevent(action->value.trace.event);
    }
}



/*
 * Assign the value of an expression to a variable (or term).
 */

public assign (var, exp)
Node var;
Node exp;
{
    int r, flreg, varsize, expsize;
    Address addr;
    char c;
    short s;
    union {
	float f;
	double d;
	Word w[2];
    } u;
    double *dp;
    long xtmp[3];
    long dtmp[2];

    varsize = size(var->nodetype);
    expsize = size(exp->nodetype);
    if (var->op == O_SYM) {
	r = regnum(var->value.sym);
	if (r != -1) {
	    eval(exp);
	    if (varsize == sizeof(double)) {
		if (expsize == sizeof(float)) {
		    u.d = pop(float);
		} else {
		    u.d = pop(double);
		}
                if (r > NREG) {
                    if (!extendedfloats) {
                        flreg = ((r-NREG)*2)+NREG;
		        setreg(flreg, u.w[0]);
		        setreg(flreg+1, u.w[1]);
                    }
                    else {
                        dbtox(&u, xtmp);
                        flreg = ((r-NREG)*3)+NREG;
		        setreg(flreg, xtmp[0]);
		        setreg(flreg+1, xtmp[1]);
		        setreg(flreg+2, xtmp[2]);
                    }
                }
                else {
		    setreg(r, u.w[0]);
		    setreg(r+1, u.w[1]);
                }
	    } else {
		if (expsize == sizeof(double)) {
		    u.f = pop(double);
		} else {
		    u.w[0] = pop(Word);
		}
                if (r > NREG) {
                    if (!extendedfloats) {
                        flreg = ((r-NREG)*2)+NREG;
		        setreg(flreg, u.w[0]);
                    }
                    else {
                        dp = (double *)dtmp;
                        *dp = u.f;
                        dbtox(dtmp, xtmp);
                        flreg = ((r-NREG)*3)+NREG;
		        setreg(flreg, xtmp[0]);
		        setreg(flreg+1, xtmp[1]);
		        setreg(flreg+2, xtmp[2]);
                    }
                }
                else {
		    setreg(r, u.w[0]);
                }
	    }
	}
    }
    addr = lval(var);
    eval(exp);
    if (varsize == sizeof(float) && expsize == sizeof(double)) {
	u.f = pop(double);
	dwrite(&u.f, addr, sizeof(float));
    } else {
	switch (varsize) {
	    case sizeof(char):
		c = pop(char);
		dwrite(&c, addr, sizeof(char));
		break;
	    case sizeof(short):
		s = pop(short);
		dwrite(&s, addr, sizeof(short));
		break;
	    default:
		sp -= expsize;
		if (expsize <= varsize) {
		    dwrite(sp, addr, expsize);
		} else {
		    dwrite(sp, addr, varsize);
		}
		break;
	}
    }
}
 
   



/* Convert 2-word integer array representing an ieee double
 * to a 3-word integer array representing an 881 extended-precision no.
 * L. M. Breed  12/87
 */

dbtox(unsigned int dw[2], unsigned int xw[3])
{
	int b = (dw[0] & 0x7ff00000) >> 20;
	unsigned sign = 0x80000000 & dw[0];
	double d;

	if (b == 0) {
	    d = scalb(*(double *)dw, 53);
	    dw = (unsigned *)&d;
	    b = ((dw[0] & 0x7ff00000) >> 20) - 53;
	    if (d == 0) {
		xw[1] = xw[2] = 0;
		xw[0] = sign;
		return;
	    }
	}  
	xw[2] = dw[1]<<11;
	xw[1] = (dw[1]>>21) | ((dw[0] & 0xfffff)<<11);
	if (b == 0x7ff) {
	    xw[0] = sign | 0x7fff0000;
	} else {
	    xw[0] = sign | (b + 0x3fff - 0x3ff)<<16;
	    xw[1] |= 0x80000000;
	}
	return;
}




/*
 * Set a debugger variable.
 */

private set (var, exp)
Node var, exp;
{
    Symbol t;

    if (var == nil) {
	defvar(nil, nil);
    } else if (exp == nil) {
	defvar(var->value.name, nil);
    } else if (var->value.name == identname("$frame", true)) {
	t = exp->nodetype;
	if (!compatible(t, t_int) && !compatible(t, t_addr)) {
	    error("$frame must be an address");
	}
	eval(exp);
	getnewregs(pop(Address));
    } else {
	defvar(var->value.name, unrval(exp));
    }
}

/*
 * Execute a list command.
 */

private list (p)
Node p;
{
    Symbol f;
    Address addr;
    Lineno line = 0, l1, l2;

    if (p->value.arg[0]->op == O_SYM) {
	f = p->value.arg[0]->value.sym;
	addr = firstline(f);
	if (addr == NOADDR) {
	    error("no source lines for \"%s\"", symname(f));
	}
	setsource(srcfilename(addr));
	line = srcline(addr);
	getsrcwindow(line, &l1, &l2);
    } else {
	eval(p->value.arg[0]);
	l1 = (Lineno) (pop(long));
	eval(p->value.arg[1]);
	l2 = (Lineno) (pop(long));
    }
    printlines(line, l1, l2);
}

/*
 * Execute a func command.
 */

private func (p)
Node p;
{
    Symbol s, f;
    Address addr;

    if (p == nil) {
	printname(stdout, curfunc);
	putchar('\n');
    } else {
	s = p->value.sym;
	if (isroutine(s)) {
	    setcurfunc(s);
	} else {
	    find(f, s->name) where isroutine(f) endfind(f);
	    if (f == nil) {
		error("%s is not a procedure or function", symname(s));
	    }
	    setcurfunc(f);
	}
	addr = codeloc(curfunc);
	if (addr != NOADDR) {
	    setsource(srcfilename(addr));
	    cursrcline = srcline(addr);
	}
    }
}

/*
 * Send a message to the current support person.
 */

public gripe ()
{
#   ifdef MAINTAINER
	typedef Operation();
	Operation *old;
	int pid, status;
	char subject[100];

	puts("Type control-D to end your message.  Be sure to include");
	puts("your name and the name of the file you are debugging.");
	putchar('\n');
	old = signal(SIGINT, SIG_DFL);
	sprintf(
	    subject, "dbx (version %d.%d) gripe", releaseNumber, versionNumber
	);
	pid = back("Mail", stdin, stdout, "-s", subject, MAINTAINER, nil);
	signal(SIGINT, SIG_IGN);
	pwait(pid, &status);
	signal(SIGINT, old);
	if (status == 0) {
	    puts("Thank you.");
	} else {
	    puts("\nMail not sent.");
	}
#   else
	puts("Sorry, not dbx maintainer available to gripe to.");
	puts("Try contacting your system manager.");
#   endif
}

/*
 * Give the user some help.
 */

public help ()
{
    puts("run                    - begin execution of the program");
    puts("print <exp>            - print the value of the expression");
    puts("where                  - print currently active procedures");
    puts("stop at <line>         - suspend execution at the line");
    puts("stop in <proc>         - suspend execution when <proc> is called");
    puts("cont                   - continue execution");
    puts("step                   - single step one line");
    puts("next                   - step to next line (skip over calls)");
    puts("trace <line#>          - trace execution of the line");
    puts("trace <proc>           - trace calls to the procedure");
    puts("trace <var>            - trace changes to the variable");
    puts("trace <exp> at <line#> - print <exp> when <line> is reached");
    puts("status                 - print trace/stop's in effect");
    puts("delete <number>        - remove trace or stop of given number");
    puts("call <proc>            - call a procedure in program");
    puts("whatis <name>          - print the declaration of the name");
    puts("list <line>, <line>    - list source lines");
    puts("gripe                  - send mail to the person in charge of dbx");
    puts("quit                   - exit dbx");
}

/*
 * Divert output to the given file name.
 * Cannot redirect to an existing file.
 */

private int so_fd;
private Boolean notstdout;

public setout (filename)
String filename;
{
    File f;

    f = fopen(filename, "r");
    if (f != nil) {
	fclose(f);
	error("%s: file already exists", filename);
    } else {
	so_fd = dup(1);
	close(1);
	if (creat(filename, 0666) == nil) {
	    unsetout();
	    error("can't create %s", filename);
	}
	notstdout = true;
    }
}

/*
 * Revert output to standard output.
 */

public unsetout ()
{
    fflush(stdout);
    close(1);
    if (dup(so_fd) != 1) {
	panic("standard out dup failed");
    }
    close(so_fd);
    notstdout = false;
}

/*
 * Determine is standard output is currently being redirected
 * to a file (as far as we know).
 */

public Boolean isredirected ()
{
    return notstdout;
}


/*
 *
 *    Extended precision Coprocessor support.   
 *       (should be valid fo mc881, i387, etc.)
 *
 *
 *
 */


  
/* Convert 3-word integer array representing an 881 extended-precision no.
 * to double representation.  L. M. Breed  12/87
 */

const static int xd1[2] = {0x41300000,0};
const static int xd2[2] = {0x3f300000,0};

xsqz(unsigned int xw[3], unsigned int t[2])
{
	int b,n;
	double d1,d2;
	double g1;
	double f;
	unsigned int dsign = xw[0] & 0x80000000;

/*	if (xw[0]&0xffff) printf("Word 1 low 16 bits should be 0.\n"); */
	if ((xw[0]&0x7fff0000) == 0x7fff0000) {
/* INF, NaN */
	    t[0] = xw[0]&0xfff00000 | xw[1]>>12;
	    t[1] = xw[1]<<20 | xw[2]>>12 | (xw[2]<<20 != 0);
		/* Assures extended NaN doesn't lose all nonzero bits */
	    return ;
	}
	if (0 == (xw[1]|xw[2])) {
/* 0.0 */
	    t[0] = dsign;
	    t[1] = 0;
	    return ;
	}
     /* Magically normalize and remove the implicit leading bit, in one swoop */
	t[0]=xd1[0];
	t[1]=xw[1];
	d1 = *(double *)t - *(double *)xd1;
	t[0]=xd2[0];
	t[1]=xw[2];
	d2 = *(double *)t - *(double *)xd2;

     /* We should have had no denormalized numbers except for subnormals
      * (which are verry small and will get squeezed to zero)
      * but for cleanliness accommodate denormals as well.
      * g's exponent will be 3fe for all normal values, or 3ff if
      * the addition rounds up to 1.0 .
      */
	b = ((xw[0] >> 16) & 0x7fff) - 0x3ffe;
	g1 = d1+d2;
	n = b - 0x3fe + (((unsigned int *)&g1)[0] >> 20);
	*(double *)t = scalb(g1,b);
	t[0] |= dsign;
	if (n > -1023 && n <= 1024) return;
     		/* It's an honest normal number with no more than
		 * the usual loss of precision.
		 */
/* out-of-double-range normals. Print a warning, return whatever it's
 * been converted to.
 */
	n = rint(b/3.32192809488736234789);
	f = exp(0.69314718055994530941*drem((double)b,3.32192809488736234789));
	g1 = g1*f;
	while (g1<1.0) {
	    g1 *= 10;
	    n--;
	}
	    /* Use g format here to get round to roundest; rely on
	       1<=x<10 to prevent g format from printing an exponent.
	    */
	fprintf(stderr,"%08x %08x %08x (%s%.17ge%+d)"
		" mapped to %.17g\n",
		xw[0],xw[1],xw[2], dsign?"-":"", g1, n, *(double *)t);
	return ;
}
