shithub: femtolisp

ref: c1b99838564a31cba20b227c1f4a9ffa51d5c74e
dir: /fl_arith_any.inc/

//value_t
//fl_*_any(value_t *args, uint32_t nargs)
// input: ACCUM_DEFAULT ARITH_OP(a,b)   MP_OP   ARITH_OVERFLOW
// add:   0             a+b             mpadd   sadd_overflow_64
// mul:   1             a*b             mpmul   smul_overflow_64

	mpint *Maccum = nil, *m = nil;
	int64_t Saccum = ACCUM_DEFAULT, x;
	uint64_t u64;
	double Faccum = ACCUM_DEFAULT;
	bool inexact = false;
	value_t arg;
	numerictype_t pt;
	void *a;
	cprim_t *cp;
	cvalue_t *cv;

	uint32_t i, j;
	FOR_ARGS(i, 0, arg, args){
		if(isfixnum(arg))
			x = numval(arg);
		else{
			if(iscprim(arg)){
				cp = ptr(arg);
				a = cp_data(cp);
				pt = cp_numtype(cp);
			}else if(iscvalue(arg)){
				cv = ptr(arg);
				a = cv_data(cv);
				pt = cv_class(cv)->numtype;
			}else{
typeerr:
				mpfree(Maccum);
				mpfree(m);
				type_error("number", arg);
			}
			switch(pt){
			case T_DOUBLE: Faccum = ARITH_OP(Faccum, *(double*)a); inexact = true; continue;
			case T_FLOAT:  Faccum = ARITH_OP(Faccum, *(float*)a); inexact = true; continue;
			case T_INT8:   x = *(int8_t*)a; break;
			case T_UINT8:  x = *(uint8_t*)a; break;
			case T_INT16:  x = *(int16_t*)a; break;
			case T_UINT16: x = *(uint16_t*)a; break;
			case T_INT32:  x = *(int32_t*)a; break;
			case T_UINT32: x = *(uint32_t*)a; break;
			case T_INT64:  x = *(int64_t*)a; break;
			case T_UINT64:
				u64 = *(uint64_t*)a;
				if(u64 > INT64_MAX){
					x = ACCUM_DEFAULT;
					goto overflow;
				}
				x = u64;
				break;
			case T_MPINT:
				x = ACCUM_DEFAULT;
				u64 = ACCUM_DEFAULT;
				m = mpcopy(*(mpint**)a);
				goto overflow;
			default:
				goto typeerr;
			}
		}

		int64_t accu;
		if(ARITH_OVERFLOW(Saccum, x, &accu)){
			u64 = ACCUM_DEFAULT;
			goto overflow;
		}
		Saccum = accu;
	}

	if(inexact)
		return mk_double(ARITH_OP(Faccum, Saccum));
	if(fits_fixnum(Saccum))
		return fixnum((fixnum_t)Saccum);
	u64 = ACCUM_DEFAULT;
	x = ACCUM_DEFAULT;

overflow:
	i++;
	if(Maccum == nil)
		Maccum = vtomp(Saccum, nil);
	if(m == nil)
		m = u64 != ACCUM_DEFAULT ? uvtomp(u64, nil) : vtomp(x, nil);

	MP_OP(Maccum, m, Maccum);

	FOR_ARGS(j, i, arg, args){
		if(isfixnum(arg)){
			vtomp(numval(arg), m);
			MP_OP(Maccum, m, Maccum);
			continue;
		}

		if(iscprim(arg)){
			cp = ptr(arg);
			a = cp_data(cp);
			pt = cp_numtype(cp);
		}else if(iscvalue(arg)){
			cv = ptr(arg);
			a = cv_data(cv);
			pt = cv_class(cv)->numtype;
		}else{
			goto typeerr;
		}
		switch(pt){
		case T_DOUBLE: Faccum = ARITH_OP(Faccum, *(double*)a); inexact = true; continue;
		case T_FLOAT:  Faccum = ARITH_OP(Faccum, *(float*)a); inexact = true; continue;
		case T_INT8:   x = *(int8_t*)a; break;
		case T_UINT8:  x = *(uint8_t*)a; break;
		case T_INT16:  x = *(int16_t*)a; break;
		case T_UINT16: x = *(uint16_t*)a; break;
		case T_INT32:  x = *(int32_t*)a; break;
		case T_UINT32: x = *(uint32_t*)a; break;
		case T_INT64:  x = *(int64_t*)a; break;
		case T_UINT64:
			uvtomp(*(uint64_t*)a, m);
			MP_OP(Maccum, m, Maccum);
			continue;
		case T_MPINT:
			MP_OP(Maccum, *(mpint**)a, Maccum);
			continue;
		default:
			goto typeerr;
		}
		vtomp(x, m);
		MP_OP(Maccum, m, Maccum);
	}

	int n = mpsignif(Maccum);
	if(n >= FIXNUM_BITS){
		if(inexact){
			dtomp(Faccum, m);
			MP_OP(Maccum, m, Maccum);
			n = mpsignif(Maccum);
			if(n < FIXNUM_BITS){
				inexact = false;
				goto down;
			}
		}
		mpfree(m);
		return mk_mpint(Maccum);
	}

down:
	mpfree(m);
	Saccum = mptov(Maccum);
	mpfree(Maccum);
	if(inexact)
		return mk_double(ARITH_OP(Faccum, Saccum));
	assert(fits_fixnum(Saccum));
	return fixnum((fixnum_t)Saccum);

#undef ACCUM_DEFAULT
#undef ARITH_OP
#undef MP_OP
#undef ARITH_OVERFLOW