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