← Back to branch summary

~ubuntu-branches/ubuntu/hardy/sigscheme/hardy-proposed

« back to all changes in this revision

Viewing changes to src/number.c

  • Committer: Bazaar Package Importer
  • Author(s): NIIBE Yutaka
  • Date: 2006-05-23 21:46:41 UTC
  • mfrom: (1.1.1 upstream)
  • Revision ID: james.westby@ubuntu.com-20060523214641-6ix4gz34wpiehub8
Tags: 0.5.0-2
http://bugs.debian.org/368571
* debian/control (Build-Depends): Added ruby.
  Thanks to Frederik Schueler.  Closes: #368571
* debian/rules (clean): invoke 'distclean' instead of 'clean'.

Show diffs side-by-side

added added

removed removed

Lines of Context:
src/number.c
 
1
/*===========================================================================
 
2
 *  FileName : number.c
 
3
 *  About    : R5RS numbers
 
4
 *
 
5
 *  Copyright (C) 2005-2006 Kazuki Ohta <mover AT hct.zaq.ne.jp>
 
6
 *
 
7
 *  All rights reserved.
 
8
 *
 
9
 *  Redistribution and use in source and binary forms, with or without
 
10
 *  modification, are permitted provided that the following conditions
 
11
 *  are met:
 
12
 *
 
13
 *  1. Redistributions of source code must retain the above copyright
 
14
 *     notice, this list of conditions and the following disclaimer.
 
15
 *  2. Redistributions in binary form must reproduce the above copyright
 
16
 *     notice, this list of conditions and the following disclaimer in the
 
17
 *     documentation and/or other materials provided with the distribution.
 
18
 *  3. Neither the name of authors nor the names of its contributors
 
19
 *     may be used to endorse or promote products derived from this software
 
20
 *     without specific prior written permission.
 
21
 *
 
22
 *  THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS
 
23
 *  IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
 
24
 *  THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
 
25
 *  PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
 
26
 *  CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
 
27
 *  EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
 
28
 *  PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
 
29
 *  OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
 
30
 *  WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
 
31
 *  OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
 
32
 *  ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 
33
===========================================================================*/
 
34
 
 
35
#include "config.h"
 
36
 
 
37
/*=======================================
 
38
  System Include
 
39
=======================================*/
 
40
#include <stdlib.h>
 
41
#include <limits.h>
 
42
#include <errno.h>
 
43
 
 
44
/*=======================================
 
45
  Local Include
 
46
=======================================*/
 
47
#include "sigscheme.h"
 
48
#include "sigschemeinternal.h"
 
49
 
 
50
/*=======================================
 
51
  File Local Struct Declarations
 
52
=======================================*/
 
53
 
 
54
/*=======================================
 
55
  File Local Macro Declarations
 
56
=======================================*/
 
57
 
 
58
/*=======================================
 
59
  Variable Declarations
 
60
=======================================*/
 
61
 
 
62
/*=======================================
 
63
  File Local Function Declarations
 
64
=======================================*/
 
65
static int prepare_radix(const char *funcname, ScmObj args);
 
66
 
 
67
/*=======================================
 
68
  Function Implementations
 
69
=======================================*/
 
70
/*=======================================
 
71
  R5RS : 6.2 Numbers
 
72
=======================================*/
 
73
/*===========================================================================
 
74
  R5RS : 6.2 Numbers : 6.2.5 Numerical Operations
 
75
===========================================================================*/
 
76
/* Note: SigScheme supports only the integer part of the numerical tower. */
 
77
 
 
78
ScmObj
 
79
scm_p_add(ScmObj left, ScmObj right, enum ScmReductionState *state)
 
80
{
 
81
    scm_int_t result;
 
82
    DECLARE_FUNCTION("+", reduction_operator);
 
83
 
 
84
    result = 0;
 
85
    switch (*state) {
 
86
    case SCM_REDUCE_PARTWAY:
 
87
    case SCM_REDUCE_LAST:
 
88
        ENSURE_INT(left);
 
89
        result = SCM_INT_VALUE(left);
 
90
        /* Fall through. */
 
91
    case SCM_REDUCE_1:
 
92
        ENSURE_INT(right);
 
93
        result += SCM_INT_VALUE(right);
 
94
        /* Fall through. */
 
95
    case SCM_REDUCE_0:
 
96
        break;
 
97
    default:
 
98
        SCM_ASSERT(scm_false);
 
99
    }
 
100
 
 
101
    return MAKE_INT(result);
 
102
}
 
103
 
 
104
ScmObj
 
105
scm_p_multiply(ScmObj left, ScmObj right, enum ScmReductionState *state)
 
106
{
 
107
    scm_int_t result;
 
108
    DECLARE_FUNCTION("*", reduction_operator);
 
109
 
 
110
    result = 1;
 
111
    switch (*state) {
 
112
    case SCM_REDUCE_PARTWAY:
 
113
    case SCM_REDUCE_LAST:
 
114
        ENSURE_INT(left);
 
115
        result = SCM_INT_VALUE(left);
 
116
        /* Fall through. */
 
117
    case SCM_REDUCE_1:
 
118
        ENSURE_INT(right);
 
119
        result *= SCM_INT_VALUE(right);
 
120
        /* Fall through. */
 
121
    case SCM_REDUCE_0:
 
122
        break;
 
123
    default:
 
124
        SCM_ASSERT(scm_false);
 
125
    }
 
126
 
 
127
    return MAKE_INT(result);
 
128
}
 
129
 
 
130
ScmObj
 
131
scm_p_subtract(ScmObj left, ScmObj right, enum ScmReductionState *state)
 
132
{
 
133
    scm_int_t result;
 
134
    DECLARE_FUNCTION("-", reduction_operator);
 
135
 
 
136
    result = 0;
 
137
    switch (*state) {
 
138
    case SCM_REDUCE_PARTWAY:
 
139
    case SCM_REDUCE_LAST:
 
140
        ENSURE_INT(left);
 
141
        result = SCM_INT_VALUE(left);
 
142
        /* Fall through. */
 
143
    case SCM_REDUCE_1:
 
144
        ENSURE_INT(right);
 
145
        result -= SCM_INT_VALUE(right);
 
146
        break;
 
147
 
 
148
    case SCM_REDUCE_0:
 
149
        ERR("at least 1 argument required");
 
150
    default:
 
151
        SCM_ASSERT(scm_false);
 
152
    }
 
153
    return MAKE_INT(result);
 
154
}
 
155
 
 
156
ScmObj
 
157
scm_p_divide(ScmObj left, ScmObj right, enum ScmReductionState *state)
 
158
{
 
159
    scm_int_t result;
 
160
    DECLARE_FUNCTION("/", reduction_operator);
 
161
 
 
162
    result = 1;
 
163
    switch (*state) {
 
164
    case SCM_REDUCE_PARTWAY:
 
165
    case SCM_REDUCE_LAST:
 
166
        ENSURE_INT(left);
 
167
        result = SCM_INT_VALUE(left);
 
168
        /* Fall through. */
 
169
    case SCM_REDUCE_1:
 
170
        ENSURE_INT(right);
 
171
        if (SCM_INT_VALUE(right) == 0)
 
172
            ERR("division by zero");
 
173
        result /= SCM_INT_VALUE(right);
 
174
        break;
 
175
    case SCM_REDUCE_0:
 
176
        ERR("at least 1 argument required");
 
177
    default:
 
178
        SCM_ASSERT(scm_false);
 
179
    }
 
180
    return MAKE_INT(result);
 
181
}
 
182
 
 
183
ScmObj
 
184
scm_p_numberp(ScmObj obj)
 
185
{
 
186
    DECLARE_FUNCTION("number?", procedure_fixed_1);
 
187
 
 
188
    return MAKE_BOOL(NUMBERP(obj));
 
189
}
 
190
 
 
191
ScmObj
 
192
scm_p_integerp(ScmObj obj)
 
193
{
 
194
    DECLARE_FUNCTION("integer?", procedure_fixed_1);
 
195
 
 
196
    return MAKE_BOOL(INTP(obj));
 
197
}
 
198
 
 
199
#define COMPARATOR_BODY(op)                                                  \
 
200
    switch (*state) {                                                        \
 
201
    case SCM_REDUCE_0:                                                       \
 
202
    case SCM_REDUCE_1:                                                       \
 
203
        ERR("at least 2 arguments required");                                \
 
204
    case SCM_REDUCE_PARTWAY:                                                 \
 
205
    case SCM_REDUCE_LAST:                                                    \
 
206
        ENSURE_INT(left);                                                    \
 
207
        ENSURE_INT(right);                                                   \
 
208
        if (SCM_INT_VALUE(left) op SCM_INT_VALUE(right))                     \
 
209
            return *state == SCM_REDUCE_LAST ? SCM_TRUE : right;             \
 
210
        *state = SCM_REDUCE_STOP;                                            \
 
211
        return SCM_FALSE;                                                    \
 
212
    default:                                                                 \
 
213
        SCM_ASSERT(scm_false);                                               \
 
214
    }                                                                        \
 
215
    return SCM_INVALID
 
216
 
 
217
ScmObj
 
218
scm_p_equal(ScmObj left, ScmObj right, enum ScmReductionState *state)
 
219
{
 
220
    DECLARE_FUNCTION("=", reduction_operator);
 
221
 
 
222
    COMPARATOR_BODY(==);
 
223
}
 
224
 
 
225
ScmObj
 
226
scm_p_less(ScmObj left, ScmObj right, enum ScmReductionState *state)
 
227
{
 
228
    DECLARE_FUNCTION("<", reduction_operator);
 
229
 
 
230
    COMPARATOR_BODY(<);
 
231
}
 
232
 
 
233
ScmObj
 
234
scm_p_less_equal(ScmObj left, ScmObj right, enum ScmReductionState *state)
 
235
{
 
236
    DECLARE_FUNCTION("<=", reduction_operator);
 
237
 
 
238
    COMPARATOR_BODY(<=);
 
239
}
 
240
 
 
241
ScmObj
 
242
scm_p_greater(ScmObj left, ScmObj right, enum ScmReductionState *state)
 
243
{
 
244
    DECLARE_FUNCTION(">", reduction_operator);
 
245
 
 
246
    COMPARATOR_BODY(>);
 
247
}
 
248
 
 
249
ScmObj
 
250
scm_p_greater_equal(ScmObj left, ScmObj right, enum ScmReductionState *state)
 
251
{
 
252
    DECLARE_FUNCTION(">=", reduction_operator);
 
253
 
 
254
    COMPARATOR_BODY(>=);
 
255
}
 
256
 
 
257
#undef COMPARATOR_BODY
 
258
 
 
259
ScmObj
 
260
scm_p_zerop(ScmObj n)
 
261
{
 
262
    DECLARE_FUNCTION("zero?", procedure_fixed_1);
 
263
 
 
264
    ENSURE_INT(n);
 
265
 
 
266
    return MAKE_BOOL(SCM_INT_VALUE(n) == 0);
 
267
}
 
268
 
 
269
ScmObj
 
270
scm_p_positivep(ScmObj n)
 
271
{
 
272
    DECLARE_FUNCTION("positive?", procedure_fixed_1);
 
273
 
 
274
    ENSURE_INT(n);
 
275
 
 
276
    return MAKE_BOOL(SCM_INT_VALUE(n) > 0);
 
277
}
 
278
 
 
279
ScmObj
 
280
scm_p_negativep(ScmObj n)
 
281
{
 
282
    DECLARE_FUNCTION("negative?", procedure_fixed_1);
 
283
 
 
284
    ENSURE_INT(n);
 
285
 
 
286
    return MAKE_BOOL(SCM_INT_VALUE(n) < 0);
 
287
}
 
288
 
 
289
ScmObj
 
290
scm_p_oddp(ScmObj n)
 
291
{
 
292
    DECLARE_FUNCTION("odd?", procedure_fixed_1);
 
293
 
 
294
    ENSURE_INT(n);
 
295
 
 
296
    return MAKE_BOOL(SCM_INT_VALUE(n) & 0x1);
 
297
}
 
298
 
 
299
ScmObj
 
300
scm_p_evenp(ScmObj n)
 
301
{
 
302
    DECLARE_FUNCTION("even?", procedure_fixed_1);
 
303
 
 
304
    ENSURE_INT(n);
 
305
 
 
306
    return MAKE_BOOL(!(SCM_INT_VALUE(n) & 0x1));
 
307
}
 
308
 
 
309
ScmObj
 
310
scm_p_max(ScmObj left, ScmObj right, enum ScmReductionState *state)
 
311
{
 
312
    DECLARE_FUNCTION("max", reduction_operator);
 
313
 
 
314
    if (*state == SCM_REDUCE_0)
 
315
        ERR("at least 1 argument required");
 
316
    ENSURE_INT(left);
 
317
    ENSURE_INT(right);
 
318
 
 
319
    return (SCM_INT_VALUE(left) > SCM_INT_VALUE(right)) ? left : right;
 
320
}
 
321
 
 
322
ScmObj
 
323
scm_p_min(ScmObj left, ScmObj right, enum ScmReductionState *state)
 
324
{
 
325
    DECLARE_FUNCTION("min", reduction_operator);
 
326
 
 
327
    if (*state == SCM_REDUCE_0)
 
328
        ERR("at least 1 argument required");
 
329
    ENSURE_INT(left);
 
330
    ENSURE_INT(right);
 
331
 
 
332
    return (SCM_INT_VALUE(left) < SCM_INT_VALUE(right)) ? left : right;
 
333
}
 
334
 
 
335
 
 
336
ScmObj
 
337
scm_p_abs(ScmObj _n)
 
338
{
 
339
    scm_int_t n;
 
340
    DECLARE_FUNCTION("abs", procedure_fixed_1);
 
341
 
 
342
    ENSURE_INT(_n);
 
343
 
 
344
    n = SCM_INT_VALUE(_n);
 
345
 
 
346
    return (n < 0) ? MAKE_INT(-n) : _n;
 
347
}
 
348
 
 
349
ScmObj
 
350
scm_p_quotient(ScmObj _n1, ScmObj _n2)
 
351
{
 
352
    scm_int_t n1, n2;
 
353
    DECLARE_FUNCTION("quotient", procedure_fixed_2);
 
354
 
 
355
    ENSURE_INT(_n1);
 
356
    ENSURE_INT(_n2);
 
357
 
 
358
    n1 = SCM_INT_VALUE(_n1);
 
359
    n2 = SCM_INT_VALUE(_n2);
 
360
 
 
361
    if (n2 == 0)
 
362
        ERR("division by zero");
 
363
 
 
364
    return MAKE_INT((int)(n1 / n2));
 
365
}
 
366
 
 
367
ScmObj
 
368
scm_p_modulo(ScmObj _n1, ScmObj _n2)
 
369
{
 
370
    scm_int_t n1, n2, rem;
 
371
    DECLARE_FUNCTION("modulo", procedure_fixed_2);
 
372
 
 
373
    ENSURE_INT(_n1);
 
374
    ENSURE_INT(_n2);
 
375
 
 
376
    n1 = SCM_INT_VALUE(_n1);
 
377
    n2 = SCM_INT_VALUE(_n2);
 
378
 
 
379
    if (n2 == 0)
 
380
        ERR("division by zero");
 
381
 
 
382
    rem  = n1 % n2;
 
383
    if (n1 < 0 && n2 > 0) {
 
384
        rem += n2;
 
385
    } else if (n1 > 0 && n2 < 0) {
 
386
        rem += n2;
 
387
    }
 
388
 
 
389
    return MAKE_INT(rem);
 
390
}
 
391
 
 
392
ScmObj
 
393
scm_p_remainder(ScmObj _n1, ScmObj _n2)
 
394
{
 
395
    scm_int_t n1, n2;
 
396
    DECLARE_FUNCTION("remainder", procedure_fixed_2);
 
397
 
 
398
    ENSURE_INT(_n1);
 
399
    ENSURE_INT(_n2);
 
400
 
 
401
    n1 = SCM_INT_VALUE(_n1);
 
402
    n2 = SCM_INT_VALUE(_n2);
 
403
 
 
404
    if (n2 == 0)
 
405
        ERR("division by zero");
 
406
 
 
407
    return MAKE_INT(n1 % n2);
 
408
}
 
409
 
 
410
/*===========================================================================
 
411
  R5RS : 6.2 Numbers : 6.2.6 Numerical input and output
 
412
===========================================================================*/
 
413
 
 
414
static int
 
415
prepare_radix(const char *funcname, ScmObj args)
 
416
{
 
417
    ScmObj radix;
 
418
    int r;
 
419
    DECLARE_INTERNAL_FUNCTION("(internal)");
 
420
 
 
421
    ASSERT_PROPER_ARG_LIST(args);
 
422
 
 
423
    /* dirty hack to replace internal function name */
 
424
    SCM_MANGLE(name) = funcname;
 
425
 
 
426
    if (NULLP(args)) {
 
427
        r = 10;
 
428
    } else {
 
429
        radix = POP(args);
 
430
        ASSERT_NO_MORE_ARG(args);
 
431
        ENSURE_INT(radix);
 
432
        r = SCM_INT_VALUE(radix);
 
433
        if (!(r == 2 || r == 8 || r == 10 || r == 16))
 
434
            ERR_OBJ("invalid radix", radix);
 
435
    }
 
436
 
 
437
    return r;
 
438
}
 
439
 
 
440
ScmObj
 
441
scm_p_number2string(ScmObj num, ScmObj args)
 
442
{
 
443
  char buf[sizeof("-") + SCM_INT_BITS];
 
444
  char *p;
 
445
  const char *end;
 
446
  scm_int_t n;
 
447
  /* 'un' must be unsinged to be capable of -INT_MIN */
 
448
  scm_uint_t un, digit, r;
 
449
  scm_bool neg;
 
450
  DECLARE_FUNCTION("number->string", procedure_variadic_1);
 
451
 
 
452
  ENSURE_INT(num);
 
453
 
 
454
  n = SCM_INT_VALUE(num);
 
455
  neg = (n < 0);
 
456
  un = (neg) ? -n : n;
 
457
  r = (scm_uint_t)prepare_radix(SCM_MANGLE(name), args);
 
458
 
 
459
  end = p = &buf[sizeof(buf) - 1];
 
460
  *p = '\0';
 
461
 
 
462
  do {
 
463
      digit = un % r;
 
464
      *--p = (digit <= 9) ? '0' + digit : 'a' + digit - 10;
 
465
  } while (un /= r);
 
466
  if (neg)
 
467
    *--p = '-';
 
468
 
 
469
  return MAKE_STRING_COPYING(p, end - p);
 
470
}
 
471
 
 
472
scm_int_t
 
473
scm_string2number(const char *str, int radix, scm_bool *err)
 
474
{
 
475
    scm_int_t n;
 
476
    char *end;
 
477
    scm_bool empty_strp;
 
478
    DECLARE_INTERNAL_FUNCTION("string->number");
 
479
 
 
480
    /* R5RS:
 
481
     *
 
482
     * - If string is not a syntactically valid notation for a number, then
 
483
     *   `string->number' returns #f.
 
484
     *
 
485
     * - `String->number' is permitted to return #f whenever string contains an
 
486
     *   explicit radix prefix.
 
487
     *
 
488
     * - If all numbers supported by an implementation are real, then
 
489
     *   `string->number' is permitted to return #f whenever string uses the
 
490
     *   polar or rectangular notations for complex numbers.
 
491
     *
 
492
     * - If all numbers are integers, then `string->number' may return #f
 
493
     *   whenever the fractional notation is used.
 
494
     *
 
495
     * - If all numbers are exact, then `string->number' may return #f whenever
 
496
     *   an exponent marker or explicit exactness prefix is used, or if a #
 
497
     *   appears in place of a digit.
 
498
     *
 
499
     * - If all inexact numbers are integers, then `string->number' may return
 
500
     *   #f whenever a decimal point is used.
 
501
     */
 
502
 
 
503
#if (SIZEOF_SCM_INT_T <= SIZEOF_LONG)
 
504
    n = (scm_int_t)strtol(str, &end, radix);
 
505
#elif (HAVE_STRTOLL && SIZEOF_SCM_INT_T <= SIZEOF_LONG_LONG)
 
506
    n = (scm_int_t)strtoll(str, &end, radix);
 
507
#elif (HAVE_STRTOIMAX && Sizeof_SCM_INT_T <= SIZEOF_INTMAX_T)
 
508
    n = (scm_int_t)strtoimax(str, &end, radix);
 
509
#else
 
510
#error "This platform is not supported"
 
511
#endif
 
512
 
 
513
    if (errno == ERANGE || n < SCM_INT_MIN || SCM_INT_MAX < n)
 
514
        ERR("fixnum limit exceeded: %d", n);
 
515
 
 
516
    empty_strp = (end == str);  /* apply the first rule above */
 
517
    *err = (empty_strp || *end);
 
518
    return n;
 
519
}
 
520
 
 
521
ScmObj
 
522
scm_p_string2number(ScmObj str, ScmObj args)
 
523
{
 
524
    scm_int_t ret;
 
525
    int r;
 
526
    const char *c_str;
 
527
    scm_bool err;
 
528
    DECLARE_FUNCTION("string->number", procedure_variadic_1);
 
529
 
 
530
    ENSURE_STRING(str);
 
531
 
 
532
    c_str = SCM_STRING_STR(str);
 
533
    r = prepare_radix(SCM_MANGLE(name), args);
 
534
 
 
535
    ret = scm_string2number(c_str, r, &err);
 
536
    return (err) ? SCM_FALSE : MAKE_INT(ret);
 
537
}