Mercurial > hg > xemacs-beta

comparison tests/automated/lisp-tests.el @ 5118:e0db3c197671 ben-lisp-object

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
merge up to latest default branch, doesn't compile yet
author Ben Wing <ben@xemacs.org>
date Sat, 26 Dec 2009 21:18:49 -0600
parents 4cf435fcebbc
children 95b04754ea8c
comparison
equal deleted inserted replaced
5117:3742ea8250b5 5118:e0db3c197671
886 (eval 886 (eval
887 `(progn 887 `(progn
888 (defun test-fun ,arglist nil) 888 (defun test-fun ,arglist nil)
889 (check-function-argcounts '(lambda ,arglist nil) ,min ,max) 889 (check-function-argcounts '(lambda ,arglist nil) ,min ,max)
890 (check-function-argcounts (byte-compile '(lambda ,arglist nil)) ,min ,max)))) 890 (check-function-argcounts (byte-compile '(lambda ,arglist nil)) ,min ,max))))
891
892 ;; Test subr-arity.
893 (loop for (function-name arity) in
894 '((let (1 . unevalled))
895 (prog1 (1 . unevalled))
896 (list (0 . many))
897 (type-of (1 . 1))
898 (garbage-collect (0 . 0)))
899 do (Assert (equal (subr-arity (symbol-function function-name)) arity)))
900
901 (Check-Error wrong-type-argument (subr-arity
902 (lambda () (message "Hi there!"))))
903
904 (Check-Error wrong-type-argument (subr-arity nil))
891 905
892 ;;----------------------------------------------------- 906 ;;-----------------------------------------------------
893 ;; Detection of cyclic variable indirection loops 907 ;; Detection of cyclic variable indirection loops
894 ;;----------------------------------------------------- 908 ;;-----------------------------------------------------
895 (fset 'test-sym1 'test-sym1) 909 (fset 'test-sym1 'test-sym1)
1277 (Assert (= (read (format "%u" most-positive-fixnum)) most-positive-fixnum)) 1291 (Assert (= (read (format "%u" most-positive-fixnum)) most-positive-fixnum))
1278 (Assert (= (read (format "%lu" most-positive-fixnum)) most-positive-fixnum)) 1292 (Assert (= (read (format "%lu" most-positive-fixnum)) most-positive-fixnum))
1279 (Assert (= (read (format "%d" most-negative-fixnum)) most-negative-fixnum)) 1293 (Assert (= (read (format "%d" most-negative-fixnum)) most-negative-fixnum))
1280 (Assert (= (read (format "%ld" most-negative-fixnum)) most-negative-fixnum)) 1294 (Assert (= (read (format "%ld" most-negative-fixnum)) most-negative-fixnum))
1281 1295
1296 ;; These used to crash.
1297 (Assert (eql (read (format "%f" 1.2e+302)) 1.2e+302))
1298 (Assert (eql (read (format "%.1000d" 1)) 1))
1299
1282 ;;; "%u" is undocumented, and Emacs Lisp has no unsigned type. 1300 ;;; "%u" is undocumented, and Emacs Lisp has no unsigned type.
1283 ;;; What to do if "%u" is used with a negative number? 1301 ;;; What to do if "%u" is used with a negative number?
1284 ;;; For non-bignum XEmacsen, the most reasonable thing seems to be to print an 1302 ;;; For non-bignum XEmacsen, the most reasonable thing seems to be to print an
1285 ;;; un-read-able number. The printed value might be useful to a human, if not 1303 ;;; un-read-able number. The printed value might be useful to a human, if not
1286 ;;; to Emacs Lisp. 1304 ;;; to Emacs Lisp.
1293 (Check-Error invalid-read-syntax (read (format "%u" -1)))) 1311 (Check-Error invalid-read-syntax (read (format "%u" -1))))
1294 1312
1295 ;; Check all-completions ignore element start with space. 1313 ;; Check all-completions ignore element start with space.
1296 (Assert (not (all-completions "" '((" hidden" . "object"))))) 1314 (Assert (not (all-completions "" '((" hidden" . "object")))))
1297 (Assert (all-completions " " '((" hidden" . "object")))) 1315 (Assert (all-completions " " '((" hidden" . "object"))))
1316
1317 (let* ((literal-with-uninterned
1318 '(first-element
1319 [#1=#:G32976 #2=#:G32974 #3=#:G32971 #4=#:G32969 alias
1320 #s(hash-table size 256 data (969 ?\xF9 55 ?7 166 ?\xA6))
1321 #5=#:G32970 #6=#:G32972]))
1322 (print-readably t)
1323 (print-gensym t)
1324 (printed-with-uninterned (prin1-to-string literal-with-uninterned))
1325 (awkward-regexp "#1=#")
1326 (first-match-start (string-match awkward-regexp
1327 printed-with-uninterned)))
1328 (Assert (null (string-match awkward-regexp printed-with-uninterned
1329 (1+ first-match-start)))))
1330
1331 (let ((char-table-with-string #s(char-table data (?\x00 "text")))
1332 (char-table-with-symbol #s(char-table data (?\x00 text))))
1333 (Assert (not (string-equal (prin1-to-string char-table-with-string)
1334 (prin1-to-string char-table-with-symbol)))
1335 "Check that char table elements are quoted correctly when printing"))
1336
1337
1338 (let ((test-file-name
1339 (make-temp-file (expand-file-name "sR4KDwU" (temp-directory))
1340 nil ".el")))
1341 (find-file test-file-name)
1342 (erase-buffer)
1343 (insert
1344 "\
1345 ;; Lisp should not be able to modify #$, which is
1346 ;; Vload_file_name_internal of lread.c.
1347 (Check-Error setting-constant (aset #$ 0 ?\\ ))
1348
1349 ;; But modifying load-file-name should work:
1350 (let ((new-char ?\\ )
1351 old-char)
1352 (setq old-char (aref load-file-name 0))
1353 (if (= new-char old-char)
1354 (setq new-char ?/))
1355 (aset load-file-name 0 new-char)
1356 (Assert (= new-char (aref load-file-name 0))
1357 \"Check that we can modify the string value of load-file-name\"))
1358
1359 (let* ((new-load-file-name \"hi there\")
1360 (load-file-name new-load-file-name))
1361 (Assert (eq new-load-file-name load-file-name)
1362 \"Checking that we can bind load-file-name successfully.\"))
1363
1364 ")
1365 (write-region (point-min) (point-max) test-file-name nil 'quiet)
1366 (set-buffer-modified-p nil)
1367 (kill-buffer nil)
1368 (load test-file-name nil t nil)
1369 (delete-file test-file-name))
1370
1371 (flet ((cl-floor (x &optional y)
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"
1479 first one-round-result))
1480 (Check-Error arith-error (round first 0))
1481 (Check-Error arith-error (round first 0.0))
1482 (Assert (equal two-round-result (multiple-value-list
1483 (round first second)))
1484 (format "checking (round %S %S) gives %S"
1485 first second two-round-result))
1486 (Assert (equal one-fround-result (multiple-value-list
1487 (fround first)))
1488 (format "checking (fround %S) gives %S"
1489 first one-fround-result))
1490 (Assert (equal one-fround-result (multiple-value-list
1491 (fround first 1)))
1492 (format "checking (fround %S 1) gives %S"
1493 first one-fround-result))
1494 (Check-Error arith-error (fround first 0))
1495 (Check-Error arith-error (fround first 0.0))
1496 (Assert (equal two-fround-result (multiple-value-list
1497 (fround first second)))
1498 (format "checking (fround %S %S) gives %S"
1499 first second two-fround-result))
1500 (Assert (equal (cl-round first second)
1501 (multiple-value-list (round first second)))
1502 (format
1503 "checking (round %S %S) gives the same as the old code"
1504 first second))
1505 (Assert (equal one-truncate-result (multiple-value-list
1506 (truncate first)))
1507 (format "checking (truncate %S) gives %S"
1508 first one-truncate-result))
1509 (Assert (equal one-truncate-result (multiple-value-list
1510 (truncate first 1)))
1511 (format "checking (truncate %S 1) gives %S"
1512 first one-truncate-result))
1513 (Check-Error arith-error (truncate first 0))
1514 (Check-Error arith-error (truncate first 0.0))
1515 (Assert (equal two-truncate-result (multiple-value-list
1516 (truncate first second)))
1517 (format "checking (truncate %S %S) gives %S"
1518 first second two-truncate-result))
1519 (Assert (equal (cl-truncate first second)
1520 (multiple-value-list (truncate first second)))
1521 (format
1522 "checking (truncate %S %S) gives the same as the old code"
1523 first second))
1524 (Assert (equal one-ftruncate-result (multiple-value-list
1525 (ftruncate first)))
1526 (format "checking (ftruncate %S) gives %S"
1527 first one-ftruncate-result))
1528 (Assert (equal one-ftruncate-result (multiple-value-list
1529 (ftruncate first 1)))
1530 (format "checking (ftruncate %S 1) gives %S"
1531 first one-ftruncate-result))
1532 (Check-Error arith-error (ftruncate first 0))
1533 (Check-Error arith-error (ftruncate first 0.0))
1534 (Assert (equal two-ftruncate-result (multiple-value-list
1535 (ftruncate first second)))
1536 (format "checking (ftruncate %S %S) gives %S"
1537 first second two-ftruncate-result)))
1538 (Assert-rounding-floating (pie ee)
1539 (let ((pie-type (type-of pie)))
1540 (assert (eq pie-type (type-of ee)) t
1541 "This code assumes the two arguments have the same type.")
1542 (Assert-rounding pie ee
1543 :one-floor-result (list 3 (- pie 3))
1544 :two-floor-result (list 1 (- pie (* 1 ee)))
1545 :one-ffloor-result (list (coerce 3 pie-type) (- pie 3.0))
1546 :two-ffloor-result (list (coerce 1 pie-type) (- pie (* 1.0 ee)))
1547 :one-ceiling-result (list 4 (- pie 4))
1548 :two-ceiling-result (list 2 (- pie (* 2 ee)))
1549 :one-fceiling-result (list (coerce 4 pie-type) (- pie 4.0))
1550 :two-fceiling-result (list (coerce 2 pie-type) (- pie (* 2.0 ee)))
1551 :one-round-result (list 3 (- pie 3))
1552 :two-round-result (list 1 (- pie (* 1 ee)))
1553 :one-fround-result (list (coerce 3 pie-type) (- pie 3.0))
1554 :two-fround-result (list (coerce 1 pie-type) (- pie (* 1.0 ee)))
1555 :one-truncate-result (list 3 (- pie 3))
1556 :two-truncate-result (list 1 (- pie (* 1 ee)))
1557 :one-ftruncate-result (list (coerce 3 pie-type) (- pie 3.0))
1558 :two-ftruncate-result (list (coerce 1 pie-type)
1559 (- pie (* 1.0 ee))))
1560 (Assert-rounding pie (- ee)
1561 :one-floor-result (list 3 (- pie 3))
1562 :two-floor-result (list -2 (- pie (* -2 (- ee))))
1563 :one-ffloor-result (list (coerce 3 pie-type) (- pie 3.0))
1564 :two-ffloor-result (list (coerce -2 pie-type)
1565 (- pie (* -2.0 (- ee))))
1566 :one-ceiling-result (list 4 (- pie 4))
1567 :two-ceiling-result (list -1 (- pie (* -1 (- ee))))
1568 :one-fceiling-result (list (coerce 4 pie-type) (- pie 4.0))
1569 :two-fceiling-result (list (coerce -1 pie-type)
1570 (- pie (* -1.0 (- ee))))
1571 :one-round-result (list 3 (- pie 3))
1572 :two-round-result (list -1 (- pie (* -1 (- ee))))
1573 :one-fround-result (list (coerce 3 pie-type) (- pie 3.0))
1574 :two-fround-result (list (coerce -1 pie-type)
1575 (- pie (* -1.0 (- ee))))
1576 :one-truncate-result (list 3 (- pie 3))
1577 :two-truncate-result (list -1 (- pie (* -1 (- ee))))
1578 :one-ftruncate-result (list (coerce 3 pie-type) (- pie 3.0))
1579 :two-ftruncate-result (list (coerce -1 pie-type)
1580 (- pie (* -1.0 (- ee)))))
1581 (Assert-rounding (- pie) ee
1582 :one-floor-result (list -4 (- (- pie) -4))
1583 :two-floor-result (list -2 (- (- pie) (* -2 ee)))
1584 :one-ffloor-result (list (coerce -4 pie-type) (- (- pie) -4.0))
1585 :two-ffloor-result (list (coerce -2 pie-type)
1586 (- (- pie) (* -2.0 ee)))
1587 :one-ceiling-result (list -3 (- (- pie) -3))
1588 :two-ceiling-result (list -1 (- (- pie) (* -1 ee)))
1589 :one-fceiling-result (list (coerce -3 pie-type) (- (- pie) -3.0))
1590 :two-fceiling-result (list (coerce -1 pie-type)
1591 (- (- pie) (* -1.0 ee)))
1592 :one-round-result (list -3 (- (- pie) -3))
1593 :two-round-result (list -1 (- (- pie) (* -1 ee)))
1594 :one-fround-result (list (coerce -3 pie-type) (- (- pie) -3.0))
1595 :two-fround-result (list (coerce -1 pie-type)
1596 (- (- pie) (* -1.0 ee)))
1597 :one-truncate-result (list -3 (- (- pie) -3))
1598 :two-truncate-result (list -1 (- (- pie) (* -1 ee)))
1599 :one-ftruncate-result (list (coerce -3 pie-type) (- (- pie) -3.0))
1600 :two-ftruncate-result (list (coerce -1 pie-type)
1601 (- (- pie) (* -1.0 ee))))
1602 (Assert-rounding (- pie) (- ee)
1603 :one-floor-result (list -4 (- (- pie) -4))
1604 :two-floor-result (list 1 (- (- pie) (* 1 (- ee))))
1605 :one-ffloor-result (list (coerce -4 pie-type) (- (- pie) -4.0))
1606 :two-ffloor-result (list (coerce 1 pie-type)
1607 (- (- pie) (* 1.0 (- ee))))
1608 :one-ceiling-result (list -3 (- (- pie) -3))
1609 :two-ceiling-result (list 2 (- (- pie) (* 2 (- ee))))
1610 :one-fceiling-result (list (coerce -3 pie-type) (- (- pie) -3.0))
1611 :two-fceiling-result (list (coerce 2 pie-type)
1612 (- (- pie) (* 2.0 (- ee))))
1613 :one-round-result (list -3 (- (- pie) -3))
1614 :two-round-result (list 1 (- (- pie) (* 1 (- ee))))
1615 :one-fround-result (list (coerce -3 pie-type) (- (- pie) -3.0))
1616 :two-fround-result (list (coerce 1 pie-type)
1617 (- (- pie) (* 1.0 (- ee))))
1618 :one-truncate-result (list -3 (- (- pie) -3))
1619 :two-truncate-result (list 1 (- (- pie) (* 1 (- ee))))
1620 :one-ftruncate-result (list (coerce -3 pie-type) (- (- pie) -3.0))
1621 :two-ftruncate-result (list (coerce 1 pie-type)
1622 (- (- pie) (* 1.0 (- ee)))))
1623 (Assert-rounding ee pie
1624 :one-floor-result (list 2 (- ee 2))
1625 :two-floor-result (list 0 ee)
1626 :one-ffloor-result (list (coerce 2 pie-type) (- ee 2.0))
1627 :two-ffloor-result (list (coerce 0 pie-type) ee)
1628 :one-ceiling-result (list 3 (- ee 3))
1629 :two-ceiling-result (list 1 (- ee pie))
1630 :one-fceiling-result (list (coerce 3 pie-type) (- ee 3.0))
1631 :two-fceiling-result (list (coerce 1 pie-type) (- ee pie))
1632 :one-round-result (list 3 (- ee 3))
1633 :two-round-result (list 1 (- ee (* 1 pie)))
1634 :one-fround-result (list (coerce 3 pie-type) (- ee 3.0))
1635 :two-fround-result (list (coerce 1 pie-type) (- ee (* 1.0 pie)))
1636 :one-truncate-result (list 2 (- ee 2))
1637 :two-truncate-result (list 0 ee)
1638 :one-ftruncate-result (list (coerce 2 pie-type) (- ee 2.0))
1639 :two-ftruncate-result (list (coerce 0 pie-type) ee))
1640 (Assert-rounding ee (- pie)
1641 :one-floor-result (list 2 (- ee 2))
1642 :two-floor-result (list -1 (- ee (* -1 (- pie))))
1643 :one-ffloor-result (list (coerce 2 pie-type) (- ee 2.0))
1644 :two-ffloor-result (list (coerce -1 pie-type)
1645 (- ee (* -1.0 (- pie))))
1646 :one-ceiling-result (list 3 (- ee 3))
1647 :two-ceiling-result (list 0 ee)
1648 :one-fceiling-result (list (coerce 3 pie-type) (- ee 3.0))
1649 :two-fceiling-result (list (coerce 0 pie-type) ee)
1650 :one-round-result (list 3 (- ee 3))
1651 :two-round-result (list -1 (- ee (* -1 (- pie))))
1652 :one-fround-result (list (coerce 3 pie-type) (- ee 3.0))
1653 :two-fround-result (list (coerce -1 pie-type)
1654 (- ee (* -1.0 (- pie))))
1655 :one-truncate-result (list 2 (- ee 2))
1656 :two-truncate-result (list 0 ee)
1657 :one-ftruncate-result (list (coerce 2 pie-type) (- ee 2.0))
1658 :two-ftruncate-result (list (coerce 0 pie-type) ee)))))
1659 ;; First, two integers:
1660 (Assert-rounding 27 8 :one-floor-result '(27 0) :two-floor-result '(3 3)
1661 :one-ffloor-result '(27.0 0) :two-ffloor-result '(3.0 3)
1662 :one-ceiling-result '(27 0) :two-ceiling-result '(4 -5)
1663 :one-fceiling-result '(27.0 0) :two-fceiling-result '(4.0 -5)
1664 :one-round-result '(27 0) :two-round-result '(3 3)
1665 :one-fround-result '(27.0 0) :two-fround-result '(3.0 3)
1666 :one-truncate-result '(27 0) :two-truncate-result '(3 3)
1667 :one-ftruncate-result '(27.0 0) :two-ftruncate-result '(3.0 3))
1668 (Assert-rounding 27 -8 :one-floor-result '(27 0) :two-floor-result '(-4 -5)
1669 :one-ffloor-result '(27.0 0) :two-ffloor-result '(-4.0 -5)
1670 :one-ceiling-result '(27 0) :two-ceiling-result '(-3 3)
1671 :one-fceiling-result '(27.0 0) :two-fceiling-result '(-3.0 3)
1672 :one-round-result '(27 0) :two-round-result '(-3 3)
1673 :one-fround-result '(27.0 0) :two-fround-result '(-3.0 3)
1674 :one-truncate-result '(27 0) :two-truncate-result '(-3 3)
1675 :one-ftruncate-result '(27.0 0) :two-ftruncate-result '(-3.0 3))
1676 (Assert-rounding -27 8
1677 :one-floor-result '(-27 0) :two-floor-result '(-4 5)
1678 :one-ffloor-result '(-27.0 0) :two-ffloor-result '(-4.0 5)
1679 :one-ceiling-result '(-27 0) :two-ceiling-result '(-3 -3)
1680 :one-fceiling-result '(-27.0 0) :two-fceiling-result '(-3.0 -3)
1681 :one-round-result '(-27 0) :two-round-result '(-3 -3)
1682 :one-fround-result '(-27.0 0) :two-fround-result '(-3.0 -3)
1683 :one-truncate-result '(-27 0) :two-truncate-result '(-3 -3)
1684 :one-ftruncate-result '(-27.0 0) :two-ftruncate-result '(-3.0 -3))
1685 (Assert-rounding -27 -8
1686 :one-floor-result '(-27 0) :two-floor-result '(3 -3)
1687 :one-ffloor-result '(-27.0 0) :two-ffloor-result '(3.0 -3)
1688 :one-ceiling-result '(-27 0) :two-ceiling-result '(4 5)
1689 :one-fceiling-result '(-27.0 0) :two-fceiling-result '(4.0 5)
1690 :one-round-result '(-27 0) :two-round-result '(3 -3)
1691 :one-fround-result '(-27.0 0) :two-fround-result '(3.0 -3)
1692 :one-truncate-result '(-27 0) :two-truncate-result '(3 -3)
1693 :one-ftruncate-result '(-27.0 0) :two-ftruncate-result '(3.0 -3))
1694 (Assert-rounding 8 27
1695 :one-floor-result '(8 0) :two-floor-result '(0 8)
1696 :one-ffloor-result '(8.0 0) :two-ffloor-result '(0.0 8)
1697 :one-ceiling-result '(8 0) :two-ceiling-result '(1 -19)
1698 :one-fceiling-result '(8.0 0) :two-fceiling-result '(1.0 -19)
1699 :one-round-result '(8 0) :two-round-result '(0 8)
1700 :one-fround-result '(8.0 0) :two-fround-result '(0.0 8)
1701 :one-truncate-result '(8 0) :two-truncate-result '(0 8)
1702 :one-ftruncate-result '(8.0 0) :two-ftruncate-result '(0.0 8))
1703 (Assert-rounding 8 -27
1704 :one-floor-result '(8 0) :two-floor-result '(-1 -19)
1705 :one-ffloor-result '(8.0 0) :two-ffloor-result '(-1.0 -19)
1706 :one-ceiling-result '(8 0) :two-ceiling-result '(0 8)
1707 :one-fceiling-result '(8.0 0) :two-fceiling-result '(0.0 8)
1708 :one-round-result '(8 0) :two-round-result '(0 8)
1709 :one-fround-result '(8.0 0) :two-fround-result '(0.0 8)
1710 :one-truncate-result '(8 0) :two-truncate-result '(0 8)
1711 :one-ftruncate-result '(8.0 0) :two-ftruncate-result '(0.0 8))
1712 (Assert-rounding -8 27
1713 :one-floor-result '(-8 0) :two-floor-result '(-1 19)
1714 :one-ffloor-result '(-8.0 0) :two-ffloor-result '(-1.0 19)
1715 :one-ceiling-result '(-8 0) :two-ceiling-result '(0 -8)
1716 :one-fceiling-result '(-8.0 0) :two-fceiling-result '(0.0 -8)
1717 :one-round-result '(-8 0) :two-round-result '(0 -8)
1718 :one-fround-result '(-8.0 0) :two-fround-result '(0.0 -8)
1719 :one-truncate-result '(-8 0) :two-truncate-result '(0 -8)
1720 :one-ftruncate-result '(-8.0 0) :two-ftruncate-result '(0.0 -8))
1721 (Assert-rounding -8 -27
1722 :one-floor-result '(-8 0) :two-floor-result '(0 -8)
1723 :one-ffloor-result '(-8.0 0) :two-ffloor-result '(0.0 -8)
1724 :one-ceiling-result '(-8 0) :two-ceiling-result '(1 19)
1725 :one-fceiling-result '(-8.0 0) :two-fceiling-result '(1.0 19)
1726 :one-round-result '(-8 0) :two-round-result '(0 -8)
1727 :one-fround-result '(-8.0 0) :two-fround-result '(0.0 -8)
1728 :one-truncate-result '(-8 0) :two-truncate-result '(0 -8)
1729 :one-ftruncate-result '(-8.0 0) :two-ftruncate-result '(0.0 -8))
1730 (Assert-rounding 32 4
1731 :one-floor-result '(32 0) :two-floor-result '(8 0)
1732 :one-ffloor-result '(32.0 0) :two-ffloor-result '(8.0 0)
1733 :one-ceiling-result '(32 0) :two-ceiling-result '(8 0)
1734 :one-fceiling-result '(32.0 0) :two-fceiling-result '(8.0 0)
1735 :one-round-result '(32 0) :two-round-result '(8 0)
1736 :one-fround-result '(32.0 0) :two-fround-result '(8.0 0)
1737 :one-truncate-result '(32 0) :two-truncate-result '(8 0)
1738 :one-ftruncate-result '(32.0 0) :two-ftruncate-result '(8.0 0))
1739 (Assert-rounding 32 -4
1740 :one-floor-result '(32 0) :two-floor-result '(-8 0)
1741 :one-ffloor-result '(32.0 0) :two-ffloor-result '(-8.0 0)
1742 :one-ceiling-result '(32 0) :two-ceiling-result '(-8 0)
1743 :one-fceiling-result '(32.0 0) :two-fceiling-result '(-8.0 0)
1744 :one-round-result '(32 0) :two-round-result '(-8 0)
1745 :one-fround-result '(32.0 0) :two-fround-result '(-8.0 0)
1746 :one-truncate-result '(32 0) :two-truncate-result '(-8 0)
1747 :one-ftruncate-result '(32.0 0) :two-ftruncate-result '(-8.0 0))
1748 (Assert-rounding 12 9
1749 :one-floor-result '(12 0) :two-floor-result '(1 3)
1750 :one-ffloor-result '(12.0 0) :two-ffloor-result '(1.0 3)
1751 :one-ceiling-result '(12 0) :two-ceiling-result '(2 -6)
1752 :one-fceiling-result '(12.0 0) :two-fceiling-result '(2.0 -6)
1753 :one-round-result '(12 0) :two-round-result '(1 3)
1754 :one-fround-result '(12.0 0) :two-fround-result '(1.0 3)
1755 :one-truncate-result '(12 0) :two-truncate-result '(1 3)
1756 :one-ftruncate-result '(12.0 0) :two-ftruncate-result '(1.0 3))
1757 (Assert-rounding 10 4
1758 :one-floor-result '(10 0) :two-floor-result '(2 2)
1759 :one-ffloor-result '(10.0 0) :two-ffloor-result '(2.0 2)
1760 :one-ceiling-result '(10 0) :two-ceiling-result '(3 -2)
1761 :one-fceiling-result '(10.0 0) :two-fceiling-result '(3.0 -2)
1762 :one-round-result '(10 0) :two-round-result '(2 2)
1763 :one-fround-result '(10.0 0) :two-fround-result '(2.0 2)
1764 :one-truncate-result '(10 0) :two-truncate-result '(2 2)
1765 :one-ftruncate-result '(10.0 0) :two-ftruncate-result '(2.0 2))
1766 (Assert-rounding 14 4
1767 :one-floor-result '(14 0) :two-floor-result '(3 2)
1768 :one-ffloor-result '(14.0 0) :two-ffloor-result '(3.0 2)
1769 :one-ceiling-result '(14 0) :two-ceiling-result '(4 -2)
1770 :one-fceiling-result '(14.0 0) :two-fceiling-result '(4.0 -2)
1771 :one-round-result '(14 0) :two-round-result '(4 -2)
1772 :one-fround-result '(14.0 0) :two-fround-result '(4.0 -2)
1773 :one-truncate-result '(14 0) :two-truncate-result '(3 2)
1774 :one-ftruncate-result '(14.0 0) :two-ftruncate-result '(3.0 2))
1775 ;; Now, two floats:
1776 (Assert-rounding-floating pi e)
1777 (when (featurep 'bigfloat)
1778 (Assert-rounding-floating (coerce pi 'bigfloat) (coerce e 'bigfloat)))
1779 (when (featurep 'bignum)
1780 (assert (not (evenp most-positive-fixnum)) t
1781 "In the unlikely event that most-positive-fixnum is even, rewrite this.")
1782 (Assert-rounding (1+ most-positive-fixnum) (* 2 most-positive-fixnum)
1783 :one-floor-result `(,(1+ most-positive-fixnum) 0)
1784 :two-floor-result `(0 ,(1+ most-positive-fixnum))
1785 :one-ffloor-result `(,(float (1+ most-positive-fixnum)) 0)
1786 :two-ffloor-result `(0.0 ,(1+ most-positive-fixnum))
1787 :one-ceiling-result `(,(1+ most-positive-fixnum) 0)
1788 :two-ceiling-result `(1 ,(1+ (- most-positive-fixnum)))
1789 :one-fceiling-result `(,(float (1+ most-positive-fixnum)) 0)
1790 :two-fceiling-result `(1.0 ,(1+ (- most-positive-fixnum)))
1791 :one-round-result `(,(1+ most-positive-fixnum) 0)
1792 :two-round-result `(1 ,(1+ (- most-positive-fixnum)))
1793 :one-fround-result `(,(float (1+ most-positive-fixnum)) 0)
1794 :two-fround-result `(1.0 ,(1+ (- most-positive-fixnum)))
1795 :one-truncate-result `(,(1+ most-positive-fixnum) 0)
1796 :two-truncate-result `(0 ,(1+ most-positive-fixnum))
1797 :one-ftruncate-result `(,(float (1+ most-positive-fixnum)) 0)
1798 :two-ftruncate-result `(0.0 ,(1+ most-positive-fixnum)))
1799 (Assert-rounding (1+ most-positive-fixnum) (- (* 2 most-positive-fixnum))
1800 :one-floor-result `(,(1+ most-positive-fixnum) 0)
1801 :two-floor-result `(-1 ,(1+ (- most-positive-fixnum)))
1802 :one-ffloor-result `(,(float (1+ most-positive-fixnum)) 0)
1803 :two-ffloor-result `(-1.0 ,(1+ (- most-positive-fixnum)))
1804 :one-ceiling-result `(,(1+ most-positive-fixnum) 0)
1805 :two-ceiling-result `(0 ,(1+ most-positive-fixnum))
1806 :one-fceiling-result `(,(float (1+ most-positive-fixnum)) 0)
1807 :two-fceiling-result `(0.0 ,(1+ most-positive-fixnum))
1808 :one-round-result `(,(1+ most-positive-fixnum) 0)
1809 :two-round-result `(-1 ,(1+ (- most-positive-fixnum)))
1810 :one-fround-result `(,(float (1+ most-positive-fixnum)) 0)
1811 :two-fround-result `(-1.0 ,(1+ (- most-positive-fixnum)))
1812 :one-truncate-result `(,(1+ most-positive-fixnum) 0)
1813 :two-truncate-result `(0 ,(1+ most-positive-fixnum))
1814 :one-ftruncate-result `(,(float (1+ most-positive-fixnum)) 0)
1815 :two-ftruncate-result `(0.0 ,(1+ most-positive-fixnum)))
1816 (Assert-rounding (- (1+ most-positive-fixnum)) (* 2 most-positive-fixnum)
1817 :one-floor-result `(,(- (1+ most-positive-fixnum)) 0)
1818 :two-floor-result `(-1 ,(1- most-positive-fixnum))
1819 :one-ffloor-result `(,(float (- (1+ most-positive-fixnum))) 0)
1820 :two-ffloor-result `(-1.0 ,(1- most-positive-fixnum))
1821 :one-ceiling-result `(,(- (1+ most-positive-fixnum)) 0)
1822 :two-ceiling-result `(0 ,(- (1+ most-positive-fixnum)))
1823 :one-fceiling-result `(,(float (- (1+ most-positive-fixnum))) 0)
1824 :two-fceiling-result `(0.0 ,(- (1+ most-positive-fixnum)))
1825 :one-round-result `(,(- (1+ most-positive-fixnum)) 0)
1826 :two-round-result `(-1 ,(1- most-positive-fixnum))
1827 :one-fround-result `(,(float (- (1+ most-positive-fixnum))) 0)
1828 :two-fround-result `(-1.0 ,(1- most-positive-fixnum))
1829 :one-truncate-result `(,(- (1+ most-positive-fixnum)) 0)
1830 :two-truncate-result `(0 ,(- (1+ most-positive-fixnum)))
1831 :one-ftruncate-result `(,(float (- (1+ most-positive-fixnum))) 0)
1832 :two-ftruncate-result `(0.0 ,(- (1+ most-positive-fixnum))))
1833 ;; Test the handling of values with .5:
1834 (Assert-rounding (1+ (* 2 most-positive-fixnum)) 2
1835 :one-floor-result `(,(1+ (* 2 most-positive-fixnum)) 0)
1836 :two-floor-result `(,most-positive-fixnum 1)
1837 :one-ffloor-result `(,(float (1+ (* 2 most-positive-fixnum))) 0)
1838 ;; We can't just call #'float here; we must use code that converts a
1839 ;; bignum with value most-positive-fixnum (the creation of which is
1840 ;; not directly possible in Lisp) to a float, not code that converts
1841 ;; the fixnum with value most-positive-fixnum to a float. The eval is
1842 ;; to avoid compile-time optimisation that can break this.
1843 :two-ffloor-result `(,(eval '(- (1+ most-positive-fixnum) 1 0.0)) 1)
1844 :one-ceiling-result `(,(1+ (* 2 most-positive-fixnum)) 0)
1845 :two-ceiling-result `(,(1+ most-positive-fixnum) -1)
1846 :one-fceiling-result `(,(float (1+ (* 2 most-positive-fixnum))) 0)
1847 :two-fceiling-result `(,(float (1+ most-positive-fixnum)) -1)
1848 :one-round-result `(,(1+ (* 2 most-positive-fixnum)) 0)
1849 :two-round-result `(,(1+ most-positive-fixnum) -1)
1850 :one-fround-result `(,(float (1+ (* 2 most-positive-fixnum))) 0)
1851 :two-fround-result `(,(float (1+ most-positive-fixnum)) -1)
1852 :one-truncate-result `(,(1+ (* 2 most-positive-fixnum)) 0)
1853 :two-truncate-result `(,most-positive-fixnum 1)
1854 :one-ftruncate-result `(,(float (1+ (* 2 most-positive-fixnum))) 0)
1855 ;; See the comment above on :two-ffloor-result:
1856 :two-ftruncate-result `(,(eval '(- (1+ most-positive-fixnum) 1 0.0)) 1))
1857 (Assert-rounding (1+ (* 2 (1- most-positive-fixnum))) 2
1858 :one-floor-result `(,(1+ (* 2 (1- most-positive-fixnum))) 0)
1859 :two-floor-result `(,(1- most-positive-fixnum) 1)
1860 :one-ffloor-result `(,(float (1+ (* 2 (1- most-positive-fixnum)))) 0)
1861 ;; See commentary above on float conversions.
1862 :two-ffloor-result `(,(eval '(- (1+ most-positive-fixnum) 2 0.0)) 1)
1863 :one-ceiling-result `(,(1+ (* 2 (1- most-positive-fixnum))) 0)
1864 :two-ceiling-result `(,most-positive-fixnum -1)
1865 :one-fceiling-result `(,(float (1+ (* 2 (1- most-positive-fixnum)))) 0)
1866 :two-fceiling-result `(,(eval '(- (1+ most-positive-fixnum) 1 0.0)) -1)
1867 :one-round-result `(,(1+ (* 2 (1- most-positive-fixnum))) 0)
1868 :two-round-result `(,(1- most-positive-fixnum) 1)
1869 :one-fround-result `(,(float (1+ (* 2 (1- most-positive-fixnum)))) 0)
1870 :two-fround-result `(,(eval '(- (1+ most-positive-fixnum) 2 0.0)) 1)
1871 :one-truncate-result `(,(1+ (* 2 (1- most-positive-fixnum))) 0)
1872 :two-truncate-result `(,(1- most-positive-fixnum) 1)
1873 :one-ftruncate-result `(,(float (1+ (* 2 (1- most-positive-fixnum)))) 0)
1874 ;; See commentary above
1875 :two-ftruncate-result `(,(eval '(- (1+ most-positive-fixnum) 2 0.0))
1876 1)))
1877 (when (featurep 'ratio)
1878 (Assert-rounding (read "4/3") (read "8/7")
1879 :one-floor-result '(1 1/3) :two-floor-result '(1 4/21)
1880 :one-ffloor-result '(1.0 1/3) :two-ffloor-result '(1.0 4/21)
1881 :one-ceiling-result '(2 -2/3) :two-ceiling-result '(2 -20/21)
1882 :one-fceiling-result '(2.0 -2/3) :two-fceiling-result '(2.0 -20/21)
1883 :one-round-result '(1 1/3) :two-round-result '(1 4/21)
1884 :one-fround-result '(1.0 1/3) :two-fround-result '(1.0 4/21)
1885 :one-truncate-result '(1 1/3) :two-truncate-result '(1 4/21)
1886 :one-ftruncate-result '(1.0 1/3) :two-ftruncate-result '(1.0 4/21))
1887 (Assert-rounding (read "-4/3") (read "8/7")
1888 :one-floor-result '(-2 2/3) :two-floor-result '(-2 20/21)
1889 :one-ffloor-result '(-2.0 2/3) :two-ffloor-result '(-2.0 20/21)
1890 :one-ceiling-result '(-1 -1/3) :two-ceiling-result '(-1 -4/21)
1891 :one-fceiling-result '(-1.0 -1/3) :two-fceiling-result '(-1.0 -4/21)
1892 :one-round-result '(-1 -1/3) :two-round-result '(-1 -4/21)
1893 :one-fround-result '(-1.0 -1/3) :two-fround-result '(-1.0 -4/21)
1894 :one-truncate-result '(-1 -1/3) :two-truncate-result '(-1 -4/21)
1895 :one-ftruncate-result '(-1.0 -1/3) :two-ftruncate-result '(-1.0 -4/21))))
1896
1897 ;; Run this function in a Common Lisp with two arguments to get results that
1898 ;; we should compare against, above. Though note the dancing-around with the
1899 ;; bigfloats and bignums above, too; you can't necessarily just use the
1900 ;; output here.
1901
1902 (defun generate-rounding-output (first second)
1903 (let ((print-readably t))
1904 (princ first)
1905 (princ " ")
1906 (princ second)
1907 (princ " :one-floor-result ")
1908 (princ (list 'quote (multiple-value-list (floor first))))
1909 (princ " :two-floor-result ")
1910 (princ (list 'quote (multiple-value-list (floor first second))))
1911 (princ " :one-ffloor-result ")
1912 (princ (list 'quote (multiple-value-list (ffloor first))))
1913 (princ " :two-ffloor-result ")
1914 (princ (list 'quote (multiple-value-list (ffloor first second))))
1915 (princ " :one-ceiling-result ")
1916 (princ (list 'quote (multiple-value-list (ceiling first))))
1917 (princ " :two-ceiling-result ")
1918 (princ (list 'quote (multiple-value-list (ceiling first second))))
1919 (princ " :one-fceiling-result ")
1920 (princ (list 'quote (multiple-value-list (fceiling first))))
1921 (princ " :two-fceiling-result ")
1922 (princ (list 'quote (multiple-value-list (fceiling first second))))
1923 (princ " :one-round-result ")
1924 (princ (list 'quote (multiple-value-list (round first))))
1925 (princ " :two-round-result ")
1926 (princ (list 'quote (multiple-value-list (round first second))))
1927 (princ " :one-fround-result ")
1928 (princ (list 'quote (multiple-value-list (fround first))))
1929 (princ " :two-fround-result ")
1930 (princ (list 'quote (multiple-value-list (fround first second))))
1931 (princ " :one-truncate-result ")
1932 (princ (list 'quote (multiple-value-list (truncate first))))
1933 (princ " :two-truncate-result ")
1934 (princ (list 'quote (multiple-value-list (truncate first second))))
1935 (princ " :one-ftruncate-result ")
1936 (princ (list 'quote (multiple-value-list (ftruncate first))))
1937 (princ " :two-ftruncate-result ")
1938 (princ (list 'quote (multiple-value-list (ftruncate first second))))))
1939
1940 ;; Multiple value tests.
1941
1942 (flet ((foo (x y)
1943 (floor (+ x y) y))
1944 (foo-zero (x y)
1945 (values (floor (+ x y) y)))
1946 (multiple-value-function-returning-t ()
1947 (values t pi e degrees-to-radians radians-to-degrees))
1948 (multiple-value-function-returning-nil ()
1949 (values nil pi e radians-to-degrees degrees-to-radians))
1950 (function-throwing-multiple-values ()
1951 (let* ((listing '(0 3 4 nil "string" symbol))
1952 (tail listing)
1953 elt)
1954 (while t
1955 (setq tail (cdr listing)
1956 elt (car listing)
1957 listing tail)
1958 (when (null elt)
1959 (throw 'VoN61Lo4Y (multiple-value-function-returning-t)))))))
1960 (Assert
1961 (= (+ (floor 5 3) (floor 19 4)) (+ 1 4) 5)
1962 "Checking that multiple values are discarded correctly as func args")
1963 (Assert
1964 (= 2 (length (multiple-value-list (foo 400 (1+ most-positive-fixnum)))))
1965 "Checking multiple values are passed through correctly as return values")
1966 (Assert
1967 (= 1 (length (multiple-value-list
1968 (foo-zero 400 (1+ most-positive-fixnum)))))
1969 "Checking multiple values are discarded correctly when forced")
1970 (Check-Error setting-constant (setq multiple-values-limit 20))
1971 (Assert
1972 (equal '(-1 1)
1973 (multiple-value-list (floor -3 4)))
1974 "Checking #'multiple-value-list gives a sane result")
1975 (let ((ey 40000)
1976 (bee "this is a string")
1977 (cee #s(hash-table size 256 data (969 ?\xF9))))
1978 (Assert
1979 (equal
1980 (multiple-value-list (values ey bee cee))
1981 (multiple-value-list (values-list (list ey bee cee))))
1982 "Checking that #'values and #'values-list are correctly related")
1983 (Assert
1984 (equal
1985 (multiple-value-list (values-list (list ey bee cee)))
1986 (multiple-value-list (apply #'values (list ey bee cee))))
1987 "Checking #'values-list and #'apply with #values are correctly related"))
1988 (Assert
1989 (= (multiple-value-call #'+ (floor 5 3) (floor 19 4)) 10)
1990 "Checking #'multiple-value-call gives reasonable results.")
1991 (Assert
1992 (= (multiple-value-call (values '+ '*) (floor 5 3) (floor 19 4)) 10)
1993 "Checking #'multiple-value-call correct when first arg multiple.")
1994 (Assert
1995 (= 1 (length (multiple-value-list (prog1 (floor pi) "hi there"))))
1996 "Checking #'prog1 does not pass back multiple values")
1997 (Assert
1998 (= 2 (length (multiple-value-list
1999 (multiple-value-prog1 (floor pi) "hi there"))))
2000 "Checking #'multiple-value-prog1 passes back multiple values")
2001 (multiple-value-bind (floored remainder this-is-nil)
2002 (floor pi 1.0)
2003 (Assert (= floored 3)
2004 "Checking floored bound correctly")
2005 (Assert (eql remainder (- pi 3.0))
2006 "Checking remainder bound correctly")
2007 (Assert (null this-is-nil)
2008 "Checking trailing arg bound but nil"))
2009 (let ((ey 40000)
2010 (bee "this is a string")
2011 (cee #s(hash-table size 256 data (969 ?\xF9))))
2012 (multiple-value-setq (ey bee cee)
2013 (ffloor e 1.0))
2014 (Assert (eql 2.0 ey) "Checking ey set correctly")
2015 (Assert (eql bee (- e 2.0)) "Checking bee set correctly")
2016 (Assert (null cee) "Checking cee set to nil correctly"))
2017 (Assert
2018 (= 3 (length (multiple-value-list (eval '(values nil t pi)))))
2019 "Checking #'eval passes back multiple values")
2020 (Assert
2021 (= 2 (length (multiple-value-list (apply #'floor '(5 3)))))
2022 "Checking #'apply passes back multiple values")
2023 (Assert
2024 (= 2 (length (multiple-value-list (funcall #'floor 5 3))))
2025 "Checking #'funcall passes back multiple values")
2026 (Assert
2027 (equal '(1 2) (multiple-value-list
2028 (multiple-value-call #'floor (values 5 3))))
2029 "Checking #'multiple-value-call passes back multiple values correctly")
2030 (Assert
2031 (= 1 (length (multiple-value-list
2032 (and (multiple-value-function-returning-nil) t))))
2033 "Checking multiple values from non-trailing forms discarded by #'and")
2034 (Assert
2035 (= 5 (length (multiple-value-list
2036 (and t (multiple-value-function-returning-nil)))))
2037 "Checking multiple values from final forms not discarded by #'and")
2038 (Assert
2039 (= 1 (length (multiple-value-list
2040 (or (multiple-value-function-returning-t) t))))
2041 "Checking multiple values from non-trailing forms discarded by #'and")
2042 (Assert
2043 (= 5 (length (multiple-value-list
2044 (or nil (multiple-value-function-returning-t)))))
2045 "Checking multiple values from final forms not discarded by #'and")
2046 (Assert
2047 (= 1 (length (multiple-value-list
2048 (cond ((multiple-value-function-returning-t))))))
2049 "Checking cond doesn't pass back multiple values in tests.")
2050 (Assert
2051 (equal (list nil pi e radians-to-degrees degrees-to-radians)
2052 (multiple-value-list
2053 (cond (t (multiple-value-function-returning-nil)))))
2054 "Checking cond passes back multiple values in clauses.")
2055 (Assert
2056 (= 1 (length (multiple-value-list
2057 (prog1 (multiple-value-function-returning-nil)))))
2058 "Checking prog1 discards multiple values correctly.")
2059 (Assert
2060 (= 5 (length (multiple-value-list
2061 (multiple-value-prog1
2062 (multiple-value-function-returning-nil)))))
2063 "Checking multiple-value-prog1 passes back multiple values correctly.")
2064 (Assert
2065 (equal (list t pi e degrees-to-radians radians-to-degrees)
2066 (multiple-value-list
2067 (catch 'VoN61Lo4Y (function-throwing-multiple-values)))))
2068 (Assert
2069 (equal (list t pi e degrees-to-radians radians-to-degrees)
2070 (multiple-value-list
2071 (loop
2072 for eye in `(a b c d ,e f g ,nil ,pi)
2073 do (when (null eye)
2074 (return (multiple-value-function-returning-t))))))
2075 "Checking #'loop passes back multiple values correctly.")
2076 (Assert
2077 (null (or))
2078 "Checking #'or behaves correctly with zero arguments.")
2079 (Assert
2080 (eq t (and))
2081 "Checking #'and behaves correctly with zero arguments.")
2082 (Assert
2083 (= (* 3.0 (- pi 3.0))
2084 (letf (((values three one-four-one-five-nine) (floor pi)))
2085 (* three one-four-one-five-nine)))
2086 "checking letf handles #'values in a basic sense"))
2087
2088 (Assert (equalp "hi there" "Hi There")
2089 "checking equalp isn't case-sensitive")
2090 (Assert (equalp 99 99.0)
2091 "checking equalp compares numerical values of different types")
2092 (Assert (null (equalp 99 ?c))
2093 "checking equalp does not convert characters to numbers")
2094 ;; Fixed in Hg d0ea57eb3de4.
2095 (Assert (null (equalp "hi there" [hi there]))
2096 "checking equalp doesn't error with string and non-string")
2097
2098 ;;; end of lisp-tests.el