diff options
-rw-r--r-- | libguile/ChangeLog | 8 | ||||
-rw-r--r-- | libguile/unif.c | 50 |
2 files changed, 45 insertions, 13 deletions
diff --git a/libguile/ChangeLog b/libguile/ChangeLog index eec991a66..faf5ca2f3 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,11 @@ +2005-02-10 Mikael Djurfeldt <djurfeldt@nada.kth.se> + + * unif.c (prototype_to_type): Bugfix: Don't compare prototype to + the prototypical examples mentioned in the old reference manual. + Instead keep the old semantics of dispatching on type. (Yes, this + is extremely ugly, but the whole point of keeping the deprecated + interface is not to break old code.) + 2005-02-08 Mikael Djurfeldt <djurfeldt@nada.kth.se> * deprecated.h (SCM_ARRAY_DIMS): Rename scm_i_attay_dims --> diff --git a/libguile/unif.c b/libguile/unif.c index 0b32c354a..3690ec74a 100644 --- a/libguile/unif.c +++ b/libguile/unif.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004, 2005 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public @@ -148,6 +148,22 @@ make_typed_vector (SCM type, size_t len) SCM_SYMBOL (scm_sym_s, "s"); SCM_SYMBOL (scm_sym_l, "l"); +static int +singp (SCM obj) +{ + if (!SCM_REALP (obj)) + return 0; + else + { + double x = SCM_REAL_VALUE (obj); + float fx = x; + return (- SCM_FLTMAX < x) && (x < SCM_FLTMAX) && (fx == x); + } +} + +SCM_API int scm_i_inump (SCM obj); +SCM_API scm_t_signed_bits scm_i_inum (SCM obj); + static SCM prototype_to_type (SCM proto) { @@ -155,24 +171,32 @@ prototype_to_type (SCM proto) if (scm_is_eq (proto, SCM_BOOL_T)) type_name = "b"; - else if (scm_is_eq (proto, SCM_MAKE_CHAR ('a'))) - type_name = "a"; else if (scm_is_eq (proto, SCM_MAKE_CHAR (0))) type_name = "s8"; + else if (SCM_CHARP (proto)) + type_name = "a"; + else if (scm_i_inump (proto)) + { + if (scm_i_inum (proto) > 0) + type_name = "u32"; + else + type_name = "s32"; + } else if (scm_is_eq (proto, scm_sym_s)) type_name = "s16"; - else if (scm_is_true (scm_eqv_p (proto, scm_from_int (1)))) - type_name = "u32"; - else if (scm_is_true (scm_eqv_p (proto, scm_from_int (-1)))) - type_name = "s32"; else if (scm_is_eq (proto, scm_sym_l)) type_name = "s64"; - else if (scm_is_true (scm_eqv_p (proto, scm_from_double (1.0)))) - type_name = "f32"; - else if (scm_is_true (scm_eqv_p (proto, scm_divide (scm_from_int (1), - scm_from_int (3))))) - type_name = "f64"; - else if (scm_is_true (scm_eqv_p (proto, scm_c_make_rectangular (0, 1)))) + else if (SCM_REALP (proto) + || scm_is_true (scm_eqv_p (proto, + scm_divide (scm_from_int (1), + scm_from_int (3))))) + { + if (singp (proto)) + type_name = "f32"; + else + type_name = "f64"; + } + else if (SCM_COMPLEXP (proto)) type_name = "c64"; else if (scm_is_null (proto)) type_name = NULL; |