bigint variant of the nqp radix op.

Author: jnthn

src/ops/nqp_bigint.ops

@@ -219,3 +219,99 @@ inline op nqp_bigint_bnot(out PMC, in PMC) :base_cor {
     mp_add_d(a, 1, b);
     mp_neg(b, b);
 }
+
+
+/*
+
+=item nqp_bigint_radix(out, radix, str, pos, flag, type)
+
+Convert string $3 into a number starting at offset $4 and using radix $2.
+The result of the conversion returns an object of type $6, which is either
+a bigint or some type that boxes one.
+
+The $5 flags is a bitmask that modifies the parse and/or result:
+    0x01: negate the result (useful if you've already parsed a minus)
+    0x02: parse a leading +/- and negate the result on -
+    0x04: parse trailing zeroes but do not include in result
+          (for parsing values after a decimal point)
+
+=cut
+
+*/
+
+inline op nqp_radix(out PMC, in INT, in STR, in INT, in INT, in PMC) :base_core {
+    PMC      *out;
+    INTVAL   radix  = $2;
+    STRING   *str   = $3;
+    INTVAL   zpos   = $4;
+    INTVAL   flags  = $5;
+    INTVAL   chars  = Parrot_str_length(interp, str);
+    int      neg    = 0;
+    INTVAL   ch;
+    mp_int   zvalue;
+    mp_int   zbase;
+    PMC      *value_obj;
+    mp_int   *value;
+    PMC      *base_obj;
+    mp_int   *base;
+    PMC      *pos_obj;
+    INTVAL   pos    = -1;
+    
+    if (radix > 36) {
+        Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION,
+            "Cannot convert radix of %d (max 36)", radix);
+    }
+    
+    mp_init(&zvalue);
+    mp_init(&zbase);
+    mp_set_int(&zbase, 1);
+    
+    value_obj = REPR($6)->allocate(interp, STABLE($6));
+    REPR(value_obj)->initialize(interp, STABLE(value_obj), OBJECT_BODY(value_obj));
+    value = get_bigint(interp, value_obj);
+    
+    base_obj = REPR($6)->allocate(interp, STABLE($6));
+    REPR(base_obj)->initialize(interp, STABLE(base_obj), OBJECT_BODY(base_obj));
+    base = get_bigint(interp, base_obj);
+    mp_set_int(base, 1);
+
+    ch = (zpos < chars) ? STRING_ord(interp, str, zpos) : 0;
+    if ((flags & 0x02) && (ch == '+' || ch == '-')) {
+        neg = (ch == '-');
+        zpos++;
+        ch = (zpos < chars) ? STRING_ord(interp, str, zpos) : 0;
+    }
+    while (zpos < chars) {
+        if (ch >= '0' && ch <= '9') ch = ch - '0';
+        else if (ch >= 'a' && ch <= 'z') ch = ch - 'a' + 10;
+        else if (ch >= 'A' && ch <= 'Z') ch = ch - 'A' + 10;
+        else break;
+        if (ch >= radix) break;
+        mp_mul_d(&zvalue, radix, &zvalue);
+        mp_add_d(&zvalue, ch, &zvalue);
+        mp_mul_d(&zbase, radix, &zbase);
+        zpos++; pos = zpos;
+        if (ch != 0 || !(flags & 0x04)) { mp_copy(&zvalue, value); mp_copy(&zbase, base); }
+        if (zpos >= chars) break;
+        ch = STRING_ord(interp, str, zpos);
+        if (ch != '_') continue;
+        zpos++;
+        if (zpos >= chars) break;
+        ch = STRING_ord(interp, str, zpos);
+    }
+    
+    mp_clear(&zvalue);
+    mp_clear(&zbase);
+    
+    pos_obj = REPR($6)->allocate(interp, STABLE($6));
+    REPR(pos_obj)->initialize(interp, STABLE(pos_obj), OBJECT_BODY(pos_obj));
+    REPR(pos_obj)->set_int(interp, STABLE(pos_obj), OBJECT_BODY(pos_obj), pos);
+
+    if (neg || flags & 0x01) { mp_neg(value, value); }
+    out = pmc_new(interp, enum_class_FixedPMCArray);
+    VTABLE_set_integer_native(interp, out, 3);
+    VTABLE_set_pmc_keyed_int(interp, out, 0, value_obj);
+    VTABLE_set_pmc_keyed_int(interp, out, 1, base_obj);
+    VTABLE_set_pmc_keyed_int(interp, out, 2, pos_obj);
+    $1 = out;
+}