Пример #1
0
/*
 * hash_number - hash a NUMBER
 *
 * given:
 *	type	- hash type (see hash.h)
 *	n	- the NUMBER
 *	state	- the state to hash or NULL
 *
 * returns:
 *	the new state
 */
HASH *
hash_number(int type, void *n, HASH *state)
{
	NUMBER *number = (NUMBER *)n;	/* n as a NUMBER pointer */
	BOOL sign;			/* sign of the denominator */

	/*
	 * initialize if state is NULL
	 */
	if (state == NULL) {
		state = hash_init(type, NULL);
	}

	/*
	 * setup for the NUMBER hash
	 */
	(state->chkpt)(state);
	state->bytes = FALSE;

	/*
	 * process the numerator
	 */
	state = hash_zvalue(type, number->num, state);

	/*
	 * if the NUMBER is not an integer, process the denominator
	 */
	if (qisfrac(number)) {

		/* note the division */
		(state->note)(HASH_DIV(state->base), state);

		/* hash denominator as positive -- just in case */
		sign = number->den.sign;
		number->den.sign = 0;

		/* hash the denominator */
		state = hash_zvalue(type, number->den, state);

		/* restore the sign */
		number->den.sign = sign;
	}

	/*
	 * all done
	 */
	return state;
}
Пример #2
0
/*
 * Raise an object to an integral power.
 * This is the default routine if the user's is not defined.
 * Negative powers mean the positive power of the inverse.
 * Zero means the multiplicative identity.
 *
 * given:
 *	vp		value to be powered
 *	q		power to raise number to
 */
S_FUNC VALUE
objpowi(VALUE *vp, NUMBER *q)
{
	VALUE res, tmp;
	long power;		/* power to raise to */
	FULL bit;		/* current bit value */

	if (qisfrac(q)) {
		math_error("Raising object to non-integral power");
		/*NOTREACHED*/
	}
	if (zge31b(q->num)) {
		math_error("Raising object to very large power");
		/*NOTREACHED*/
	}
	power = ztolong(q->num);
	if (qisneg(q))
		power = -power;
	/*
	 * Handle some low powers specially
	 */
	if ((power <= 2) && (power >= -2)) {
		switch ((int) power) {
		case 0:
			return objcall(OBJ_ONE, vp, NULL_VALUE, NULL_VALUE);
		case 1:
			res.v_obj = objcopy(vp->v_obj);
			res.v_type = V_OBJ;
			res.v_subtype = V_NOSUBTYPE;
			return res;
		case -1:
			return objcall(OBJ_INV, vp, NULL_VALUE, NULL_VALUE);
		case 2:
			return objcall(OBJ_SQUARE, vp, NULL_VALUE, NULL_VALUE);
		}
	}
	if (power < 0)
		power = -power;
	/*
	 * Compute the power by squaring and multiplying.
	 * This uses the left to right method of power raising.
	 */
	bit = TOPFULL;
	while ((bit & power) == 0)
		bit >>= 1L;
	bit >>= 1L;
	res = objcall(OBJ_SQUARE, vp, NULL_VALUE, NULL_VALUE);
	if (bit & power) {
		tmp = objcall(OBJ_MUL, &res, vp, NULL_VALUE);
		objfree(res.v_obj);
		res = tmp;
	}
	bit >>= 1L;
	while (bit) {
		tmp = objcall(OBJ_SQUARE, &res, NULL_VALUE, NULL_VALUE);
		objfree(res.v_obj);
		res = tmp;
		if (bit & power) {
			tmp = objcall(OBJ_MUL, &res, vp, NULL_VALUE);
			objfree(res.v_obj);
			res = tmp;
		}
		bit >>= 1L;
	}
	if (qisneg(q)) {
		tmp = objcall(OBJ_INV, &res, NULL_VALUE, NULL_VALUE);
		objfree(res.v_obj);
		return tmp;
	}
	return res;
}
Пример #3
0
/*
 * Add an opcode to the current function being compiled.
 * Note: This can change the curfunc global variable when the
 * function needs expanding.
 */
void
addop(long op)
{
    register FUNC *fp;		/* current function */
    NUMBER *q, *q1, *q2;
    unsigned long count;
    BOOL cut;
    int diff;

    fp = curfunc;
    count = fp->f_opcodecount;
    cut = TRUE;
    diff = 2;
    q = NULL;
    if ((count + 5) >= maxopcodes) {
        maxopcodes += OPCODEALLOCSIZE;
        fp = (FUNC *) malloc(funcsize(maxopcodes));
        if (fp == NULL) {
            math_error("cannot malloc function");
            /*NOTREACHED*/
        }
        memcpy((char *) fp, (char *) curfunc,
               funcsize(curfunc->f_opcodecount));
        if (curfunc != functemplate)
            free(curfunc);
        curfunc = fp;
    }

    /*
     * Check the current opcode against the previous opcode and try to
     * slightly optimize the code depending on the various combinations.
     */
    switch (op) {
    case OP_GETVALUE:
        switch (oldop) {
        case OP_NUMBER:
        case OP_ZERO:
        case OP_ONE:
        case OP_IMAGINARY:
        case OP_GETEPSILON:
        case OP_SETEPSILON:
        case OP_STRING:
        case OP_UNDEF:
        case OP_GETCONFIG:
        case OP_SETCONFIG:
            return;
        case OP_DUPLICATE:
            diff = 1;
            oldop = OP_DUPVALUE;
            break;
        case OP_FIADDR:
            diff = 1;
            oldop = OP_FIVALUE;
            break;
        case OP_GLOBALADDR:
            diff = 1 + PTR_SIZE;
            oldop = OP_GLOBALVALUE;
            break;
        case OP_LOCALADDR:
            oldop = OP_LOCALVALUE;
            break;
        case OP_PARAMADDR:
            oldop = OP_PARAMVALUE;
            break;
        case OP_ELEMADDR:
            oldop = OP_ELEMVALUE;
            break;
        default:
            cut = FALSE;

        }
        if (cut) {
            fp->f_opcodes[count - diff] = oldop;
            return;
        }
        break;
    case OP_POP:
        switch (oldop) {
        case OP_ASSIGN:
            fp->f_opcodes[count-1] = OP_ASSIGNPOP;
            oldop = OP_ASSIGNPOP;
            return;
        case OP_NUMBER:
        case OP_IMAGINARY:
            q = constvalue(fp->f_opcodes[count-1]);
            qfree(q);
            break;
        case OP_STRING:
            sfree(findstring((long)fp->f_opcodes[count-1]));
            break;
        case OP_LOCALADDR:
        case OP_PARAMADDR:
            break;
        case OP_GLOBALADDR:
            diff = 1 + PTR_SIZE;
            break;
        case OP_UNDEF:
            fp->f_opcodecount -= 1;
            oldop = OP_NOP;
            oldoldop = OP_NOP;
            return;
        default:
            cut = FALSE;
        }
        if (cut) {
            fp->f_opcodecount -= diff;
            oldop = OP_NOP;
            oldoldop = OP_NOP;
            fprintf(stderr,
                    "Line %ld: unused value ignored\n",
                    linenumber());
            return;
        }
        break;
    case OP_NEGATE:
        if (oldop == OP_NUMBER) {
            q = constvalue(fp->f_opcodes[count-1]);
            fp->f_opcodes[count-1] = addqconstant(qneg(q));
            qfree(q);
            return;
        }
    }
    if (oldop == OP_NUMBER) {
        if (oldoldop == OP_NUMBER) {
            q1 = constvalue(fp->f_opcodes[count - 3]);
            q2 = constvalue(fp->f_opcodes[count - 1]);
            switch (op) {
            case OP_DIV:
                if (qiszero(q2)) {
                    cut = FALSE;
                    break;
                }
                q = qqdiv(q1,q2);
                break;
            case OP_MUL:
                q = qmul(q1,q2);
                break;
            case OP_ADD:
                q = qqadd(q1,q2);
                break;
            case OP_SUB:
                q = qsub(q1,q2);
                break;
            case OP_POWER:
                if (qisfrac(q2) || qisneg(q2))
                    cut = FALSE;
                else
                    q = qpowi(q1,q2);
                break;
            default:
                cut = FALSE;
            }
            if (cut) {
                qfree(q1);
                qfree(q2);
                fp->f_opcodes[count - 3] = addqconstant(q);
                fp->f_opcodecount -= 2;
                oldoldop = OP_NOP;
                return;
            }
        } else if (op != OP_NUMBER) {
            q = constvalue(fp->f_opcodes[count - 1]);
            if (op == OP_POWER) {
                if (qcmpi(q, 2L) == 0) {
                    fp->f_opcodecount--;
                    fp->f_opcodes[count - 2] = OP_SQUARE;
                    qfree(q);
                    oldop = OP_SQUARE;
                    return;
                }
                if (qcmpi(q, 4L) == 0) {
                    fp->f_opcodes[count - 2] = OP_SQUARE;
                    fp->f_opcodes[count - 1] = OP_SQUARE;
                    qfree(q);
                    oldop = OP_SQUARE;
                    return;
                }
            }
            if (qiszero(q)) {
                qfree(q);
                fp->f_opcodes[count - 2] = OP_ZERO;
                fp->f_opcodecount--;
            } else if (qisone(q)) {
                qfree(q);
                fp->f_opcodes[count - 2] = OP_ONE;
                fp->f_opcodecount--;
            }
        }
    }
    /*
     * No optimization possible, so store the opcode.
     */
    fp->f_opcodes[fp->f_opcodecount] = op;
    fp->f_opcodecount++;
    oldoldop = oldop;
    oldop = op;
}
Пример #4
0
/*
 * Call the appropriate user-defined routine to handle an object action.
 * Returns the value that the routine returned.
 */
VALUE
objcall(int action, VALUE *v1, VALUE *v2, VALUE *v3)
{
	FUNC *fp;		/* function to call */
	STATIC OBJECTACTIONS *oap; /* object to call for */
	struct objectinfo *oip; /* information about action */
	long index;		/* index of function (negative if undefined) */
	VALUE val;		/* return value */
	VALUE tmp;		/* temp value */
	char name[SYMBOLSIZE+1+1];	/* full name of user routine to call */
	size_t namestr_len;	/* length of the namestr() return string */
	char *namestr_ret;	/* namestr() return string */
	size_t opi_name_len;	/* length of the oip name */

	/* initialize VALUEs */
	val.v_subtype = V_NOSUBTYPE;
	tmp.v_subtype = V_NOSUBTYPE;

	if ((unsigned)action > OBJ_MAXFUNC) {
		math_error("Illegal action for object call");
		/*NOTREACHED*/
	}
	oip = &objectinfo[action];
	if (v1->v_type == V_OBJ) {
		oap = v1->v_obj->o_actions;
	} else if (v2->v_type == V_OBJ) {
		oap = v2->v_obj->o_actions;
	} else {
		math_error("Object routine called with non-object");
		/*NOTREACHED*/
	}
	index = oap->oa_indices[action];
	if (index < 0) {
		namestr_ret = namestr(&objectnames, oap->oa_index);
		if (namestr_ret == NULL) {
			math_error("namestr returned NULL!!!");
			/*NOTREACHED*/
		}
		namestr_len = strlen(namestr_ret);
		opi_name_len = strlen(oip->name);
		if (namestr_len > (size_t)SYMBOLSIZE-1-opi_name_len) {
			math_error("namestr returned a strong too long!!!");
			/*NOTREACHED*/
		}
		name[0] = '\0';
		strncpy(name, namestr_ret, namestr_len+1);
		strcat(name, "_");
		strncat(name, oip->name, opi_name_len+1);
		index = adduserfunc(name);
		oap->oa_indices[action] = index;
	}
	fp = NULL;
	if (index >= 0)
		fp = findfunc(index);
	if (fp == NULL) {
		switch (oip->error) {
		case ERR_PRINT:
			objprint(v1->v_obj);
			val.v_type = V_NULL;
			break;
		case ERR_CMP:
			val.v_type = V_INT;
			if (v1->v_type != v2->v_type) {
				val.v_int = 1;
				return val;
			}
			val.v_int = objcmp(v1->v_obj, v2->v_obj);
			break;
		case ERR_TEST:
			val.v_type = V_INT;
			val.v_int = objtest(v1->v_obj);
			break;
		case ERR_POW:
			if (v2->v_type != V_NUM) {
				math_error("Non-real power");
				/*NOTREACHED*/
			}
			val = objpowi(v1, v2->v_num);
			break;
		case ERR_ONE:
			val.v_type = V_NUM;
			val.v_num = qlink(&_qone_);
			break;
		case ERR_INC:
			tmp.v_type = V_NUM;
			tmp.v_num = &_qone_;
			val = objcall(OBJ_ADD, v1, &tmp, NULL_VALUE);
			break;
		case ERR_DEC:
			tmp.v_type = V_NUM;
			tmp.v_num = &_qone_;
			val = objcall(OBJ_SUB, v1, &tmp, NULL_VALUE);
			break;
		case ERR_SQUARE:
			val = objcall(OBJ_MUL, v1, v1, NULL_VALUE);
			break;
		case ERR_VALUE:
			copyvalue(v1, &val);
			break;
		case ERR_ASSIGN:
			copyvalue(v2, &tmp);
			tmp.v_subtype |= v1->v_subtype;
			freevalue(v1);
			*v1 = tmp;
			val.v_type = V_NULL;
			break;
		default:
			math_error("Function \"%s\" is undefined", 
				    namefunc(index));
			/*NOTREACHED*/
		}
		return val;
	}
	switch (oip->args) {
	case 0:
		break;
	case 1:
		++stack;
		stack->v_addr = v1;
		stack->v_type = V_ADDR;
		break;
	case 2:
		++stack;
		stack->v_addr = v1;
		stack->v_type = V_ADDR;
		++stack;
		stack->v_addr = v2;
		stack->v_type = V_ADDR;
		break;
	case 3:
		++stack;
		stack->v_addr = v1;
		stack->v_type = V_ADDR;
		++stack;
		stack->v_addr = v2;
		stack->v_type = V_ADDR;
		++stack;
		stack->v_addr = v3;
		stack->v_type = V_ADDR;
		break;
	default:
		math_error("Bad number of args to calculate");
		/*NOTREACHED*/
	}
	calculate(fp, oip->args);
	switch (oip->retval) {
	case A_VALUE:
		return *stack--;
	case A_UNDEF:
		freevalue(stack--);
		val.v_type = V_NULL;
		break;
	case A_INT:
		if ((stack->v_type != V_NUM) || qisfrac(stack->v_num)) {
			math_error("Integer return value required");
			/*NOTREACHED*/
		}
		index = qtoi(stack->v_num);
		qfree(stack->v_num);
		stack--;
		val.v_type = V_INT;
		val.v_int = index;
		break;
	default:
		math_error("Bad object return");
		/*NOTREACHED*/
	}
	return val;
}