diff options
author | Mikael Djurfeldt <djurfeldt@nada.kth.se> | 2005-02-10 11:15:50 +0000 |
---|---|---|
committer | Mikael Djurfeldt <djurfeldt@nada.kth.se> | 2005-02-10 11:15:50 +0000 |
commit | 29fed193d3af3bf34ee801bdec819e1ccdec0cf2 (patch) | |
tree | 8d8f4e59862c661d8ee1c4a8968406ec41c036cd /libguile/unif.c | |
parent | e94d0be22bfb2c47539cd6938167b9237aa8fa8f (diff) | |
download | guile-29fed193d3af3bf34ee801bdec819e1ccdec0cf2.tar.gz |
(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.)
Diffstat (limited to 'libguile/unif.c')
-rw-r--r-- | libguile/unif.c | 50 |
1 files changed, 37 insertions, 13 deletions
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; |