Changeset 31350 in project
 Timestamp:
 09/09/14 17:22:30 (5 years ago)
 Location:
 release/4/numbers/trunk
 Files:

 3 edited
Legend:
 Unmodified
 Added
 Removed

release/4/numbers/trunk/numbersc.c
r31349 r31350 584 584 C_return(C_flonum(p, xub)); 585 585 } 586 587 static bignum_type588 bignum_add_unsigned(bignum_type x, bignum_type y, int negative_p)589 {590 if ((BIGNUM_LENGTH (y)) > (BIGNUM_LENGTH (x)))591 {592 bignum_type z = x;593 x = y;594 y = z;595 }596 {597 bignum_length_type x_length = (BIGNUM_LENGTH (x));598 bignum_type r = (bignum_allocate ((x_length + 1), negative_p));599 bignum_digit_type sum;600 bignum_digit_type carry = 0;601 bignum_digit_type * scan_x = (BIGNUM_START_PTR (x));602 bignum_digit_type * scan_r = (BIGNUM_START_PTR (r));603 {604 bignum_digit_type * scan_y = (BIGNUM_START_PTR (y));605 bignum_digit_type * end_y = (scan_y + (BIGNUM_LENGTH (y)));606 while (scan_y < end_y)607 {608 sum = ((*scan_x++) + (*scan_y++) + carry);609 if (sum < BIGNUM_RADIX)610 {611 (*scan_r++) = sum;612 carry = 0;613 }614 else615 {616 (*scan_r++) = (sum  BIGNUM_RADIX);617 carry = 1;618 }619 }620 }621 {622 bignum_digit_type * end_x = ((BIGNUM_START_PTR (x)) + x_length);623 if (carry != 0)624 while (scan_x < end_x)625 {626 sum = ((*scan_x++) + 1);627 if (sum < BIGNUM_RADIX)628 {629 (*scan_r++) = sum;630 carry = 0;631 break;632 }633 else634 (*scan_r++) = (sum  BIGNUM_RADIX);635 }636 while (scan_x < end_x)637 (*scan_r++) = (*scan_x++);638 }639 if (carry != 0) {640 (*scan_r) = 1;641 } else { /* r is one word too big (to hold a possible carry), readjust */642 BIGNUM_SET_HEADER(r, x_length, negative_p);643 BIGNUM_REDUCE_LENGTH(r, r, x_length);644 }645 return (r);646 }647 }648 649 /*650 * This now makes the assumption it is never passed a bignum of LENGTH 0.651 * This should always be valid in Chicken.652 */653 static bignum_type654 bignum_subtract(bignum_type x, bignum_type y)655 {656 return657 (((BIGNUM_NEGATIVE_P (x))658 ? ((BIGNUM_NEGATIVE_P (y))659 ? (bignum_subtract_unsigned (y, x))660 : (bignum_add_unsigned (x, y, 1)))661 : ((BIGNUM_NEGATIVE_P (y))662 ? (bignum_add_unsigned (x, y, 0))663 : (bignum_subtract_unsigned (x, y)))));664 }665 666 static bignum_type667 bignum_subtract_unsigned(bignum_type x, bignum_type y)668 {669 int negative_p;670 switch (bignum_compare_unsigned (x, y))671 {672 case bignum_comparison_equal:673 return (BIGNUM_ZERO ());674 case bignum_comparison_less:675 {676 bignum_type z = x;677 x = y;678 y = z;679 }680 negative_p = 1;681 break;682 case bignum_comparison_greater:683 negative_p = 0;684 break;685 }686 {687 bignum_length_type x_length = (BIGNUM_LENGTH (x));688 bignum_type r = (bignum_allocate (x_length, negative_p));689 bignum_digit_type difference;690 bignum_digit_type borrow = 0;691 bignum_digit_type * scan_x = (BIGNUM_START_PTR (x));692 bignum_digit_type * scan_r = (BIGNUM_START_PTR (r));693 {694 bignum_digit_type * scan_y = (BIGNUM_START_PTR (y));695 bignum_digit_type * end_y = (scan_y + (BIGNUM_LENGTH (y)));696 while (scan_y < end_y)697 {698 difference = (((*scan_x++)  (*scan_y++))  borrow);699 if (difference < 0)700 {701 (*scan_r++) = (difference + BIGNUM_RADIX);702 borrow = 1;703 }704 else705 {706 (*scan_r++) = difference;707 borrow = 0;708 }709 }710 }711 {712 bignum_digit_type * end_x = ((BIGNUM_START_PTR (x)) + x_length);713 if (borrow != 0)714 while (scan_x < end_x)715 {716 difference = ((*scan_x++)  borrow);717 if (difference < 0)718 (*scan_r++) = (difference + BIGNUM_RADIX);719 else720 {721 (*scan_r++) = difference;722 borrow = 0;723 break;724 }725 }726 assert(borrow == 0);727 while (scan_x < end_x)728 (*scan_r++) = (*scan_x++);729 }730 return (bignum_trim (r));731 }732 }733 734 586 735 587 /* Division */ … … 1483 1335 } 1484 1336 1485 static void1486 int_not(C_word c, C_word self, C_word k, C_word x)1487 {1488 bignum_type bigx, result;1489 1490 if((x & C_FIXNUM_BIT) != 0)1491 bigx = bignum_allocate_from_fixnum(x);1492 else1493 bigx = big_of(x);1494 1495 result = bignum_bitwise_not(bigx);1496 1497 if((x & C_FIXNUM_BIT) != 0)1498 BIGNUM_DEALLOCATE(bigx);1499 1500 C_return_bignum(k, result);1501 }1502 1503 bignum_type1504 bignum_bitwise_not(bignum_type x)1505 {1506 static C_word invbits[] = { BIGNUM_RADIX  1, 1 }; /* bignum representing 1 */1507 return bignum_subtract((bignum_type)invbits, x);1508 }1509 1510 static void1511 int_shift_fix(C_word c, C_word self, C_word k, C_word x, C_word y)1512 {1513 bignum_type bigx, result;1514 1515 if (y == C_fix(0)) C_kontinue(k, x); /* Done too (no shift) */1516 1517 /* Ensure x is a bignum */1518 if((x & C_FIXNUM_BIT) != 0) {1519 if (x == C_fix(0)) /* Skip everything else */1520 C_kontinue(k, x);1521 1522 bigx = bignum_allocate_from_fixnum(x);1523 } else {1524 bigx = big_of(x);1525 }1526 1527 result = bignum_arithmetic_shift(bigx, C_unfix(y));1528 if ((x & C_FIXNUM_BIT) != 0)1529 BIGNUM_DEALLOCATE(bigx);1530 C_return_bignum(k, result);1531 }1532 1533 static bignum_type1534 bignum_arithmetic_shift(bignum_type arg1, C_word n)1535 {1536 bignum_type tmp1, tmp2, result;1537 if (BIGNUM_NEGATIVE_P(arg1) && n < 0) {1538 tmp1 = bignum_bitwise_not(arg1);1539 tmp2 = bignum_magnitude_ash(tmp1, n);1540 BIGNUM_DEALLOCATE(tmp1);1541 result = bignum_bitwise_not(tmp2);1542 BIGNUM_DEALLOCATE(tmp2);1543 return result;1544 } else {1545 return bignum_magnitude_ash(arg1, n);1546 }1547 }1548 1549 static bignum_type1550 bignum_magnitude_ash(bignum_type arg1, C_word n)1551 {1552 bignum_type result;1553 bignum_digit_type *scan1;1554 bignum_digit_type *scanr;1555 bignum_digit_type *end;1556 1557 C_word digit_offset,bit_offset;1558 assert(n != 0); /* int_shift_fix checks this */1559 1560 if (n > 0) {1561 digit_offset = n / BIGNUM_DIGIT_LENGTH;1562 bit_offset = n % BIGNUM_DIGIT_LENGTH;1563 1564 result = bignum_allocate_zeroed (BIGNUM_LENGTH (arg1) + digit_offset + 1,1565 BIGNUM_NEGATIVE_P(arg1));1566 1567 scanr = BIGNUM_START_PTR (result) + digit_offset;1568 scan1 = BIGNUM_START_PTR (arg1);1569 end = scan1 + BIGNUM_LENGTH (arg1);1570 1571 while (scan1 < end) {1572 *scanr = *scanr  (*scan1 & BIGNUM_DIGIT_MASK) << bit_offset;1573 *scanr = *scanr & BIGNUM_DIGIT_MASK;1574 scanr++;1575 *scanr = *scan1++ >> (BIGNUM_DIGIT_LENGTH  bit_offset);1576 *scanr = *scanr & BIGNUM_DIGIT_MASK;1577 }1578 }1579 else if (n < 01580 && (n >= (BIGNUM_LENGTH (arg1) * (bignum_length_type) BIGNUM_DIGIT_LENGTH)))1581 result = BIGNUM_ZERO ();1582 1583 else /* if (n < 0) */ {1584 digit_offset = n / BIGNUM_DIGIT_LENGTH;1585 bit_offset = n % BIGNUM_DIGIT_LENGTH;1586 1587 result = bignum_allocate_zeroed (BIGNUM_LENGTH (arg1)  digit_offset,1588 BIGNUM_NEGATIVE_P(arg1));1589 1590 scanr = BIGNUM_START_PTR (result);1591 scan1 = BIGNUM_START_PTR (arg1) + digit_offset;1592 end = scanr + BIGNUM_LENGTH (result)  1;1593 1594 while (scanr < end) {1595 *scanr = (*scan1++ & BIGNUM_DIGIT_MASK) >> bit_offset ;1596 *scanr = (*scanr 1597 *scan1 << (BIGNUM_DIGIT_LENGTH  bit_offset)) & BIGNUM_DIGIT_MASK;1598 scanr++;1599 }1600 *scanr = (*scan1++ & BIGNUM_DIGIT_MASK) >> bit_offset ;1601 }1602 1603 return (bignum_trim (result));1604 }1605 1606 1337 static bignum_type 1607 1338 bignum_pospos_bitwise_op(int op, bignum_type arg1, bignum_type arg2) … … 1874 1605 static void flo_to_int_2(C_word c, C_word self, C_word result); 1875 1606 static C_word ilen(C_uword x); 1607 static void bignum_allocate_for_shift(C_word c, C_word self, C_word x); 1608 static void bignum_negate_after_shift(C_word c, C_word self, C_word result); 1609 static void bignum_actual_shift(C_word c, C_word self, C_word result); 1876 1610 1877 1611 /* Eventually this will probably need to be integrated into C_2_plus. */ … … 2672 2406 } 2673 2407 } 2408 2409 void C_ccall 2410 C_u_int_shift_fix(C_word c, C_word self, C_word k, C_word x, C_word y) 2411 { 2412 C_word kab[C_SIZEOF_FIX_BIGNUM + C_SIZEOF_CLOSURE(3) + C_SIZEOF_CLOSURE(2)], 2413 *ka = kab, k2, k3, size; 2414 2415 if (y == C_fix(0)  x == C_fix(0)) { /* Done (no shift) */ 2416 C_kontinue(k, x); 2417 } else if (x & C_FIXNUM_BIT) { 2418 /* TODO: This should probably see if shifting fits a fixnum, first */ 2419 x = C_a_u_i_fix_to_big(&ka, x); 2420 } 2421 2422 /* Invert all the bits before shifting right a negative value */ 2423 if (C_bignum_negativep(x) && C_unfix(y) < 0) { 2424 /* When done shifting, invert again */ 2425 k3 = C_closure(&ka, 2, (C_word)bignum_negate_after_shift, k); 2426 /* Before shifting, allocate the bignum */ 2427 k2 = C_closure(&ka, 3, (C_word)bignum_allocate_for_shift, k3, y); 2428 /* Actually invert by subtracting: 1  x */ 2429 C_u_fixnum_minus_bignum(2, (C_word)NULL, k2, C_fix(1), x); 2430 } else { 2431 k2 = C_closure(&ka, 3, (C_word)bignum_allocate_for_shift, k, y); 2432 C_kontinue(k2, x); 2433 } 2434 } 2435 2436 static void 2437 bignum_allocate_for_shift(C_word c, C_word self, C_word x) 2438 { 2439 C_word k = C_block_item(self, 1), 2440 y = C_block_item(self, 2), 2441 uy = C_unfix(y), 2442 negp, digit_offset, bit_offset, 2443 ab[C_SIZEOF_FIX_BIGNUM + C_SIZEOF_CLOSURE(6)], *a = ab, k2, size; 2444 2445 if (x & C_FIXNUM_BIT) /* Normalisation may happen after negation */ 2446 x = C_a_u_i_fix_to_big(&a, x); 2447 2448 negp = C_mk_bool(C_bignum_negativep(x)); 2449 2450 /* uy is guaranteed not to be 0 here */ 2451 if (uy > 0) { 2452 digit_offset = uy / C_BIGNUM_DIGIT_LENGTH; 2453 bit_offset = uy % C_BIGNUM_DIGIT_LENGTH; 2454 2455 k2 = C_closure(&a, 6, (C_word)bignum_actual_shift, k, 2456 x, C_SCHEME_TRUE, C_fix(digit_offset), C_fix(bit_offset)); 2457 size = C_fix(C_bignum_size(x) + digit_offset + 1); 2458 C_allocate_bignum(3, (C_word)NULL, k2, size, negp, C_SCHEME_TRUE); 2459 } else if (uy >= C_bignum_size(x) * (C_word)C_BIGNUM_DIGIT_LENGTH) { 2460 /* All bits are shifted out, just return 0 */ 2461 C_kontinue(k, C_fix(0)); 2462 } else { 2463 digit_offset = uy / BIGNUM_DIGIT_LENGTH; 2464 bit_offset = uy % BIGNUM_DIGIT_LENGTH; 2465 2466 k2 = C_closure(&a, 6, (C_word)bignum_actual_shift, k, 2467 x, C_SCHEME_FALSE, C_fix(digit_offset), C_fix(bit_offset)); 2468 size = C_fix(C_bignum_size(x)  digit_offset); 2469 C_allocate_bignum(3, (C_word)NULL, k2, size, negp, C_SCHEME_TRUE); 2470 } 2471 } 2472 2473 static void 2474 bignum_negate_after_shift(C_word c, C_word self, C_word result) 2475 { 2476 C_word k = C_block_item(self, 1), 2477 ab[C_SIZEOF_FIX_BIGNUM], *a = ab; 2478 if (result & C_FIXNUM_BIT) /* Normalisation may happen after shift */ 2479 C_kontinue(k, C_fix(1  C_unfix(result))); 2480 else 2481 C_u_fixnum_minus_bignum(2, (C_word)NULL, k, C_fix(1), result); 2482 } 2483 2484 static void 2485 bignum_actual_shift(C_word c, C_word self, C_word result) 2486 { 2487 C_word k = C_block_item(self, 1), 2488 x = C_block_item(self, 2), 2489 shift_left = C_truep(C_block_item(self, 3)), 2490 digit_offset = C_unfix(C_block_item(self, 4)), 2491 bit_offset = C_unfix(C_block_item(self, 5)), 2492 *scanx, *scanr, *end; 2493 2494 if (shift_left) { 2495 scanr = C_bignum_digits(result) + digit_offset; 2496 scanx = C_bignum_digits(x); 2497 end = scanx + C_bignum_size(x); 2498 2499 while (scanx < end) { 2500 *scanr = *scanr  (*scanx & C_BIGNUM_DIGIT_MASK) << bit_offset; 2501 *scanr = *scanr & C_BIGNUM_DIGIT_MASK; 2502 scanr++; 2503 *scanr = *scanx++ >> (C_BIGNUM_DIGIT_LENGTH  bit_offset); 2504 *scanr = *scanr & C_BIGNUM_DIGIT_MASK; 2505 } 2506 } else { 2507 scanr = C_bignum_digits(result); 2508 scanx = C_bignum_digits(x) + digit_offset; 2509 end = scanr + C_bignum_size(result)  1; 2510 2511 while (scanr < end) { 2512 *scanr = (*scanx++ & C_BIGNUM_DIGIT_MASK) >> bit_offset; 2513 *scanr = (*scanr  2514 *scanx << (C_BIGNUM_DIGIT_LENGTH  bit_offset)) & C_BIGNUM_DIGIT_MASK; 2515 scanr++; 2516 } 2517 *scanr = (*scanx++ & C_BIGNUM_DIGIT_MASK) >> bit_offset; 2518 } 2519 C_bignum_destructive_trim(result); 2520 C_kontinue(k, C_bignum_normalize(result)); 2521 } 
release/4/numbers/trunk/numbersc.h
r31349 r31350 240 240 C_word C_u_i_int_length(C_word x); 241 241 242 void C_ccall C_u_int_shift_fix(C_word c, C_word self, C_word k, C_word x, C_word y); 243 242 244 C_inline C_word C_bignum1(C_word **ptr, int negp, C_uword d1) 243 245 { 
release/4/numbers/trunk/numbers.scm
r31349 r31350 188 188 189 189 (define %intbitwiseint (##core#primitive "int_bitwise_int")) 190 (define %intshiftfix (##core#primitive " int_shift_fix"))190 (define %intshiftfix (##core#primitive "C_u_int_shift_fix")) 191 191 (defineinline (%intlength i) (##core#inline "C_u_i_int_length" i)) 192 192
Note: See TracChangeset
for help on using the changeset viewer.