shithub: sl

ref: 55b73ae9d6016819d0f17a3b0ac4b10d0f34ee80
dir: /src/sl_arith_any.h/

//sl_v
//sl_*_any(sl_v *args, u32int 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;
	s64int Saccum = ACCUM_DEFAULT, x;
	double Faccum = ACCUM_DEFAULT;
	u64int u64;
	bool inexact = false;
	int forcetype = -1;
	sl_v arg;
	sl_numtype pt;
	void *a;
	sl_cv *cv;

	u32int i, j;
	FOR_ARGS(i, 0, arg, args){
		if(isfixnum(arg))
			x = numval(arg);
		else{
			if(isubnum(arg)){
				u64 = ubnumval(arg);
				a = &u64;
				pt = ubnumtype(arg);
			}else if(iscvalue(arg)){
				cv = ptr(arg);
				a = cv_data(cv);
				pt = cv_numtype(cv);
			}else{
typeerr:
				mpfree(Maccum);
				mpfree(m);
				type_error("num", arg);
			}
			switch(pt){
			case T_DBL: Faccum = ARITH_OP(Faccum, *(double*)a); inexact = true; continue;
			case T_FLT:  Faccum = ARITH_OP(Faccum, *(float*)a); inexact = true; continue;
			case T_S8:  x = *(s8int*)a; break;
			case T_U8:  x = *(u8int*)a; break;
			case T_S16: x = *(s16int*)a; break;
			case T_U16: x = *(u16int*)a; break;
			case T_S32: x = *(s32int*)a; break;
			case T_P32: if(forcetype < T_P32) forcetype = T_P32;
				// fall through
			case T_U32: x = *(u32int*)a; break;
			case T_S64: x = *(s64int*)a; break;
			case T_P64: if(forcetype < T_P64) forcetype = T_P64;
				// fall through
			case T_U64:
				u64 = *(u64int*)a;
				if(u64 > INT64_MAX){
					x = ACCUM_DEFAULT;
					goto overflow;
				}
				x = u64;
				break;
			case T_BIG:
				x = ACCUM_DEFAULT;
				u64 = ACCUM_DEFAULT;
				m = mpcopy(*(mpint**)a);
				goto overflow;
			default:
				goto typeerr;
			}
		}

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

	if(forcetype >= 0){
forcedptr:
		if(inexact)
			lerrorf(sl_errarg, "arithmetic on a mix of ptr and inexact types");
		switch(forcetype){
		case T_P32: return mk_p32(Saccum);
		case T_P64: return mk_p64(Saccum);
		default: abort();
		}
	}
	if(inexact)
		return mk_double(ARITH_OP(Faccum, Saccum));
	if(fits_fixnum(Saccum))
		return fixnum((sl_fx)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(isubnum(arg)){
			u64 = ubnumval(arg);
			a = &u64;
			pt = ubnumtype(arg);
		}else if(iscvalue(arg)){
			cv = ptr(arg);
			a = cv_data(cv);
			pt = cv_numtype(cv);
		}else{
			goto typeerr;
		}
		switch(pt){
		case T_DBL: Faccum = ARITH_OP(Faccum, *(double*)a); inexact = true; continue;
		case T_FLT:  Faccum = ARITH_OP(Faccum, *(float*)a); inexact = true; continue;
		case T_S8:  x = *(s8int*)a; break;
		case T_U8:  x = *(u8int*)a; break;
		case T_S16: x = *(s16int*)a; break;
		case T_U16: x = *(u16int*)a; break;
		case T_S32: x = *(s32int*)a; break;
		case T_P32: if(forcetype < T_P32) forcetype = T_P32;
			// fall through
		case T_U32: x = *(u32int*)a; break;
		case T_S64: x = *(s64int*)a; break;
		case T_P64: if(forcetype < T_P64) forcetype = T_P64;
			// fall through
		case T_U64:
			uvtomp(*(u64int*)a, m);
			MP_OP(Maccum, m, Maccum);
			continue;
		case T_BIG:
			MP_OP(Maccum, *(mpint**)a, Maccum);
			continue;
		default:
			goto typeerr;
		}
		vtomp(x, m);
		MP_OP(Maccum, m, Maccum);
	}

	if(forcetype >= 0){
		Saccum = mptouv(Maccum);
		goto forcedptr;
	}

	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_bignum(Maccum);
	}
down:
	mpfree(m);
	Saccum = mptov(Maccum);
	mpfree(Maccum);
	if(inexact)
		return mk_double(ARITH_OP(Faccum, Saccum));
	assert(fits_fixnum(Saccum));
	return fixnum((sl_fx)Saccum);

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