1 /*===========================================================================
2 * Filename : number-io.c
3 * About : Numerical input/output procedures of R5RS numbers
4 *
5 * Copyright (C) 2005 Kazuki Ohta <mover AT hct.zaq.ne.jp>
6 * Copyright (C) 2005-2006 Jun Inoue <jun.lambda AT gmail.com>
7 * Copyright (C) 2005-2006 YAMAMOTO Kengo <yamaken AT bp.iij4u.or.jp>
8 * Copyright (c) 2007-2008 SigScheme Project <uim-en AT googlegroups.com>
9 *
10 * All rights reserved.
11 *
12 * Redistribution and use in source and binary forms, with or without
13 * modification, are permitted provided that the following conditions
14 * are met:
15 *
16 * 1. Redistributions of source code must retain the above copyright
17 * notice, this list of conditions and the following disclaimer.
18 * 2. Redistributions in binary form must reproduce the above copyright
19 * notice, this list of conditions and the following disclaimer in the
20 * documentation and/or other materials provided with the distribution.
21 * 3. Neither the name of authors nor the names of its contributors
22 * may be used to endorse or promote products derived from this software
23 * without specific prior written permission.
24 *
25 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS
26 * IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
27 * THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
28 * PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
29 * CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
30 * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
31 * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
32 * OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
33 * WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
34 * OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
35 * ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
36 ===========================================================================*/
37
38 #include <config.h>
39
40 #include <stdlib.h>
41 #include <limits.h>
42 #include <errno.h>
43 #if SCM_STRICT_ARGCHECK
44 #include <string.h>
45 #endif
46
47 #include "sigscheme.h"
48 #include "sigschemeinternal.h"
49
50 /*=======================================
51 File Local Macro Definitions
52 =======================================*/
53 #define VALID_RADIXP(r) ((r) == 2 || (r) == 8 || (r) == 10 || (r) == 16)
54
55 /*=======================================
56 File Local Type Definitions
57 =======================================*/
58
59 /*=======================================
60 Variable Definitions
61 =======================================*/
62
63 /*=======================================
64 File Local Function Declarations
65 =======================================*/
66 #if SCM_USE_STRING
67 static int prepare_radix(const char *funcname, ScmObj args);
68 #endif
69
70 /*=======================================
71 Function Definitions
72 =======================================*/
73 /*===========================================================================
74 R5RS : 6.2 Numbers : 6.2.6 Numerical input and output
75 ===========================================================================*/
76 #if SCM_USE_STRING
77 static int
prepare_radix(const char * funcname,ScmObj args)78 prepare_radix(const char *funcname, ScmObj args)
79 {
80 ScmObj radix;
81 int r;
82 DECLARE_INTERNAL_FUNCTION("(internal)");
83
84 ASSERT_PROPER_ARG_LIST(args);
85
86 /* dirty hack to replace internal function name */
87 SCM_MANGLE(name) = funcname;
88
89 if (NULLP(args)) {
90 r = 10;
91 } else {
92 radix = POP(args);
93 ASSERT_NO_MORE_ARG(args);
94 ENSURE_INT(radix);
95 r = SCM_INT_VALUE(radix);
96 if (!VALID_RADIXP(r))
97 ERR_OBJ("invalid radix", radix);
98 }
99
100 return r;
101 }
102
103 SCM_EXPORT char *
scm_int2string(ScmValueFormat vfmt,uintmax_t n,int radix)104 scm_int2string(ScmValueFormat vfmt, uintmax_t n, int radix)
105 {
106 char buf[sizeof("-") + sizeof(uintmax_t) * CHAR_BIT];
107 char *p, *end, *str;
108 uintmax_t un; /* must be unsigned to be capable of -INT_MIN */
109 int digit, sign_len, pad_len, len;
110 scm_bool neg;
111 DECLARE_INTERNAL_FUNCTION("scm_int2string");
112
113 SCM_ASSERT(VALID_RADIXP(radix));
114 neg = (vfmt.signedp && ((intmax_t)n < 0));
115 un = (neg) ? (uintmax_t)-(intmax_t)n : n;
116
117 end = p = &buf[sizeof(buf) - 1];
118 *end = '\0';
119
120 do {
121 digit = un % radix;
122 *--p = (digit <= 9) ? '0' + digit : 'a' + digit - 10;
123 } while (un /= radix);
124 if (neg && vfmt.pad != '0')
125 *--p = '-';
126
127 sign_len = (neg && vfmt.pad == '0') ? 1 : 0;
128 len = end - p;
129 pad_len = (sign_len + len < vfmt.width) ? vfmt.width - sign_len - len : 0;
130
131 str = scm_malloc(sign_len + pad_len + len + sizeof(""));
132 strcpy(&str[sign_len + pad_len], p);
133 while (pad_len)
134 str[sign_len + --pad_len] = vfmt.pad;
135
136 if (sign_len)
137 *str = '-';
138
139 return str;
140 }
141
142 SCM_EXPORT ScmObj
scm_p_number2string(ScmObj num,ScmObj args)143 scm_p_number2string(ScmObj num, ScmObj args)
144 {
145 char *str;
146 intmax_t n;
147 int r;
148 ScmValueFormat vfmt;
149 DECLARE_FUNCTION("number->string", procedure_variadic_1);
150
151 ENSURE_INT(num);
152
153 n = (intmax_t)SCM_INT_VALUE(num);
154 r = prepare_radix(SCM_MANGLE(name), args);
155 SCM_VALUE_FORMAT_INIT(vfmt);
156 str = scm_int2string(vfmt, (uintmax_t)n, r);
157
158 return MAKE_STRING(str, SCM_STRLEN_UNKNOWN);
159 }
160 #endif /* SCM_USE_STRING */
161
162 SCM_EXPORT scm_int_t
scm_string2number(const char * str,int radix,scm_bool * err)163 scm_string2number(const char *str, int radix, scm_bool *err)
164 {
165 scm_int_t n;
166 char *end;
167 scm_bool empty_strp;
168 DECLARE_INTERNAL_FUNCTION("string->number");
169
170 SCM_ASSERT(str);
171 SCM_ASSERT(VALID_RADIXP(radix));
172 SCM_ASSERT(err);
173
174 /* R5RS:
175 *
176 * - If string is not a syntactically valid notation for a number, then
177 * `string->number' returns #f.
178 *
179 * - `String->number' is permitted to return #f whenever string contains an
180 * explicit radix prefix.
181 *
182 * - If all numbers supported by an implementation are real, then
183 * `string->number' is permitted to return #f whenever string uses the
184 * polar or rectangular notations for complex numbers.
185 *
186 * - If all numbers are integers, then `string->number' may return #f
187 * whenever the fractional notation is used.
188 *
189 * - If all numbers are exact, then `string->number' may return #f whenever
190 * an exponent marker or explicit exactness prefix is used, or if a #
191 * appears in place of a digit.
192 *
193 * - If all inexact numbers are integers, then `string->number' may return
194 * #f whenever a decimal point is used.
195 */
196
197 #if SCM_STRICT_ARGCHECK
198 /* Reject "0xa", " 1" etc. */
199 if ((*err = str[strspn(str, "0123456789abcdefABCDEF-+")]))
200 return 0;
201 #endif /* SCM_STRICT_ARGCHECK */
202
203 errno = 0;
204 #if (SIZEOF_SCM_INT_T <= SIZEOF_LONG)
205 n = (scm_int_t)strtol(str, &end, radix);
206 #elif (HAVE_STRTOLL && SIZEOF_SCM_INT_T <= SIZEOF_LONG_LONG)
207 n = (scm_int_t)strtoll(str, &end, radix);
208 #elif (HAVE_STRTOIMAX && SIZEOF_SCM_INT_T <= SIZEOF_INTMAX_T)
209 n = (scm_int_t)strtoimax(str, &end, radix);
210 #else
211 #error "This platform is not supported"
212 #endif
213
214 empty_strp = (end == str); /* apply the first rule above */
215 *err = (empty_strp || *end);
216
217 /*
218 * glibc warning: Although the manpage describes the behavior as follows,
219 * ERANGE is returned for "". The description "may be set to [EINVAL]" is
220 * really 'may'. And the ISO C standard does not define errno for the
221 * case. So we should not depend on the assumption that ERANGE is returned
222 * only when overflow/underflow is occurred.
223 *
224 * quoted from glibc 2.3:
225 * RETURN VALUE
226 * Upon successful completion, these functions shall return the
227 * converted value, if any. If no conversion could be performed, 0
228 * shall be returned and errno may be set to [EINVAL].
229 */
230 if ((errno == ERANGE && !empty_strp) || INT_OUT_OF_RANGEP(n)) {
231 #if 0
232 ERR(ERRMSG_FIXNUM_OVERFLOW ": ~S (radix ~D)", str, radix);
233 #else
234 /* R5RS: If string is not a syntactically valid notation for a number,
235 * then `string->number' returns #f. */
236 *err = scm_true;
237 n = 0;
238 #endif
239 }
240
241 return n;
242 }
243
244 #if SCM_USE_STRING
245 SCM_EXPORT ScmObj
scm_p_string2number(ScmObj str,ScmObj args)246 scm_p_string2number(ScmObj str, ScmObj args)
247 {
248 scm_int_t ret;
249 int r;
250 const char *c_str;
251 scm_bool err;
252 DECLARE_FUNCTION("string->number", procedure_variadic_1);
253
254 ENSURE_STRING(str);
255
256 c_str = SCM_STRING_STR(str);
257 r = prepare_radix(SCM_MANGLE(name), args);
258
259 ret = scm_string2number(c_str, r, &err);
260 return (err) ? SCM_FALSE : MAKE_INT(ret);
261 }
262 #endif /* SCM_USE_STRING */
263