#endif
#include <verify.h>
+ #include <assert.h>
#include <math.h>
#include <string.h>
{
SCM bignum;
- bignum = PTR2SCM (ptr);
+ bignum = SCM_PACK_POINTER (ptr);
mpz_clear (SCM_I_BIG_MPZ (bignum));
}
{
SCM z;
- z = PTR2SCM (scm_gc_malloc_pointerless (sizeof (scm_t_double), "real"));
+ z = SCM_PACK_POINTER (scm_gc_malloc_pointerless (sizeof (scm_t_double), "real"));
SCM_SET_CELL_TYPE (z, scm_tc16_real);
SCM_REAL_VALUE (z) = val;
else if (SCM_NUMBERP (x))
return SCM_BOOL_T;
else
- SCM_WTA_DISPATCH_1 (g_scm_exact_p, x, 1, s_scm_exact_p);
+ return scm_wta_dispatch_1 (g_scm_exact_p, x, 1, s_scm_exact_p);
}
#undef FUNC_NAME
else if (SCM_NUMBERP (x))
return SCM_BOOL_F;
else
- SCM_WTA_DISPATCH_1 (g_scm_inexact_p, x, 1, s_scm_inexact_p);
+ return scm_wta_dispatch_1 (g_scm_inexact_p, x, 1, s_scm_inexact_p);
}
#undef FUNC_NAME
return SCM_BOOL_F;
}
}
- SCM_WTA_DISPATCH_1 (g_scm_odd_p, n, 1, s_scm_odd_p);
+ return scm_wta_dispatch_1 (g_scm_odd_p, n, 1, s_scm_odd_p);
}
#undef FUNC_NAME
return SCM_BOOL_T;
}
}
- SCM_WTA_DISPATCH_1 (g_scm_even_p, n, 1, s_scm_even_p);
+ return scm_wta_dispatch_1 (g_scm_even_p, n, 1, s_scm_even_p);
}
#undef FUNC_NAME
else if (scm_is_real (x))
return SCM_BOOL_T;
else
- SCM_WTA_DISPATCH_1 (g_scm_finite_p, x, 1, s_scm_finite_p);
+ return scm_wta_dispatch_1 (g_scm_finite_p, x, 1, s_scm_finite_p);
}
#undef FUNC_NAME
else if (scm_is_real (x))
return SCM_BOOL_F;
else
- SCM_WTA_DISPATCH_1 (g_scm_inf_p, x, 1, s_scm_inf_p);
+ return scm_wta_dispatch_1 (g_scm_inf_p, x, 1, s_scm_inf_p);
}
#undef FUNC_NAME
else if (scm_is_real (x))
return SCM_BOOL_F;
else
- SCM_WTA_DISPATCH_1 (g_scm_nan_p, x, 1, s_scm_nan_p);
+ return scm_wta_dispatch_1 (g_scm_nan_p, x, 1, s_scm_nan_p);
}
#undef FUNC_NAME
SCM_FRACTION_DENOMINATOR (x));
}
else
- SCM_WTA_DISPATCH_1 (g_scm_abs, x, 1, s_scm_abs);
+ return scm_wta_dispatch_1 (g_scm_abs, x, 1, s_scm_abs);
}
#undef FUNC_NAME
if (SCM_LIKELY (scm_is_integer (y)))
return scm_truncate_quotient (x, y);
else
- SCM_WTA_DISPATCH_2 (g_scm_quotient, x, y, SCM_ARG2, s_scm_quotient);
+ return scm_wta_dispatch_2 (g_scm_quotient, x, y, SCM_ARG2, s_scm_quotient);
}
else
- SCM_WTA_DISPATCH_2 (g_scm_quotient, x, y, SCM_ARG1, s_scm_quotient);
+ return scm_wta_dispatch_2 (g_scm_quotient, x, y, SCM_ARG1, s_scm_quotient);
}
#undef FUNC_NAME
if (SCM_LIKELY (scm_is_integer (y)))
return scm_truncate_remainder (x, y);
else
- SCM_WTA_DISPATCH_2 (g_scm_remainder, x, y, SCM_ARG2, s_scm_remainder);
+ return scm_wta_dispatch_2 (g_scm_remainder, x, y, SCM_ARG2, s_scm_remainder);
}
else
- SCM_WTA_DISPATCH_2 (g_scm_remainder, x, y, SCM_ARG1, s_scm_remainder);
+ return scm_wta_dispatch_2 (g_scm_remainder, x, y, SCM_ARG1, s_scm_remainder);
}
#undef FUNC_NAME
if (SCM_LIKELY (scm_is_integer (y)))
return scm_floor_remainder (x, y);
else
- SCM_WTA_DISPATCH_2 (g_scm_modulo, x, y, SCM_ARG2, s_scm_modulo);
+ return scm_wta_dispatch_2 (g_scm_modulo, x, y, SCM_ARG2, s_scm_modulo);
}
else
- SCM_WTA_DISPATCH_2 (g_scm_modulo, x, y, SCM_ARG1, s_scm_modulo);
+ return scm_wta_dispatch_2 (g_scm_modulo, x, y, SCM_ARG1, s_scm_modulo);
}
#undef FUNC_NAME
two_valued_wta_dispatch_2 (SCM gf, SCM a1, SCM a2, int pos,
const char *subr, SCM *rp1, SCM *rp2)
{
- if (SCM_UNPACK (gf))
- scm_i_extract_values_2 (scm_call_generic_2 (gf, a1, a2), rp1, rp2);
- else
- scm_wrong_type_arg (subr, pos, (pos == SCM_ARG1) ? a1 : a2);
+ SCM vals = scm_wta_dispatch_2 (gf, a1, a2, pos, subr);
+
+ scm_i_extract_values_2 (vals, rp1, rp2);
}
SCM_DEFINE (scm_euclidean_quotient, "euclidean-quotient", 2, 0, 0,
else if (SCM_FRACTIONP (y))
return scm_i_exact_rational_floor_quotient (x, y);
else
- SCM_WTA_DISPATCH_2 (g_scm_floor_quotient, x, y, SCM_ARG2,
- s_scm_floor_quotient);
+ return scm_wta_dispatch_2 (g_scm_floor_quotient, x, y, SCM_ARG2,
+ s_scm_floor_quotient);
}
else if (SCM_BIGP (x))
{
else if (SCM_FRACTIONP (y))
return scm_i_exact_rational_floor_quotient (x, y);
else
- SCM_WTA_DISPATCH_2 (g_scm_floor_quotient, x, y, SCM_ARG2,
- s_scm_floor_quotient);
+ return scm_wta_dispatch_2 (g_scm_floor_quotient, x, y, SCM_ARG2,
+ s_scm_floor_quotient);
}
else if (SCM_REALP (x))
{
return scm_i_inexact_floor_quotient
(SCM_REAL_VALUE (x), scm_to_double (y));
else
- SCM_WTA_DISPATCH_2 (g_scm_floor_quotient, x, y, SCM_ARG2,
- s_scm_floor_quotient);
+ return scm_wta_dispatch_2 (g_scm_floor_quotient, x, y, SCM_ARG2,
+ s_scm_floor_quotient);
}
else if (SCM_FRACTIONP (x))
{
else if (SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y))
return scm_i_exact_rational_floor_quotient (x, y);
else
- SCM_WTA_DISPATCH_2 (g_scm_floor_quotient, x, y, SCM_ARG2,
- s_scm_floor_quotient);
+ return scm_wta_dispatch_2 (g_scm_floor_quotient, x, y, SCM_ARG2,
+ s_scm_floor_quotient);
}
else
- SCM_WTA_DISPATCH_2 (g_scm_floor_quotient, x, y, SCM_ARG1,
- s_scm_floor_quotient);
+ return scm_wta_dispatch_2 (g_scm_floor_quotient, x, y, SCM_ARG1,
+ s_scm_floor_quotient);
}
#undef FUNC_NAME
else if (SCM_FRACTIONP (y))
return scm_i_exact_rational_floor_remainder (x, y);
else
- SCM_WTA_DISPATCH_2 (g_scm_floor_remainder, x, y, SCM_ARG2,
- s_scm_floor_remainder);
+ return scm_wta_dispatch_2 (g_scm_floor_remainder, x, y, SCM_ARG2,
+ s_scm_floor_remainder);
}
else if (SCM_BIGP (x))
{
else if (SCM_FRACTIONP (y))
return scm_i_exact_rational_floor_remainder (x, y);
else
- SCM_WTA_DISPATCH_2 (g_scm_floor_remainder, x, y, SCM_ARG2,
- s_scm_floor_remainder);
+ return scm_wta_dispatch_2 (g_scm_floor_remainder, x, y, SCM_ARG2,
+ s_scm_floor_remainder);
}
else if (SCM_REALP (x))
{
return scm_i_inexact_floor_remainder
(SCM_REAL_VALUE (x), scm_to_double (y));
else
- SCM_WTA_DISPATCH_2 (g_scm_floor_remainder, x, y, SCM_ARG2,
- s_scm_floor_remainder);
+ return scm_wta_dispatch_2 (g_scm_floor_remainder, x, y, SCM_ARG2,
+ s_scm_floor_remainder);
}
else if (SCM_FRACTIONP (x))
{
else if (SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y))
return scm_i_exact_rational_floor_remainder (x, y);
else
- SCM_WTA_DISPATCH_2 (g_scm_floor_remainder, x, y, SCM_ARG2,
- s_scm_floor_remainder);
+ return scm_wta_dispatch_2 (g_scm_floor_remainder, x, y, SCM_ARG2,
+ s_scm_floor_remainder);
}
else
- SCM_WTA_DISPATCH_2 (g_scm_floor_remainder, x, y, SCM_ARG1,
- s_scm_floor_remainder);
+ return scm_wta_dispatch_2 (g_scm_floor_remainder, x, y, SCM_ARG1,
+ s_scm_floor_remainder);
}
#undef FUNC_NAME
else if (SCM_FRACTIONP (y))
return scm_i_exact_rational_ceiling_quotient (x, y);
else
- SCM_WTA_DISPATCH_2 (g_scm_ceiling_quotient, x, y, SCM_ARG2,
- s_scm_ceiling_quotient);
+ return scm_wta_dispatch_2 (g_scm_ceiling_quotient, x, y, SCM_ARG2,
+ s_scm_ceiling_quotient);
}
else if (SCM_BIGP (x))
{
else if (SCM_FRACTIONP (y))
return scm_i_exact_rational_ceiling_quotient (x, y);
else
- SCM_WTA_DISPATCH_2 (g_scm_ceiling_quotient, x, y, SCM_ARG2,
- s_scm_ceiling_quotient);
+ return scm_wta_dispatch_2 (g_scm_ceiling_quotient, x, y, SCM_ARG2,
+ s_scm_ceiling_quotient);
}
else if (SCM_REALP (x))
{
return scm_i_inexact_ceiling_quotient
(SCM_REAL_VALUE (x), scm_to_double (y));
else
- SCM_WTA_DISPATCH_2 (g_scm_ceiling_quotient, x, y, SCM_ARG2,
- s_scm_ceiling_quotient);
+ return scm_wta_dispatch_2 (g_scm_ceiling_quotient, x, y, SCM_ARG2,
+ s_scm_ceiling_quotient);
}
else if (SCM_FRACTIONP (x))
{
else if (SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y))
return scm_i_exact_rational_ceiling_quotient (x, y);
else
- SCM_WTA_DISPATCH_2 (g_scm_ceiling_quotient, x, y, SCM_ARG2,
- s_scm_ceiling_quotient);
+ return scm_wta_dispatch_2 (g_scm_ceiling_quotient, x, y, SCM_ARG2,
+ s_scm_ceiling_quotient);
}
else
- SCM_WTA_DISPATCH_2 (g_scm_ceiling_quotient, x, y, SCM_ARG1,
- s_scm_ceiling_quotient);
+ return scm_wta_dispatch_2 (g_scm_ceiling_quotient, x, y, SCM_ARG1,
+ s_scm_ceiling_quotient);
}
#undef FUNC_NAME
else if (SCM_FRACTIONP (y))
return scm_i_exact_rational_ceiling_remainder (x, y);
else
- SCM_WTA_DISPATCH_2 (g_scm_ceiling_remainder, x, y, SCM_ARG2,
- s_scm_ceiling_remainder);
+ return scm_wta_dispatch_2 (g_scm_ceiling_remainder, x, y, SCM_ARG2,
+ s_scm_ceiling_remainder);
}
else if (SCM_BIGP (x))
{
else if (SCM_FRACTIONP (y))
return scm_i_exact_rational_ceiling_remainder (x, y);
else
- SCM_WTA_DISPATCH_2 (g_scm_ceiling_remainder, x, y, SCM_ARG2,
- s_scm_ceiling_remainder);
+ return scm_wta_dispatch_2 (g_scm_ceiling_remainder, x, y, SCM_ARG2,
+ s_scm_ceiling_remainder);
}
else if (SCM_REALP (x))
{
return scm_i_inexact_ceiling_remainder
(SCM_REAL_VALUE (x), scm_to_double (y));
else
- SCM_WTA_DISPATCH_2 (g_scm_ceiling_remainder, x, y, SCM_ARG2,
- s_scm_ceiling_remainder);
+ return scm_wta_dispatch_2 (g_scm_ceiling_remainder, x, y, SCM_ARG2,
+ s_scm_ceiling_remainder);
}
else if (SCM_FRACTIONP (x))
{
else if (SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y))
return scm_i_exact_rational_ceiling_remainder (x, y);
else
- SCM_WTA_DISPATCH_2 (g_scm_ceiling_remainder, x, y, SCM_ARG2,
- s_scm_ceiling_remainder);
+ return scm_wta_dispatch_2 (g_scm_ceiling_remainder, x, y, SCM_ARG2,
+ s_scm_ceiling_remainder);
}
else
- SCM_WTA_DISPATCH_2 (g_scm_ceiling_remainder, x, y, SCM_ARG1,
- s_scm_ceiling_remainder);
+ return scm_wta_dispatch_2 (g_scm_ceiling_remainder, x, y, SCM_ARG1,
+ s_scm_ceiling_remainder);
}
#undef FUNC_NAME
else if (SCM_FRACTIONP (y))
return scm_i_exact_rational_truncate_quotient (x, y);
else
- SCM_WTA_DISPATCH_2 (g_scm_truncate_quotient, x, y, SCM_ARG2,
- s_scm_truncate_quotient);
+ return scm_wta_dispatch_2 (g_scm_truncate_quotient, x, y, SCM_ARG2,
+ s_scm_truncate_quotient);
}
else if (SCM_BIGP (x))
{
else if (SCM_FRACTIONP (y))
return scm_i_exact_rational_truncate_quotient (x, y);
else
- SCM_WTA_DISPATCH_2 (g_scm_truncate_quotient, x, y, SCM_ARG2,
- s_scm_truncate_quotient);
+ return scm_wta_dispatch_2 (g_scm_truncate_quotient, x, y, SCM_ARG2,
+ s_scm_truncate_quotient);
}
else if (SCM_REALP (x))
{
return scm_i_inexact_truncate_quotient
(SCM_REAL_VALUE (x), scm_to_double (y));
else
- SCM_WTA_DISPATCH_2 (g_scm_truncate_quotient, x, y, SCM_ARG2,
- s_scm_truncate_quotient);
+ return scm_wta_dispatch_2 (g_scm_truncate_quotient, x, y, SCM_ARG2,
+ s_scm_truncate_quotient);
}
else if (SCM_FRACTIONP (x))
{
else if (SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y))
return scm_i_exact_rational_truncate_quotient (x, y);
else
- SCM_WTA_DISPATCH_2 (g_scm_truncate_quotient, x, y, SCM_ARG2,
- s_scm_truncate_quotient);
+ return scm_wta_dispatch_2 (g_scm_truncate_quotient, x, y, SCM_ARG2,
+ s_scm_truncate_quotient);
}
else
- SCM_WTA_DISPATCH_2 (g_scm_truncate_quotient, x, y, SCM_ARG1,
- s_scm_truncate_quotient);
+ return scm_wta_dispatch_2 (g_scm_truncate_quotient, x, y, SCM_ARG1,
+ s_scm_truncate_quotient);
}
#undef FUNC_NAME
else if (SCM_FRACTIONP (y))
return scm_i_exact_rational_truncate_remainder (x, y);
else
- SCM_WTA_DISPATCH_2 (g_scm_truncate_remainder, x, y, SCM_ARG2,
- s_scm_truncate_remainder);
+ return scm_wta_dispatch_2 (g_scm_truncate_remainder, x, y, SCM_ARG2,
+ s_scm_truncate_remainder);
}
else if (SCM_BIGP (x))
{
else if (SCM_FRACTIONP (y))
return scm_i_exact_rational_truncate_remainder (x, y);
else
- SCM_WTA_DISPATCH_2 (g_scm_truncate_remainder, x, y, SCM_ARG2,
- s_scm_truncate_remainder);
+ return scm_wta_dispatch_2 (g_scm_truncate_remainder, x, y, SCM_ARG2,
+ s_scm_truncate_remainder);
}
else if (SCM_REALP (x))
{
return scm_i_inexact_truncate_remainder
(SCM_REAL_VALUE (x), scm_to_double (y));
else
- SCM_WTA_DISPATCH_2 (g_scm_truncate_remainder, x, y, SCM_ARG2,
- s_scm_truncate_remainder);
+ return scm_wta_dispatch_2 (g_scm_truncate_remainder, x, y, SCM_ARG2,
+ s_scm_truncate_remainder);
}
else if (SCM_FRACTIONP (x))
{
else if (SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y))
return scm_i_exact_rational_truncate_remainder (x, y);
else
- SCM_WTA_DISPATCH_2 (g_scm_truncate_remainder, x, y, SCM_ARG2,
- s_scm_truncate_remainder);
+ return scm_wta_dispatch_2 (g_scm_truncate_remainder, x, y, SCM_ARG2,
+ s_scm_truncate_remainder);
}
else
- SCM_WTA_DISPATCH_2 (g_scm_truncate_remainder, x, y, SCM_ARG1,
- s_scm_truncate_remainder);
+ return scm_wta_dispatch_2 (g_scm_truncate_remainder, x, y, SCM_ARG1,
+ s_scm_truncate_remainder);
}
#undef FUNC_NAME
else if (SCM_FRACTIONP (y))
return scm_i_exact_rational_centered_quotient (x, y);
else
- SCM_WTA_DISPATCH_2 (g_scm_centered_quotient, x, y, SCM_ARG2,
- s_scm_centered_quotient);
+ return scm_wta_dispatch_2 (g_scm_centered_quotient, x, y, SCM_ARG2,
+ s_scm_centered_quotient);
}
else if (SCM_BIGP (x))
{
else if (SCM_FRACTIONP (y))
return scm_i_exact_rational_centered_quotient (x, y);
else
- SCM_WTA_DISPATCH_2 (g_scm_centered_quotient, x, y, SCM_ARG2,
- s_scm_centered_quotient);
+ return scm_wta_dispatch_2 (g_scm_centered_quotient, x, y, SCM_ARG2,
+ s_scm_centered_quotient);
}
else if (SCM_REALP (x))
{
return scm_i_inexact_centered_quotient
(SCM_REAL_VALUE (x), scm_to_double (y));
else
- SCM_WTA_DISPATCH_2 (g_scm_centered_quotient, x, y, SCM_ARG2,
- s_scm_centered_quotient);
+ return scm_wta_dispatch_2 (g_scm_centered_quotient, x, y, SCM_ARG2,
+ s_scm_centered_quotient);
}
else if (SCM_FRACTIONP (x))
{
else if (SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y))
return scm_i_exact_rational_centered_quotient (x, y);
else
- SCM_WTA_DISPATCH_2 (g_scm_centered_quotient, x, y, SCM_ARG2,
- s_scm_centered_quotient);
+ return scm_wta_dispatch_2 (g_scm_centered_quotient, x, y, SCM_ARG2,
+ s_scm_centered_quotient);
}
else
- SCM_WTA_DISPATCH_2 (g_scm_centered_quotient, x, y, SCM_ARG1,
- s_scm_centered_quotient);
+ return scm_wta_dispatch_2 (g_scm_centered_quotient, x, y, SCM_ARG1,
+ s_scm_centered_quotient);
}
#undef FUNC_NAME
else if (SCM_FRACTIONP (y))
return scm_i_exact_rational_centered_remainder (x, y);
else
- SCM_WTA_DISPATCH_2 (g_scm_centered_remainder, x, y, SCM_ARG2,
- s_scm_centered_remainder);
+ return scm_wta_dispatch_2 (g_scm_centered_remainder, x, y, SCM_ARG2,
+ s_scm_centered_remainder);
}
else if (SCM_BIGP (x))
{
else if (SCM_FRACTIONP (y))
return scm_i_exact_rational_centered_remainder (x, y);
else
- SCM_WTA_DISPATCH_2 (g_scm_centered_remainder, x, y, SCM_ARG2,
- s_scm_centered_remainder);
+ return scm_wta_dispatch_2 (g_scm_centered_remainder, x, y, SCM_ARG2,
+ s_scm_centered_remainder);
}
else if (SCM_REALP (x))
{
return scm_i_inexact_centered_remainder
(SCM_REAL_VALUE (x), scm_to_double (y));
else
- SCM_WTA_DISPATCH_2 (g_scm_centered_remainder, x, y, SCM_ARG2,
- s_scm_centered_remainder);
+ return scm_wta_dispatch_2 (g_scm_centered_remainder, x, y, SCM_ARG2,
+ s_scm_centered_remainder);
}
else if (SCM_FRACTIONP (x))
{
else if (SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y))
return scm_i_exact_rational_centered_remainder (x, y);
else
- SCM_WTA_DISPATCH_2 (g_scm_centered_remainder, x, y, SCM_ARG2,
- s_scm_centered_remainder);
+ return scm_wta_dispatch_2 (g_scm_centered_remainder, x, y, SCM_ARG2,
+ s_scm_centered_remainder);
}
else
- SCM_WTA_DISPATCH_2 (g_scm_centered_remainder, x, y, SCM_ARG1,
- s_scm_centered_remainder);
+ return scm_wta_dispatch_2 (g_scm_centered_remainder, x, y, SCM_ARG1,
+ s_scm_centered_remainder);
}
#undef FUNC_NAME
else if (SCM_FRACTIONP (y))
return scm_i_exact_rational_round_quotient (x, y);
else
- SCM_WTA_DISPATCH_2 (g_scm_round_quotient, x, y, SCM_ARG2,
- s_scm_round_quotient);
+ return scm_wta_dispatch_2 (g_scm_round_quotient, x, y, SCM_ARG2,
+ s_scm_round_quotient);
}
else if (SCM_BIGP (x))
{
else if (SCM_FRACTIONP (y))
return scm_i_exact_rational_round_quotient (x, y);
else
- SCM_WTA_DISPATCH_2 (g_scm_round_quotient, x, y, SCM_ARG2,
- s_scm_round_quotient);
+ return scm_wta_dispatch_2 (g_scm_round_quotient, x, y, SCM_ARG2,
+ s_scm_round_quotient);
}
else if (SCM_REALP (x))
{
return scm_i_inexact_round_quotient
(SCM_REAL_VALUE (x), scm_to_double (y));
else
- SCM_WTA_DISPATCH_2 (g_scm_round_quotient, x, y, SCM_ARG2,
- s_scm_round_quotient);
+ return scm_wta_dispatch_2 (g_scm_round_quotient, x, y, SCM_ARG2,
+ s_scm_round_quotient);
}
else if (SCM_FRACTIONP (x))
{
else if (SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y))
return scm_i_exact_rational_round_quotient (x, y);
else
- SCM_WTA_DISPATCH_2 (g_scm_round_quotient, x, y, SCM_ARG2,
- s_scm_round_quotient);
+ return scm_wta_dispatch_2 (g_scm_round_quotient, x, y, SCM_ARG2,
+ s_scm_round_quotient);
}
else
- SCM_WTA_DISPATCH_2 (g_scm_round_quotient, x, y, SCM_ARG1,
- s_scm_round_quotient);
+ return scm_wta_dispatch_2 (g_scm_round_quotient, x, y, SCM_ARG1,
+ s_scm_round_quotient);
}
#undef FUNC_NAME
else if (SCM_FRACTIONP (y))
return scm_i_exact_rational_round_remainder (x, y);
else
- SCM_WTA_DISPATCH_2 (g_scm_round_remainder, x, y, SCM_ARG2,
- s_scm_round_remainder);
+ return scm_wta_dispatch_2 (g_scm_round_remainder, x, y, SCM_ARG2,
+ s_scm_round_remainder);
}
else if (SCM_BIGP (x))
{
else if (SCM_FRACTIONP (y))
return scm_i_exact_rational_round_remainder (x, y);
else
- SCM_WTA_DISPATCH_2 (g_scm_round_remainder, x, y, SCM_ARG2,
- s_scm_round_remainder);
+ return scm_wta_dispatch_2 (g_scm_round_remainder, x, y, SCM_ARG2,
+ s_scm_round_remainder);
}
else if (SCM_REALP (x))
{
return scm_i_inexact_round_remainder
(SCM_REAL_VALUE (x), scm_to_double (y));
else
- SCM_WTA_DISPATCH_2 (g_scm_round_remainder, x, y, SCM_ARG2,
- s_scm_round_remainder);
+ return scm_wta_dispatch_2 (g_scm_round_remainder, x, y, SCM_ARG2,
+ s_scm_round_remainder);
}
else if (SCM_FRACTIONP (x))
{
else if (SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y))
return scm_i_exact_rational_round_remainder (x, y);
else
- SCM_WTA_DISPATCH_2 (g_scm_round_remainder, x, y, SCM_ARG2,
- s_scm_round_remainder);
+ return scm_wta_dispatch_2 (g_scm_round_remainder, x, y, SCM_ARG2,
+ s_scm_round_remainder);
}
else
- SCM_WTA_DISPATCH_2 (g_scm_round_remainder, x, y, SCM_ARG1,
- s_scm_round_remainder);
+ return scm_wta_dispatch_2 (g_scm_round_remainder, x, y, SCM_ARG1,
+ s_scm_round_remainder);
}
#undef FUNC_NAME
else if (SCM_REALP (y) && scm_is_integer (y))
goto handle_inexacts;
else
- SCM_WTA_DISPATCH_2 (g_gcd, x, y, SCM_ARG2, s_gcd);
+ return scm_wta_dispatch_2 (g_gcd, x, y, SCM_ARG2, s_gcd);
}
else if (SCM_BIGP (x))
{
else if (SCM_REALP (y) && scm_is_integer (y))
goto handle_inexacts;
else
- SCM_WTA_DISPATCH_2 (g_gcd, x, y, SCM_ARG2, s_gcd);
+ return scm_wta_dispatch_2 (g_gcd, x, y, SCM_ARG2, s_gcd);
}
else if (SCM_REALP (x) && scm_is_integer (x))
{
scm_inexact_to_exact (y)));
}
else
- SCM_WTA_DISPATCH_2 (g_gcd, x, y, SCM_ARG2, s_gcd);
+ return scm_wta_dispatch_2 (g_gcd, x, y, SCM_ARG2, s_gcd);
}
else
- SCM_WTA_DISPATCH_2 (g_gcd, x, y, SCM_ARG1, s_gcd);
+ return scm_wta_dispatch_2 (g_gcd, x, y, SCM_ARG1, s_gcd);
}
SCM_PRIMITIVE_GENERIC (scm_i_lcm, "lcm", 0, 2, 1,
else if (SCM_REALP (n2) && scm_is_integer (n2))
goto handle_inexacts;
else
- SCM_WTA_DISPATCH_2 (g_lcm, n1, n2, SCM_ARG2, s_lcm);
+ return scm_wta_dispatch_2 (g_lcm, n1, n2, SCM_ARG2, s_lcm);
}
else if (SCM_LIKELY (SCM_BIGP (n1)))
{
else if (SCM_REALP (n2) && scm_is_integer (n2))
goto handle_inexacts;
else
- SCM_WTA_DISPATCH_2 (g_lcm, n1, n2, SCM_ARG2, s_lcm);
+ return scm_wta_dispatch_2 (g_lcm, n1, n2, SCM_ARG2, s_lcm);
}
else if (SCM_REALP (n1) && scm_is_integer (n1))
{
scm_inexact_to_exact (n2)));
}
else
- SCM_WTA_DISPATCH_2 (g_lcm, n1, n2, SCM_ARG2, s_lcm);
+ return scm_wta_dispatch_2 (g_lcm, n1, n2, SCM_ARG2, s_lcm);
}
else
- SCM_WTA_DISPATCH_2 (g_lcm, n1, n2, SCM_ARG1, s_lcm);
+ return scm_wta_dispatch_2 (g_lcm, n1, n2, SCM_ARG1, s_lcm);
}
/* Emulating 2's complement bignums with sign magnitude arithmetic:
return result;
}
else
- scm_syserror ("left_shift_exact_integer");
+ assert (0);
}
/* Efficiently compute floor (N / 2^COUNT),
return scm_i_normbig (result);
}
else
- scm_syserror ("floor_right_shift_exact_integer");
+ assert (0);
}
/* Efficiently compute round (N / 2^COUNT),
return scm_i_normbig (q);
}
else
- scm_syserror ("round_right_shift_exact_integer");
+ assert (0);
}
SCM_DEFINE (scm_ash, "ash", 2, 0, 0,
scm_print_real (SCM sexp, SCM port, scm_print_state *pstate SCM_UNUSED)
{
char num_buf[FLOBUFLEN];
- scm_lfwrite (num_buf, iflo2str (sexp, num_buf, 10), port);
+ scm_lfwrite_unlocked (num_buf, iflo2str (sexp, num_buf, 10), port);
return !0;
}
scm_i_print_double (double val, SCM port)
{
char num_buf[FLOBUFLEN];
- scm_lfwrite (num_buf, idbl2str (val, num_buf, 10), port);
+ scm_lfwrite_unlocked (num_buf, idbl2str (val, num_buf, 10), port);
}
int
{
char num_buf[FLOBUFLEN];
- scm_lfwrite (num_buf, iflo2str (sexp, num_buf, 10), port);
+ scm_lfwrite_unlocked (num_buf, iflo2str (sexp, num_buf, 10), port);
return !0;
}
scm_i_print_complex (double real, double imag, SCM port)
{
char num_buf[FLOBUFLEN];
- scm_lfwrite (num_buf, icmplx2str (real, imag, num_buf, 10), port);
+ scm_lfwrite_unlocked (num_buf, icmplx2str (real, imag, num_buf, 10), port);
}
int
void (*freefunc) (void *, size_t);
mp_get_memory_functions (NULL, NULL, &freefunc);
scm_remember_upto_here_1 (exp);
- scm_lfwrite (str, len, port);
+ scm_lfwrite_unlocked (str, len, port);
freefunc (str, len + 1);
return !0;
}
}
/* We should never get here */
- scm_syserror ("mem2ureal");
+ assert (0);
}
else if (SCM_FRACTIONP (y))
return SCM_BOOL_F;
else
- SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p, x, y, SCM_ARGn, s_scm_i_num_eq_p);
+ return scm_wta_dispatch_2 (g_scm_i_num_eq_p, x, y, SCM_ARGn,
+ s_scm_i_num_eq_p);
}
else if (SCM_BIGP (x))
{
else if (SCM_FRACTIONP (y))
return SCM_BOOL_F;
else
- SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p, x, y, SCM_ARGn, s_scm_i_num_eq_p);
+ return scm_wta_dispatch_2 (g_scm_i_num_eq_p, x, y, SCM_ARGn,
+ s_scm_i_num_eq_p);
}
else if (SCM_REALP (x))
{
goto again;
}
else
- SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p, x, y, SCM_ARGn, s_scm_i_num_eq_p);
+ return scm_wta_dispatch_2 (g_scm_i_num_eq_p, x, y, SCM_ARGn,
+ s_scm_i_num_eq_p);
}
else if (SCM_COMPLEXP (x))
{
goto again;
}
else
- SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p, x, y, SCM_ARGn, s_scm_i_num_eq_p);
+ return scm_wta_dispatch_2 (g_scm_i_num_eq_p, x, y, SCM_ARGn,
+ s_scm_i_num_eq_p);
}
else if (SCM_FRACTIONP (x))
{
else if (SCM_FRACTIONP (y))
return scm_i_fraction_equalp (x, y);
else
- SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p, x, y, SCM_ARGn, s_scm_i_num_eq_p);
+ return scm_wta_dispatch_2 (g_scm_i_num_eq_p, x, y, SCM_ARGn,
+ s_scm_i_num_eq_p);
}
else
- SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p, x, y, SCM_ARG1, s_scm_i_num_eq_p);
+ return scm_wta_dispatch_2 (g_scm_i_num_eq_p, x, y, SCM_ARG1,
+ s_scm_i_num_eq_p);
}
goto again;
}
else
- SCM_WTA_DISPATCH_2 (g_scm_i_num_less_p, x, y, SCM_ARGn, s_scm_i_num_less_p);
+ return scm_wta_dispatch_2 (g_scm_i_num_less_p, x, y, SCM_ARGn,
+ s_scm_i_num_less_p);
}
else if (SCM_BIGP (x))
{
else if (SCM_FRACTIONP (y))
goto int_frac;
else
- SCM_WTA_DISPATCH_2 (g_scm_i_num_less_p, x, y, SCM_ARGn, s_scm_i_num_less_p);
+ return scm_wta_dispatch_2 (g_scm_i_num_less_p, x, y, SCM_ARGn,
+ s_scm_i_num_less_p);
}
else if (SCM_REALP (x))
{
goto again;
}
else
- SCM_WTA_DISPATCH_2 (g_scm_i_num_less_p, x, y, SCM_ARGn, s_scm_i_num_less_p);
+ return scm_wta_dispatch_2 (g_scm_i_num_less_p, x, y, SCM_ARGn,
+ s_scm_i_num_less_p);
}
else if (SCM_FRACTIONP (x))
{
goto again;
}
else
- SCM_WTA_DISPATCH_2 (g_scm_i_num_less_p, x, y, SCM_ARGn, s_scm_i_num_less_p);
+ return scm_wta_dispatch_2 (g_scm_i_num_less_p, x, y, SCM_ARGn,
+ s_scm_i_num_less_p);
}
else
- SCM_WTA_DISPATCH_2 (g_scm_i_num_less_p, x, y, SCM_ARG1, s_scm_i_num_less_p);
+ return scm_wta_dispatch_2 (g_scm_i_num_less_p, x, y, SCM_ARG1,
+ s_scm_i_num_less_p);
}
scm_gr_p (SCM x, SCM y)
{
if (!SCM_NUMBERP (x))
- SCM_WTA_DISPATCH_2 (g_scm_i_num_gr_p, x, y, SCM_ARG1, FUNC_NAME);
+ return scm_wta_dispatch_2 (g_scm_i_num_gr_p, x, y, SCM_ARG1, FUNC_NAME);
else if (!SCM_NUMBERP (y))
- SCM_WTA_DISPATCH_2 (g_scm_i_num_gr_p, x, y, SCM_ARG2, FUNC_NAME);
+ return scm_wta_dispatch_2 (g_scm_i_num_gr_p, x, y, SCM_ARG2, FUNC_NAME);
else
return scm_less_p (y, x);
}
scm_leq_p (SCM x, SCM y)
{
if (!SCM_NUMBERP (x))
- SCM_WTA_DISPATCH_2 (g_scm_i_num_leq_p, x, y, SCM_ARG1, FUNC_NAME);
+ return scm_wta_dispatch_2 (g_scm_i_num_leq_p, x, y, SCM_ARG1, FUNC_NAME);
else if (!SCM_NUMBERP (y))
- SCM_WTA_DISPATCH_2 (g_scm_i_num_leq_p, x, y, SCM_ARG2, FUNC_NAME);
+ return scm_wta_dispatch_2 (g_scm_i_num_leq_p, x, y, SCM_ARG2, FUNC_NAME);
else if (scm_is_true (scm_nan_p (x)) || scm_is_true (scm_nan_p (y)))
return SCM_BOOL_F;
else
scm_geq_p (SCM x, SCM y)
{
if (!SCM_NUMBERP (x))
- SCM_WTA_DISPATCH_2 (g_scm_i_num_geq_p, x, y, SCM_ARG1, FUNC_NAME);
+ return scm_wta_dispatch_2 (g_scm_i_num_geq_p, x, y, SCM_ARG1, FUNC_NAME);
else if (!SCM_NUMBERP (y))
- SCM_WTA_DISPATCH_2 (g_scm_i_num_geq_p, x, y, SCM_ARG2, FUNC_NAME);
+ return scm_wta_dispatch_2 (g_scm_i_num_geq_p, x, y, SCM_ARG2, FUNC_NAME);
else if (scm_is_true (scm_nan_p (x)) || scm_is_true (scm_nan_p (y)))
return SCM_BOOL_F;
else
else if (SCM_FRACTIONP (z))
return SCM_BOOL_F;
else
- SCM_WTA_DISPATCH_1 (g_scm_zero_p, z, SCM_ARG1, s_scm_zero_p);
+ return scm_wta_dispatch_1 (g_scm_zero_p, z, SCM_ARG1, s_scm_zero_p);
}
#undef FUNC_NAME
else if (SCM_FRACTIONP (x))
return scm_positive_p (SCM_FRACTION_NUMERATOR (x));
else
- SCM_WTA_DISPATCH_1 (g_scm_positive_p, x, SCM_ARG1, s_scm_positive_p);
+ return scm_wta_dispatch_1 (g_scm_positive_p, x, SCM_ARG1, s_scm_positive_p);
}
#undef FUNC_NAME
else if (SCM_FRACTIONP (x))
return scm_negative_p (SCM_FRACTION_NUMERATOR (x));
else
- SCM_WTA_DISPATCH_1 (g_scm_negative_p, x, SCM_ARG1, s_scm_negative_p);
+ return scm_wta_dispatch_1 (g_scm_negative_p, x, SCM_ARG1, s_scm_negative_p);
}
#undef FUNC_NAME
if (SCM_UNBNDP (y))
{
if (SCM_UNBNDP (x))
- SCM_WTA_DISPATCH_0 (g_max, s_max);
+ return scm_wta_dispatch_0 (g_max, s_max);
else if (SCM_I_INUMP(x) || SCM_BIGP(x) || SCM_REALP(x) || SCM_FRACTIONP(x))
return x;
else
- SCM_WTA_DISPATCH_1 (g_max, x, SCM_ARG1, s_max);
+ return scm_wta_dispatch_1 (g_max, x, SCM_ARG1, s_max);
}
if (SCM_I_INUMP (x))
return (scm_is_false (scm_less_p (x, y)) ? x : y);
}
else
- SCM_WTA_DISPATCH_2 (g_max, x, y, SCM_ARGn, s_max);
+ return scm_wta_dispatch_2 (g_max, x, y, SCM_ARGn, s_max);
}
else if (SCM_BIGP (x))
{
goto use_less;
}
else
- SCM_WTA_DISPATCH_2 (g_max, x, y, SCM_ARGn, s_max);
+ return scm_wta_dispatch_2 (g_max, x, y, SCM_ARGn, s_max);
}
else if (SCM_REALP (x))
{
return (xx < yy) ? scm_i_from_double (yy) : x;
}
else
- SCM_WTA_DISPATCH_2 (g_max, x, y, SCM_ARGn, s_max);
+ return scm_wta_dispatch_2 (g_max, x, y, SCM_ARGn, s_max);
}
else if (SCM_FRACTIONP (x))
{
goto use_less;
}
else
- SCM_WTA_DISPATCH_2 (g_max, x, y, SCM_ARGn, s_max);
+ return scm_wta_dispatch_2 (g_max, x, y, SCM_ARGn, s_max);
}
else
- SCM_WTA_DISPATCH_2 (g_max, x, y, SCM_ARG1, s_max);
+ return scm_wta_dispatch_2 (g_max, x, y, SCM_ARG1, s_max);
}
if (SCM_UNBNDP (y))
{
if (SCM_UNBNDP (x))
- SCM_WTA_DISPATCH_0 (g_min, s_min);
+ return scm_wta_dispatch_0 (g_min, s_min);
else if (SCM_I_INUMP(x) || SCM_BIGP(x) || SCM_REALP(x) || SCM_FRACTIONP(x))
return x;
else
- SCM_WTA_DISPATCH_1 (g_min, x, SCM_ARG1, s_min);
+ return scm_wta_dispatch_1 (g_min, x, SCM_ARG1, s_min);
}
if (SCM_I_INUMP (x))
return (scm_is_false (scm_less_p (x, y)) ? y : x);
}
else
- SCM_WTA_DISPATCH_2 (g_min, x, y, SCM_ARGn, s_min);
+ return scm_wta_dispatch_2 (g_min, x, y, SCM_ARGn, s_min);
}
else if (SCM_BIGP (x))
{
goto use_less;
}
else
- SCM_WTA_DISPATCH_2 (g_min, x, y, SCM_ARGn, s_min);
+ return scm_wta_dispatch_2 (g_min, x, y, SCM_ARGn, s_min);
}
else if (SCM_REALP (x))
{
return (yy < xx) ? scm_i_from_double (yy) : x;
}
else
- SCM_WTA_DISPATCH_2 (g_min, x, y, SCM_ARGn, s_min);
+ return scm_wta_dispatch_2 (g_min, x, y, SCM_ARGn, s_min);
}
else if (SCM_FRACTIONP (x))
{
goto use_less;
}
else
- SCM_WTA_DISPATCH_2 (g_min, x, y, SCM_ARGn, s_min);
+ return scm_wta_dispatch_2 (g_min, x, y, SCM_ARGn, s_min);
}
else
- SCM_WTA_DISPATCH_2 (g_min, x, y, SCM_ARG1, s_min);
+ return scm_wta_dispatch_2 (g_min, x, y, SCM_ARG1, s_min);
}
{
if (SCM_NUMBERP (x)) return x;
if (SCM_UNBNDP (x)) return SCM_INUM0;
- SCM_WTA_DISPATCH_1 (g_sum, x, SCM_ARG1, s_sum);
+ return scm_wta_dispatch_1 (g_sum, x, SCM_ARG1, s_sum);
}
if (SCM_LIKELY (SCM_I_INUMP (x)))
scm_product (x, SCM_FRACTION_DENOMINATOR (y))),
SCM_FRACTION_DENOMINATOR (y));
else
- SCM_WTA_DISPATCH_2 (g_sum, x, y, SCM_ARGn, s_sum);
+ return scm_wta_dispatch_2 (g_sum, x, y, SCM_ARGn, s_sum);
} else if (SCM_BIGP (x))
{
if (SCM_I_INUMP (y))
scm_product (x, SCM_FRACTION_DENOMINATOR (y))),
SCM_FRACTION_DENOMINATOR (y));
else
- SCM_WTA_DISPATCH_2 (g_sum, x, y, SCM_ARGn, s_sum);
+ return scm_wta_dispatch_2 (g_sum, x, y, SCM_ARGn, s_sum);
}
else if (SCM_REALP (x))
{
else if (SCM_FRACTIONP (y))
return scm_i_from_double (SCM_REAL_VALUE (x) + scm_i_fraction2double (y));
else
- SCM_WTA_DISPATCH_2 (g_sum, x, y, SCM_ARGn, s_sum);
+ return scm_wta_dispatch_2 (g_sum, x, y, SCM_ARGn, s_sum);
}
else if (SCM_COMPLEXP (x))
{
return scm_c_make_rectangular (SCM_COMPLEX_REAL (x) + scm_i_fraction2double (y),
SCM_COMPLEX_IMAG (x));
else
- SCM_WTA_DISPATCH_2 (g_sum, x, y, SCM_ARGn, s_sum);
+ return scm_wta_dispatch_2 (g_sum, x, y, SCM_ARGn, s_sum);
}
else if (SCM_FRACTIONP (x))
{
scm_product (SCM_FRACTION_NUMERATOR (y), SCM_FRACTION_DENOMINATOR (x))),
scm_product (SCM_FRACTION_DENOMINATOR (x), SCM_FRACTION_DENOMINATOR (y)));
else
- SCM_WTA_DISPATCH_2 (g_sum, x, y, SCM_ARGn, s_sum);
+ return scm_wta_dispatch_2 (g_sum, x, y, SCM_ARGn, s_sum);
}
else
- SCM_WTA_DISPATCH_2 (g_sum, x, y, SCM_ARG1, s_sum);
+ return scm_wta_dispatch_2 (g_sum, x, y, SCM_ARG1, s_sum);
}
if (SCM_UNLIKELY (SCM_UNBNDP (y)))
{
if (SCM_UNBNDP (x))
- SCM_WTA_DISPATCH_0 (g_difference, s_difference);
+ return scm_wta_dispatch_0 (g_difference, s_difference);
else
if (SCM_I_INUMP (x))
{
(scm_difference (SCM_FRACTION_NUMERATOR (x), SCM_UNDEFINED),
SCM_FRACTION_DENOMINATOR (x));
else
- SCM_WTA_DISPATCH_1 (g_difference, x, SCM_ARG1, s_difference);
+ return scm_wta_dispatch_1 (g_difference, x, SCM_ARG1, s_difference);
}
if (SCM_LIKELY (SCM_I_INUMP (x)))
SCM_FRACTION_NUMERATOR (y)),
SCM_FRACTION_DENOMINATOR (y));
else
- SCM_WTA_DISPATCH_2 (g_difference, x, y, SCM_ARGn, s_difference);
+ return scm_wta_dispatch_2 (g_difference, x, y, SCM_ARGn, s_difference);
}
else if (SCM_BIGP (x))
{
return scm_i_make_ratio (scm_difference (scm_product (x, SCM_FRACTION_DENOMINATOR (y)),
SCM_FRACTION_NUMERATOR (y)),
SCM_FRACTION_DENOMINATOR (y));
- else SCM_WTA_DISPATCH_2 (g_difference, x, y, SCM_ARGn, s_difference);
+ else
+ return scm_wta_dispatch_2 (g_difference, x, y, SCM_ARGn, s_difference);
}
else if (SCM_REALP (x))
{
else if (SCM_FRACTIONP (y))
return scm_i_from_double (SCM_REAL_VALUE (x) - scm_i_fraction2double (y));
else
- SCM_WTA_DISPATCH_2 (g_difference, x, y, SCM_ARGn, s_difference);
+ return scm_wta_dispatch_2 (g_difference, x, y, SCM_ARGn, s_difference);
}
else if (SCM_COMPLEXP (x))
{
return scm_c_make_rectangular (SCM_COMPLEX_REAL (x) - scm_i_fraction2double (y),
SCM_COMPLEX_IMAG (x));
else
- SCM_WTA_DISPATCH_2 (g_difference, x, y, SCM_ARGn, s_difference);
+ return scm_wta_dispatch_2 (g_difference, x, y, SCM_ARGn, s_difference);
}
else if (SCM_FRACTIONP (x))
{
scm_product (SCM_FRACTION_NUMERATOR (y), SCM_FRACTION_DENOMINATOR (x))),
scm_product (SCM_FRACTION_DENOMINATOR (x), SCM_FRACTION_DENOMINATOR (y)));
else
- SCM_WTA_DISPATCH_2 (g_difference, x, y, SCM_ARGn, s_difference);
+ return scm_wta_dispatch_2 (g_difference, x, y, SCM_ARGn, s_difference);
}
else
- SCM_WTA_DISPATCH_2 (g_difference, x, y, SCM_ARG1, s_difference);
+ return scm_wta_dispatch_2 (g_difference, x, y, SCM_ARG1, s_difference);
}
#undef FUNC_NAME
else if (SCM_NUMBERP (x))
return x;
else
- SCM_WTA_DISPATCH_1 (g_product, x, SCM_ARG1, s_product);
+ return scm_wta_dispatch_1 (g_product, x, SCM_ARG1, s_product);
}
if (SCM_LIKELY (SCM_I_INUMP (x)))
else if (SCM_NUMP (y))
return SCM_INUM0;
else
- SCM_WTA_DISPATCH_2 (g_product, x, y, SCM_ARGn, s_product);
+ return scm_wta_dispatch_2 (g_product, x, y, SCM_ARGn, s_product);
break;
case -1:
/*
return scm_i_make_ratio (scm_product (x, SCM_FRACTION_NUMERATOR (y)),
SCM_FRACTION_DENOMINATOR (y));
else
- SCM_WTA_DISPATCH_2 (g_product, x, y, SCM_ARGn, s_product);
+ return scm_wta_dispatch_2 (g_product, x, y, SCM_ARGn, s_product);
}
else if (SCM_BIGP (x))
{
return scm_i_make_ratio (scm_product (x, SCM_FRACTION_NUMERATOR (y)),
SCM_FRACTION_DENOMINATOR (y));
else
- SCM_WTA_DISPATCH_2 (g_product, x, y, SCM_ARGn, s_product);
+ return scm_wta_dispatch_2 (g_product, x, y, SCM_ARGn, s_product);
}
else if (SCM_REALP (x))
{
else if (SCM_FRACTIONP (y))
return scm_i_from_double (SCM_REAL_VALUE (x) * scm_i_fraction2double (y));
else
- SCM_WTA_DISPATCH_2 (g_product, x, y, SCM_ARGn, s_product);
+ return scm_wta_dispatch_2 (g_product, x, y, SCM_ARGn, s_product);
}
else if (SCM_COMPLEXP (x))
{
yy * SCM_COMPLEX_IMAG (x));
}
else
- SCM_WTA_DISPATCH_2 (g_product, x, y, SCM_ARGn, s_product);
+ return scm_wta_dispatch_2 (g_product, x, y, SCM_ARGn, s_product);
}
else if (SCM_FRACTIONP (x))
{
scm_product (SCM_FRACTION_DENOMINATOR (x),
SCM_FRACTION_DENOMINATOR (y)));
else
- SCM_WTA_DISPATCH_2 (g_product, x, y, SCM_ARGn, s_product);
+ return scm_wta_dispatch_2 (g_product, x, y, SCM_ARGn, s_product);
}
else
- SCM_WTA_DISPATCH_2 (g_product, x, y, SCM_ARG1, s_product);
+ return scm_wta_dispatch_2 (g_product, x, y, SCM_ARG1, s_product);
}
#if ((defined (HAVE_ISINF) && defined (HAVE_ISNAN)) \
if (SCM_UNLIKELY (SCM_UNBNDP (y)))
{
if (SCM_UNBNDP (x))
- SCM_WTA_DISPATCH_0 (g_divide, s_divide);
+ return scm_wta_dispatch_0 (g_divide, s_divide);
else if (SCM_I_INUMP (x))
{
scm_t_inum xx = SCM_I_INUM (x);
return scm_i_make_ratio_already_reduced (SCM_FRACTION_DENOMINATOR (x),
SCM_FRACTION_NUMERATOR (x));
else
- SCM_WTA_DISPATCH_1 (g_divide, x, SCM_ARG1, s_divide);
+ return scm_wta_dispatch_1 (g_divide, x, SCM_ARG1, s_divide);
}
if (SCM_LIKELY (SCM_I_INUMP (x)))
return scm_i_make_ratio (scm_product (x, SCM_FRACTION_DENOMINATOR (y)),
SCM_FRACTION_NUMERATOR (y));
else
- SCM_WTA_DISPATCH_2 (g_divide, x, y, SCM_ARGn, s_divide);
+ return scm_wta_dispatch_2 (g_divide, x, y, SCM_ARGn, s_divide);
}
else if (SCM_BIGP (x))
{
return scm_i_make_ratio (scm_product (x, SCM_FRACTION_DENOMINATOR (y)),
SCM_FRACTION_NUMERATOR (y));
else
- SCM_WTA_DISPATCH_2 (g_divide, x, y, SCM_ARGn, s_divide);
+ return scm_wta_dispatch_2 (g_divide, x, y, SCM_ARGn, s_divide);
}
else if (SCM_REALP (x))
{
else if (SCM_FRACTIONP (y))
return scm_i_from_double (rx / scm_i_fraction2double (y));
else
- SCM_WTA_DISPATCH_2 (g_divide, x, y, SCM_ARGn, s_divide);
+ return scm_wta_dispatch_2 (g_divide, x, y, SCM_ARGn, s_divide);
}
else if (SCM_COMPLEXP (x))
{
return scm_c_make_rectangular (rx / yy, ix / yy);
}
else
- SCM_WTA_DISPATCH_2 (g_divide, x, y, SCM_ARGn, s_divide);
+ return scm_wta_dispatch_2 (g_divide, x, y, SCM_ARGn, s_divide);
}
else if (SCM_FRACTIONP (x))
{
return scm_i_make_ratio (scm_product (SCM_FRACTION_NUMERATOR (x), SCM_FRACTION_DENOMINATOR (y)),
scm_product (SCM_FRACTION_NUMERATOR (y), SCM_FRACTION_DENOMINATOR (x)));
else
- SCM_WTA_DISPATCH_2 (g_divide, x, y, SCM_ARGn, s_divide);
+ return scm_wta_dispatch_2 (g_divide, x, y, SCM_ARGn, s_divide);
}
else
- SCM_WTA_DISPATCH_2 (g_divide, x, y, SCM_ARG1, s_divide);
+ return scm_wta_dispatch_2 (g_divide, x, y, SCM_ARG1, s_divide);
}
#undef FUNC_NAME
return scm_truncate_quotient (SCM_FRACTION_NUMERATOR (x),
SCM_FRACTION_DENOMINATOR (x));
else
- SCM_WTA_DISPATCH_1 (g_scm_truncate_number, x, SCM_ARG1,
+ return scm_wta_dispatch_1 (g_scm_truncate_number, x, SCM_ARG1,
s_scm_truncate_number);
}
#undef FUNC_NAME
return scm_round_quotient (SCM_FRACTION_NUMERATOR (x),
SCM_FRACTION_DENOMINATOR (x));
else
- SCM_WTA_DISPATCH_1 (g_scm_round_number, x, SCM_ARG1,
- s_scm_round_number);
+ return scm_wta_dispatch_1 (g_scm_round_number, x, SCM_ARG1,
+ s_scm_round_number);
}
#undef FUNC_NAME
return scm_floor_quotient (SCM_FRACTION_NUMERATOR (x),
SCM_FRACTION_DENOMINATOR (x));
else
- SCM_WTA_DISPATCH_1 (g_scm_floor, x, 1, s_scm_floor);
+ return scm_wta_dispatch_1 (g_scm_floor, x, 1, s_scm_floor);
}
#undef FUNC_NAME
return scm_ceiling_quotient (SCM_FRACTION_NUMERATOR (x),
SCM_FRACTION_DENOMINATOR (x));
else
- SCM_WTA_DISPATCH_1 (g_scm_ceiling, x, 1, s_scm_ceiling);
+ return scm_wta_dispatch_1 (g_scm_ceiling, x, 1, s_scm_ceiling);
}
#undef FUNC_NAME
else if (scm_is_complex (x) && scm_is_complex (y))
return scm_exp (scm_product (scm_log (x), y));
else if (scm_is_complex (x))
- SCM_WTA_DISPATCH_2 (g_scm_expt, x, y, SCM_ARG2, s_scm_expt);
+ return scm_wta_dispatch_2 (g_scm_expt, x, y, SCM_ARG2, s_scm_expt);
else
- SCM_WTA_DISPATCH_2 (g_scm_expt, x, y, SCM_ARG1, s_scm_expt);
+ return scm_wta_dispatch_2 (g_scm_expt, x, y, SCM_ARG1, s_scm_expt);
}
#undef FUNC_NAME
cos (x) * sinh (y));
}
else
- SCM_WTA_DISPATCH_1 (g_scm_sin, z, 1, s_scm_sin);
+ return scm_wta_dispatch_1 (g_scm_sin, z, 1, s_scm_sin);
}
#undef FUNC_NAME
-sin (x) * sinh (y));
}
else
- SCM_WTA_DISPATCH_1 (g_scm_cos, z, 1, s_scm_cos);
+ return scm_wta_dispatch_1 (g_scm_cos, z, 1, s_scm_cos);
}
#undef FUNC_NAME
return scm_c_make_rectangular (sin (x) / w, sinh (y) / w);
}
else
- SCM_WTA_DISPATCH_1 (g_scm_tan, z, 1, s_scm_tan);
+ return scm_wta_dispatch_1 (g_scm_tan, z, 1, s_scm_tan);
}
#undef FUNC_NAME
cosh (x) * sin (y));
}
else
- SCM_WTA_DISPATCH_1 (g_scm_sinh, z, 1, s_scm_sinh);
+ return scm_wta_dispatch_1 (g_scm_sinh, z, 1, s_scm_sinh);
}
#undef FUNC_NAME
sinh (x) * sin (y));
}
else
- SCM_WTA_DISPATCH_1 (g_scm_cosh, z, 1, s_scm_cosh);
+ return scm_wta_dispatch_1 (g_scm_cosh, z, 1, s_scm_cosh);
}
#undef FUNC_NAME
return scm_c_make_rectangular (sinh (x) / w, sin (y) / w);
}
else
- SCM_WTA_DISPATCH_1 (g_scm_tanh, z, 1, s_scm_tanh);
+ return scm_wta_dispatch_1 (g_scm_tanh, z, 1, s_scm_tanh);
}
#undef FUNC_NAME
scm_sys_asinh (scm_c_make_rectangular (-y, x)));
}
else
- SCM_WTA_DISPATCH_1 (g_scm_asin, z, 1, s_scm_asin);
+ return scm_wta_dispatch_1 (g_scm_asin, z, 1, s_scm_asin);
}
#undef FUNC_NAME
scm_sys_asinh (scm_c_make_rectangular (-y, x))));
}
else
- SCM_WTA_DISPATCH_1 (g_scm_acos, z, 1, s_scm_acos);
+ return scm_wta_dispatch_1 (g_scm_acos, z, 1, s_scm_acos);
}
#undef FUNC_NAME
scm_c_make_rectangular (0, 2));
}
else
- SCM_WTA_DISPATCH_1 (g_scm_atan, z, SCM_ARG1, s_scm_atan);
+ return scm_wta_dispatch_1 (g_scm_atan, z, SCM_ARG1, s_scm_atan);
}
else if (scm_is_real (z))
{
if (scm_is_real (y))
return scm_i_from_double (atan2 (scm_to_double (z), scm_to_double (y)));
else
- SCM_WTA_DISPATCH_2 (g_scm_atan, z, y, SCM_ARG2, s_scm_atan);
+ return scm_wta_dispatch_2 (g_scm_atan, z, y, SCM_ARG2, s_scm_atan);
}
else
- SCM_WTA_DISPATCH_2 (g_scm_atan, z, y, SCM_ARG1, s_scm_atan);
+ return scm_wta_dispatch_2 (g_scm_atan, z, y, SCM_ARG1, s_scm_atan);
}
#undef FUNC_NAME
scm_sqrt (scm_sum (scm_product (z, z),
SCM_INUM1))));
else
- SCM_WTA_DISPATCH_1 (g_scm_sys_asinh, z, 1, s_scm_sys_asinh);
+ return scm_wta_dispatch_1 (g_scm_sys_asinh, z, 1, s_scm_sys_asinh);
}
#undef FUNC_NAME
scm_sqrt (scm_difference (scm_product (z, z),
SCM_INUM1))));
else
- SCM_WTA_DISPATCH_1 (g_scm_sys_acosh, z, 1, s_scm_sys_acosh);
+ return scm_wta_dispatch_1 (g_scm_sys_acosh, z, 1, s_scm_sys_acosh);
}
#undef FUNC_NAME
scm_difference (SCM_INUM1, z))),
SCM_I_MAKINUM (2));
else
- SCM_WTA_DISPATCH_1 (g_scm_sys_atanh, z, 1, s_scm_sys_atanh);
+ return scm_wta_dispatch_1 (g_scm_sys_atanh, z, 1, s_scm_sys_atanh);
}
#undef FUNC_NAME
{
SCM z;
- z = PTR2SCM (scm_gc_malloc_pointerless (sizeof (scm_t_complex),
+ z = SCM_PACK_POINTER (scm_gc_malloc_pointerless (sizeof (scm_t_complex),
"complex"));
SCM_SET_CELL_TYPE (z, scm_tc16_complex);
SCM_COMPLEX_REAL (z) = re;
else if (SCM_I_INUMP (z) || SCM_BIGP (z) || SCM_REALP (z) || SCM_FRACTIONP (z))
return z;
else
- SCM_WTA_DISPATCH_1 (g_scm_real_part, z, SCM_ARG1, s_scm_real_part);
+ return scm_wta_dispatch_1 (g_scm_real_part, z, SCM_ARG1, s_scm_real_part);
}
#undef FUNC_NAME
else if (SCM_I_INUMP (z) || SCM_REALP (z) || SCM_BIGP (z) || SCM_FRACTIONP (z))
return SCM_INUM0;
else
- SCM_WTA_DISPATCH_1 (g_scm_imag_part, z, SCM_ARG1, s_scm_imag_part);
+ return scm_wta_dispatch_1 (g_scm_imag_part, z, SCM_ARG1, s_scm_imag_part);
}
#undef FUNC_NAME
else if (SCM_FRACTIONP (z))
return SCM_FRACTION_NUMERATOR (z);
else if (SCM_REALP (z))
- return scm_exact_to_inexact (scm_numerator (scm_inexact_to_exact (z)));
+ {
+ double zz = SCM_REAL_VALUE (z);
+ if (zz == floor (zz))
+ /* Handle -0.0 and infinities in accordance with R6RS
+ flnumerator, and optimize handling of integers. */
+ return z;
+ else
+ return scm_exact_to_inexact (scm_numerator (scm_inexact_to_exact (z)));
+ }
else
- SCM_WTA_DISPATCH_1 (g_scm_numerator, z, SCM_ARG1, s_scm_numerator);
+ return scm_wta_dispatch_1 (g_scm_numerator, z, SCM_ARG1, s_scm_numerator);
}
#undef FUNC_NAME
else if (SCM_FRACTIONP (z))
return SCM_FRACTION_DENOMINATOR (z);
else if (SCM_REALP (z))
- return scm_exact_to_inexact (scm_denominator (scm_inexact_to_exact (z)));
+ {
+ double zz = SCM_REAL_VALUE (z);
+ if (zz == floor (zz))
+ /* Handle infinities in accordance with R6RS fldenominator, and
+ optimize handling of integers. */
+ return scm_i_from_double (1.0);
+ else
+ return scm_exact_to_inexact (scm_denominator (scm_inexact_to_exact (z)));
+ }
else
- SCM_WTA_DISPATCH_1 (g_scm_denominator, z, SCM_ARG1, s_scm_denominator);
+ return scm_wta_dispatch_1 (g_scm_denominator, z, SCM_ARG1,
+ s_scm_denominator);
}
#undef FUNC_NAME
SCM_FRACTION_DENOMINATOR (z));
}
else
- SCM_WTA_DISPATCH_1 (g_scm_magnitude, z, SCM_ARG1, s_scm_magnitude);
+ return scm_wta_dispatch_1 (g_scm_magnitude, z, SCM_ARG1,
+ s_scm_magnitude);
}
#undef FUNC_NAME
else return scm_i_from_double (atan2 (0.0, -1.0));
}
else
- SCM_WTA_DISPATCH_1 (g_scm_angle, z, SCM_ARG1, s_scm_angle);
+ return scm_wta_dispatch_1 (g_scm_angle, z, SCM_ARG1, s_scm_angle);
}
#undef FUNC_NAME
else if (SCM_INEXACTP (z))
return z;
else
- SCM_WTA_DISPATCH_1 (g_scm_exact_to_inexact, z, 1, s_scm_exact_to_inexact);
+ return scm_wta_dispatch_1 (g_scm_exact_to_inexact, z, 1,
+ s_scm_exact_to_inexact);
}
#undef FUNC_NAME
else if (SCM_COMPLEXP (z) && SCM_COMPLEX_IMAG (z) == 0.0)
val = SCM_COMPLEX_REAL (z);
else
- SCM_WTA_DISPATCH_1 (g_scm_inexact_to_exact, z, 1, s_scm_inexact_to_exact);
+ return scm_wta_dispatch_1 (g_scm_inexact_to_exact, z, 1,
+ s_scm_inexact_to_exact);
if (!SCM_LIKELY (isfinite (val)))
SCM_OUT_OF_RANGE (1, z);
return scm_i_from_double (val);
}
-#if SCM_ENABLE_DEPRECATED == 1
-
-float
-scm_num2float (SCM num, unsigned long pos, const char *s_caller)
-{
- scm_c_issue_deprecation_warning
- ("`scm_num2float' is deprecated. Use scm_to_double instead.");
-
- if (SCM_BIGP (num))
- {
- float res = mpz_get_d (SCM_I_BIG_MPZ (num));
- if (!isinf (res))
- return res;
- else
- scm_out_of_range (NULL, num);
- }
- else
- return scm_to_double (num);
-}
-
-double
-scm_num2double (SCM num, unsigned long pos, const char *s_caller)
-{
- scm_c_issue_deprecation_warning
- ("`scm_num2double' is deprecated. Use scm_to_double instead.");
-
- if (SCM_BIGP (num))
- {
- double res = mpz_get_d (SCM_I_BIG_MPZ (num));
- if (!isinf (res))
- return res;
- else
- scm_out_of_range (NULL, num);
- }
- else
- return scm_to_double (num);
-}
-
-#endif
-
int
scm_is_complex (SCM val)
{
return log_of_fraction (SCM_FRACTION_NUMERATOR (z),
SCM_FRACTION_DENOMINATOR (z));
else
- SCM_WTA_DISPATCH_1 (g_scm_log, z, 1, s_scm_log);
+ return scm_wta_dispatch_1 (g_scm_log, z, 1, s_scm_log);
}
#undef FUNC_NAME
log_of_fraction (SCM_FRACTION_NUMERATOR (z),
SCM_FRACTION_DENOMINATOR (z)));
else
- SCM_WTA_DISPATCH_1 (g_scm_log10, z, 1, s_scm_log10);
+ return scm_wta_dispatch_1 (g_scm_log10, z, 1, s_scm_log10);
}
#undef FUNC_NAME
return scm_i_from_double (exp (scm_to_double (z)));
}
else
- SCM_WTA_DISPATCH_1 (g_scm_exp, z, 1, s_scm_exp);
+ return scm_wta_dispatch_1 (g_scm_exp, z, 1, s_scm_exp);
}
#undef FUNC_NAME
}
}
else
- SCM_WTA_DISPATCH_1 (g_scm_sqrt, z, 1, s_scm_sqrt);
+ return scm_wta_dispatch_1 (g_scm_sqrt, z, 1, s_scm_sqrt);
}
#undef FUNC_NAME
#include <uniconv.h>
#include <unictype.h>
-#include <c-strcase.h>
#include "libguile/_scm.h"
#include "libguile/chars.h"
#include "libguile/macros.h"
#include "libguile/procprop.h"
#include "libguile/read.h"
-#include "libguile/weaks.h"
#include "libguile/programs.h"
#include "libguile/alist.h"
#include "libguile/struct.h"
{ \
if (pstate->top - pstate->list_offset >= pstate->level) \
{ \
- scm_putc ('#', port); \
+ scm_putc_unlocked ('#', port); \
return; \
} \
} \
for (i = pstate->top - 1; 1; --i)
if (scm_is_eq (PSTATE_STACK_REF(pstate, i), ref))
break;
- scm_putc ('#', port);
+ scm_putc_unlocked ('#', port);
scm_intprint (i - self, 10, port);
- scm_putc ('#', port);
+ scm_putc_unlocked ('#', port);
}
/* Print the name of a symbol. */
(INITIAL_IDENTIFIER_MASK \
| UC_CATEGORY_MASK_Nd | UC_CATEGORY_MASK_Mc | UC_CATEGORY_MASK_Me)
+/* FIXME: Cache this information on the symbol, somehow. */
static int
symbol_has_extended_read_syntax (SCM sym)
{
c = scm_i_symbol_ref (sym, 0);
- /* Single dot; conflicts with dotted-pair notation. */
- if (len == 1 && c == '.')
- return 1;
-
- /* Other initial-character constraints. */
- if (c == '\'' || c == '`' || c == ',' || c == '"' || c == ';' || c == '#')
- return 1;
+ switch (c)
+ {
+ case '\'':
+ case '`':
+ case ',':
+ case '"':
+ case ';':
+ case '#':
+ /* Some initial-character constraints. */
+ return 1;
- /* Keywords can be identified by trailing colons too. */
- if (c == ':' || scm_i_symbol_ref (sym, len - 1) == ':')
- return quote_keywordish_symbols ();
+ case ':':
+ /* Symbols that look like keywords. */
+ return quote_keywordish_symbols ();
- /* Number-ish symbols. */
- if (scm_is_true (scm_i_string_to_number (scm_symbol_to_string (sym), 10)))
- return 1;
+ case '.':
+ /* Single dot conflicts with dotted-pair notation. */
+ if (len == 1)
+ return 1;
+ /* Fall through to check numbers. */
+ case '+':
+ case '-':
+ case '0':
+ case '1':
+ case '2':
+ case '3':
+ case '4':
+ case '5':
+ case '6':
+ case '7':
+ case '8':
+ case '9':
+ /* Number-ish symbols. Numbers with radixes already caught be #
+ above. */
+ if (scm_is_true (scm_i_string_to_number (scm_symbol_to_string (sym), 10)))
+ return 1;
+ break;
+
+ default:
+ break;
+ }
/* Other disallowed first characters. */
if (!uc_is_general_category_withtable (c, INITIAL_IDENTIFIER_MASK))
return 1;
+ /* Keywords can be identified by trailing colons too. */
+ if (scm_i_symbol_ref (sym, len - 1) == ':')
+ return quote_keywordish_symbols ();
+
/* Otherwise, any character that's in the identifier category mask is
fine to pass through as-is, provided it's not one of the ASCII
delimiters like `;'. */
static void
print_normal_symbol (SCM sym, SCM port)
{
- scm_display (scm_symbol_to_string (sym), port);
+ size_t len;
+ scm_t_string_failed_conversion_handler strategy;
+
+ len = scm_i_symbol_length (sym);
+ strategy = SCM_PTAB_ENTRY (port)->ilseq_handler;
+
+ if (scm_i_is_narrow_symbol (sym))
+ display_string (scm_i_symbol_chars (sym), 1, len, port, strategy);
+ else
+ display_string (scm_i_symbol_wide_chars (sym), 0, len, port, strategy);
}
static void
len = scm_i_symbol_length (sym);
strategy = PORT_CONVERSION_HANDLER (port);
- scm_lfwrite ("#{", 2, port);
+ scm_lfwrite_unlocked ("#{", 2, port);
for (pos = 0; pos < len; pos++)
{
SUBSEQUENT_IDENTIFIER_MASK
| UC_CATEGORY_MASK_Zs))
{
- if (!display_character (c, port, strategy))
+ if (!display_character (c, port, strategy)
+ || (c == '\\' && !display_character (c, port, strategy)))
scm_encoding_error ("print_extended_symbol", errno,
"cannot convert to output locale",
port, SCM_MAKE_CHAR (c));
}
}
- scm_lfwrite ("}#", 2, port);
+ scm_lfwrite_unlocked ("}#", 2, port);
}
/* FIXME: allow R6RS hex escapes instead of #{...}#. */
-void
-scm_i_print_symbol_name (SCM sym, SCM port)
+static void
+print_symbol (SCM sym, SCM port)
{
if (symbol_has_extended_read_syntax (sym))
print_extended_symbol (sym, port);
void
scm_print_symbol_name (const char *str, size_t len, SCM port)
{
- SCM symbol = scm_from_locale_symboln (str, len);
- scm_i_print_symbol_name (symbol, port);
+ SCM symbol = scm_from_utf8_symboln (str, len);
+ print_symbol (symbol, port);
}
/* Print generally. Handles both write and display according to PSTATE.
scm_intprint (i, 8, port); \
else \
{ \
- scm_puts ("x", port); \
+ scm_puts_unlocked ("x", port); \
scm_intprint (i, 16, port); \
} \
} \
else if (SCM_IFLAGP (exp)
&& ((size_t) SCM_IFLAGNUM (exp) < (sizeof iflagnames / sizeof (char *))))
{
- scm_puts (iflagnames [SCM_IFLAGNUM (exp)], port);
+ scm_puts_unlocked (iflagnames [SCM_IFLAGNUM (exp)], port);
}
else
{
goto print_struct;
pwps = scm_i_port_with_print_state (port, pstate->handle);
pstate->revealed = 1;
- scm_call_generic_2 (print, exp, pwps);
+ scm_call_2 (print, exp, pwps);
}
else
{
case scm_tc7_symbol:
if (scm_i_symbol_is_interned (exp))
{
- scm_i_print_symbol_name (exp, port);
+ print_symbol (exp, port);
scm_remember_upto_here_1 (exp);
}
else
{
- scm_puts ("#<uninterned-symbol ", port);
- scm_i_print_symbol_name (exp, port);
- scm_putc (' ', port);
+ scm_puts_unlocked ("#<uninterned-symbol ", port);
+ print_symbol (exp, port);
+ scm_putc_unlocked (' ', port);
scm_uintprint (SCM_UNPACK (exp), 16, port);
- scm_putc ('>', port);
+ scm_putc_unlocked ('>', port);
}
break;
case scm_tc7_variable:
scm_i_variable_print (exp, port, pstate);
break;
+ case scm_tc7_rtl_program:
case scm_tc7_program:
scm_i_program_print (exp, port, pstate);
break;
case scm_tc7_hashtable:
scm_i_hashtable_print (exp, port, pstate);
break;
+ case scm_tc7_weak_set:
+ scm_i_weak_set_print (exp, port, pstate);
+ break;
+ case scm_tc7_weak_table:
+ scm_i_weak_table_print (exp, port, pstate);
+ break;
case scm_tc7_fluid:
scm_i_fluid_print (exp, port, pstate);
break;
case scm_tc7_vm_cont:
scm_i_vm_cont_print (exp, port, pstate);
break;
- case scm_tc7_prompt:
- scm_i_prompt_print (exp, port, pstate);
- break;
- case scm_tc7_with_fluids:
- scm_i_with_fluids_print (exp, port, pstate);
- break;
case scm_tc7_array:
ENTER_NESTED_DATA (pstate, exp, circref);
scm_i_print_array (exp, port, pstate);
break;
case scm_tc7_wvect:
ENTER_NESTED_DATA (pstate, exp, circref);
- if (SCM_IS_WHVEC (exp))
- scm_puts ("#wh(", port);
- else
- scm_puts ("#w(", port);
+ scm_puts_unlocked ("#w(", port);
goto common_vector_printer;
case scm_tc7_vector:
ENTER_NESTED_DATA (pstate, exp, circref);
- scm_puts ("#(", port);
+ scm_puts_unlocked ("#(", port);
common_vector_printer:
{
register long i;
last = pstate->length - 1;
cutp = 1;
}
- if (SCM_I_WVECTP (exp))
- {
- /* Elements of weak vectors may not be accessed via the
- `SIMPLE_VECTOR_REF ()' macro. */
- for (i = 0; i < last; ++i)
- {
- scm_iprin1 (scm_c_vector_ref (exp, i),
- port, pstate);
- scm_putc (' ', port);
- }
- }
- else
- {
- for (i = 0; i < last; ++i)
- {
- scm_iprin1 (SCM_SIMPLE_VECTOR_REF (exp, i), port, pstate);
- scm_putc (' ', port);
- }
- }
-
+ for (i = 0; i < last; ++i)
+ {
+ scm_iprin1 (scm_c_vector_ref (exp, i), port, pstate);
+ scm_putc_unlocked (' ', port);
+ }
if (i == last)
{
/* CHECK_INTS; */
scm_iprin1 (scm_c_vector_ref (exp, i), port, pstate);
}
if (cutp)
- scm_puts (" ...", port);
- scm_putc (')', port);
+ scm_puts_unlocked (" ...", port);
+ scm_putc_unlocked (')', port);
}
EXIT_NESTED_DATA (pstate);
break;
case scm_tc7_port:
{
- register long i = SCM_PTOBNUM (exp);
- if (i < scm_numptob
- && scm_ptobs[i].print
- && (scm_ptobs[i].print) (exp, port, pstate))
+ scm_t_ptob_descriptor *ptob = SCM_PORT_DESCRIPTOR (exp);
+ if (ptob->print && ptob->print (exp, port, pstate))
break;
goto punk;
}
/* INPUT was successfully converted, entirely; print the
result. */
- scm_lfwrite (utf8_buf, utf8_len, port);
+ scm_lfwrite_unlocked (utf8_buf, utf8_len, port);
printed += i - printed;
}
return len;
}
+/* Write STR to PORT as ISO-8859-1. STR is a LEN-codepoint string; it
+ is narrow if NARROW_P is true, wide otherwise. Return LEN. */
+static size_t
+display_string_as_latin1 (const void *str, int narrow_p, size_t len,
+ SCM port,
+ scm_t_string_failed_conversion_handler strategy)
+{
+ size_t printed = 0;
+
+ if (narrow_p)
+ {
+ scm_lfwrite_unlocked (str, len, port);
+ return len;
+ }
+
+ while (printed < len)
+ {
+ char buf[256];
+ size_t i;
+
+ for (i = 0; i < sizeof(buf) && printed < len; i++, printed++)
+ {
+ scm_t_wchar c = STR_REF (str, printed);
+
+ if (c < 256)
+ buf[i] = c;
+ else
+ break;
+ }
+
+ scm_lfwrite_unlocked (buf, i, port);
+
+ if (i < sizeof(buf) && printed < len)
+ {
+ if (strategy == SCM_FAILED_CONVERSION_ERROR)
+ break;
+ else if (strategy == SCM_FAILED_CONVERSION_ESCAPE_SEQUENCE)
+ write_character_escaped (STR_REF (str, printed), 1, port);
+ else
+ /* STRATEGY is `SCM_FAILED_CONVERSION_QUESTION_MARK'. */
+ display_string ("?", 1, 1, port, strategy);
+ printed++;
+ }
+ }
+
+ return printed;
+}
+
/* Convert STR through PORT's output conversion descriptor and write the
output to PORT. Return the number of codepoints written. */
static size_t
pti->at_stream_start_for_bom_read = 0;
/* Write a BOM if appropriate. */
- if (SCM_UNLIKELY (c_strcasecmp(pt->encoding, "UTF-16") == 0
- || c_strcasecmp(pt->encoding, "UTF-32") == 0))
+ if (SCM_UNLIKELY (strcmp(pt->encoding, "UTF-16") == 0
+ || strcmp(pt->encoding, "UTF-32") == 0))
display_character (SCM_UNICODE_BOM, port, iconveh_error);
}
iconv (id->output_cd, NULL, NULL, NULL, NULL);
/* Print the OUTPUT_LEN bytes successfully converted. */
- scm_lfwrite (encoded_output, output_len, port);
+ scm_lfwrite_unlocked (encoded_output, output_len, port);
/* See how many input codepoints these OUTPUT_LEN bytes
corresponds to. */
{
/* INPUT was successfully converted, entirely; print the
result. */
- scm_lfwrite (encoded_output, output_len, port);
+ scm_lfwrite_unlocked (encoded_output, output_len, port);
codepoints_read = i - printed;
printed += codepoints_read;
}
display_string (const void *str, int narrow_p,
size_t len, SCM port,
scm_t_string_failed_conversion_handler strategy)
-
{
scm_t_port_internal *pti;
if (pti->encoding_mode == SCM_PORT_ENCODING_MODE_UTF8)
return display_string_as_utf8 (str, narrow_p, len, port);
+ else if (pti->encoding_mode == SCM_PORT_ENCODING_MODE_LATIN1)
+ return display_string_as_latin1 (str, narrow_p, len, port, strategy);
else
- return display_string_using_iconv (str, narrow_p, len,
- port, strategy);
+ return display_string_using_iconv (str, narrow_p, len, port, strategy);
}
/* Attempt to display CH to PORT according to STRATEGY. Return non-zero
/* Use special escapes for some C0 controls. */
buf[0] = '\\';
buf[1] = escapes[ch - 0x07];
- scm_lfwrite (buf, 2, port);
+ scm_lfwrite_unlocked (buf, 2, port);
}
else if (!SCM_R6RS_ESCAPES_P)
{
buf[1] = 'x';
buf[2] = hex[ch / 16];
buf[3] = hex[ch % 16];
- scm_lfwrite (buf, 4, port);
+ scm_lfwrite_unlocked (buf, 4, port);
}
else if (ch <= 0xFFFF)
{
buf[3] = hex[(ch & 0xF00) >> 8];
buf[4] = hex[(ch & 0xF0) >> 4];
buf[5] = hex[(ch & 0xF)];
- scm_lfwrite (buf, 6, port);
+ scm_lfwrite_unlocked (buf, 6, port);
}
else if (ch > 0xFFFF)
{
buf[5] = hex[(ch & 0xF00) >> 8];
buf[6] = hex[(ch & 0xF0) >> 4];
buf[7] = hex[(ch & 0xF)];
- scm_lfwrite (buf, 8, port);
+ scm_lfwrite_unlocked (buf, 8, port);
}
}
else
buf[i] = 'x';
i --;
buf[i] = '\\';
- scm_lfwrite (buf + i, 9 - i, port);
+ scm_lfwrite_unlocked (buf + i, 9 - i, port);
}
}
else
name = scm_i_charname (SCM_MAKE_CHAR (ch));
if (name != NULL)
- scm_puts (name, port);
+ scm_puts_unlocked (name, port);
else
PRINT_CHAR_ESCAPE (ch, port);
}
scm_intprint (scm_t_intmax n, int radix, SCM port)
{
char num_buf[SCM_INTBUFLEN];
- scm_lfwrite (num_buf, scm_iint2str (n, radix, num_buf), port);
+ scm_lfwrite_unlocked (num_buf, scm_iint2str (n, radix, num_buf), port);
}
void
scm_uintprint (scm_t_uintmax n, int radix, SCM port)
{
char num_buf[SCM_INTBUFLEN];
- scm_lfwrite (num_buf, scm_iuint2str (n, radix, num_buf), port);
+ scm_lfwrite_unlocked (num_buf, scm_iuint2str (n, radix, num_buf), port);
}
/* Print an object of unrecognized type.
void
scm_ipruk (char *hdr, SCM ptr, SCM port)
{
- scm_puts ("#<unknown-", port);
- scm_puts (hdr, port);
+ scm_puts_unlocked ("#<unknown-", port);
+ scm_puts_unlocked (hdr, port);
if (1) /* (scm_in_heap_p (ptr)) */ /* FIXME */
{
- scm_puts (" (0x", port);
+ scm_puts_unlocked (" (0x", port);
scm_uintprint (SCM_CELL_WORD_0 (ptr), 16, port);
- scm_puts (" . 0x", port);
+ scm_puts_unlocked (" . 0x", port);
scm_uintprint (SCM_CELL_WORD_1 (ptr), 16, port);
- scm_puts (") @", port);
+ scm_puts_unlocked (") @", port);
}
- scm_puts (" 0x", port);
+ scm_puts_unlocked (" 0x", port);
scm_uintprint (SCM_UNPACK (ptr), 16, port);
- scm_putc ('>', port);
+ scm_putc_unlocked ('>', port);
}
{
register SCM hare, tortoise;
long floor = pstate->top - 2;
- scm_puts (hdr, port);
+ scm_puts_unlocked (hdr, port);
/* CHECK_INTS; */
if (pstate->fancyp)
goto fancy_printing;
if (scm_is_eq (PSTATE_STACK_REF(pstate, i), exp))
goto circref;
PUSH_REF (pstate, exp);
- scm_putc (' ', port);
+ scm_putc_unlocked (' ', port);
/* CHECK_INTS; */
scm_iprin1 (SCM_CAR (exp), port, pstate);
}
if (!SCM_NULL_OR_NIL_P (exp))
{
- scm_puts (" . ", port);
+ scm_puts_unlocked (" . ", port);
scm_iprin1 (exp, port, pstate);
}
end:
- scm_putc (tlr, port);
+ scm_putc_unlocked (tlr, port);
pstate->top = floor + 2;
return;
{
if (n == 0)
{
- scm_puts (" ...", port);
+ scm_puts_unlocked (" ...", port);
goto skip_tail;
}
else
}
PUSH_REF(pstate, exp);
++pstate->list_offset;
- scm_putc (' ', port);
+ scm_putc_unlocked (' ', port);
/* CHECK_INTS; */
scm_iprin1 (SCM_CAR (exp), port, pstate);
}
}
if (!SCM_NULL_OR_NIL_P (exp))
{
- scm_puts (" . ", port);
+ scm_puts_unlocked (" . ", port);
scm_iprin1 (exp, port, pstate);
}
skip_tail:
pstate->list_offset -= pstate->top - floor - 2;
circref:
- scm_puts (" . ", port);
+ scm_puts_unlocked (" . ", port);
print_circref (port, pstate, exp);
goto end;
}
SCM_ASSERT (scm_valid_oport_value_p (port), port, SCM_ARG2, s_write);
+ scm_dynwind_begin (0);
+ scm_dynwind_lock_port (SCM_COERCE_OUTPORT (port));
scm_prin1 (obj, port, 1);
+ scm_dynwind_end ();
+
return SCM_UNSPECIFIED;
}
SCM_ASSERT (scm_valid_oport_value_p (port), port, SCM_ARG2, s_display);
+ scm_dynwind_begin (0);
+ scm_dynwind_lock_port (SCM_COERCE_OUTPORT (port));
scm_prin1 (obj, port, 0);
+ scm_dynwind_end ();
+
return SCM_UNSPECIFIED;
}
SCM_VALIDATE_OPORT_VALUE (1, port);
- scm_putc ('\n', SCM_COERCE_OUTPORT (port));
+ scm_putc_unlocked ('\n', SCM_COERCE_OUTPORT (port));
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
port_with_ps_print (SCM obj, SCM port, scm_print_state *pstate)
{
obj = SCM_PORT_WITH_PS_PORT (obj);
- return scm_ptobs[SCM_PTOBNUM (obj)].print (obj, port, pstate);
+ return SCM_PORT_DESCRIPTOR (obj)->print (obj, port, pstate);
}
SCM
{
SCM type;
- scm_gc_register_root (&print_state_pool);
- scm_gc_register_root (&scm_print_state_vtable);
type = scm_make_vtable (scm_from_locale_string (SCM_PRINT_STATE_LAYOUT),
SCM_BOOL_F);
scm_set_struct_vtable_name_x (type, scm_from_latin1_symbol ("print-state"));
HCoop / bpt / guile.git / commitdiff