← Back to branch summary

~ubuntu-branches/ubuntu/vivid/nqp/vivid-proposed

« back to all changes in this revision

Viewing changes to src/ops/nqp_bigint.ops

  • Committer: Package Import Robot
  • Author(s): Alessandro Ghedini
  • Date: 2013-11-01 12:09:18 UTC
  • mfrom: (1.1.4)
  • Revision ID: package-import@ubuntu.com-20131101120918-kx51sl0sxl3exsxi
Tags: 2013.10-1
* New upstream release
* Bump versioned (Build-)Depends on parrot
* Update patches
* Install new README.pod
* Fix vcs-field-not-canonical
* Do not install rubyish examples
* Do not Depends on parrot-devel anymore
* Add 07_disable-serialization-tests.patch

Show diffs side-by-side

added added

removed removed

Lines of Context:
src/ops/nqp_bigint.ops
1
 
BEGIN_OPS_PREAMBLE
2
 
 
3
 
/* Parroty includes. */
4
 
#include "parrot/parrot.h"
5
 
#include "parrot/extend.h"
6
 
#include "parrot/dynext.h"
7
 
#include "../6model/sixmodelobject.h"
8
 
#include "../6model/reprs/P6bigint.h"
9
 
 
10
 
/* The ID of the bigint REPR. */
11
 
static INTVAL bigint_repr_id = 0;
12
 
 
13
 
static mp_int * get_bigint(PARROT_INTERP, PMC *obj) {
14
 
    struct SixModel_REPROps *r = REPR(obj);
15
 
    if (r->ID == bigint_repr_id)
16
 
        return &((P6bigintInstance *)PMC_data(obj))->body.i;
17
 
    else
18
 
        return &((P6bigintBody *)r->box_funcs->get_boxed_ref(interp, STABLE(obj), OBJECT_BODY(obj),
19
 
            bigint_repr_id))->i;
20
 
}
21
 
 
22
 
static FLOATVAL mp_get_double(mp_int *a) {
23
 
    FLOATVAL d    = 0.0;
24
 
    FLOATVAL sign = SIGN(a) == MP_NEG ? -1.0 : 1.0;
25
 
    int i;
26
 
    if (USED(a) == 0)
27
 
        return d;
28
 
    if (USED(a) == 1)
29
 
        return sign * (FLOATVAL) DIGIT(a, 0);
30
 
 
31
 
    mp_clamp(a);
32
 
    i = USED(a) - 1;
33
 
    d = (FLOATVAL) DIGIT(a, i);
34
 
    i--;
35
 
    if (i == -1) {
36
 
        return sign * d;
37
 
    }
38
 
    d *= pow(2.0, DIGIT_BIT);
39
 
    d += (FLOATVAL) DIGIT(a, i);
40
 
 
41
 
    if (USED(a) > 2) {
42
 
        i--;
43
 
        d *= pow(2.0, DIGIT_BIT);
44
 
        d += (FLOATVAL) DIGIT(a, i);
45
 
    }
46
 
 
47
 
    d *= pow(2.0, DIGIT_BIT * i);
48
 
    return sign * d;
49
 
}
50
 
 
51
 
 
52
 
static void from_num(FLOATVAL d, mp_int *a) {
53
 
    FLOATVAL d_digit = pow(2, DIGIT_BIT);
54
 
    FLOATVAL da      = fabs(d);
55
 
    FLOATVAL upper;
56
 
    FLOATVAL lower;
57
 
    FLOATVAL lowest;
58
 
    FLOATVAL rest;
59
 
    int      digits  = 0;
60
 
 
61
 
    mp_zero(a);
62
 
 
63
 
    while (da > d_digit * d_digit * d_digit) {;
64
 
        da /= d_digit;
65
 
        digits++;
66
 
    }
67
 
    mp_grow(a, digits + 3);
68
 
 
69
 
    /* populate the top 3 digits */
70
 
    upper = da / (d_digit*d_digit);
71
 
    rest = fmod(da, d_digit*d_digit);
72
 
    lower = rest / d_digit;
73
 
    lowest = fmod(rest,d_digit );
74
 
    if (upper >= 1) {
75
 
        mp_set_long(a, (unsigned long) upper);
76
 
        mp_mul_2d(a, DIGIT_BIT , a);
77
 
        DIGIT(a, 0) = (mp_digit) lower;
78
 
        mp_mul_2d(a, DIGIT_BIT , a);
79
 
    } else {
80
 
        if (lower >= 1) {
81
 
            mp_set_long(a, (unsigned long) lower);
82
 
            mp_mul_2d(a, DIGIT_BIT , a);
83
 
            a->used = 2;
84
 
        } else {
85
 
            a->used = 1;
86
 
        }
87
 
    }
88
 
    DIGIT(a, 0) = (mp_digit) lowest;
89
 
 
90
 
    /* shift the rest */
91
 
    mp_mul_2d(a, DIGIT_BIT * digits, a);
92
 
    if (d < 0)
93
 
        mp_neg(a, a);
94
 
    mp_clamp(a);
95
 
    mp_shrink(a);
96
 
}
97
 
 
98
 
static void grow_and_negate(mp_int *a, int size, mp_int *b) {
99
 
    int i;
100
 
    int actual_size = MAX(size, USED(a));
101
 
    mp_zero(b);
102
 
    mp_grow(b, actual_size);
103
 
    USED(b) = actual_size;
104
 
    for (i = 0; i < actual_size; i++) {
105
 
        DIGIT(b, i) = (~DIGIT(a, i)) & MP_MASK;
106
 
    }
107
 
    mp_add_d(b, 1, b);
108
 
}
109
 
 
110
 
 
111
 
static void two_complement_bitop(mp_int *a, mp_int *b, mp_int *c,
112
 
        int (*mp_bitop)(mp_int *, mp_int *, mp_int *)) {
113
 
    mp_int d;
114
 
    if (SIGN(a) ^ SIGN(b)) {
115
 
        /* exactly one of them is negative, so need to perform
116
 
         * some magic. tommath stores a sign bit, but Perl 6 expects
117
 
         * 2's complement */
118
 
        mp_init(&d);
119
 
        if (MP_NEG == SIGN(a)) {
120
 
            grow_and_negate(a, USED(b), &d);
121
 
            mp_bitop(&d, b, c);
122
 
        } else {
123
 
            grow_and_negate(b, USED(a), &d);
124
 
            mp_bitop(a, &d, c);
125
 
        }
126
 
        if (DIGIT(c, USED(c) - 1) & ((mp_digit)1<<(mp_digit)(DIGIT_BIT - 1))) {
127
 
            grow_and_negate(c, c->used, &d);
128
 
            mp_copy(&d, c);
129
 
            mp_neg(c, c);
130
 
        }
131
 
        mp_clear(&d);
132
 
    } else {
133
 
        mp_bitop(a, b, c);
134
 
    }
135
 
 
136
 
}
137
 
 
138
 
 
139
 
END_OPS_PREAMBLE
140
 
 
141
 
/*
142
 
 * The ops in here mostly just delegate off to libtommath. nqp_bigint_setup must be
143
 
 * called before you create any types using the bigint representation.
144
 
 */
145
 
 
146
 
inline op nqp_bigint_setup() :base_core {
147
 
    /* Register the bigint representation. */
148
 
    if (!bigint_repr_id) {
149
 
        bigint_repr_id = REGISTER_DYNAMIC_REPR(interp,
150
 
            Parrot_str_new_constant(interp, "P6bigint"),
151
 
            P6bigint_initialize);
152
 
        srand((unsigned int) Parrot_util_int_rand(0));
153
 
    }
154
 
}
155
 
 
156
 
inline op nqp_bigint_add(out PMC, invar PMC, invar PMC, invar PMC) :base_core {
157
 
    mp_int *a = get_bigint(interp, $2);
158
 
    mp_int *b = get_bigint(interp, $3);
159
 
    $1 = REPR($4)->allocate(interp, STABLE($4));
160
 
    REPR($1)->initialize(interp, STABLE($1), OBJECT_BODY($1));
161
 
    mp_add(a, b, get_bigint(interp, $1));
162
 
}
163
 
 
164
 
inline op nqp_bigint_sub(out PMC, invar PMC, invar PMC, invar PMC) :base_core {
165
 
    mp_int *a = get_bigint(interp, $2);
166
 
    mp_int *b = get_bigint(interp, $3);
167
 
    $1 = REPR($4)->allocate(interp, STABLE($4));
168
 
    REPR($1)->initialize(interp, STABLE($1), OBJECT_BODY($1));
169
 
    mp_sub(a, b, get_bigint(interp, $1));
170
 
}
171
 
 
172
 
inline op nqp_bigint_mul(out PMC, invar PMC, invar PMC, invar PMC) :base_core {
173
 
    mp_int *a = get_bigint(interp, $2);
174
 
    mp_int *b = get_bigint(interp, $3);
175
 
    $1 = REPR($4)->allocate(interp, STABLE($4));
176
 
    REPR($1)->initialize(interp, STABLE($1), OBJECT_BODY($1));
177
 
    mp_mul(a, b, get_bigint(interp, $1));
178
 
}
179
 
 
180
 
inline op nqp_bigint_div(out PMC, invar PMC, invar PMC, invar PMC) :base_core {
181
 
    mp_int *a = get_bigint(interp, $2);
182
 
    mp_int *b = get_bigint(interp, $3);
183
 
    int result;
184
 
    $1 = REPR($4)->allocate(interp, STABLE($4));
185
 
    REPR($1)->initialize(interp, STABLE($1), OBJECT_BODY($1));
186
 
    result = mp_div(a, b, get_bigint(interp, $1), NULL);
187
 
    if (result == MP_VAL)
188
 
        Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION,
189
 
            "Divide by zero");
190
 
}
191
 
 
192
 
inline op nqp_bigint_mod(out PMC, invar PMC, invar PMC, invar PMC) :base_core {
193
 
    mp_int *a = get_bigint(interp, $2);
194
 
    mp_int *b = get_bigint(interp, $3);
195
 
    $1 = REPR($4)->allocate(interp, STABLE($4));
196
 
    REPR($1)->initialize(interp, STABLE($1), OBJECT_BODY($1));
197
 
    mp_mod(a, b, get_bigint(interp, $1));
198
 
}
199
 
 
200
 
inline op nqp_bigint_exp_mod(out PMC, invar PMC, invar PMC, invar PMC, invar PMC) :base_core {
201
 
    mp_int *a = get_bigint(interp, $2);
202
 
    mp_int *b = get_bigint(interp, $3);
203
 
    mp_int *c = get_bigint(interp, $4);
204
 
    $1 = REPR($5)->allocate(interp, STABLE($5));
205
 
    REPR($1)->initialize(interp, STABLE($1), OBJECT_BODY($1));
206
 
    mp_exptmod(a, b, c, get_bigint(interp, $1));
207
 
}
208
 
 
209
 
inline op nqp_bigint_is_prime(out INT, invar PMC, in INT) {
210
 
    /* mp_prime_is_prime returns True for 1, and I think
211
 
     * it's worth special-casing this particular number :-)
212
 
     */
213
 
    mp_int *a = get_bigint(interp, $2);
214
 
    if (mp_cmp_d(a, 1) == MP_EQ) {
215
 
        $1 = 0;
216
 
    }
217
 
    else {
218
 
        mp_prime_is_prime(a, $3, (int *) &$1);
219
 
    }
220
 
}
221
 
 
222
 
/* generates a pseudo random number up to $2 of type $3 */
223
 
inline op nqp_bigint_rand(out PMC, invar PMC, invar PMC) :base_core {
224
 
    mp_int *a = get_bigint(interp, $2);
225
 
    mp_int *b = NULL;
226
 
 
227
 
    $1 = REPR($3)->allocate(interp, STABLE($3));
228
 
    REPR($1)->initialize(interp, STABLE($1), OBJECT_BODY($1));
229
 
 
230
 
    b = get_bigint(interp, $1);
231
 
    mp_rand(b, USED(a) + 1);
232
 
    mp_mod(b, a, b);
233
 
}
234
 
 
235
 
 
236
 
inline op nqp_bigint_neg(out PMC, invar PMC, invar PMC) :base_core {
237
 
    mp_int *a = get_bigint(interp, $2);
238
 
    $1 = REPR($3)->allocate(interp, STABLE($3));
239
 
    REPR($1)->initialize(interp, STABLE($1), OBJECT_BODY($1));
240
 
    mp_neg(a, get_bigint(interp, $1));
241
 
}
242
 
inline op nqp_bigint_abs(out PMC, invar PMC, invar PMC) :base_core {
243
 
    mp_int *a = get_bigint(interp, $2);
244
 
    $1 = REPR($3)->allocate(interp, STABLE($3));
245
 
    REPR($1)->initialize(interp, STABLE($1), OBJECT_BODY($1));
246
 
    mp_abs(a, get_bigint(interp, $1));
247
 
}
248
 
 
249
 
inline op nqp_bigint_cmp(out INT, invar PMC, invar PMC) :base_core {
250
 
    mp_int *a = get_bigint(interp, $2);
251
 
    mp_int *b = get_bigint(interp, $3);
252
 
    $1 = mp_cmp(a, b);
253
 
}
254
 
 
255
 
inline op nqp_bigint_bool(out INT, invar PMC) :base_core {
256
 
    $1 = !mp_iszero(get_bigint(interp, $2));
257
 
}
258
 
 
259
 
inline op nqp_bigint_eq(out INT, invar PMC, invar PMC) :base_core {
260
 
    mp_int *a = get_bigint(interp, $2);
261
 
    mp_int *b = get_bigint(interp, $3);
262
 
    $1 = MP_EQ == mp_cmp(a, b);
263
 
}
264
 
 
265
 
inline op nqp_bigint_ne(out INT, invar PMC, invar PMC) :base_core {
266
 
    mp_int *a = get_bigint(interp, $2);
267
 
    mp_int *b = get_bigint(interp, $3);
268
 
    $1 = MP_EQ != mp_cmp(a, b);
269
 
}
270
 
 
271
 
inline op nqp_bigint_gt(out INT, invar PMC, invar PMC) :base_cor {
272
 
    mp_int *a = get_bigint(interp, $2);
273
 
    mp_int *b = get_bigint(interp, $3);
274
 
    $1 = MP_GT == mp_cmp(a, b);
275
 
}
276
 
 
277
 
inline op nqp_bigint_ge(out INT, invar PMC, invar PMC) :base_core {
278
 
    mp_int *a = get_bigint(interp, $2);
279
 
    mp_int *b = get_bigint(interp, $3);
280
 
    $1 = MP_LT != mp_cmp(a, b);
281
 
}
282
 
 
283
 
inline op nqp_bigint_lt(out INT, invar PMC, invar PMC) :base_core {
284
 
    mp_int *a = get_bigint(interp, $2);
285
 
    mp_int *b = get_bigint(interp, $3);
286
 
    $1 = MP_LT == mp_cmp(a, b);
287
 
}
288
 
 
289
 
inline op nqp_bigint_le(out INT, invar PMC, invar PMC) :base_core {
290
 
    mp_int *a = get_bigint(interp, $2);
291
 
    mp_int *b = get_bigint(interp, $3);
292
 
    $1 = MP_GT != mp_cmp(a, b);
293
 
}
294
 
 
295
 
inline op nqp_bigint_gcd(out PMC, invar PMC, invar PMC, invar PMC) :base_core {
296
 
    mp_int *a = get_bigint(interp, $2);
297
 
    mp_int *b = get_bigint(interp, $3);
298
 
    $1 = REPR($4)->allocate(interp, STABLE($4));
299
 
    REPR($1)->initialize(interp, STABLE($1), OBJECT_BODY($1));
300
 
    mp_gcd(a, b, get_bigint(interp, $1));
301
 
}
302
 
 
303
 
inline op nqp_bigint_lcm(out PMC, invar PMC, invar PMC, invar PMC) :base_core {
304
 
    mp_int *a = get_bigint(interp, $2);
305
 
    mp_int *b = get_bigint(interp, $3);
306
 
    $1 = REPR($4)->allocate(interp, STABLE($4));
307
 
    REPR($1)->initialize(interp, STABLE($1), OBJECT_BODY($1));
308
 
    mp_lcm(a, b, get_bigint(interp, $1));
309
 
}
310
 
 
311
 
inline op nqp_bigint_from_str(out PMC, in STR, invar PMC) :base_core {
312
 
    const char *buf = Parrot_str_cstring(interp, $2);
313
 
    $1 = REPR($3)->allocate(interp, STABLE($3));
314
 
    REPR($1)->initialize(interp, STABLE($1), OBJECT_BODY($1));
315
 
    mp_read_radix(get_bigint(interp, $1), buf, 10);
316
 
}
317
 
 
318
 
inline op nqp_bigint_to_str(out STR, invar PMC) :base_core {
319
 
    mp_int *i = get_bigint(interp, $2);
320
 
    int len;
321
 
    char *buf;
322
 
    mp_radix_size(i, 10, &len);
323
 
    buf = (char *) mem_sys_allocate(len);
324
 
    mp_toradix_n(i, buf, 10, len);
325
 
    /* len - 1 because buf is \0-terminated */
326
 
    $1 = Parrot_str_new(interp, buf, len - 1);
327
 
    mem_sys_free(buf);
328
 
}
329
 
 
330
 
inline op nqp_bigint_to_str_base(out STR, invar PMC, in INT) :base_core {
331
 
    mp_int *i = get_bigint(interp, $2);
332
 
    int len;
333
 
    char *buf;
334
 
    mp_radix_size(i, $3, &len);
335
 
    buf = (char *) mem_sys_allocate(len);
336
 
    mp_toradix_n(i, buf, $3, len);
337
 
    /* len - 1 because buf is \0-terminated */
338
 
    $1 = Parrot_str_new(interp, buf, len - 1);
339
 
    mem_sys_free(buf);
340
 
}
341
 
 
342
 
inline op nqp_bigint_to_num(out NUM, invar PMC) :base_core {
343
 
    mp_int  *a = get_bigint(interp, $2);
344
 
    $1         = mp_get_double(a);
345
 
}
346
 
 
347
 
inline op nqp_bigint_from_num(out PMC, in NUM, invar PMC) :base_core {
348
 
    $1 = REPR($3)->allocate(interp, STABLE($3));
349
 
    REPR($1)->initialize(interp, STABLE($1), OBJECT_BODY($1));
350
 
    from_num($2, get_bigint(interp, $1));
351
 
}
352
 
 
353
 
inline op nqp_bigint_div_num(out NUM, invar PMC, invar PMC) :base_core {
354
 
    mp_int *a = get_bigint(interp, $2);
355
 
    mp_int *b = get_bigint(interp, $3);
356
 
 
357
 
    int max_size = DIGIT_BIT * MAX(USED(a), USED(b));
358
 
    if (max_size > 1023) {
359
 
        mp_int reduced_a, reduced_b;
360
 
        mp_init(&reduced_a);
361
 
        mp_init(&reduced_b);
362
 
        mp_div_2d(a, max_size - 1023, &reduced_a, NULL);
363
 
        mp_div_2d(b, max_size - 1023, &reduced_b, NULL);
364
 
        $1 = mp_get_double(&reduced_a) / mp_get_double(&reduced_b);
365
 
        mp_clear(&reduced_a);
366
 
        mp_clear(&reduced_b);
367
 
    } else {
368
 
        $1 = mp_get_double(a) / mp_get_double(b);
369
 
    }
370
 
}
371
 
 
372
 
inline op nqp_bigint_shr(out PMC, invar PMC, in INT, invar PMC) :base_core {
373
 
    mp_int *a = get_bigint(interp, $2);
374
 
    $1 = REPR($4)->allocate(interp, STABLE($4));
375
 
    REPR($1)->initialize(interp, STABLE($1), OBJECT_BODY($1));
376
 
    mp_div_2d(a, $3, get_bigint(interp, $1), NULL);
377
 
}
378
 
 
379
 
inline op nqp_bigint_shl(out PMC, invar PMC, in INT, invar PMC) :base_core {
380
 
    mp_int *b;
381
 
    mp_int *a = get_bigint(interp, $2);
382
 
    $1 = REPR($4)->allocate(interp, STABLE($4));
383
 
    REPR($1)->initialize(interp, STABLE($1), OBJECT_BODY($1));
384
 
    b = get_bigint(interp, $1);
385
 
    mp_mul_2d(a, $3, b);
386
 
}
387
 
 
388
 
inline op nqp_bigint_band(out PMC, invar PMC, invar PMC, invar PMC) :base_core {
389
 
    mp_int *a = get_bigint(interp, $2);
390
 
    mp_int *b = get_bigint(interp, $3);
391
 
    $1 = REPR($4)->allocate(interp, STABLE($4));
392
 
    REPR($1)->initialize(interp, STABLE($1), OBJECT_BODY($1));
393
 
    two_complement_bitop(a, b, get_bigint(interp, $1), mp_and);
394
 
}
395
 
inline op nqp_bigint_bor(out PMC, invar PMC, invar PMC, invar PMC) :base_core {
396
 
    mp_int *a = get_bigint(interp, $2);
397
 
    mp_int *b = get_bigint(interp, $3);
398
 
    $1 = REPR($4)->allocate(interp, STABLE($4));
399
 
    REPR($1)->initialize(interp, STABLE($1), OBJECT_BODY($1));
400
 
    two_complement_bitop(a, b, get_bigint(interp, $1), mp_or);
401
 
}
402
 
inline op nqp_bigint_bxor(out PMC, invar PMC, invar PMC, invar PMC) :base_core {
403
 
    mp_int *a = get_bigint(interp, $2);
404
 
    mp_int *b = get_bigint(interp, $3);
405
 
    $1 = REPR($4)->allocate(interp, STABLE($4));
406
 
    REPR($1)->initialize(interp, STABLE($1), OBJECT_BODY($1));
407
 
    two_complement_bitop(a, b, get_bigint(interp, $1), mp_xor);
408
 
}
409
 
inline op nqp_bigint_bnot(out PMC, invar PMC, invar PMC) :base_core {
410
 
    mp_int *a = get_bigint(interp, $2);
411
 
    mp_int *b;
412
 
    $1 = REPR($3)->allocate(interp, STABLE($3));
413
 
    REPR($1)->initialize(interp, STABLE($1), OBJECT_BODY($1));
414
 
    b = get_bigint(interp, $1);
415
 
 
416
 
    /* 2s complement: add 1, negate */
417
 
    mp_add_d(a, 1, b);
418
 
    mp_neg(b, b);
419
 
}
420
 
 
421
 
 
422
 
/*
423
 
 
424
 
=item nqp_bigint_radix(out, radix, str, pos, flag, type)
425
 
 
426
 
Convert string $3 into a number starting at offset $4 and using radix $2.
427
 
The result of the conversion returns a FixedPMCArray of size 3 with objects
428
 
of type $6, which is either a bigint or some type that boxes one.
429
 
 
430
 
The contents of $6 are the return value, the base to divide the value by if
431
 
it is something after a decimal dot, and the new position.
432
 
 
433
 
The $5 flags is a bitmask that modifies the parse and/or result:
434
 
    0x01: negate the result (useful if you've already parsed a minus)
435
 
    0x02: parse a leading +/- and negate the result on -
436
 
    0x04: parse trailing zeroes but do not include in result
437
 
          (for parsing values after a decimal point)
438
 
 
439
 
=cut
440
 
 
441
 
*/
442
 
 
443
 
inline op nqp_bigint_radix(out PMC, in INT, in STR, in INT, in INT, invar PMC) :base_core {
444
 
    PMC      *out;
445
 
    INTVAL   radix  = $2;
446
 
    STRING   *str   = $3;
447
 
    INTVAL   zpos   = $4;
448
 
    INTVAL   flags  = $5;
449
 
    INTVAL   chars  = Parrot_str_length(interp, str);
450
 
    int      neg    = 0;
451
 
    INTVAL   ch;
452
 
    mp_int   zvalue;
453
 
    mp_int   zbase;
454
 
    PMC      *value_obj;
455
 
    mp_int   *value;
456
 
    PMC      *base_obj;
457
 
    mp_int   *base;
458
 
    PMC      *pos_obj;
459
 
    INTVAL   pos    = -1;
460
 
    
461
 
    if (radix > 36) {
462
 
        Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION,
463
 
            "Cannot convert radix of %d (max 36)", radix);
464
 
    }
465
 
    
466
 
    mp_init(&zvalue);
467
 
    mp_init(&zbase);
468
 
    mp_set_int(&zbase, 1);
469
 
    
470
 
    value_obj = REPR($6)->allocate(interp, STABLE($6));
471
 
    REPR(value_obj)->initialize(interp, STABLE(value_obj), OBJECT_BODY(value_obj));
472
 
    value = get_bigint(interp, value_obj);
473
 
    
474
 
    base_obj = REPR($6)->allocate(interp, STABLE($6));
475
 
    REPR(base_obj)->initialize(interp, STABLE(base_obj), OBJECT_BODY(base_obj));
476
 
    base = get_bigint(interp, base_obj);
477
 
    mp_set_int(base, 1);
478
 
 
479
 
    ch = (zpos < chars) ? STRING_ord(interp, str, zpos) : 0;
480
 
    if ((flags & 0x02) && (ch == '+' || ch == '-')) {
481
 
        neg = (ch == '-');
482
 
        zpos++;
483
 
        ch = (zpos < chars) ? STRING_ord(interp, str, zpos) : 0;
484
 
    }
485
 
    while (zpos < chars) {
486
 
        if (ch >= '0' && ch <= '9') ch = ch - '0';
487
 
        else if (ch >= 'a' && ch <= 'z') ch = ch - 'a' + 10;
488
 
        else if (ch >= 'A' && ch <= 'Z') ch = ch - 'A' + 10;
489
 
        else break;
490
 
        if (ch >= radix) break;
491
 
        mp_mul_d(&zvalue, radix, &zvalue);
492
 
        mp_add_d(&zvalue, ch, &zvalue);
493
 
        mp_mul_d(&zbase, radix, &zbase);
494
 
        zpos++; pos = zpos;
495
 
        if (ch != 0 || !(flags & 0x04)) { mp_copy(&zvalue, value); mp_copy(&zbase, base); }
496
 
        if (zpos >= chars) break;
497
 
        ch = STRING_ord(interp, str, zpos);
498
 
        if (ch != '_') continue;
499
 
        zpos++;
500
 
        if (zpos >= chars) break;
501
 
        ch = STRING_ord(interp, str, zpos);
502
 
    }
503
 
    
504
 
    mp_clear(&zvalue);
505
 
    mp_clear(&zbase);
506
 
    
507
 
    pos_obj = REPR($6)->allocate(interp, STABLE($6));
508
 
    REPR(pos_obj)->initialize(interp, STABLE(pos_obj), OBJECT_BODY(pos_obj));
509
 
    REPR(pos_obj)->box_funcs->set_int(interp, STABLE(pos_obj), OBJECT_BODY(pos_obj), pos);
510
 
 
511
 
    if (neg || flags & 0x01) { mp_neg(value, value); }
512
 
    out = Parrot_pmc_new(interp, enum_class_FixedPMCArray);
513
 
    VTABLE_set_integer_native(interp, out, 3);
514
 
    VTABLE_set_pmc_keyed_int(interp, out, 0, value_obj);
515
 
    VTABLE_set_pmc_keyed_int(interp, out, 1, base_obj);
516
 
    VTABLE_set_pmc_keyed_int(interp, out, 2, pos_obj);
517
 
    $1 = out;
518
 
}
519
 
 
520
 
/* calculates $1 = $2 ** $3
521
 
 * if it either overflows ($3 being too big), or $2 is negative,
522
 
 * a float is returned. $4 should contain the type object to box the
523
 
 * float into, $5 the type object to box the bigint into.
524
 
 */
525
 
inline op nqp_bigint_pow(out PMC, invar PMC, invar PMC, invar PMC, invar PMC) :base_core {
526
 
    mp_digit exponent_d = 0;
527
 
    mp_int *exponent = get_bigint(interp, $3);
528
 
    mp_int *base     = get_bigint(interp, $2);
529
 
    int cmp          = mp_cmp_d(exponent, 0);
530
 
    if (cmp == MP_EQ || MP_EQ == mp_cmp_d(base, 1)) {
531
 
        /* $x ** 0 or 1 ** $x */
532
 
        $1 = REPR($5)->allocate(interp, STABLE($5));
533
 
        REPR($1)->initialize(interp, STABLE($1), OBJECT_BODY($1));
534
 
        mp_set_int(get_bigint(interp, $1), 1);
535
 
    }
536
 
    else if (cmp == MP_GT) {
537
 
        exponent_d = mp_get_int(exponent);
538
 
        if (MP_GT == mp_cmp_d(exponent, exponent_d)) {
539
 
            /* the exponent is larger than what fits into an int register...
540
 
             * that's scary, and should be treated with care */
541
 
 
542
 
 
543
 
            /* XXX a bit ugly that it reuses cmp, but safe for now */
544
 
            cmp = mp_cmp_d(base, 0);
545
 
            if (MP_EQ == cmp || MP_EQ == mp_cmp_d(base, 1)) {
546
 
                /* 0 ** $big_number and 1 ** big_number are easy to do: */
547
 
                $1 = REPR($2)->allocate(interp, STABLE($2));
548
 
                REPR($1)->initialize(interp, STABLE($1), OBJECT_BODY($1));
549
 
                mp_copy(base, get_bigint(interp, $1));
550
 
            }
551
 
            else {
552
 
                FLOATVAL ZERO = 0.0;
553
 
                $1 = REPR($4)->allocate(interp, STABLE($4));
554
 
                REPR($1)->initialize(interp, STABLE($1), OBJECT_BODY($1));
555
 
                /* TODO: better ways to create +- Inf */
556
 
                if (MP_GT == cmp) {
557
 
                    REPR($1)->box_funcs->set_num(interp, STABLE($1), OBJECT_BODY($1), (FLOATVAL) 1.0/ZERO);
558
 
                }
559
 
                else {
560
 
                    REPR($1)->box_funcs->set_num(interp, STABLE($1), OBJECT_BODY($1), (FLOATVAL) -1.0/ZERO);
561
 
                }
562
 
            }
563
 
        }
564
 
        else {
565
 
            /* since the exponent fits into a digit, mp_expt_d is fine */
566
 
            $1 = REPR($5)->allocate(interp, STABLE($5));
567
 
            REPR($1)->initialize(interp, STABLE($1), OBJECT_BODY($1));
568
 
            mp_expt_d(get_bigint(interp, $2), exponent_d, get_bigint(interp, $1));
569
 
        }
570
 
    }
571
 
    else {
572
 
        FLOATVAL f_base = mp_get_double(base);
573
 
        FLOATVAL f_exp  = mp_get_double(exponent);
574
 
        $1 = REPR($4)->allocate(interp, STABLE($4));
575
 
        REPR($1)->initialize(interp, STABLE($1), OBJECT_BODY($1));
576
 
        REPR($1)->box_funcs->set_num(interp, STABLE($1), OBJECT_BODY($1), pow(f_base, f_exp));
577
 
    }
578
 
}
579
 
 
580
 
/* returns 1 if $2 is too large to fit into an INTVAL without loss of
581
 
   information */
582
 
inline op nqp_bigint_is_big(out INT, invar PMC) :base_core {
583
 
    mp_int *a = get_bigint(interp, $2);
584
 
    $1 = a->used > 1;
585
 
    /* XXX somebody please check that on a 32 bit platform */
586
 
    if ( sizeof(INTVAL) * 8 < DIGIT_BIT && $1 == 0 && DIGIT(a, 0) & ~0x7FFFFFFFUL)
587
 
        $1 = 1;
588
 
}