Mercurial > hg > xemacs-beta
view tests/automated/extent-tests.el @ 5912:47ffa085a9ad
Fix a bug when passing a float to truncate and giving a bignum result.
src/ChangeLog addition:
2015-05-10 Aidan Kehoe <kehoea@parhasard.net>
* floatfns.c (truncate_one_float):
Fix a bug here when double_to_integer() (and previously
float_to_int()) returned a bignum; this was silently treated as a
fixnum, giving consistently incorrect remainders and less
consistently-incorrect but still buggy divisors.
tests/ChangeLog addition:
Check that a bug when supplying #'truncate with one float that
rounds to a bignum, has been fixed.
author | Aidan Kehoe <kehoea@parhasard.net> |
---|---|
date | Sun, 10 May 2015 23:55:41 +0100 |
parents | b79e1e02bf01 |
children |
line wrap: on
line source
;; Copyright (C) 2001 Free Software Foundation, Inc. ;; Author: Hrvoje Niksic <hniksic@xemacs.org> ;; Maintainer: Hrvoje Niksic <hniksic@xemacs.org> ;; Created: 1999 ;; Keywords: tests ;; This file is part of XEmacs. ;; XEmacs is free software: you can redistribute it and/or modify it ;; under the terms of the GNU General Public License as published by the ;; Free Software Foundation, either version 3 of the License, or (at your ;; option) any later version. ;; XEmacs is distributed in the hope that it will be useful, but WITHOUT ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or ;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License ;; for more details. ;; You should have received a copy of the GNU General Public License ;; along with XEmacs. If not, see <http://www.gnu.org/licenses/>. ;;; Synched up with: Not in FSF. ;;; Commentary: ;; Test extents operations. ;; See test-harness.el for instructions on how to run these tests. (eval-when-compile (condition-case nil (require 'test-harness) (file-error (push "." load-path) (when (and (boundp 'load-file-name) (stringp load-file-name)) (push (file-name-directory load-file-name) load-path)) (require 'test-harness)))) ;;----------------------------------------------------- ;; Creating and attaching. ;;----------------------------------------------------- (with-temp-buffer (let ((extent (make-extent nil nil)) (string "somecoolstring")) ;; Detached extent. (Assert (extent-detached-p extent)) ;; Put it in a buffer. (set-extent-endpoints extent 1 1 (current-buffer)) (Assert (eq (extent-object extent) (current-buffer))) ;; And then into another buffer. (with-temp-buffer (set-extent-endpoints extent 1 1 (current-buffer)) (Assert (eq (extent-object extent) (current-buffer)))) ;; Now that the buffer doesn't exist, extent should be detached ;; again. (Assert (extent-detached-p extent)) ;; This line crashes XEmacs 21.2.46 and prior. (set-extent-endpoints extent 1 (length string) string) (Assert (eq (extent-object extent) string)) ) (let ((extent (make-extent 1 1))) ;; By default, extent should be closed-open (Assert (eq (get extent 'start-closed) t)) (Assert (eq (get extent 'start-open) nil)) (Assert (eq (get extent 'end-open) t)) (Assert (eq (get extent 'end-closed) nil)) ;; Make it closed-closed. (set-extent-property extent 'end-closed t) (Assert (eq (get extent 'start-closed) t)) (Assert (eq (get extent 'start-open) nil)) (Assert (eq (get extent 'end-open) nil)) (Assert (eq (get extent 'end-closed) t)) ;; open-closed (set-extent-property extent 'start-open t) (Assert (eq (get extent 'start-closed) nil)) (Assert (eq (get extent 'start-open) t)) (Assert (eq (get extent 'end-open) nil)) (Assert (eq (get extent 'end-closed) t)) ;; open-open (set-extent-property extent 'end-open t) (Assert (eq (get extent 'start-closed) nil)) (Assert (eq (get extent 'start-open) t)) (Assert (eq (get extent 'end-open) t)) (Assert (eq (get extent 'end-closed) nil))) ) ;;----------------------------------------------------- ;; Insertion behavior. ;;----------------------------------------------------- (defun et-range (extent) "List (START-POSITION END-POSITION) of EXTENT." (list (extent-start-position extent) (extent-end-position extent))) (defun et-insert-at (string position) "Insert STRING at POSITION in the current buffer." (save-excursion (goto-char position) (insert string))) ;; Test insertion at the beginning, middle, and end of the extent. ;; closed-open (with-temp-buffer (insert "###eee###") (let ((e (make-extent 4 7))) ;; current state: "###[eee)###" ;; 123 456 789 (Assert (equal (et-range e) '(4 7))) (et-insert-at "xxx" 4) ;; current state: "###[xxxeee)###" ;; 123 456789 012 (Assert (equal (et-range e) '(4 10))) (et-insert-at "yyy" 7) ;; current state: "###[xxxyyyeee)###" ;; 123 456789012 345 (Assert (equal (et-range e) '(4 13))) (et-insert-at "zzz" 13) ;; current state: "###[xxxyyyeee)zzz###" ;; 123 456789012 345678 (Assert (equal (et-range e) '(4 13))) )) ;; closed-closed (with-temp-buffer (insert "###eee###") (let ((e (make-extent 4 7))) (put e 'end-closed t) ;; current state: "###[eee]###" ;; 123 456 789 (Assert (equal (et-range e) '(4 7))) (et-insert-at "xxx" 4) ;; current state: "###[xxxeee]###" ;; 123 456789 012 (Assert (equal (et-range e) '(4 10))) (et-insert-at "yyy" 7) ;; current state: "###[xxxyyyeee]###" ;; 123 456789012 345 (Assert (equal (et-range e) '(4 13))) (et-insert-at "zzz" 13) ;; current state: "###[xxxyyyeeezzz]###" ;; 123 456789012345 678 (Assert (equal (et-range e) '(4 16))) )) ;; open-closed (with-temp-buffer (insert "###eee###") (let ((e (make-extent 4 7))) (put e 'start-open t) (put e 'end-closed t) ;; current state: "###(eee]###" ;; 123 456 789 (Assert (equal (et-range e) '(4 7))) (et-insert-at "xxx" 4) ;; current state: "###xxx(eee]###" ;; 123456 789 012 (Assert (equal (et-range e) '(7 10))) (et-insert-at "yyy" 8) ;; current state: "###xxx(eyyyee]###" ;; 123456 789012 345 (Assert (equal (et-range e) '(7 13))) (et-insert-at "zzz" 13) ;; current state: "###xxx(eyyyeezzz]###" ;; 123456 789012345 678 (Assert (equal (et-range e) '(7 16))) )) ;; open-open (with-temp-buffer (insert "###eee###") (let ((e (make-extent 4 7))) (put e 'start-open t) ;; current state: "###(eee)###" ;; 123 456 789 (Assert (equal (et-range e) '(4 7))) (et-insert-at "xxx" 4) ;; current state: "###xxx(eee)###" ;; 123456 789 012 (Assert (equal (et-range e) '(7 10))) (et-insert-at "yyy" 8) ;; current state: "###xxx(eyyyee)###" ;; 123456 789012 345 (Assert (equal (et-range e) '(7 13))) (et-insert-at "zzz" 13) ;; current state: "###xxx(eyyyee)zzz###" ;; 123456 789012 345678 (Assert (equal (et-range e) '(7 13))) )) ;;----------------------------------------------------- ;; Deletion behavior. ;;----------------------------------------------------- (dolist (props '((start-closed t end-open t) (start-closed t end-open nil) (start-closed nil end-open nil) (start-closed nil end-open t))) ;; Deletion needs to behave the same regardless of the open-ness of ;; the boundaries. (with-temp-buffer (insert "xxxxxxxxxx") (let ((e (make-extent 3 9))) (set-extent-properties e props) ;; current state: xx[xxxxxx]xx ;; 12 345678 90 (Assert (equal (et-range e) '(3 9))) (delete-region 1 2) ;; current state: x[xxxxxx]xx ;; 1 234567 89 (Assert (equal (et-range e) '(2 8))) (delete-region 2 4) ;; current state: x[xxxx]xx ;; 1 2345 67 (Assert (equal (et-range e) '(2 6))) (delete-region 1 3) ;; current state: [xxx]xx ;; 123 45 (Assert (equal (et-range e) '(1 4))) (delete-region 3 5) ;; current state: [xx]x ;; 12 3 (Assert (equal (et-range e) '(1 3))) ))) ;;; #### Should have a test for read-only-ness and insertion and ;;; deletion! ;;----------------------------------------------------- ;; `detachable' property ;;----------------------------------------------------- (dolist (props '((start-closed t end-open t) (start-closed t end-open nil) (start-closed nil end-open nil) (start-closed nil end-open t))) ;; `detachable' shouldn't relate to region properties, hence the ;; loop. (with-temp-buffer (insert "###eee###") (let ((e (make-extent 4 7))) (set-extent-properties e props) (Assert (get e 'detachable)) (Assert (not (extent-detached-p e))) (delete-region 4 5) ;; ###ee### (not detached yet) (Assert (not (extent-detached-p e))) (delete-region 4 6) ;; ###### (should be detached now) (Assert (extent-detached-p e)))) (with-temp-buffer (insert "###eee###") (let ((e (make-extent 4 7))) (set-extent-properties e props) (put e 'detachable nil) (Assert (not (get e 'detachable))) (Assert (not (extent-detached-p e))) (delete-region 4 5) ;; ###ee### (Assert (not (extent-detached-p e))) (delete-region 4 6) ;; ###[]### (Assert (not (extent-detached-p e))) (Assert (equal (et-range e) '(4 4))) )) ) ;;----------------------------------------------------- ;; Zero-length extents. ;;----------------------------------------------------- ;; closed-open (should stay put) (with-temp-buffer (insert "######") (let ((e (make-extent 4 4))) (et-insert-at "foo" 4) (Assert (equal (et-range e) '(4 4))))) ;; open-closed (should move) (with-temp-buffer (insert "######") (let ((e (make-extent 4 4))) (put e 'start-open t) (put e 'end-closed t) (et-insert-at "foo" 4) (Assert (equal (et-range e) '(7 7))))) ;; closed-closed (should extend) (with-temp-buffer (insert "######") (let ((e (make-extent 4 4))) (put e 'end-closed t) (et-insert-at "foo" 4) (Assert (equal (et-range e) '(4 7))))) ;; open-open (illegal; forced to behave like closed-open) (with-temp-buffer (insert "######") (let ((e (make-extent 4 4))) (put e 'start-open t) (et-insert-at "foo" 4) (Assert (equal (et-range e) '(4 4))))) ;;----------------------------------------------------- ;; Extents and the minibuffer. ;;----------------------------------------------------- (let* ((string (copy-sequence "Der Hoelle Rache kocht in meinem Herzen")) (e (make-extent (search "Rache" string) (search "kocht" string) string)) (ee (make-extent (search "meinem" string) (search "Herzen" string) string)) (property-name '#:secret-token) event list) (setf (extent-property e 'duplicable) t (extent-property e property-name) t (extent-property ee 'duplicable) nil) ;; Actually the default. (block enough (enqueue-eval-event #'(lambda (ignore) (return-from enough)) nil) ;; Silence prompt on TTY. Maybe we shouldn't be doing this. (flet ((send-string-to-terminal (&rest ignore))) (while (setq event (next-event event string)) (dispatch-event event)))) (setq list (extent-list (get-buffer " *Echo Area*"))) (Assert list "checking extent info was preserved in #'next-event") (Assert (eql 1 (length list)) "checking only one extent was preserved") (Assert (eql t (get (car list) property-name)) "checking it was our duplicable extent that was preserved"))