Mercurial > hg > xemacs-beta

comparison tests/automated/lisp-tests.el @ 5911:48386fd60fd0

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
GMP functions that take doubles choke on non-finite values, avoid that. src/ChangeLog addition: 2015-05-10 Aidan Kehoe <kehoea@parhasard.net> * floatfns.c (double_to_integer): Rename this from float_to_int to fit our newer, bignum-compatible terminology. GMP can signal SIGFPE when asked to turn NaN or infinity into a bignum, and we're not prepared to handle that signal if the OS float library routines don't do that, so check for those values explicitly. * floatfns.c (ceiling_two_float): * floatfns.c (ceiling_one_float): * floatfns.c (floor_two_float): * floatfns.c (floor_one_float): * floatfns.c (round_two_float): * floatfns.c (round_one_float): * floatfns.c (truncate_two_float): * floatfns.c (truncate_one_float): Call double_to_integer() with its new name. * number.c: Don't use the {bignum,ratio,bigfloat}_set_double functions directly here, with GMP they can choke when handed non-finite C doubles, call Ftruncate() and the new float_to_bigfloat() from floatfns.c. Maybe we should extend number-gmp.c with GMP-specific implementations that check for non-finite values. tests/ChangeLog addition: 2015-05-10 Aidan Kehoe <kehoea@parhasard.net> * automated/lisp-tests.el: Backslash a few parentheses in the first column for the sake of fontification. * automated/lisp-tests.el: Check that the rounding functions signal Lisp errors correctly when handed positive and negative infinity and NaN.
author Aidan Kehoe <kehoea@parhasard.net>
date Sun, 10 May 2015 19:07:09 +0100
parents 85fd1ab80057
children 47ffa085a9ad
comparison
equal deleted inserted replaced
5910:eb1e15c9440b 5911:48386fd60fd0
1509 (erase-buffer) 1509 (erase-buffer)
1510 (insert 1510 (insert
1511 "\ 1511 "\
1512 ;; Lisp should not be able to modify #$, which is 1512 ;; Lisp should not be able to modify #$, which is
1513 ;; Vload_file_name_internal of lread.c. 1513 ;; Vload_file_name_internal of lread.c.
1514 (Check-Error setting-constant (aset #$ 0 ?\\ )) 1514 \(Check-Error setting-constant (aset #$ 0 ?\\ ))
1515 1515
1516 ;; But modifying load-file-name should work: 1516 ;; But modifying load-file-name should work:
1517 (let ((new-char ?\\ ) 1517 \(let ((new-char ?\\ )
1518 old-char) 1518 old-char)
1519 (setq old-char (aref load-file-name 0)) 1519 (setq old-char (aref load-file-name 0))
1520 (if (= new-char old-char) 1520 (if (= new-char old-char)
1521 (setq new-char ?/)) 1521 (setq new-char ?/))
1522 (aset load-file-name 0 new-char) 1522 (aset load-file-name 0 new-char)
1523 (Assert (= new-char (aref load-file-name 0)) 1523 (Assert (= new-char (aref load-file-name 0))
1524 \"Check that we can modify the string value of load-file-name\")) 1524 \"Check that we can modify the string value of load-file-name\"))
1525 1525
1526 (let* ((new-load-file-name \"hi there\") 1526 \(let* ((new-load-file-name \"hi there\")
1527 (load-file-name new-load-file-name)) 1527 (load-file-name new-load-file-name))
1528 (Assert (eq new-load-file-name load-file-name) 1528 (Assert (eq new-load-file-name load-file-name)
1529 \"Checking that we can bind load-file-name successfully.\")) 1529 \"Checking that we can bind load-file-name successfully.\"))
1530 1530
1531 ") 1531 ")
1532 (write-region (point-min) (point-max) test-file-name nil 'quiet) 1532 (write-region (point-min) (point-max) test-file-name nil 'quiet)
1533 (set-buffer-modified-p nil) 1533 (set-buffer-modified-p nil)
1534 (kill-buffer nil) 1534 (kill-buffer nil)
1535 (load test-file-name nil t nil) 1535 (load test-file-name nil t nil)
1536 (delete-file test-file-name)) 1536 (delete-file test-file-name))
1537
1538 ;; These used to crash with bignum support thanks to GMP:
1539 (symbol-macrolet
1540 ((positive-infinity
1541 (expt (+ most-positive-fixnum 0.0) most-positive-fixnum))
1542 (negative-infinity
1543 (expt (+ most-negative-fixnum 0.0) most-positive-fixnum))
1544 (not-a-number (expt -1 0.5)))
1545 (Check-Error range-error (ceiling positive-infinity))
1546 (Check-Error range-error (ceiling negative-infinity))
1547 (Check-Error range-error (ceiling positive-infinity 1))
1548 (Check-Error range-error (ceiling negative-infinity 1))
1549 (Check-Error range-error (floor positive-infinity))
1550 (Check-Error range-error (floor negative-infinity))
1551 (Check-Error range-error (floor positive-infinity 1))
1552 (Check-Error range-error (floor negative-infinity 1))
1553 (Check-Error range-error (round positive-infinity))
1554 (Check-Error range-error (round negative-infinity))
1555 (Check-Error range-error (round positive-infinity 1))
1556 (Check-Error range-error (round negative-infinity 1))
1557 (Check-Error range-error (ceiling not-a-number))
1558 (Check-Error range-error (ceiling not-a-number 1))
1559 (Check-Error range-error (floor not-a-number))
1560 (Check-Error range-error (floor not-a-number 1))
1561 (Check-Error range-error (round not-a-number))
1562 (Check-Error range-error (round not-a-number 1))
1563 (Check-Error range-error (coerce positive-infinity 'fixnum))
1564 (Check-Error range-error (coerce negative-infinity 'fixnum))
1565 (Check-Error range-error (coerce not-a-number 'fixnum))
1566 (Check-Error range-error (coerce positive-infinity 'integer))
1567 (Check-Error range-error (coerce negative-infinity 'integer))
1568 (Check-Error range-error (coerce not-a-number 'integer))
1569 (when (ignore-errors (coerce 1 'ratio))
1570 (Check-Error range-error (coerce positive-infinity 'ratio))
1571 (Check-Error range-error (coerce negative-infinity 'ratio))
1572 (Check-Error range-error (coerce not-a-number 'ratio)))
1573 (when (ignore-errors (coerce 1 'bigfloat))
1574 (Check-Error range-error (coerce positive-infinity 'bigfloat))
1575 (Check-Error range-error (coerce negative-infinity 'bigfloat))
1576 (Check-Error range-error (coerce not-a-number 'bigfloat))))
1537 1577
1538 (labels ((cl-floor (x &optional y) 1578 (labels ((cl-floor (x &optional y)
1539 (let ((q (floor x y))) 1579 (let ((q (floor x y)))
1540 (list q (- x (if y (* y q) q))))) 1580 (list q (- x (if y (* y q) q)))))
1541 (cl-ceiling (x &optional y) 1581 (cl-ceiling (x &optional y)