Mercurial > hg > xemacs-beta

comparison tests/automated/lisp-tests.el @ 4678:b5e1d4f6b66f

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. lisp/ChangeLog addition: 2009-08-11 Aidan Kehoe <kehoea@parhasard.net> * cl-extra.el (ceiling*, floor*, round*, truncate*): Implement these in terms of the C functions; mark them as obsolete. (mod*, rem*): Use #'nth-value with the C functions, not #'nth with the CL emulation functions. man/ChangeLog addition: 2009-08-11 Aidan Kehoe <kehoea@parhasard.net> * lispref/numbers.texi (Bigfloat Basics): Correct this documentation (ignoring for the moment that it breaks off in mid-sentence). tests/ChangeLog addition: 2009-08-11 Aidan Kehoe <kehoea@parhasard.net> * automated/lisp-tests.el: Test the new Common Lisp-compatible rounding functions available in C. (generate-rounding-output): Provide a function useful for generating the data for the rounding functions tests. src/ChangeLog addition: 2009-08-11 Aidan Kehoe <kehoea@parhasard.net> * floatfns.c (ROUNDING_CONVERT, CONVERT_WITH_NUMBER_TYPES) (CONVERT_WITHOUT_NUMBER_TYPES, MAYBE_TWO_ARGS_BIGNUM) (MAYBE_ONE_ARG_BIGNUM, MAYBE_TWO_ARGS_RATIO) (MAYBE_ONE_ARG_RATIO, MAYBE_TWO_ARGS_BIGFLOAT) (MAYBE_ONE_ARG_BIGFLOAT, MAYBE_EFF, MAYBE_CHAR_OR_MARKER): New macros, used in the implementation of the rounding functions. (ceiling_two_fixnum, ceiling_two_bignum, ceiling_two_ratio) (ceiling_two_bigfloat, ceiling_one_ratio, ceiling_one_bigfloat) (ceiling_two_float, ceiling_one_float, ceiling_one_mundane_arg) (floor_two_fixnum, floor_two_bignum, floor_two_ratio) (floor_two_bigfloat, floor_one_ratio, floor_one_bigfloat) (floor_two_float, floor_one_mundane_arg, round_two_fixnum) (round_two_bignum_1, round_two_bignum, round_two_ratio) (round_one_bigfloat_1, round_two_bigfloat, round_one_ratio) (round_one_bigfloat, round_two_float, round_one_float) (round_one_mundane_arg, truncate_two_fixnum) (truncate_two_bignum, truncate_two_ratio, truncate_two_bigfloat) (truncate_one_ratio, truncate_one_bigfloat, truncate_two_float) (truncate_one_float, truncate_one_mundane_arg): New functions, used in the implementation of the rounding functions. (Fceiling, Ffloor, Fround, Ftruncate, Ffceiling, Fffloor) (Ffround, Fftruncate): Revise to fully support Common Lisp conventions. This means: -- All functions have optional DIVISOR arguments -- All functions return multiple values; see #'values -- All functions do their arithmetic with the correct number types according to the contamination rules. -- #'round and #'fround always round towards the even number in ambiguous cases. * doprnt.c (emacs_doprnt_1): * number.c (internal_coerce_number): Call Ftruncate with two arguments, not one. * floatfns.c (Ffloat): Correct this, if NUMBER is a bignum. * lisp.h: Declare Ftruncate as taking two arguments. * number.c: Provide scratch_ratio2, init it appropriately. * number.h: Make scratch_ratio2 available. * number.h (BIGFLOAT_ARITH_RETURN): * number.h (BIGFLOAT_ARITH_RETURN1): Correct these functions.
author Aidan Kehoe <kehoea@parhasard.net>
date Tue, 11 Aug 2009 17:59:23 +0100
parents 1e3cf11fa27d
children 2c64d2bbb316
comparison
equal deleted inserted replaced
4677:8f1ee2d15784 4678:b5e1d4f6b66f
1366 (set-buffer-modified-p nil) 1366 (set-buffer-modified-p nil)
1367 (kill-buffer nil) 1367 (kill-buffer nil)
1368 (load test-file-name nil t nil) 1368 (load test-file-name nil t nil)
1369 (delete-file test-file-name)) 1369 (delete-file test-file-name))
1370 1370
1371 1371 (flet ((cl-floor (x &optional y)
1372 1372 (let ((q (floor x y)))
1373 (list q (- x (if y (* y q) q)))))
1374 (cl-ceiling (x &optional y)
1375 (let ((res (cl-floor x y)))
1376 (if (= (car (cdr res)) 0) res
1377 (list (1+ (car res)) (- (car (cdr res)) (or y 1))))))
1378 (cl-truncate (x &optional y)
1379 (if (eq (>= x 0) (or (null y) (>= y 0)))
1380 (cl-floor x y) (cl-ceiling x y)))
1381 (cl-round (x &optional y)
1382 (if y
1383 (if (and (integerp x) (integerp y))
1384 (let* ((hy (/ y 2))
1385 (res (cl-floor (+ x hy) y)))
1386 (if (and (= (car (cdr res)) 0)
1387 (= (+ hy hy) y)
1388 (/= (% (car res) 2) 0))
1389 (list (1- (car res)) hy)
1390 (list (car res) (- (car (cdr res)) hy))))
1391 (let ((q (round (/ x y))))
1392 (list q (- x (* q y)))))
1393 (if (integerp x) (list x 0)
1394 (let ((q (round x)))
1395 (list q (- x q))))))
1396 (Assert-rounding (first second &key
1397 one-floor-result two-floor-result
1398 one-ffloor-result two-ffloor-result
1399 one-ceiling-result two-ceiling-result
1400 one-fceiling-result two-fceiling-result
1401 one-round-result two-round-result
1402 one-fround-result two-fround-result
1403 one-truncate-result two-truncate-result
1404 one-ftruncate-result two-ftruncate-result)
1405 (Assert (equal one-floor-result (multiple-value-list
1406 (floor first)))
1407 (format "checking (floor %S) gives %S"
1408 first one-floor-result))
1409 (Assert (equal one-floor-result (multiple-value-list
1410 (floor first 1)))
1411 (format "checking (floor %S 1) gives %S"
1412 first one-floor-result))
1413 (Check-Error arith-error (floor first 0))
1414 (Check-Error arith-error (floor first 0.0))
1415 (Assert (equal two-floor-result (multiple-value-list
1416 (floor first second)))
1417 (format
1418 "checking (floor %S %S) gives %S"
1419 first second two-floor-result))
1420 (Assert (equal (cl-floor first second)
1421 (multiple-value-list (floor first second)))
1422 (format
1423 "checking (floor %S %S) gives the same as the old code"
1424 first second))
1425 (Assert (equal one-ffloor-result (multiple-value-list
1426 (ffloor first)))
1427 (format "checking (ffloor %S) gives %S"
1428 first one-ffloor-result))
1429 (Assert (equal one-ffloor-result (multiple-value-list
1430 (ffloor first 1)))
1431 (format "checking (ffloor %S 1) gives %S"
1432 first one-ffloor-result))
1433 (Check-Error arith-error (ffloor first 0))
1434 (Check-Error arith-error (ffloor first 0.0))
1435 (Assert (equal two-ffloor-result (multiple-value-list
1436 (ffloor first second)))
1437 (format "checking (ffloor %S %S) gives %S"
1438 first second two-ffloor-result))
1439 (Assert (equal one-ceiling-result (multiple-value-list
1440 (ceiling first)))
1441 (format "checking (ceiling %S) gives %S"
1442 first one-ceiling-result))
1443 (Assert (equal one-ceiling-result (multiple-value-list
1444 (ceiling first 1)))
1445 (format "checking (ceiling %S 1) gives %S"
1446 first one-ceiling-result))
1447 (Check-Error arith-error (ceiling first 0))
1448 (Check-Error arith-error (ceiling first 0.0))
1449 (Assert (equal two-ceiling-result (multiple-value-list
1450 (ceiling first second)))
1451 (format "checking (ceiling %S %S) gives %S"
1452 first second two-ceiling-result))
1453 (Assert (equal (cl-ceiling first second)
1454 (multiple-value-list (ceiling first second)))
1455 (format
1456 "checking (ceiling %S %S) gives the same as the old code"
1457 first second))
1458 (Assert (equal one-fceiling-result (multiple-value-list
1459 (fceiling first)))
1460 (format "checking (fceiling %S) gives %S"
1461 first one-fceiling-result))
1462 (Assert (equal one-fceiling-result (multiple-value-list
1463 (fceiling first 1)))
1464 (format "checking (fceiling %S 1) gives %S"
1465 first one-fceiling-result))
1466 (Check-Error arith-error (fceiling first 0))
1467 (Check-Error arith-error (fceiling first 0.0))
1468 (Assert (equal two-fceiling-result (multiple-value-list
1469 (fceiling first second)))
1470 (format "checking (fceiling %S %S) gives %S"
1471 first second two-fceiling-result))
1472 (Assert (equal one-round-result (multiple-value-list
1473 (round first)))
1474 (format "checking (round %S) gives %S"
1475 first one-round-result))
1476 (Assert (equal one-round-result (multiple-value-list
1477 (round first 1)))
1478 (format "checking (round %S 1) gives %S, types %S, actual %S, types %S"
1479 first one-round-result (mapcar #'type-of one-round-result)
1480 (multiple-value-list (round first 1))
1481 (mapcar #'type-of (multiple-value-list (round first 1)))))
1482
1483 (Check-Error arith-error (round first 0))
1484 (Check-Error arith-error (round first 0.0))
1485 (Assert (equal two-round-result (multiple-value-list
1486 (round first second)))
1487 (format "checking (round %S %S) gives %S"
1488 first second two-round-result))
1489 (Assert (equal one-fround-result (multiple-value-list
1490 (fround first)))
1491 (format "checking (fround %S) gives %S"
1492 first one-fround-result))
1493 (Assert (equal one-fround-result (multiple-value-list
1494 (fround first 1)))
1495 (format "checking (fround %S 1) gives %S"
1496 first one-fround-result))
1497 (Check-Error arith-error (fround first 0))
1498 (Check-Error arith-error (fround first 0.0))
1499 (Assert (equal two-fround-result (multiple-value-list
1500 (fround first second)))
1501 (format "checking (fround %S %S) gives %S"
1502 first second two-fround-result))
1503 (Assert (equal (cl-round first second)
1504 (multiple-value-list (round first second)))
1505 (format
1506 "checking (round %S %S) gives the same as the old code"
1507 first second))
1508 (Assert (equal one-truncate-result (multiple-value-list
1509 (truncate first)))
1510 (format "checking (truncate %S) gives %S"
1511 first one-truncate-result))
1512 (Assert (equal one-truncate-result (multiple-value-list
1513 (truncate first 1)))
1514 (format "checking (truncate %S 1) gives %S"
1515 first one-truncate-result))
1516 (Check-Error arith-error (truncate first 0))
1517 (Check-Error arith-error (truncate first 0.0))
1518 (Assert (equal two-truncate-result (multiple-value-list
1519 (truncate first second)))
1520 (format "checking (truncate %S %S) gives %S"
1521 first second two-truncate-result))
1522 (Assert (equal (cl-truncate first second)
1523 (multiple-value-list (truncate first second)))
1524 (format
1525 "checking (truncate %S %S) gives the same as the old code"
1526 first second))
1527 (Assert (equal one-ftruncate-result (multiple-value-list
1528 (ftruncate first)))
1529 (format "checking (ftruncate %S) gives %S"
1530 first one-ftruncate-result))
1531 (Assert (equal one-ftruncate-result (multiple-value-list
1532 (ftruncate first 1)))
1533 (format "checking (ftruncate %S 1) gives %S"
1534 first one-ftruncate-result))
1535 (Check-Error arith-error (ftruncate first 0))
1536 (Check-Error arith-error (ftruncate first 0.0))
1537 (Assert (equal two-ftruncate-result (multiple-value-list
1538 (ftruncate first second)))
1539 (format "checking (ftruncate %S %S) gives %S"
1540 first second two-ftruncate-result)))
1541 (Assert-rounding-floating (pie ee)
1542 (let ((pie-type (type-of pie)))
1543 (assert (eq pie-type (type-of ee)) t
1544 "This code assumes the two arguments have the same type.")
1545 (Assert-rounding pie ee
1546 :one-floor-result (list 3 (- pie 3))
1547 :two-floor-result (list 1 (- pie (* 1 ee)))
1548 :one-ffloor-result (list (coerce 3 pie-type) (- pie 3.0))
1549 :two-ffloor-result (list (coerce 1 pie-type) (- pie (* 1.0 ee)))
1550 :one-ceiling-result (list 4 (- pie 4))
1551 :two-ceiling-result (list 2 (- pie (* 2 ee)))
1552 :one-fceiling-result (list (coerce 4 pie-type) (- pie 4.0))
1553 :two-fceiling-result (list (coerce 2 pie-type) (- pie (* 2.0 ee)))
1554 :one-round-result (list 3 (- pie 3))
1555 :two-round-result (list 1 (- pie (* 1 ee)))
1556 :one-fround-result (list (coerce 3 pie-type) (- pie 3.0))
1557 :two-fround-result (list (coerce 1 pie-type) (- pie (* 1.0 ee)))
1558 :one-truncate-result (list 3 (- pie 3))
1559 :two-truncate-result (list 1 (- pie (* 1 ee)))
1560 :one-ftruncate-result (list (coerce 3 pie-type) (- pie 3.0))
1561 :two-ftruncate-result (list (coerce 1 pie-type)
1562 (- pie (* 1.0 ee))))
1563 (Assert-rounding pie (- ee)
1564 :one-floor-result (list 3 (- pie 3))
1565 :two-floor-result (list -2 (- pie (* -2 (- ee))))
1566 :one-ffloor-result (list (coerce 3 pie-type) (- pie 3.0))
1567 :two-ffloor-result (list (coerce -2 pie-type)
1568 (- pie (* -2.0 (- ee))))
1569 :one-ceiling-result (list 4 (- pie 4))
1570 :two-ceiling-result (list -1 (- pie (* -1 (- ee))))
1571 :one-fceiling-result (list (coerce 4 pie-type) (- pie 4.0))
1572 :two-fceiling-result (list (coerce -1 pie-type)
1573 (- pie (* -1.0 (- ee))))
1574 :one-round-result (list 3 (- pie 3))
1575 :two-round-result (list -1 (- pie (* -1 (- ee))))
1576 :one-fround-result (list (coerce 3 pie-type) (- pie 3.0))
1577 :two-fround-result (list (coerce -1 pie-type)
1578 (- pie (* -1.0 (- ee))))
1579 :one-truncate-result (list 3 (- pie 3))
1580 :two-truncate-result (list -1 (- pie (* -1 (- ee))))
1581 :one-ftruncate-result (list (coerce 3 pie-type) (- pie 3.0))
1582 :two-ftruncate-result (list (coerce -1 pie-type)
1583 (- pie (* -1.0 (- ee)))))
1584 (Assert-rounding (- pie) ee
1585 :one-floor-result (list -4 (- (- pie) -4))
1586 :two-floor-result (list -2 (- (- pie) (* -2 ee)))
1587 :one-ffloor-result (list (coerce -4 pie-type) (- (- pie) -4.0))
1588 :two-ffloor-result (list (coerce -2 pie-type)
1589 (- (- pie) (* -2.0 ee)))
1590 :one-ceiling-result (list -3 (- (- pie) -3))
1591 :two-ceiling-result (list -1 (- (- pie) (* -1 ee)))
1592 :one-fceiling-result (list (coerce -3 pie-type) (- (- pie) -3.0))
1593 :two-fceiling-result (list (coerce -1 pie-type)
1594 (- (- pie) (* -1.0 ee)))
1595 :one-round-result (list -3 (- (- pie) -3))
1596 :two-round-result (list -1 (- (- pie) (* -1 ee)))
1597 :one-fround-result (list (coerce -3 pie-type) (- (- pie) -3.0))
1598 :two-fround-result (list (coerce -1 pie-type)
1599 (- (- pie) (* -1.0 ee)))
1600 :one-truncate-result (list -3 (- (- pie) -3))
1601 :two-truncate-result (list -1 (- (- pie) (* -1 ee)))
1602 :one-ftruncate-result (list (coerce -3 pie-type) (- (- pie) -3.0))
1603 :two-ftruncate-result (list (coerce -1 pie-type)
1604 (- (- pie) (* -1.0 ee))))
1605 (Assert-rounding (- pie) (- ee)
1606 :one-floor-result (list -4 (- (- pie) -4))
1607 :two-floor-result (list 1 (- (- pie) (* 1 (- ee))))
1608 :one-ffloor-result (list (coerce -4 pie-type) (- (- pie) -4.0))
1609 :two-ffloor-result (list (coerce 1 pie-type)
1610 (- (- pie) (* 1.0 (- ee))))
1611 :one-ceiling-result (list -3 (- (- pie) -3))
1612 :two-ceiling-result (list 2 (- (- pie) (* 2 (- ee))))
1613 :one-fceiling-result (list (coerce -3 pie-type) (- (- pie) -3.0))
1614 :two-fceiling-result (list (coerce 2 pie-type)
1615 (- (- pie) (* 2.0 (- ee))))
1616 :one-round-result (list -3 (- (- pie) -3))
1617 :two-round-result (list 1 (- (- pie) (* 1 (- ee))))
1618 :one-fround-result (list (coerce -3 pie-type) (- (- pie) -3.0))
1619 :two-fround-result (list (coerce 1 pie-type)
1620 (- (- pie) (* 1.0 (- ee))))
1621 :one-truncate-result (list -3 (- (- pie) -3))
1622 :two-truncate-result (list 1 (- (- pie) (* 1 (- ee))))
1623 :one-ftruncate-result (list (coerce -3 pie-type) (- (- pie) -3.0))
1624 :two-ftruncate-result (list (coerce 1 pie-type)
1625 (- (- pie) (* 1.0 (- ee)))))
1626 (Assert-rounding ee pie
1627 :one-floor-result (list 2 (- ee 2))
1628 :two-floor-result (list 0 ee)
1629 :one-ffloor-result (list (coerce 2 pie-type) (- ee 2.0))
1630 :two-ffloor-result (list (coerce 0 pie-type) ee)
1631 :one-ceiling-result (list 3 (- ee 3))
1632 :two-ceiling-result (list 1 (- ee pie))
1633 :one-fceiling-result (list (coerce 3 pie-type) (- ee 3.0))
1634 :two-fceiling-result (list (coerce 1 pie-type) (- ee pie))
1635 :one-round-result (list 3 (- ee 3))
1636 :two-round-result (list 1 (- ee (* 1 pie)))
1637 :one-fround-result (list (coerce 3 pie-type) (- ee 3.0))
1638 :two-fround-result (list (coerce 1 pie-type) (- ee (* 1.0 pie)))
1639 :one-truncate-result (list 2 (- ee 2))
1640 :two-truncate-result (list 0 ee)
1641 :one-ftruncate-result (list (coerce 2 pie-type) (- ee 2.0))
1642 :two-ftruncate-result (list (coerce 0 pie-type) ee))
1643 (Assert-rounding ee (- pie)
1644 :one-floor-result (list 2 (- ee 2))
1645 :two-floor-result (list -1 (- ee (* -1 (- pie))))
1646 :one-ffloor-result (list (coerce 2 pie-type) (- ee 2.0))
1647 :two-ffloor-result (list (coerce -1 pie-type)
1648 (- ee (* -1.0 (- pie))))
1649 :one-ceiling-result (list 3 (- ee 3))
1650 :two-ceiling-result (list 0 ee)
1651 :one-fceiling-result (list (coerce 3 pie-type) (- ee 3.0))
1652 :two-fceiling-result (list (coerce 0 pie-type) ee)
1653 :one-round-result (list 3 (- ee 3))
1654 :two-round-result (list -1 (- ee (* -1 (- pie))))
1655 :one-fround-result (list (coerce 3 pie-type) (- ee 3.0))
1656 :two-fround-result (list (coerce -1 pie-type)
1657 (- ee (* -1.0 (- pie))))
1658 :one-truncate-result (list 2 (- ee 2))
1659 :two-truncate-result (list 0 ee)
1660 :one-ftruncate-result (list (coerce 2 pie-type) (- ee 2.0))
1661 :two-ftruncate-result (list (coerce 0 pie-type) ee)))))
1662 ;; First, two integers:
1663 (Assert-rounding 27 8 :one-floor-result '(27 0) :two-floor-result '(3 3)
1664 :one-ffloor-result '(27.0 0) :two-ffloor-result '(3.0 3)
1665 :one-ceiling-result '(27 0) :two-ceiling-result '(4 -5)
1666 :one-fceiling-result '(27.0 0) :two-fceiling-result '(4.0 -5)
1667 :one-round-result '(27 0) :two-round-result '(3 3)
1668 :one-fround-result '(27.0 0) :two-fround-result '(3.0 3)
1669 :one-truncate-result '(27 0) :two-truncate-result '(3 3)
1670 :one-ftruncate-result '(27.0 0) :two-ftruncate-result '(3.0 3))
1671 (Assert-rounding 27 -8 :one-floor-result '(27 0) :two-floor-result '(-4 -5)
1672 :one-ffloor-result '(27.0 0) :two-ffloor-result '(-4.0 -5)
1673 :one-ceiling-result '(27 0) :two-ceiling-result '(-3 3)
1674 :one-fceiling-result '(27.0 0) :two-fceiling-result '(-3.0 3)
1675 :one-round-result '(27 0) :two-round-result '(-3 3)
1676 :one-fround-result '(27.0 0) :two-fround-result '(-3.0 3)
1677 :one-truncate-result '(27 0) :two-truncate-result '(-3 3)
1678 :one-ftruncate-result '(27.0 0) :two-ftruncate-result '(-3.0 3))
1679 (Assert-rounding -27 8
1680 :one-floor-result '(-27 0) :two-floor-result '(-4 5)
1681 :one-ffloor-result '(-27.0 0) :two-ffloor-result '(-4.0 5)
1682 :one-ceiling-result '(-27 0) :two-ceiling-result '(-3 -3)
1683 :one-fceiling-result '(-27.0 0) :two-fceiling-result '(-3.0 -3)
1684 :one-round-result '(-27 0) :two-round-result '(-3 -3)
1685 :one-fround-result '(-27.0 0) :two-fround-result '(-3.0 -3)
1686 :one-truncate-result '(-27 0) :two-truncate-result '(-3 -3)
1687 :one-ftruncate-result '(-27.0 0) :two-ftruncate-result '(-3.0 -3))
1688 (Assert-rounding -27 -8
1689 :one-floor-result '(-27 0) :two-floor-result '(3 -3)
1690 :one-ffloor-result '(-27.0 0) :two-ffloor-result '(3.0 -3)
1691 :one-ceiling-result '(-27 0) :two-ceiling-result '(4 5)
1692 :one-fceiling-result '(-27.0 0) :two-fceiling-result '(4.0 5)
1693 :one-round-result '(-27 0) :two-round-result '(3 -3)
1694 :one-fround-result '(-27.0 0) :two-fround-result '(3.0 -3)
1695 :one-truncate-result '(-27 0) :two-truncate-result '(3 -3)
1696 :one-ftruncate-result '(-27.0 0) :two-ftruncate-result '(3.0 -3))
1697 (Assert-rounding 8 27
1698 :one-floor-result '(8 0) :two-floor-result '(0 8)
1699 :one-ffloor-result '(8.0 0) :two-ffloor-result '(0.0 8)
1700 :one-ceiling-result '(8 0) :two-ceiling-result '(1 -19)
1701 :one-fceiling-result '(8.0 0) :two-fceiling-result '(1.0 -19)
1702 :one-round-result '(8 0) :two-round-result '(0 8)
1703 :one-fround-result '(8.0 0) :two-fround-result '(0.0 8)
1704 :one-truncate-result '(8 0) :two-truncate-result '(0 8)
1705 :one-ftruncate-result '(8.0 0) :two-ftruncate-result '(0.0 8))
1706 (Assert-rounding 8 -27
1707 :one-floor-result '(8 0) :two-floor-result '(-1 -19)
1708 :one-ffloor-result '(8.0 0) :two-ffloor-result '(-1.0 -19)
1709 :one-ceiling-result '(8 0) :two-ceiling-result '(0 8)
1710 :one-fceiling-result '(8.0 0) :two-fceiling-result '(0.0 8)
1711 :one-round-result '(8 0) :two-round-result '(0 8)
1712 :one-fround-result '(8.0 0) :two-fround-result '(0.0 8)
1713 :one-truncate-result '(8 0) :two-truncate-result '(0 8)
1714 :one-ftruncate-result '(8.0 0) :two-ftruncate-result '(0.0 8))
1715 (Assert-rounding -8 27
1716 :one-floor-result '(-8 0) :two-floor-result '(-1 19)
1717 :one-ffloor-result '(-8.0 0) :two-ffloor-result '(-1.0 19)
1718 :one-ceiling-result '(-8 0) :two-ceiling-result '(0 -8)
1719 :one-fceiling-result '(-8.0 0) :two-fceiling-result '(0.0 -8)
1720 :one-round-result '(-8 0) :two-round-result '(0 -8)
1721 :one-fround-result '(-8.0 0) :two-fround-result '(0.0 -8)
1722 :one-truncate-result '(-8 0) :two-truncate-result '(0 -8)
1723 :one-ftruncate-result '(-8.0 0) :two-ftruncate-result '(0.0 -8))
1724 (Assert-rounding -8 -27
1725 :one-floor-result '(-8 0) :two-floor-result '(0 -8)
1726 :one-ffloor-result '(-8.0 0) :two-ffloor-result '(0.0 -8)
1727 :one-ceiling-result '(-8 0) :two-ceiling-result '(1 19)
1728 :one-fceiling-result '(-8.0 0) :two-fceiling-result '(1.0 19)
1729 :one-round-result '(-8 0) :two-round-result '(0 -8)
1730 :one-fround-result '(-8.0 0) :two-fround-result '(0.0 -8)
1731 :one-truncate-result '(-8 0) :two-truncate-result '(0 -8)
1732 :one-ftruncate-result '(-8.0 0) :two-ftruncate-result '(0.0 -8))
1733 (Assert-rounding 32 4
1734 :one-floor-result '(32 0) :two-floor-result '(8 0)
1735 :one-ffloor-result '(32.0 0) :two-ffloor-result '(8.0 0)
1736 :one-ceiling-result '(32 0) :two-ceiling-result '(8 0)
1737 :one-fceiling-result '(32.0 0) :two-fceiling-result '(8.0 0)
1738 :one-round-result '(32 0) :two-round-result '(8 0)
1739 :one-fround-result '(32.0 0) :two-fround-result '(8.0 0)
1740 :one-truncate-result '(32 0) :two-truncate-result '(8 0)
1741 :one-ftruncate-result '(32.0 0) :two-ftruncate-result '(8.0 0))
1742 (Assert-rounding 32 -4
1743 :one-floor-result '(32 0) :two-floor-result '(-8 0)
1744 :one-ffloor-result '(32.0 0) :two-ffloor-result '(-8.0 0)
1745 :one-ceiling-result '(32 0) :two-ceiling-result '(-8 0)
1746 :one-fceiling-result '(32.0 0) :two-fceiling-result '(-8.0 0)
1747 :one-round-result '(32 0) :two-round-result '(-8 0)
1748 :one-fround-result '(32.0 0) :two-fround-result '(-8.0 0)
1749 :one-truncate-result '(32 0) :two-truncate-result '(-8 0)
1750 :one-ftruncate-result '(32.0 0) :two-ftruncate-result '(-8.0 0))
1751 (Assert-rounding 12 9
1752 :one-floor-result '(12 0) :two-floor-result '(1 3)
1753 :one-ffloor-result '(12.0 0) :two-ffloor-result '(1.0 3)
1754 :one-ceiling-result '(12 0) :two-ceiling-result '(2 -6)
1755 :one-fceiling-result '(12.0 0) :two-fceiling-result '(2.0 -6)
1756 :one-round-result '(12 0) :two-round-result '(1 3)
1757 :one-fround-result '(12.0 0) :two-fround-result '(1.0 3)
1758 :one-truncate-result '(12 0) :two-truncate-result '(1 3)
1759 :one-ftruncate-result '(12.0 0) :two-ftruncate-result '(1.0 3))
1760 (Assert-rounding 10 4
1761 :one-floor-result '(10 0) :two-floor-result '(2 2)
1762 :one-ffloor-result '(10.0 0) :two-ffloor-result '(2.0 2)
1763 :one-ceiling-result '(10 0) :two-ceiling-result '(3 -2)
1764 :one-fceiling-result '(10.0 0) :two-fceiling-result '(3.0 -2)
1765 :one-round-result '(10 0) :two-round-result '(2 2)
1766 :one-fround-result '(10.0 0) :two-fround-result '(2.0 2)
1767 :one-truncate-result '(10 0) :two-truncate-result '(2 2)
1768 :one-ftruncate-result '(10.0 0) :two-ftruncate-result '(2.0 2))
1769 (Assert-rounding 14 4
1770 :one-floor-result '(14 0) :two-floor-result '(3 2)
1771 :one-ffloor-result '(14.0 0) :two-ffloor-result '(3.0 2)
1772 :one-ceiling-result '(14 0) :two-ceiling-result '(4 -2)
1773 :one-fceiling-result '(14.0 0) :two-fceiling-result '(4.0 -2)
1774 :one-round-result '(14 0) :two-round-result '(4 -2)
1775 :one-fround-result '(14.0 0) :two-fround-result '(4.0 -2)
1776 :one-truncate-result '(14 0) :two-truncate-result '(3 2)
1777 :one-ftruncate-result '(14.0 0) :two-ftruncate-result '(3.0 2))
1778 ;; Now, two floats:
1779 (Assert-rounding-floating pi e)
1780 (when (featurep 'bigfloat)
1781 (Assert-rounding-floating (coerce pi 'bigfloat) (coerce e 'bigfloat)))
1782 (when (featurep 'bignum)
1783 (assert (not (evenp most-positive-fixnum)) t
1784 "In the unlikely event that most-positive-fixnum is even, rewrite this.")
1785 (Assert-rounding (1+ most-positive-fixnum) (* 2 most-positive-fixnum)
1786 :one-floor-result `(,(1+ most-positive-fixnum) 0)
1787 :two-floor-result `(0 ,(1+ most-positive-fixnum))
1788 :one-ffloor-result `(,(float (1+ most-positive-fixnum)) 0)
1789 :two-ffloor-result `(0.0 ,(1+ most-positive-fixnum))
1790 :one-ceiling-result `(,(1+ most-positive-fixnum) 0)
1791 :two-ceiling-result `(1 ,(1+ (- most-positive-fixnum)))
1792 :one-fceiling-result `(,(float (1+ most-positive-fixnum)) 0)
1793 :two-fceiling-result `(1.0 ,(1+ (- most-positive-fixnum)))
1794 :one-round-result `(,(1+ most-positive-fixnum) 0)
1795 :two-round-result `(1 ,(1+ (- most-positive-fixnum)))
1796 :one-fround-result `(,(float (1+ most-positive-fixnum)) 0)
1797 :two-fround-result `(1.0 ,(1+ (- most-positive-fixnum)))
1798 :one-truncate-result `(,(1+ most-positive-fixnum) 0)
1799 :two-truncate-result `(0 ,(1+ most-positive-fixnum))
1800 :one-ftruncate-result `(,(float (1+ most-positive-fixnum)) 0)
1801 :two-ftruncate-result `(0.0 ,(1+ most-positive-fixnum)))
1802 (Assert-rounding (1+ most-positive-fixnum) (- (* 2 most-positive-fixnum))
1803 :one-floor-result `(,(1+ most-positive-fixnum) 0)
1804 :two-floor-result `(-1 ,(1+ (- most-positive-fixnum)))
1805 :one-ffloor-result `(,(float (1+ most-positive-fixnum)) 0)
1806 :two-ffloor-result `(-1.0 ,(1+ (- most-positive-fixnum)))
1807 :one-ceiling-result `(,(1+ most-positive-fixnum) 0)
1808 :two-ceiling-result `(0 ,(1+ most-positive-fixnum))
1809 :one-fceiling-result `(,(float (1+ most-positive-fixnum)) 0)
1810 :two-fceiling-result `(0.0 ,(1+ most-positive-fixnum))
1811 :one-round-result `(,(1+ most-positive-fixnum) 0)
1812 :two-round-result `(-1 ,(1+ (- most-positive-fixnum)))
1813 :one-fround-result `(,(float (1+ most-positive-fixnum)) 0)
1814 :two-fround-result `(-1.0 ,(1+ (- most-positive-fixnum)))
1815 :one-truncate-result `(,(1+ most-positive-fixnum) 0)
1816 :two-truncate-result `(0 ,(1+ most-positive-fixnum))
1817 :one-ftruncate-result `(,(float (1+ most-positive-fixnum)) 0)
1818 :two-ftruncate-result `(0.0 ,(1+ most-positive-fixnum)))
1819 (Assert-rounding (- (1+ most-positive-fixnum)) (* 2 most-positive-fixnum)
1820 :one-floor-result `(,(- (1+ most-positive-fixnum)) 0)
1821 :two-floor-result `(-1 ,(1- most-positive-fixnum))
1822 :one-ffloor-result `(,(float (- (1+ most-positive-fixnum))) 0)
1823 :two-ffloor-result `(-1.0 ,(1- most-positive-fixnum))
1824 :one-ceiling-result `(,(- (1+ most-positive-fixnum)) 0)
1825 :two-ceiling-result `(0 ,(- (1+ most-positive-fixnum)))
1826 :one-fceiling-result `(,(float (- (1+ most-positive-fixnum))) 0)
1827 :two-fceiling-result `(0.0 ,(- (1+ most-positive-fixnum)))
1828 :one-round-result `(,(- (1+ most-positive-fixnum)) 0)
1829 :two-round-result `(-1 ,(1- most-positive-fixnum))
1830 :one-fround-result `(,(float (- (1+ most-positive-fixnum))) 0)
1831 :two-fround-result `(-1.0 ,(1- most-positive-fixnum))
1832 :one-truncate-result `(,(- (1+ most-positive-fixnum)) 0)
1833 :two-truncate-result `(0 ,(- (1+ most-positive-fixnum)))
1834 :one-ftruncate-result `(,(float (- (1+ most-positive-fixnum))) 0)
1835 :two-ftruncate-result `(0.0 ,(- (1+ most-positive-fixnum))))
1836 ;; Test the handling of values with .5:
1837 (Assert-rounding (1+ (* 2 most-positive-fixnum)) 2
1838 :one-floor-result `(,(1+ (* 2 most-positive-fixnum)) 0)
1839 :two-floor-result `(,most-positive-fixnum 1)
1840 :one-ffloor-result `(,(float (1+ (* 2 most-positive-fixnum))) 0)
1841 ;; We can't just call #'float here; we must use code that converts a
1842 ;; bignum with value most-positive-fixnum (the creation of which is
1843 ;; not directly possible in Lisp) to a float, not code that converts
1844 ;; the fixnum with value most-positive-fixnum to a float. The eval is
1845 ;; to avoid compile-time optimisation that can break this.
1846 :two-ffloor-result `(,(eval '(- (1+ most-positive-fixnum) 1 0.0)) 1)
1847 :one-ceiling-result `(,(1+ (* 2 most-positive-fixnum)) 0)
1848 :two-ceiling-result `(,(1+ most-positive-fixnum) -1)
1849 :one-fceiling-result `(,(float (1+ (* 2 most-positive-fixnum))) 0)
1850 :two-fceiling-result `(,(float (1+ most-positive-fixnum)) -1)
1851 :one-round-result `(,(1+ (* 2 most-positive-fixnum)) 0)
1852 :two-round-result `(,(1+ most-positive-fixnum) -1)
1853 :one-fround-result `(,(float (1+ (* 2 most-positive-fixnum))) 0)
1854 :two-fround-result `(,(float (1+ most-positive-fixnum)) -1)
1855 :one-truncate-result `(,(1+ (* 2 most-positive-fixnum)) 0)
1856 :two-truncate-result `(,most-positive-fixnum 1)
1857 :one-ftruncate-result `(,(float (1+ (* 2 most-positive-fixnum))) 0)
1858 ;; See the comment above on :two-ffloor-result:
1859 :two-ftruncate-result `(,(eval '(- (1+ most-positive-fixnum) 1 0.0)) 1))
1860 (Assert-rounding (1+ (* 2 (1- most-positive-fixnum))) 2
1861 :one-floor-result `(,(1+ (* 2 (1- most-positive-fixnum))) 0)
1862 :two-floor-result `(,(1- most-positive-fixnum) 1)
1863 :one-ffloor-result `(,(float (1+ (* 2 (1- most-positive-fixnum)))) 0)
1864 ;; See commentary above on float conversions.
1865 :two-ffloor-result `(,(eval '(- (1+ most-positive-fixnum) 2 0.0)) 1)
1866 :one-ceiling-result `(,(1+ (* 2 (1- most-positive-fixnum))) 0)
1867 :two-ceiling-result `(,most-positive-fixnum -1)
1868 :one-fceiling-result `(,(float (1+ (* 2 (1- most-positive-fixnum)))) 0)
1869 :two-fceiling-result `(,(eval '(- (1+ most-positive-fixnum) 1 0.0)) -1)
1870 :one-round-result `(,(1+ (* 2 (1- most-positive-fixnum))) 0)
1871 :two-round-result `(,(1- most-positive-fixnum) 1)
1872 :one-fround-result `(,(float (1+ (* 2 (1- most-positive-fixnum)))) 0)
1873 :two-fround-result `(,(eval '(- (1+ most-positive-fixnum) 2 0.0)) 1)
1874 :one-truncate-result `(,(1+ (* 2 (1- most-positive-fixnum))) 0)
1875 :two-truncate-result `(,(1- most-positive-fixnum) 1)
1876 :one-ftruncate-result `(,(float (1+ (* 2 (1- most-positive-fixnum)))) 0)
1877 ;; See commentary above
1878 :two-ftruncate-result `(,(eval '(- (1+ most-positive-fixnum) 2 0.0))
1879 1)))
1880 (when (featurep 'ratio)
1881 (Assert-rounding (read "4/3") (read "8/7")
1882 :one-floor-result '(1 1/3) :two-floor-result '(1 4/21)
1883 :one-ffloor-result '(1.0 1/3) :two-ffloor-result '(1.0 4/21)
1884 :one-ceiling-result '(2 -2/3) :two-ceiling-result '(2 -20/21)
1885 :one-fceiling-result '(2.0 -2/3) :two-fceiling-result '(2.0 -20/21)
1886 :one-round-result '(1 1/3) :two-round-result '(1 4/21)
1887 :one-fround-result '(1.0 1/3) :two-fround-result '(1.0 4/21)
1888 :one-truncate-result '(1 1/3) :two-truncate-result '(1 4/21)
1889 :one-ftruncate-result '(1.0 1/3) :two-ftruncate-result '(1.0 4/21))
1890 (Assert-rounding (read "-4/3") (read "8/7")
1891 :one-floor-result '(-2 2/3) :two-floor-result '(-2 20/21)
1892 :one-ffloor-result '(-2.0 2/3) :two-ffloor-result '(-2.0 20/21)
1893 :one-ceiling-result '(-1 -1/3) :two-ceiling-result '(-1 -4/21)
1894 :one-fceiling-result '(-1.0 -1/3) :two-fceiling-result '(-1.0 -4/21)
1895 :one-round-result '(-1 -1/3) :two-round-result '(-1 -4/21)
1896 :one-fround-result '(-1.0 -1/3) :two-fround-result '(-1.0 -4/21)
1897 :one-truncate-result '(-1 -1/3) :two-truncate-result '(-1 -4/21)
1898 :one-ftruncate-result '(-1.0 -1/3) :two-ftruncate-result '(-1.0 -4/21))))
1899
1900 ;; Run this function in a Common Lisp with two arguments to get results that
1901 ;; we should compare against, above. Though note the dancing-around with the
1902 ;; bigfloats and bignums above, too; you can't necessarily just use the
1903 ;; output here.
1904
1905 (defun generate-rounding-output (first second)
1906 (let ((print-readably t))
1907 (princ first)
1908 (princ " ")
1909 (princ second)
1910 (princ " :one-floor-result ")
1911 (princ (list 'quote (multiple-value-list (floor first))))
1912 (princ " :two-floor-result ")
1913 (princ (list 'quote (multiple-value-list (floor first second))))
1914 (princ " :one-ffloor-result ")
1915 (princ (list 'quote (multiple-value-list (ffloor first))))
1916 (princ " :two-ffloor-result ")
1917 (princ (list 'quote (multiple-value-list (ffloor first second))))
1918 (princ " :one-ceiling-result ")
1919 (princ (list 'quote (multiple-value-list (ceiling first))))
1920 (princ " :two-ceiling-result ")
1921 (princ (list 'quote (multiple-value-list (ceiling first second))))
1922 (princ " :one-fceiling-result ")
1923 (princ (list 'quote (multiple-value-list (fceiling first))))
1924 (princ " :two-fceiling-result ")
1925 (princ (list 'quote (multiple-value-list (fceiling first second))))
1926 (princ " :one-round-result ")
1927 (princ (list 'quote (multiple-value-list (round first))))
1928 (princ " :two-round-result ")
1929 (princ (list 'quote (multiple-value-list (round first second))))
1930 (princ " :one-fround-result ")
1931 (princ (list 'quote (multiple-value-list (fround first))))
1932 (princ " :two-fround-result ")
1933 (princ (list 'quote (multiple-value-list (fround first second))))
1934 (princ " :one-truncate-result ")
1935 (princ (list 'quote (multiple-value-list (truncate first))))
1936 (princ " :two-truncate-result ")
1937 (princ (list 'quote (multiple-value-list (truncate first second))))
1938 (princ " :one-ftruncate-result ")
1939 (princ (list 'quote (multiple-value-list (ftruncate first))))
1940 (princ " :two-ftruncate-result ")
1941 (princ (list 'quote (multiple-value-list (ftruncate first second))))))