Scheme_Object *scheme_complex_sqrt(const Scheme_Object *o) { Scheme_Complex *c = (Scheme_Complex *)o; Scheme_Object *r, *i, *ssq, *srssq, *nrsq, *prsq, *nr, *ni; r = c->r; i = c->i; if (scheme_is_zero(i)) { /* Special case for x+0.0i: */ r = scheme_sqrt(1, &r); if (!SCHEME_COMPLEXP(r)) return scheme_make_complex(r, i); else { c = (Scheme_Complex *)r; if (SAME_OBJ(c->r, zero)) { /* need an inexact-zero real part: */ #ifdef MZ_USE_SINGLE_FLOATS if (SCHEME_FLTP(c->i)) r = scheme_make_float(0.0); else #endif r = scheme_make_double(0.0); return scheme_make_complex(r, c->i); } else return r; } } ssq = scheme_bin_plus(scheme_bin_mult(r, r), scheme_bin_mult(i, i)); srssq = scheme_sqrt(1, &ssq); if (SCHEME_FLOATP(srssq)) { /* We may have lost too much precision, if i << r. The result is going to be inexact, anyway, so switch to using expt. */ Scheme_Object *a[2]; a[0] = (Scheme_Object *)o; a[1] = scheme_make_double(0.5); return scheme_expt(2, a); } nrsq = scheme_bin_div(scheme_bin_minus(srssq, r), scheme_make_integer(2)); nr = scheme_sqrt(1, &nrsq); if (scheme_is_negative(i)) nr = scheme_bin_minus(zero, nr); prsq = scheme_bin_div(scheme_bin_plus(srssq, r), scheme_make_integer(2)); ni = scheme_sqrt(1, &prsq); return scheme_make_complex(ni, nr); }
Scheme_Object *scheme_complex_power(const Scheme_Object *base, const Scheme_Object *exponent) { Scheme_Complex *cb = (Scheme_Complex *)base; Scheme_Complex *ce = (Scheme_Complex *)exponent; double a, b, c, d, bm, ba, nm, na, r1, r2; int d_is_zero; if ((ce->i == zero) && !SCHEME_FLOATP(ce->r)) { if (SCHEME_INTP(ce->r) || SCHEME_BIGNUMP(ce->r)) return scheme_generic_integer_power(base, ce->r); } a = scheme_get_val_as_double(cb->r); b = scheme_get_val_as_double(cb->i); c = scheme_get_val_as_double(ce->r); d = scheme_get_val_as_double(ce->i); d_is_zero = (ce->i == zero); bm = sqrt(a * a + b * b); ba = atan2(b, a); /* New mag & angle */ nm = scheme_double_expt(bm, c) * exp(-(ba * d)); if (d_is_zero) /* precision here can avoid NaNs */ na = ba * c; else na = log(bm) * d + ba * c; r1 = nm * cos(na); r2 = nm * sin(na); #ifdef MZ_USE_SINGLE_FLOATS /* Coerce to double or float? */ #ifdef USE_SINGLE_FLOATS_AS_DEFAULT if (!SCHEME_DBLP(cb->r) && !SCHEME_DBLP(cb->i) && !SCHEME_DBLP(ce->r) && !SCHEME_DBLP(ce->i)) #else if (SCHEME_FLTP(cb->r) && SCHEME_FLTP(cb->i) && SCHEME_FLTP(ce->r) && SCHEME_FLTP(ce->i)) #endif return scheme_make_complex(scheme_make_float((float)r1), scheme_make_float((float)r2)); #endif return scheme_make_complex(scheme_make_double(r1), scheme_make_double(r2)); }
Scheme_Object *scheme_complex_subtract(const Scheme_Object *a, const Scheme_Object *b) { Scheme_Complex *ca = (Scheme_Complex *)a; Scheme_Complex *cb = (Scheme_Complex *)b; return scheme_make_complex(scheme_bin_minus(ca->r, cb->r), scheme_bin_minus(ca->i, cb->i)); }
Scheme_Object *scheme_complex_multiply(const Scheme_Object *a, const Scheme_Object *b) { Scheme_Complex *ca = (Scheme_Complex *)a; Scheme_Complex *cb = (Scheme_Complex *)b; return scheme_make_complex(scheme_bin_minus(scheme_bin_mult(ca->r, cb->r), scheme_bin_mult(ca->i, cb->i)), scheme_bin_plus(scheme_bin_mult(ca->r, cb->i), scheme_bin_mult(ca->i, cb->r))); }
Scheme_Object *scheme_complex_divide(const Scheme_Object *_n, const Scheme_Object *_d) { Scheme_Complex *cn = (Scheme_Complex *)_n; Scheme_Complex *cd = (Scheme_Complex *)_d; Scheme_Object *den, *r, *i, *a, *b, *c, *d, *cm, *dm, *aa[1]; int swap; if ((cn->r == zero) && (cn->i == zero)) return zero; a = cn->r; b = cn->i; c = cd->r; d = cd->i; /* Check for exact-zero simplifications in d: */ if (c == zero) { i = scheme_bin_minus(zero, scheme_bin_div(a, d)); r = scheme_bin_div(b, d); return scheme_make_complex(r, i); } else if (d == zero) { r = scheme_bin_div(a, c); i = scheme_bin_div(b, c); return scheme_make_complex(r, i); } if (!SCHEME_FLOATP(c) && !SCHEME_FLOATP(d)) { /* The simple way: */ cm = scheme_bin_plus(scheme_bin_mult(c, c), scheme_bin_mult(d, d)); r = scheme_bin_div(scheme_bin_plus(scheme_bin_mult(c, a), scheme_bin_mult(d, b)), cm); i = scheme_bin_div(scheme_bin_minus(scheme_bin_mult(c, b), scheme_bin_mult(d, a)), cm); return scheme_make_complex(r, i); } if (scheme_is_zero(d)) { /* This is like dividing by a real number, except that the inexact 0 imaginary part can interact with +inf.0 and +nan.0 */ r = scheme_bin_plus(scheme_bin_div(a, c), /* Either 0.0 or +nan.0: */ scheme_bin_mult(d, b)); i = scheme_bin_minus(scheme_bin_div(b, c), /* Either 0.0 or +nan.0: */ scheme_bin_mult(d, a)); return scheme_make_complex(r, i); } if (scheme_is_zero(c)) { r = scheme_bin_plus(scheme_bin_div(b, d), /* Either 0.0 or +nan.0: */ scheme_bin_mult(c, a)); i = scheme_bin_minus(scheme_bin_mult(c, b), /* either 0.0 or +nan.0 */ scheme_bin_div(a, d)); return scheme_make_complex(r, i); } aa[0] = c; cm = scheme_abs(1, aa); aa[0] = d; dm = scheme_abs(1, aa); if (scheme_bin_lt(cm, dm)) { cm = a; a = b; b = cm; cm = c; c = d; d = cm; swap = 1; } else swap = 0; r = scheme_bin_div(c, d); den = scheme_bin_plus(d, scheme_bin_mult(c, r)); if (swap) i = scheme_bin_div(scheme_bin_minus(a, scheme_bin_mult(b, r)), den); else i = scheme_bin_div(scheme_bin_minus(scheme_bin_mult(b, r), a), den); r = scheme_bin_div(scheme_bin_plus(b, scheme_bin_mult(a, r)), den); return scheme_make_complex(r, i); }
Scheme_Object *scheme_places_deep_copy_worker(Scheme_Object *so, Scheme_Hash_Table *ht) { Scheme_Object *new_so = so; if (SCHEME_INTP(so)) { return so; } if (ht) { Scheme_Object *r; if ((r = scheme_hash_get(ht, so))) { return r; } } switch (so->type) { case scheme_true_type: case scheme_false_type: case scheme_null_type: case scheme_void_type: /* place_bi_channels are allocated in the master and can be passed along as is */ case scheme_place_bi_channel_type: new_so = so; break; case scheme_place_type: new_so = ((Scheme_Place *) so)->channel; break; case scheme_char_type: new_so = scheme_make_char(SCHEME_CHAR_VAL(so)); break; case scheme_rational_type: { Scheme_Object *n; Scheme_Object *d; n = scheme_rational_numerator(so); d = scheme_rational_denominator(so); n = scheme_places_deep_copy_worker(n, ht); d = scheme_places_deep_copy_worker(d, ht); new_so = scheme_make_rational(n, d); } break; case scheme_float_type: new_so = scheme_make_float(SCHEME_FLT_VAL(so)); break; case scheme_double_type: new_so = scheme_make_double(SCHEME_DBL_VAL(so)); break; case scheme_complex_type: { Scheme_Object *r; Scheme_Object *i; r = scheme_complex_real_part(so); i = scheme_complex_imaginary_part(so); r = scheme_places_deep_copy_worker(r, ht); i = scheme_places_deep_copy_worker(i, ht); new_so = scheme_make_complex(r, i); } break; case scheme_char_string_type: new_so = scheme_make_sized_offset_char_string(SCHEME_CHAR_STR_VAL(so), 0, SCHEME_CHAR_STRLEN_VAL(so), 1); break; case scheme_byte_string_type: if (SHARED_ALLOCATEDP(so)) { new_so = so; } else { new_so = scheme_make_sized_offset_byte_string(SCHEME_BYTE_STR_VAL(so), 0, SCHEME_BYTE_STRLEN_VAL(so), 1); } break; case scheme_unix_path_type: new_so = scheme_make_sized_offset_path(SCHEME_BYTE_STR_VAL(so), 0, SCHEME_BYTE_STRLEN_VAL(so), 1); break; case scheme_symbol_type: if (SCHEME_SYM_UNINTERNEDP(so)) { scheme_log_abort("cannot copy uninterned symbol"); abort(); } else { new_so = scheme_make_sized_offset_byte_string(SCHEME_SYM_VAL(so), 0, SCHEME_SYM_LEN(so), 1); new_so->type = scheme_serialized_symbol_type; } break; case scheme_serialized_symbol_type: new_so = scheme_intern_exact_symbol(SCHEME_BYTE_STR_VAL(so), SCHEME_BYTE_STRLEN_VAL(so)); break; case scheme_pair_type: { Scheme_Object *car; Scheme_Object *cdr; Scheme_Object *pair; car = scheme_places_deep_copy_worker(SCHEME_CAR(so), ht); cdr = scheme_places_deep_copy_worker(SCHEME_CDR(so), ht); pair = scheme_make_pair(car, cdr); new_so = pair; } break; case scheme_vector_type: { Scheme_Object *vec; intptr_t i; intptr_t size = SCHEME_VEC_SIZE(so); vec = scheme_make_vector(size, 0); for (i = 0; i <size ; i++) { Scheme_Object *tmp; tmp = scheme_places_deep_copy_worker(SCHEME_VEC_ELS(so)[i], ht); SCHEME_VEC_ELS(vec)[i] = tmp; } SCHEME_SET_IMMUTABLE(vec); new_so = vec; } break; case scheme_fxvector_type: if (SHARED_ALLOCATEDP(so)) { new_so = so; } else { Scheme_Vector *vec; intptr_t i; intptr_t size = SCHEME_FXVEC_SIZE(so); vec = scheme_alloc_fxvector(size); for (i = 0; i < size; i++) { SCHEME_FXVEC_ELS(vec)[i] = SCHEME_FXVEC_ELS(so)[i]; } new_so = (Scheme_Object *) vec; } break; case scheme_flvector_type: if (SHARED_ALLOCATEDP(so)) { new_so = so; } else { Scheme_Double_Vector *vec; intptr_t i; intptr_t size = SCHEME_FLVEC_SIZE(so); vec = scheme_alloc_flvector(size); for (i = 0; i < size; i++) { SCHEME_FLVEC_ELS(vec)[i] = SCHEME_FLVEC_ELS(so)[i]; } new_so = (Scheme_Object *) vec; } break; case scheme_structure_type: { Scheme_Structure *st = (Scheme_Structure*)so; Scheme_Serialized_Structure *nst; Scheme_Struct_Type *stype = st->stype; Scheme_Struct_Type *ptype = stype->parent_types[stype->name_pos - 1]; Scheme_Object *nprefab_key; intptr_t size = stype->num_slots; int local_slots = stype->num_slots - (ptype ? ptype->num_slots : 0); int i = 0; if (!stype->prefab_key) { scheme_log_abort("cannot copy non prefab structure"); abort(); } { for (i = 0; i < local_slots; i++) { if (!stype->immutables || stype->immutables[i] != 1) { scheme_log_abort("cannot copy mutable prefab structure"); abort(); } } } nprefab_key = scheme_places_deep_copy_worker(stype->prefab_key, ht); nst = (Scheme_Serialized_Structure*) scheme_make_serialized_struct_instance(nprefab_key, size); for (i = 0; i <size ; i++) { Scheme_Object *tmp; tmp = scheme_places_deep_copy_worker((Scheme_Object*) st->slots[i], ht); nst->slots[i] = tmp; } new_so = (Scheme_Object*) nst; } break; case scheme_serialized_structure_type: { Scheme_Serialized_Structure *st = (Scheme_Serialized_Structure*)so; Scheme_Struct_Type *stype; Scheme_Structure *nst; intptr_t size; int i = 0; size = st->num_slots; stype = scheme_lookup_prefab_type(SCHEME_CDR(st->prefab_key), size); nst = (Scheme_Structure*) scheme_make_blank_prefab_struct_instance(stype); for (i = 0; i <size ; i++) { Scheme_Object *tmp; tmp = scheme_places_deep_copy_worker((Scheme_Object*) st->slots[i], ht); nst->slots[i] = tmp; } new_so = (Scheme_Object*)nst; } break; case scheme_resolved_module_path_type: default: printf("places deep copy cannot copy object of type %hi at %p\n", so->type, so); scheme_log_abort("places deep copy cannot copy object"); abort(); break; } if (ht) { scheme_hash_set(ht, so, new_so); } return new_so; }