Mercurial > hg > xemacs-beta
annotate tests/automated/lisp-tests.el @ 5067:7d7ae8db0341
add functions `stable-union' and `stable-intersection' to do stable set operations
-------------------- ChangeLog entries follow: --------------------
lisp/ChangeLog addition:
2010-02-22 Ben Wing <ben@xemacs.org>
* cl-seq.el:
* cl-seq.el (stable-union): New.
* cl-seq.el (stable-intersection): New.
New functions to do stable set operations, i.e. preserve the order
of the elements in the argument lists, and prefer LIST1 over LIST2
when ordering the combined result. The result looks as much like
LIST1 as possible, followed (in the case of `stable-union') by
any necessary elements from LIST2, in order. This is contrary to
`union' and `intersection', which are not required to be order-
preserving and are not -- they prefer LIST2 and output results in
backwards order.
| author | Ben Wing <ben@xemacs.org> |
|---|---|
| date | Mon, 22 Feb 2010 21:23:02 -0600 |
| parents | 9624523604c5 |
| children | 0f66906b6e37 |
| rev | line source |
|---|---|
|
5035
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1 ;; Copyright (C) 1998 Free Software Foundation, Inc. -*- coding: iso-8859-1 -*- |
| 428 | 2 |
| 3 ;; Author: Martin Buchholz <martin@xemacs.org> | |
| 4 ;; Maintainer: Martin Buchholz <martin@xemacs.org> | |
| 5 ;; Created: 1998 | |
| 6 ;; Keywords: tests | |
| 7 | |
| 8 ;; This file is part of XEmacs. | |
| 9 | |
| 10 ;; XEmacs is free software; you can redistribute it and/or modify it | |
| 11 ;; under the terms of the GNU General Public License as published by | |
| 12 ;; the Free Software Foundation; either version 2, or (at your option) | |
| 13 ;; any later version. | |
| 14 | |
| 15 ;; XEmacs is distributed in the hope that it will be useful, but | |
| 16 ;; WITHOUT ANY WARRANTY; without even the implied warranty of | |
| 17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU | |
| 18 ;; General Public License for more details. | |
| 19 | |
| 20 ;; You should have received a copy of the GNU General Public License | |
| 21 ;; along with XEmacs; see the file COPYING. If not, write to the Free | |
| 22 ;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA | |
| 23 ;; 02111-1307, USA. | |
| 24 | |
| 25 ;;; Synched up with: Not in FSF. | |
| 26 | |
| 27 ;;; Commentary: | |
| 28 | |
| 29 ;;; Test basic Lisp engine functionality | |
| 30 ;;; See test-harness.el for instructions on how to run these tests. | |
| 31 | |
| 32 (eval-when-compile | |
| 33 (condition-case nil | |
| 34 (require 'test-harness) | |
| 35 (file-error | |
| 36 (push "." load-path) | |
| 37 (when (and (boundp 'load-file-name) (stringp load-file-name)) | |
| 38 (push (file-name-directory load-file-name) load-path)) | |
| 39 (require 'test-harness)))) | |
| 40 | |
| 41 (Check-Error wrong-number-of-arguments (setq setq-test-foo)) | |
| 42 (Check-Error wrong-number-of-arguments (setq setq-test-foo 1 setq-test-bar)) | |
| 43 (Check-Error wrong-number-of-arguments (setq-default setq-test-foo)) | |
| 44 (Check-Error wrong-number-of-arguments (setq-default setq-test-foo 1 setq-test-bar)) | |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
45 (Assert-eq (setq) nil) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
46 (Assert-eq (setq-default) nil) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
47 (Assert-eq (setq setq-test-foo 42) 42) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
48 (Assert-eq (setq-default setq-test-foo 42) 42) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
49 (Assert-eq (setq setq-test-foo 42 setq-test-bar 99) 99) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
50 (Assert-eq (setq-default setq-test-foo 42 setq-test-bar 99) 99) |
| 428 | 51 |
| 52 (macrolet ((test-setq (expected-result &rest body) | |
| 53 `(progn | |
| 54 (defun test-setq-fun () ,@body) | |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
55 (Assert-eq ,expected-result (test-setq-fun)) |
| 428 | 56 (byte-compile 'test-setq-fun) |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
57 (Assert-eq ,expected-result (test-setq-fun))))) |
| 428 | 58 (test-setq nil (setq)) |
| 59 (test-setq nil (setq-default)) | |
| 60 (test-setq 42 (setq test-setq-var 42)) | |
| 61 (test-setq 42 (setq-default test-setq-var 42)) | |
| 62 (test-setq 42 (setq test-setq-bar 99 test-setq-var 42)) | |
| 63 (test-setq 42 (setq-default test-setq-bar 99 test-setq-var 42)) | |
| 64 ) | |
| 65 | |
| 66 (let ((my-vector [1 2 3 4]) | |
| 67 (my-bit-vector (bit-vector 1 0 1 0)) | |
| 68 (my-string "1234") | |
| 69 (my-list '(1 2 3 4))) | |
| 70 | |
| 71 ;;(Assert (fooooo)) ;; Generate Other failure | |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
72 ;;(Assert-eq 1 2) ;; Generate Assertion failure |
| 428 | 73 |
| 74 (dolist (sequence (list my-vector my-bit-vector my-string my-list)) | |
| 75 (Assert (sequencep sequence)) | |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
76 (Assert-eq 4 (length sequence))) |
| 428 | 77 |
| 78 (dolist (array (list my-vector my-bit-vector my-string)) | |
| 79 (Assert (arrayp array))) | |
| 80 | |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
81 (Assert-eq (elt my-vector 0) 1) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
82 (Assert-eq (elt my-bit-vector 0) 1) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
83 (Assert-eq (elt my-string 0) ?1) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
84 (Assert-eq (elt my-list 0) 1) |
| 428 | 85 |
| 86 (fillarray my-vector 5) | |
| 87 (fillarray my-bit-vector 1) | |
| 88 (fillarray my-string ?5) | |
| 89 | |
| 90 (dolist (array (list my-vector my-bit-vector)) | |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
91 (Assert-eq 4 (length array))) |
| 428 | 92 |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
93 (Assert-eq (elt my-vector 0) 5) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
94 (Assert-eq (elt my-bit-vector 0) 1) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
95 (Assert-eq (elt my-string 0) ?5) |
| 428 | 96 |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
97 (Assert-eq (elt my-vector 3) 5) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
98 (Assert-eq (elt my-bit-vector 3) 1) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
99 (Assert-eq (elt my-string 3) ?5) |
| 428 | 100 |
| 101 (fillarray my-bit-vector 0) | |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
102 (Assert-eq 4 (length my-bit-vector)) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
103 (Assert-eq (elt my-bit-vector 2) 0) |
| 428 | 104 ) |
| 105 | |
| 106 (defun make-circular-list (length) | |
| 107 "Create evil emacs-crashing circular list of length LENGTH" | |
| 108 (let ((circular-list | |
| 109 (make-list | |
| 110 length | |
| 111 'you-are-trapped-in-a-twisty-maze-of-cons-cells-all-alike))) | |
| 112 (setcdr (last circular-list) circular-list) | |
| 113 circular-list)) | |
| 114 | |
| 115 ;;----------------------------------------------------- | |
| 116 ;; Test `nconc' | |
| 117 ;;----------------------------------------------------- | |
| 118 (defun make-list-012 () (list 0 1 2)) | |
| 119 | |
| 120 (Check-Error wrong-type-argument (nconc 'foo nil)) | |
| 121 | |
| 122 (dolist (length '(1 2 3 4 1000 2000)) | |
| 123 (Check-Error circular-list (nconc (make-circular-list length) 'foo)) | |
| 124 (Check-Error circular-list (nconc '(1 . 2) (make-circular-list length) 'foo)) | |
| 125 (Check-Error circular-list (nconc '(1 . 2) '(3 . 4) (make-circular-list length) 'foo))) | |
| 126 | |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
127 (Assert-eq (nconc) nil) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
128 (Assert-eq (nconc nil) nil) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
129 (Assert-eq (nconc nil nil) nil) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
130 (Assert-eq (nconc nil nil nil) nil) |
| 428 | 131 |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
132 (let ((x (make-list-012))) (Assert-eq (nconc nil x) x)) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
133 (let ((x (make-list-012))) (Assert-eq (nconc x nil) x)) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
134 (let ((x (make-list-012))) (Assert-eq (nconc nil x nil) x)) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
135 (let ((x (make-list-012))) (Assert-eq (nconc x) x)) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
136 (let ((x (make-list-012))) (Assert-eq (nconc x (make-circular-list 3)) x)) |
| 428 | 137 |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
138 (Assert-equal (nconc '(1 . 2) '(3 . 4) '(5 . 6)) '(1 3 5 . 6)) |
| 428 | 139 |
| 140 (let ((y (nconc (make-list-012) nil (list 3 4 5) nil))) | |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
141 (Assert-eq (length y) 6) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
142 (Assert-eq (nth 3 y) 3)) |
| 428 | 143 |
| 144 ;;----------------------------------------------------- | |
| 145 ;; Test `last' | |
| 146 ;;----------------------------------------------------- | |
| 147 (Check-Error wrong-type-argument (last 'foo)) | |
| 148 (Check-Error wrong-number-of-arguments (last)) | |
| 149 (Check-Error wrong-number-of-arguments (last '(1 2) 1 1)) | |
| 150 (Check-Error circular-list (last (make-circular-list 1))) | |
| 151 (Check-Error circular-list (last (make-circular-list 2000))) | |
| 152 (let ((x (list 0 1 2 3))) | |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
153 (Assert-eq (last nil) nil) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
154 (Assert-eq (last x 0) nil) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
155 (Assert-eq (last x ) (cdddr x)) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
156 (Assert-eq (last x 1) (cdddr x)) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
157 (Assert-eq (last x 2) (cddr x)) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
158 (Assert-eq (last x 3) (cdr x)) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
159 (Assert-eq (last x 4) x) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
160 (Assert-eq (last x 9) x) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
161 (Assert-eq (last '(1 . 2) 0) 2) |
| 428 | 162 ) |
| 163 | |
| 164 ;;----------------------------------------------------- | |
| 165 ;; Test `butlast' and `nbutlast' | |
| 166 ;;----------------------------------------------------- | |
| 167 (Check-Error wrong-type-argument (butlast 'foo)) | |
| 168 (Check-Error wrong-type-argument (nbutlast 'foo)) | |
| 169 (Check-Error wrong-number-of-arguments (butlast)) | |
| 170 (Check-Error wrong-number-of-arguments (nbutlast)) | |
| 171 (Check-Error wrong-number-of-arguments (butlast '(1 2) 1 1)) | |
| 172 (Check-Error wrong-number-of-arguments (nbutlast '(1 2) 1 1)) | |
| 173 (Check-Error circular-list (butlast (make-circular-list 1))) | |
| 174 (Check-Error circular-list (nbutlast (make-circular-list 1))) | |
| 175 (Check-Error circular-list (butlast (make-circular-list 2000))) | |
| 176 (Check-Error circular-list (nbutlast (make-circular-list 2000))) | |
| 177 | |
| 178 (let* ((x (list 0 1 2 3)) | |
| 179 (y (butlast x)) | |
| 180 (z (nbutlast x))) | |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
181 (Assert-eq z x) |
| 428 | 182 (Assert (not (eq y x))) |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
183 (Assert-equal y '(0 1 2)) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
184 (Assert-equal z y)) |
| 428 | 185 |
| 186 (let* ((x (list 0 1 2 3 4)) | |
| 187 (y (butlast x 2)) | |
| 188 (z (nbutlast x 2))) | |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
189 (Assert-eq z x) |
| 428 | 190 (Assert (not (eq y x))) |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
191 (Assert-equal y '(0 1 2)) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
192 (Assert-equal z y)) |
| 428 | 193 |
| 194 (let* ((x (list 0 1 2 3)) | |
| 195 (y (butlast x 0)) | |
| 196 (z (nbutlast x 0))) | |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
197 (Assert-eq z x) |
| 428 | 198 (Assert (not (eq y x))) |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
199 (Assert-equal y '(0 1 2 3)) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
200 (Assert-equal z y)) |
| 428 | 201 |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
202 (Assert-eq (butlast '(x)) nil) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
203 (Assert-eq (nbutlast '(x)) nil) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
204 (Assert-eq (butlast '()) nil) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
205 (Assert-eq (nbutlast '()) nil) |
| 428 | 206 |
| 207 ;;----------------------------------------------------- | |
| 208 ;; Test `copy-list' | |
| 209 ;;----------------------------------------------------- | |
| 210 (Check-Error wrong-type-argument (copy-list 'foo)) | |
| 211 (Check-Error wrong-number-of-arguments (copy-list)) | |
| 212 (Check-Error wrong-number-of-arguments (copy-list '(1 2) 1)) | |
| 213 (Check-Error circular-list (copy-list (make-circular-list 1))) | |
| 214 (Check-Error circular-list (copy-list (make-circular-list 2000))) | |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
215 (Assert-eq '() (copy-list '())) |
| 428 | 216 (dolist (x '((1) (1 2) (1 2 3) (1 2 . 3))) |
| 217 (let ((y (copy-list x))) | |
| 218 (Assert (and (equal x y) (not (eq x y)))))) | |
| 219 | |
| 220 ;;----------------------------------------------------- | |
| 221 ;; Arithmetic operations | |
| 222 ;;----------------------------------------------------- | |
| 223 | |
| 224 ;; Test `+' | |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
225 (Assert-eq (+ 1 1) 2) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
226 (Assert= (+ 1.0 1.0) 2.0) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
227 (Assert= (+ 1.0 3.0 0.0) 4.0) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
228 (Assert= (+ 1 1.0) 2.0) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
229 (Assert= (+ 1.0 1) 2.0) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
230 (Assert= (+ 1.0 1 1) 3.0) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
231 (Assert= (+ 1 1 1.0) 3.0) |
| 1983 | 232 (if (featurep 'bignum) |
| 233 (progn | |
| 234 (Assert (bignump (1+ most-positive-fixnum))) | |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
235 (Assert-eq most-positive-fixnum (1- (1+ most-positive-fixnum))) |
| 1983 | 236 (Assert (bignump (+ most-positive-fixnum 1))) |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
237 (Assert-eq most-positive-fixnum (- (+ most-positive-fixnum 1) 1)) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
238 (Assert= (1+ most-positive-fixnum) (- most-negative-fixnum)) |
| 1983 | 239 (Assert (zerop (+ (* 3 most-negative-fixnum) (* 3 most-positive-fixnum) |
| 240 3)))) | |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
241 (Assert-eq (1+ most-positive-fixnum) most-negative-fixnum) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
242 (Assert-eq (+ most-positive-fixnum 1) most-negative-fixnum)) |
| 1983 | 243 |
| 244 (when (featurep 'ratio) | |
| 245 (let ((threefourths (read "3/4")) | |
| 246 (threehalfs (read "3/2")) | |
| 247 (bigpos (div (+ most-positive-fixnum 2) (1+ most-positive-fixnum))) | |
| 248 (bigneg (div (+ most-positive-fixnum 2) most-negative-fixnum)) | |
| 249 (negone (div (1+ most-positive-fixnum) most-negative-fixnum))) | |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
250 (Assert= negone -1) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
251 (Assert= threehalfs (+ threefourths threefourths)) |
| 1983 | 252 (Assert (zerop (+ bigpos bigneg))))) |
| 428 | 253 |
| 254 ;; Test `-' | |
| 255 (Check-Error wrong-number-of-arguments (-)) | |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
256 (Assert-eq (- 0) 0) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
257 (Assert-eq (- 1) -1) |
| 428 | 258 (dolist (one `(1 1.0 ?\1 ,(Int-to-Marker 1))) |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
259 (Assert= (+ 1 one) 2) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
260 (Assert= (+ one) 1) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
261 (Assert= (+ one) one) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
262 (Assert= (- one) -1) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
263 (Assert= (- one one) 0) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
264 (Assert= (- one one one) -1) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
265 (Assert= (- 0 one) -1) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
266 (Assert= (- 0 one one) -2) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
267 (Assert= (+ one 1) 2) |
| 428 | 268 (dolist (zero '(0 0.0 ?\0)) |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
269 (Assert= (+ 1 zero) 1 zero) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
270 (Assert= (+ zero 1) 1 zero) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
271 (Assert= (- zero) zero zero) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
272 (Assert= (- zero) 0 zero) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
273 (Assert= (- zero zero) 0 zero) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
274 (Assert= (- zero one one) -2 zero))) |
| 428 | 275 |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
276 (Assert= (- 1.5 1) .5) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
277 (Assert= (- 1 1.5) (- .5)) |
| 428 | 278 |
| 1983 | 279 (if (featurep 'bignum) |
| 280 (progn | |
| 281 (Assert (bignump (1- most-negative-fixnum))) | |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
282 (Assert-eq most-negative-fixnum (1+ (1- most-negative-fixnum))) |
| 1983 | 283 (Assert (bignump (- most-negative-fixnum 1))) |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
284 (Assert-eq most-negative-fixnum (+ (- most-negative-fixnum 1) 1)) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
285 (Assert= (1- most-negative-fixnum) (- 0 most-positive-fixnum 2)) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
286 (Assert-eq (- (- most-positive-fixnum most-negative-fixnum) |
| 1983 | 287 (* 2 most-positive-fixnum)) |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
288 1)) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
289 (Assert-eq (1- most-negative-fixnum) most-positive-fixnum) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
290 (Assert-eq (- most-negative-fixnum 1) most-positive-fixnum)) |
| 1983 | 291 |
| 292 (when (featurep 'ratio) | |
| 293 (let ((threefourths (read "3/4")) | |
| 294 (threehalfs (read "3/2")) | |
| 295 (bigpos (div (+ most-positive-fixnum 2) (1+ most-positive-fixnum))) | |
| 296 (bigneg (div most-positive-fixnum most-negative-fixnum)) | |
| 297 (negone (div (1+ most-positive-fixnum) most-negative-fixnum))) | |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
298 (Assert= (- negone) 1) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
299 (Assert= threefourths (- threehalfs threefourths)) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
300 (Assert= (- bigpos bigneg) 2))) |
| 428 | 301 |
| 302 ;; Test `/' | |
| 303 | |
| 304 ;; Test division by zero errors | |
| 305 (dolist (zero '(0 0.0 ?\0)) | |
| 306 (Check-Error arith-error (/ zero)) | |
| 307 (dolist (n1 `(42 42.0 ?\042 ,(Int-to-Marker 42))) | |
| 308 (Check-Error arith-error (/ n1 zero)) | |
| 309 (dolist (n2 `(3 3.0 ?\03 ,(Int-to-Marker 3))) | |
| 310 (Check-Error arith-error (/ n1 n2 zero))))) | |
| 311 | |
| 312 ;; Other tests for `/' | |
| 313 (Check-Error wrong-number-of-arguments (/)) | |
| 314 (let (x) | |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
315 (Assert= (/ (setq x 2)) 0) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
316 (Assert= (/ (setq x 2.0)) 0.5)) |
| 428 | 317 |
| 318 (dolist (six '(6 6.0 ?\06)) | |
| 319 (dolist (two '(2 2.0 ?\02)) | |
| 320 (dolist (three '(3 3.0 ?\03)) | |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
321 (Assert= (/ six two) three (list six two three))))) |
| 428 | 322 |
| 323 (dolist (three '(3 3.0 ?\03)) | |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
324 (Assert= (/ three 2.0) 1.5 three)) |
| 428 | 325 (dolist (two '(2 2.0 ?\02)) |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
326 (Assert= (/ 3.0 two) 1.5 two)) |
| 428 | 327 |
| 1983 | 328 (when (featurep 'bignum) |
| 329 (let* ((million 1000000) | |
| 330 (billion (* million 1000)) ;; American, not British, billion | |
| 331 (trillion (* billion 1000))) | |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
332 (Assert= (/ billion 1000) (/ trillion million) million 1000000.0) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
333 (Assert= (/ billion -1000) (/ trillion (- million)) (- million)) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
334 (Assert= (/ trillion 1000) billion 1000000000.0) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
335 (Assert= (/ trillion -1000) (- billion) -1000000000.0) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
336 (Assert= (/ trillion 10) (* 100 billion) 100000000000.0) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
337 (Assert= (/ (- trillion) 10) (* -100 billion) -100000000000.0))) |
| 1983 | 338 |
| 339 (when (featurep 'ratio) | |
| 340 (let ((half (div 1 2)) | |
| 341 (fivefourths (div 5 4)) | |
| 342 (fivehalfs (div 5 2))) | |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
343 (Assert= half (read "3000000000/6000000000")) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
344 (Assert= (/ fivehalfs fivefourths) 2) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
345 (Assert= (/ fivefourths fivehalfs) half) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
346 (Assert= (- half) (read "-3000000000/6000000000")) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
347 (Assert= (/ fivehalfs (- fivefourths)) -2) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
348 (Assert= (/ (- fivefourths) fivehalfs) (- half)))) |
| 1983 | 349 |
| 428 | 350 ;; Test `*' |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
351 (Assert= 1 (*)) |
| 428 | 352 |
| 353 (dolist (one `(1 1.0 ?\01 ,(Int-to-Marker 1))) | |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
354 (Assert= 1 (* one) one)) |
| 428 | 355 |
| 356 (dolist (two '(2 2.0 ?\02)) | |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
357 (Assert= 2 (* two) two)) |
| 428 | 358 |
| 359 (dolist (six '(6 6.0 ?\06)) | |
| 360 (dolist (two '(2 2.0 ?\02)) | |
| 361 (dolist (three '(3 3.0 ?\03)) | |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
362 (Assert= (* three two) six (list three two six))))) |
| 428 | 363 |
| 364 (dolist (three '(3 3.0 ?\03)) | |
| 365 (dolist (two '(2 2.0 ?\02)) | |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
366 (Assert= (* 1.5 two) three (list two three)) |
| 428 | 367 (dolist (five '(5 5.0 ?\05)) |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
368 (Assert= 30 (* five two three) (list five two three))))) |
| 428 | 369 |
| 1983 | 370 (when (featurep 'bignum) |
| 371 (let ((64K 65536)) | |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
372 (Assert= (* 64K 64K) (read "4294967296")) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
373 (Assert= (* (- 64K) 64K) (read "-4294967296")) |
| 1983 | 374 (Assert (/= (* -1 most-negative-fixnum) most-negative-fixnum)))) |
| 375 | |
| 376 (when (featurep 'ratio) | |
| 377 (let ((half (div 1 2)) | |
| 378 (fivefourths (div 5 4)) | |
| 379 (twofifths (div 2 5))) | |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
380 (Assert= (* fivefourths twofifths) half) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
381 (Assert= (* half twofifths) (read "3/15")))) |
| 1983 | 382 |
| 428 | 383 ;; Test `+' |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
384 (Assert= 0 (+)) |
| 428 | 385 |
| 386 (dolist (one `(1 1.0 ?\01 ,(Int-to-Marker 1))) | |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
387 (Assert= 1 (+ one) one)) |
| 428 | 388 |
| 389 (dolist (two '(2 2.0 ?\02)) | |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
390 (Assert= 2 (+ two) two)) |
| 428 | 391 |
| 392 (dolist (five '(5 5.0 ?\05)) | |
| 393 (dolist (two '(2 2.0 ?\02)) | |
| 394 (dolist (three '(3 3.0 ?\03)) | |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
395 (Assert= (+ three two) five (list three two five)) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
396 (Assert= 10 (+ five two three) (list five two three))))) |
| 428 | 397 |
| 398 ;; Test `max', `min' | |
| 399 (dolist (one `(1 1.0 ?\01 ,(Int-to-Marker 1))) | |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
400 (Assert= one (max one) one) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
401 (Assert= one (max one one) one) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
402 (Assert= one (max one one one) one) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
403 (Assert= one (min one) one) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
404 (Assert= one (min one one) one) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
405 (Assert= one (min one one one) one) |
| 428 | 406 (dolist (two `(2 2.0 ?\02 ,(Int-to-Marker 2))) |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
407 (Assert= one (min one two) (list one two)) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
408 (Assert= one (min one two two) (list one two)) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
409 (Assert= one (min two two one) (list one two)) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
410 (Assert= two (max one two) (list one two)) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
411 (Assert= two (max one two two) (list one two)) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
412 (Assert= two (max two two one) (list one two)))) |
| 428 | 413 |
| 1983 | 414 (when (featurep 'bignum) |
| 415 (let ((big (1+ most-positive-fixnum)) | |
| 416 (small (1- most-negative-fixnum))) | |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
417 (Assert= big (max 1 1000000.0 most-positive-fixnum big)) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
418 (Assert= small (min -1 -1000000.0 most-negative-fixnum small)))) |
| 1983 | 419 |
| 420 (when (featurep 'ratio) | |
| 421 (let* ((big (1+ most-positive-fixnum)) | |
| 422 (small (1- most-negative-fixnum)) | |
| 423 (bigr (div (* 5 (1+ most-positive-fixnum)) 4)) | |
| 424 (smallr (- bigr))) | |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
425 (Assert= bigr (max 1 1000000.0 most-positive-fixnum big bigr)) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
426 (Assert= smallr (min -1 -1000000.0 most-negative-fixnum small smallr)))) |
| 1983 | 427 |
| 446 | 428 ;; The byte compiler has special handling for these constructs: |
| 429 (let ((three 3) (five 5)) | |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
430 (Assert= (+ three five 1) 9) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
431 (Assert= (+ 1 three five) 9) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
432 (Assert= (+ three five -1) 7) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
433 (Assert= (+ -1 three five) 7) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
434 (Assert= (+ three 1) 4) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
435 (Assert= (+ three -1) 2) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
436 (Assert= (+ -1 three) 2) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
437 (Assert= (+ -1 three) 2) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
438 (Assert= (- three five 1) -3) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
439 (Assert= (- 1 three five) -7) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
440 (Assert= (- three five -1) -1) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
441 (Assert= (- -1 three five) -9) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
442 (Assert= (- three 1) 2) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
443 (Assert= (- three 2 1) 0) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
444 (Assert= (- 2 three 1) -2) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
445 (Assert= (- three -1) 4) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
446 (Assert= (- three 0) 3) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
447 (Assert= (- three 0 five) -2) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
448 (Assert= (- 0 three 0 five) -8) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
449 (Assert= (- 0 three five) -8) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
450 (Assert= (* three 2) 6) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
451 (Assert= (* three -1 five) -15) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
452 (Assert= (* three 1 five) 15) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
453 (Assert= (* three 0 five) 0) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
454 (Assert= (* three 2 five) 30) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
455 (Assert= (/ three 1) 3) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
456 (Assert= (/ three -1) -3) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
457 (Assert= (/ (* five five) 2 2) 6) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
458 (Assert= (/ 64 five 2) 6)) |
| 446 | 459 |
| 460 | |
| 428 | 461 ;;----------------------------------------------------- |
| 462 ;; Logical bit-twiddling operations | |
| 463 ;;----------------------------------------------------- | |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
464 (Assert= (logxor) 0) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
465 (Assert= (logior) 0) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
466 (Assert= (logand) -1) |
| 428 | 467 |
| 468 (Check-Error wrong-type-argument (logxor 3.0)) | |
| 469 (Check-Error wrong-type-argument (logior 3.0)) | |
| 470 (Check-Error wrong-type-argument (logand 3.0)) | |
| 471 | |
| 472 (dolist (three '(3 ?\03)) | |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
473 (Assert-eq 3 (logand three) three) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
474 (Assert-eq 3 (logxor three) three) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
475 (Assert-eq 3 (logior three) three) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
476 (Assert-eq 3 (logand three three) three) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
477 (Assert-eq 0 (logxor three three) three) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
478 (Assert-eq 3 (logior three three)) three) |
| 428 | 479 |
| 480 (dolist (one `(1 ?\01 ,(Int-to-Marker 1))) | |
| 481 (dolist (two '(2 ?\02)) | |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
482 (Assert-eq 0 (logand one two) (list one two)) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
483 (Assert-eq 3 (logior one two) (list one two)) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
484 (Assert-eq 3 (logxor one two) (list one two))) |
| 428 | 485 (dolist (three '(3 ?\03)) |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
486 (Assert-eq 1 (logand one three) (list one three)) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
487 (Assert-eq 3 (logior one three) (list one three)) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
488 (Assert-eq 2 (logxor one three) (list one three)))) |
| 428 | 489 |
| 490 ;;----------------------------------------------------- | |
| 491 ;; Test `%', mod | |
| 492 ;;----------------------------------------------------- | |
| 493 (Check-Error wrong-number-of-arguments (%)) | |
| 494 (Check-Error wrong-number-of-arguments (% 1)) | |
| 495 (Check-Error wrong-number-of-arguments (% 1 2 3)) | |
| 496 | |
| 497 (Check-Error wrong-number-of-arguments (mod)) | |
| 498 (Check-Error wrong-number-of-arguments (mod 1)) | |
| 499 (Check-Error wrong-number-of-arguments (mod 1 2 3)) | |
| 500 | |
| 501 (Check-Error wrong-type-argument (% 10.0 2)) | |
| 502 (Check-Error wrong-type-argument (% 10 2.0)) | |
| 503 | |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
504 (flet ((test1 (x) (Assert-eql x (+ (% x 17) (* (/ x 17) 17)) x)) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
505 (test2 (x) (Assert-eql (- x) (+ (% (- x) 17) (* (/ (- x) 17) 17)) x)) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
506 (test3 (x) (Assert-eql x (+ (% (- x) 17) (* (/ (- x) 17) 17)) x)) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
507 (test4 (x) (Assert-eql (% x -17) (- (% (- x) 17)) x)) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
508 (test5 (x) (Assert-eql (% x -17) (% (- x) 17)) x)) |
| 2056 | 509 (test1 most-negative-fixnum) |
| 510 (if (featurep 'bignum) | |
| 2075 | 511 (progn |
| 512 (test2 most-negative-fixnum) | |
| 513 (test4 most-negative-fixnum)) | |
| 514 (test3 most-negative-fixnum) | |
| 515 (test5 most-negative-fixnum)) | |
| 2056 | 516 (test1 most-positive-fixnum) |
| 517 (test2 most-positive-fixnum) | |
| 518 (test4 most-positive-fixnum) | |
| 519 (dotimes (j 30) | |
| 520 (let ((x (random))) | |
| 521 (if (eq x most-negative-fixnum) (setq x (1+ x))) | |
| 522 (if (eq x most-positive-fixnum) (setq x (1- x))) | |
| 523 (test1 x) | |
| 524 (test2 x) | |
| 525 (test4 x)))) | |
| 428 | 526 |
| 527 (macrolet | |
| 528 ((division-test (seven) | |
| 529 `(progn | |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
530 (Assert-eq (% ,seven 2) 1) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
531 (Assert-eq (% ,seven -2) 1) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
532 (Assert-eq (% (- ,seven) 2) -1) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
533 (Assert-eq (% (- ,seven) -2) -1) |
| 428 | 534 |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
535 (Assert-eq (% ,seven 4) 3) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
536 (Assert-eq (% ,seven -4) 3) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
537 (Assert-eq (% (- ,seven) 4) -3) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
538 (Assert-eq (% (- ,seven) -4) -3) |
| 428 | 539 |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
540 (Assert-eq (% 35 ,seven) 0) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
541 (Assert-eq (% -35 ,seven) 0) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
542 (Assert-eq (% 35 (- ,seven)) 0) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
543 (Assert-eq (% -35 (- ,seven)) 0) |
| 428 | 544 |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
545 (Assert-eq (mod ,seven 2) 1) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
546 (Assert-eq (mod ,seven -2) -1) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
547 (Assert-eq (mod (- ,seven) 2) 1) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
548 (Assert-eq (mod (- ,seven) -2) -1) |
| 428 | 549 |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
550 (Assert-eq (mod ,seven 4) 3) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
551 (Assert-eq (mod ,seven -4) -1) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
552 (Assert-eq (mod (- ,seven) 4) 1) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
553 (Assert-eq (mod (- ,seven) -4) -3) |
| 428 | 554 |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
555 (Assert-eq (mod 35 ,seven) 0) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
556 (Assert-eq (mod -35 ,seven) 0) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
557 (Assert-eq (mod 35 (- ,seven)) 0) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
558 (Assert-eq (mod -35 (- ,seven)) 0) |
| 428 | 559 |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
560 (Assert= (mod ,seven 2.0) 1.0) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
561 (Assert= (mod ,seven -2.0) -1.0) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
562 (Assert= (mod (- ,seven) 2.0) 1.0) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
563 (Assert= (mod (- ,seven) -2.0) -1.0) |
| 428 | 564 |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
565 (Assert= (mod ,seven 4.0) 3.0) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
566 (Assert= (mod ,seven -4.0) -1.0) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
567 (Assert= (mod (- ,seven) 4.0) 1.0) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
568 (Assert= (mod (- ,seven) -4.0) -3.0) |
| 428 | 569 |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
570 (Assert-eq (% 0 ,seven) 0) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
571 (Assert-eq (% 0 (- ,seven)) 0) |
| 428 | 572 |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
573 (Assert-eq (mod 0 ,seven) 0) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
574 (Assert-eq (mod 0 (- ,seven)) 0) |
| 428 | 575 |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
576 (Assert= (mod 0.0 ,seven) 0.0) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
577 (Assert= (mod 0.0 (- ,seven)) 0.0)))) |
| 428 | 578 |
| 579 (division-test 7) | |
| 580 (division-test ?\07) | |
| 581 (division-test (Int-to-Marker 7))) | |
| 582 | |
| 1983 | 583 (when (featurep 'bignum) |
| 584 (let ((big (+ (* 7 most-positive-fixnum 6))) | |
| 585 (negbig (- (* 7 most-negative-fixnum 6)))) | |
| 586 (= (% big (1+ most-positive-fixnum)) most-positive-fixnum) | |
| 587 (= (% negbig (1- most-negative-fixnum)) most-negative-fixnum) | |
| 588 (= (mod big (1+ most-positive-fixnum)) most-positive-fixnum) | |
| 589 (= (mod negbig (1- most-negative-fixnum)) most-negative-fixnum))) | |
| 428 | 590 |
| 591 ;;----------------------------------------------------- | |
| 592 ;; Arithmetic comparison operations | |
| 593 ;;----------------------------------------------------- | |
| 594 (Check-Error wrong-number-of-arguments (=)) | |
| 595 (Check-Error wrong-number-of-arguments (<)) | |
| 596 (Check-Error wrong-number-of-arguments (>)) | |
| 597 (Check-Error wrong-number-of-arguments (<=)) | |
| 598 (Check-Error wrong-number-of-arguments (>=)) | |
| 599 (Check-Error wrong-number-of-arguments (/=)) | |
| 600 | |
| 601 ;; One argument always yields t | |
| 602 (loop for x in `(1 1.0 ,(Int-to-Marker 1) ?z) do | |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
603 (Assert-eq t (= x) x) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
604 (Assert-eq t (< x) x) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
605 (Assert-eq t (> x) x) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
606 (Assert-eq t (>= x) x) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
607 (Assert-eq t (<= x) x) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
608 (Assert-eq t (/= x) x) |
| 428 | 609 ) |
| 610 | |
| 611 ;; Type checking | |
| 612 (Check-Error wrong-type-argument (= 'foo 1)) | |
| 613 (Check-Error wrong-type-argument (<= 'foo 1)) | |
| 614 (Check-Error wrong-type-argument (>= 'foo 1)) | |
| 615 (Check-Error wrong-type-argument (< 'foo 1)) | |
| 616 (Check-Error wrong-type-argument (> 'foo 1)) | |
| 617 (Check-Error wrong-type-argument (/= 'foo 1)) | |
| 618 | |
| 619 ;; Meat | |
| 620 (dolist (one `(1 1.0 ,(Int-to-Marker 1) ?\01)) | |
| 621 (dolist (two '(2 2.0 ?\02)) | |
| 2056 | 622 (Assert (< one two) (list one two)) |
| 623 (Assert (<= one two) (list one two)) | |
| 624 (Assert (<= two two) two) | |
| 625 (Assert (> two one) (list one two)) | |
| 626 (Assert (>= two one) (list one two)) | |
| 627 (Assert (>= two two) two) | |
| 628 (Assert (/= one two) (list one two)) | |
| 629 (Assert (not (/= two two)) two) | |
| 630 (Assert (not (< one one)) one) | |
| 631 (Assert (not (> one one)) one) | |
| 632 (Assert (<= one one two two) (list one two)) | |
| 633 (Assert (not (< one one two two)) (list one two)) | |
| 634 (Assert (>= two two one one) (list one two)) | |
| 635 (Assert (not (> two two one one)) (list one two)) | |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
636 (Assert= one one one one) |
| 2056 | 637 (Assert (not (= one one one two)) (list one two)) |
| 638 (Assert (not (/= one two one)) (list one two)) | |
| 428 | 639 )) |
| 640 | |
| 641 (dolist (one `(1 1.0 ,(Int-to-Marker 1) ?\01)) | |
| 642 (dolist (two '(2 2.0 ?\02)) | |
| 2056 | 643 (Assert (< one two) (list one two)) |
| 644 (Assert (<= one two) (list one two)) | |
| 645 (Assert (<= two two) two) | |
| 646 (Assert (> two one) (list one two)) | |
| 647 (Assert (>= two one) (list one two)) | |
| 648 (Assert (>= two two) two) | |
| 649 (Assert (/= one two) (list one two)) | |
| 650 (Assert (not (/= two two)) two) | |
| 651 (Assert (not (< one one)) one) | |
| 652 (Assert (not (> one one)) one) | |
| 653 (Assert (<= one one two two) (list one two)) | |
| 654 (Assert (not (< one one two two)) (list one two)) | |
| 655 (Assert (>= two two one one) (list one two)) | |
| 656 (Assert (not (> two two one one)) (list one two)) | |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
657 (Assert= one one one one) |
| 2056 | 658 (Assert (not (= one one one two)) (list one two)) |
| 659 (Assert (not (/= one two one)) (list one two)) | |
| 428 | 660 )) |
| 661 | |
| 662 ;; ad-hoc | |
| 663 (Assert (< 1 2)) | |
| 664 (Assert (< 1 2 3 4 5 6)) | |
| 665 (Assert (not (< 1 1))) | |
| 666 (Assert (not (< 2 1))) | |
| 667 | |
| 668 | |
| 669 (Assert (not (< 1 1))) | |
| 670 (Assert (< 1 2 3 4 5 6)) | |
| 671 (Assert (<= 1 2 3 4 5 6)) | |
| 672 (Assert (<= 1 2 3 4 5 6 6)) | |
| 673 (Assert (not (< 1 2 3 4 5 6 6))) | |
| 674 (Assert (<= 1 1)) | |
| 675 | |
| 676 (Assert (not (eq (point) (point-marker)))) | |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
677 (Assert= 1 (Int-to-Marker 1)) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
678 (Assert= (point) (point-marker)) |
| 428 | 679 |
| 1983 | 680 (when (featurep 'bignum) |
| 681 (let ((big1 (1+ most-positive-fixnum)) | |
| 682 (big2 (* 10 most-positive-fixnum)) | |
| 683 (small1 (1- most-negative-fixnum)) | |
| 684 (small2 (* 10 most-negative-fixnum))) | |
| 685 (Assert (< small2 small1 most-negative-fixnum most-positive-fixnum big1 | |
| 686 big2)) | |
| 687 (Assert (<= small2 small1 most-negative-fixnum most-positive-fixnum big1 | |
| 688 big2)) | |
| 689 (Assert (> big2 big1 most-positive-fixnum most-negative-fixnum small1 | |
| 690 small2)) | |
| 691 (Assert (>= big2 big1 most-positive-fixnum most-negative-fixnum small1 | |
| 692 small2)) | |
| 693 (Assert (/= small2 small1 most-negative-fixnum most-positive-fixnum big1 | |
| 694 big2)))) | |
| 695 | |
| 696 (when (featurep 'ratio) | |
| 697 (let ((big1 (div (* 10 most-positive-fixnum) 4)) | |
| 698 (big2 (div (* 5 most-positive-fixnum) 2)) | |
| 699 (big3 (div (* 7 most-positive-fixnum) 2)) | |
| 700 (small1 (div (* 10 most-negative-fixnum) 4)) | |
| 701 (small2 (div (* 5 most-negative-fixnum) 2)) | |
| 702 (small3 (div (* 7 most-negative-fixnum) 2))) | |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
703 (Assert= big1 big2) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
704 (Assert= small1 small2) |
| 1983 | 705 (Assert (< small3 small1 most-negative-fixnum most-positive-fixnum big1 |
| 706 big3)) | |
| 707 (Assert (<= small3 small2 small1 most-negative-fixnum most-positive-fixnum | |
| 708 big1 big2 big3)) | |
| 709 (Assert (> big3 big1 most-positive-fixnum most-negative-fixnum small1 | |
| 710 small3)) | |
| 711 (Assert (>= big3 big2 big1 most-positive-fixnum most-negative-fixnum | |
| 712 small1 small2 small3)) | |
| 713 (Assert (/= big3 big1 most-positive-fixnum most-negative-fixnum small1 | |
| 714 small3)))) | |
| 715 | |
| 428 | 716 ;;----------------------------------------------------- |
| 717 ;; testing list-walker functions | |
| 718 ;;----------------------------------------------------- | |
| 719 (macrolet | |
| 720 ((test-fun | |
| 721 (fun) | |
| 722 `(progn | |
| 723 (Check-Error wrong-number-of-arguments (,fun)) | |
| 724 (Check-Error wrong-number-of-arguments (,fun nil)) | |
| 725 (Check-Error malformed-list (,fun nil 1)) | |
| 726 ,@(loop for n in '(1 2 2000) | |
| 727 collect `(Check-Error circular-list (,fun 1 (make-circular-list ,n)))))) | |
| 728 (test-funs (&rest funs) `(progn ,@(loop for fun in funs collect `(test-fun ,fun))))) | |
| 729 | |
| 730 (test-funs member old-member | |
| 731 memq old-memq | |
| 732 assoc old-assoc | |
| 733 rassoc old-rassoc | |
| 734 rassq old-rassq | |
| 735 delete old-delete | |
| 736 delq old-delq | |
| 737 remassoc remassq remrassoc remrassq)) | |
| 738 | |
| 739 (let ((x '((1 . 2) 3 (4 . 5)))) | |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
740 (Assert-eq (assoc 1 x) (car x)) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
741 (Assert-eq (assq 1 x) (car x)) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
742 (Assert-eq (rassoc 1 x) nil) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
743 (Assert-eq (rassq 1 x) nil) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
744 (Assert-eq (assoc 2 x) nil) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
745 (Assert-eq (assq 2 x) nil) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
746 (Assert-eq (rassoc 2 x) (car x)) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
747 (Assert-eq (rassq 2 x) (car x)) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
748 (Assert-eq (assoc 3 x) nil) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
749 (Assert-eq (assq 3 x) nil) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
750 (Assert-eq (rassoc 3 x) nil) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
751 (Assert-eq (rassq 3 x) nil) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
752 (Assert-eq (assoc 4 x) (caddr x)) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
753 (Assert-eq (assq 4 x) (caddr x)) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
754 (Assert-eq (rassoc 4 x) nil) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
755 (Assert-eq (rassq 4 x) nil) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
756 (Assert-eq (assoc 5 x) nil) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
757 (Assert-eq (assq 5 x) nil) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
758 (Assert-eq (rassoc 5 x) (caddr x)) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
759 (Assert-eq (rassq 5 x) (caddr x)) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
760 (Assert-eq (assoc 6 x) nil) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
761 (Assert-eq (assq 6 x) nil) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
762 (Assert-eq (rassoc 6 x) nil) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
763 (Assert-eq (rassq 6 x) nil)) |
| 428 | 764 |
| 765 (let ((x '(("1" . "2") "3" ("4" . "5")))) | |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
766 (Assert-eq (assoc "1" x) (car x)) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
767 (Assert-eq (assq "1" x) nil) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
768 (Assert-eq (rassoc "1" x) nil) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
769 (Assert-eq (rassq "1" x) nil) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
770 (Assert-eq (assoc "2" x) nil) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
771 (Assert-eq (assq "2" x) nil) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
772 (Assert-eq (rassoc "2" x) (car x)) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
773 (Assert-eq (rassq "2" x) nil) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
774 (Assert-eq (assoc "3" x) nil) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
775 (Assert-eq (assq "3" x) nil) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
776 (Assert-eq (rassoc "3" x) nil) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
777 (Assert-eq (rassq "3" x) nil) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
778 (Assert-eq (assoc "4" x) (caddr x)) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
779 (Assert-eq (assq "4" x) nil) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
780 (Assert-eq (rassoc "4" x) nil) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
781 (Assert-eq (rassq "4" x) nil) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
782 (Assert-eq (assoc "5" x) nil) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
783 (Assert-eq (assq "5" x) nil) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
784 (Assert-eq (rassoc "5" x) (caddr x)) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
785 (Assert-eq (rassq "5" x) nil) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
786 (Assert-eq (assoc "6" x) nil) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
787 (Assert-eq (assq "6" x) nil) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
788 (Assert-eq (rassoc "6" x) nil) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
789 (Assert-eq (rassq "6" x) nil)) |
| 428 | 790 |
| 791 (flet ((a () (list '(1 . 2) 3 '(4 . 5)))) | |
| 792 (Assert (let* ((x (a)) (y (remassoc 1 x))) (and (not (eq x y)) (equal y '(3 (4 . 5)))))) | |
| 793 (Assert (let* ((x (a)) (y (remassq 1 x))) (and (not (eq x y)) (equal y '(3 (4 . 5)))))) | |
| 794 (Assert (let* ((x (a)) (y (remrassoc 1 x))) (and (eq x y) (equal y (a))))) | |
| 795 (Assert (let* ((x (a)) (y (remrassq 1 x))) (and (eq x y) (equal y (a))))) | |
| 796 | |
| 797 (Assert (let* ((x (a)) (y (remassoc 2 x))) (and (eq x y) (equal y (a))))) | |
| 798 (Assert (let* ((x (a)) (y (remassq 2 x))) (and (eq x y) (equal y (a))))) | |
| 799 (Assert (let* ((x (a)) (y (remrassoc 2 x))) (and (not (eq x y)) (equal y '(3 (4 . 5)))))) | |
| 800 (Assert (let* ((x (a)) (y (remrassq 2 x))) (and (not (eq x y)) (equal y '(3 (4 . 5)))))) | |
| 801 | |
| 802 (Assert (let* ((x (a)) (y (remassoc 3 x))) (and (eq x y) (equal y (a))))) | |
| 803 (Assert (let* ((x (a)) (y (remassq 3 x))) (and (eq x y) (equal y (a))))) | |
| 804 (Assert (let* ((x (a)) (y (remrassoc 3 x))) (and (eq x y) (equal y (a))))) | |
| 805 (Assert (let* ((x (a)) (y (remrassq 3 x))) (and (eq x y) (equal y (a))))) | |
| 806 | |
| 807 (Assert (let* ((x (a)) (y (remassoc 4 x))) (and (eq x y) (equal y '((1 . 2) 3))))) | |
| 808 (Assert (let* ((x (a)) (y (remassq 4 x))) (and (eq x y) (equal y '((1 . 2) 3))))) | |
| 809 (Assert (let* ((x (a)) (y (remrassoc 4 x))) (and (eq x y) (equal y (a))))) | |
| 810 (Assert (let* ((x (a)) (y (remrassq 4 x))) (and (eq x y) (equal y (a))))) | |
| 811 | |
| 812 (Assert (let* ((x (a)) (y (remassoc 5 x))) (and (eq x y) (equal y (a))))) | |
| 813 (Assert (let* ((x (a)) (y (remassq 5 x))) (and (eq x y) (equal y (a))))) | |
| 814 (Assert (let* ((x (a)) (y (remrassoc 5 x))) (and (eq x y) (equal y '((1 . 2) 3))))) | |
| 815 (Assert (let* ((x (a)) (y (remrassq 5 x))) (and (eq x y) (equal y '((1 . 2) 3))))) | |
| 816 | |
| 817 (Assert (let* ((x (a)) (y (remassoc 6 x))) (and (eq x y) (equal y (a))))) | |
| 818 (Assert (let* ((x (a)) (y (remassq 6 x))) (and (eq x y) (equal y (a))))) | |
| 819 (Assert (let* ((x (a)) (y (remrassoc 6 x))) (and (eq x y) (equal y (a))))) | |
| 820 (Assert (let* ((x (a)) (y (remrassq 6 x))) (and (eq x y) (equal y (a))))) | |
| 821 | |
| 822 (Assert (let* ((x (a)) (y (delete 3 x))) (and (eq x y) (equal y '((1 . 2) (4 . 5)))))) | |
| 823 (Assert (let* ((x (a)) (y (delq 3 x))) (and (eq x y) (equal y '((1 . 2) (4 . 5)))))) | |
| 824 (Assert (let* ((x (a)) (y (old-delete 3 x))) (and (eq x y) (equal y '((1 . 2) (4 . 5)))))) | |
| 825 (Assert (let* ((x (a)) (y (old-delq 3 x))) (and (eq x y) (equal y '((1 . 2) (4 . 5)))))) | |
| 826 | |
| 827 (Assert (let* ((x (a)) (y (delete '(1 . 2) x))) (and (not (eq x y)) (equal y '(3 (4 . 5)))))) | |
| 828 (Assert (let* ((x (a)) (y (delq '(1 . 2) x))) (and (eq x y) (equal y (a))))) | |
| 829 (Assert (let* ((x (a)) (y (old-delete '(1 . 2) x))) (and (not (eq x y)) (equal y '(3 (4 . 5)))))) | |
| 830 (Assert (let* ((x (a)) (y (old-delq '(1 . 2) x))) (and (eq x y) (equal y (a))))) | |
| 831 ) | |
| 832 | |
| 833 | |
| 834 | |
| 835 (flet ((a () (list '("1" . "2") "3" '("4" . "5")))) | |
| 836 (Assert (let* ((x (a)) (y (remassoc "1" x))) (and (not (eq x y)) (equal y '("3" ("4" . "5")))))) | |
| 837 (Assert (let* ((x (a)) (y (remassq "1" x))) (and (eq x y) (equal y (a))))) | |
| 838 (Assert (let* ((x (a)) (y (remrassoc "1" x))) (and (eq x y) (equal y (a))))) | |
| 839 (Assert (let* ((x (a)) (y (remrassq "1" x))) (and (eq x y) (equal y (a))))) | |
| 840 | |
| 841 (Assert (let* ((x (a)) (y (remassoc "2" x))) (and (eq x y) (equal y (a))))) | |
| 842 (Assert (let* ((x (a)) (y (remassq "2" x))) (and (eq x y) (equal y (a))))) | |
| 843 (Assert (let* ((x (a)) (y (remrassoc "2" x))) (and (not (eq x y)) (equal y '("3" ("4" . "5")))))) | |
| 844 (Assert (let* ((x (a)) (y (remrassq "2" x))) (and (eq x y) (equal y (a))))) | |
| 845 | |
| 846 (Assert (let* ((x (a)) (y (remassoc "3" x))) (and (eq x y) (equal y (a))))) | |
| 847 (Assert (let* ((x (a)) (y (remassq "3" x))) (and (eq x y) (equal y (a))))) | |
| 848 (Assert (let* ((x (a)) (y (remrassoc "3" x))) (and (eq x y) (equal y (a))))) | |
| 849 (Assert (let* ((x (a)) (y (remrassq "3" x))) (and (eq x y) (equal y (a))))) | |
| 850 | |
| 851 (Assert (let* ((x (a)) (y (remassoc "4" x))) (and (eq x y) (equal y '(("1" . "2") "3"))))) | |
| 852 (Assert (let* ((x (a)) (y (remassq "4" x))) (and (eq x y) (equal y (a))))) | |
| 853 (Assert (let* ((x (a)) (y (remrassoc "4" x))) (and (eq x y) (equal y (a))))) | |
| 854 (Assert (let* ((x (a)) (y (remrassq "4" x))) (and (eq x y) (equal y (a))))) | |
| 855 | |
| 856 (Assert (let* ((x (a)) (y (remassoc "5" x))) (and (eq x y) (equal y (a))))) | |
| 857 (Assert (let* ((x (a)) (y (remassq "5" x))) (and (eq x y) (equal y (a))))) | |
| 858 (Assert (let* ((x (a)) (y (remrassoc "5" x))) (and (eq x y) (equal y '(("1" . "2") "3"))))) | |
| 859 (Assert (let* ((x (a)) (y (remrassq "5" x))) (and (eq x y) (equal y (a))))) | |
| 860 | |
| 861 (Assert (let* ((x (a)) (y (remassoc "6" x))) (and (eq x y) (equal y (a))))) | |
| 862 (Assert (let* ((x (a)) (y (remassq "6" x))) (and (eq x y) (equal y (a))))) | |
| 863 (Assert (let* ((x (a)) (y (remrassoc "6" x))) (and (eq x y) (equal y (a))))) | |
| 864 (Assert (let* ((x (a)) (y (remrassq "6" x))) (and (eq x y) (equal y (a)))))) | |
| 865 | |
| 866 ;;----------------------------------------------------- | |
| 867 ;; function-max-args, function-min-args | |
| 868 ;;----------------------------------------------------- | |
| 869 (defmacro check-function-argcounts (fun min max) | |
| 870 `(progn | |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
871 (Assert-eq (function-min-args ,fun) ,min) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
872 (Assert-eq (function-max-args ,fun) ,max))) |
| 428 | 873 |
| 874 (check-function-argcounts 'prog1 1 nil) ; special form | |
| 875 (check-function-argcounts 'command-execute 1 3) ; normal subr | |
| 876 (check-function-argcounts 'funcall 1 nil) ; `MANY' subr | |
| 877 (check-function-argcounts 'garbage-collect 0 0) ; no args subr | |
| 878 | |
| 879 ;; Test interpreted and compiled functions | |
| 880 (loop for (arglist min max) in | |
| 881 '(((arg1 arg2 &rest args) 2 nil) | |
| 882 ((arg1 arg2 &optional arg3 arg4) 2 4) | |
| 883 ((arg1 arg2 &optional arg3 arg4 &rest args) 2 nil) | |
| 884 (() 0 0)) | |
| 885 do | |
| 886 (eval | |
| 887 `(progn | |
| 888 (defun test-fun ,arglist nil) | |
| 889 (check-function-argcounts '(lambda ,arglist nil) ,min ,max) | |
| 890 (check-function-argcounts (byte-compile '(lambda ,arglist nil)) ,min ,max)))) | |
| 891 | |
|
4575
eecd28508f4a
Add #'subr-arity, API taken from GNU, implementation our own.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4396
diff
changeset
|
892 ;; Test subr-arity. |
|
eecd28508f4a
Add #'subr-arity, API taken from GNU, implementation our own.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4396
diff
changeset
|
893 (loop for (function-name arity) in |
|
eecd28508f4a
Add #'subr-arity, API taken from GNU, implementation our own.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4396
diff
changeset
|
894 '((let (1 . unevalled)) |
|
eecd28508f4a
Add #'subr-arity, API taken from GNU, implementation our own.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4396
diff
changeset
|
895 (prog1 (1 . unevalled)) |
|
eecd28508f4a
Add #'subr-arity, API taken from GNU, implementation our own.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4396
diff
changeset
|
896 (list (0 . many)) |
|
eecd28508f4a
Add #'subr-arity, API taken from GNU, implementation our own.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4396
diff
changeset
|
897 (type-of (1 . 1)) |
|
eecd28508f4a
Add #'subr-arity, API taken from GNU, implementation our own.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4396
diff
changeset
|
898 (garbage-collect (0 . 0))) |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
899 do (Assert-equal (subr-arity (symbol-function function-name)) arity)) |
|
4575
eecd28508f4a
Add #'subr-arity, API taken from GNU, implementation our own.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4396
diff
changeset
|
900 |
|
eecd28508f4a
Add #'subr-arity, API taken from GNU, implementation our own.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4396
diff
changeset
|
901 (Check-Error wrong-type-argument (subr-arity |
|
eecd28508f4a
Add #'subr-arity, API taken from GNU, implementation our own.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4396
diff
changeset
|
902 (lambda () (message "Hi there!")))) |
|
eecd28508f4a
Add #'subr-arity, API taken from GNU, implementation our own.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4396
diff
changeset
|
903 |
|
eecd28508f4a
Add #'subr-arity, API taken from GNU, implementation our own.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4396
diff
changeset
|
904 (Check-Error wrong-type-argument (subr-arity nil)) |
|
eecd28508f4a
Add #'subr-arity, API taken from GNU, implementation our own.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4396
diff
changeset
|
905 |
| 428 | 906 ;;----------------------------------------------------- |
| 907 ;; Detection of cyclic variable indirection loops | |
| 908 ;;----------------------------------------------------- | |
| 909 (fset 'test-sym1 'test-sym1) | |
| 910 (Check-Error cyclic-function-indirection (test-sym1)) | |
| 911 | |
| 912 (fset 'test-sym1 'test-sym2) | |
| 913 (fset 'test-sym2 'test-sym1) | |
| 914 (Check-Error cyclic-function-indirection (test-sym1)) | |
| 915 (fmakunbound 'test-sym1) ; else macroexpand-internal infloops! | |
| 916 (fmakunbound 'test-sym2) | |
| 917 | |
| 918 ;;----------------------------------------------------- | |
| 919 ;; Test `type-of' | |
| 920 ;;----------------------------------------------------- | |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
921 (Assert-eq (type-of load-path) 'cons) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
922 (Assert-eq (type-of obarray) 'vector) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
923 (Assert-eq (type-of 42) 'integer) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
924 (Assert-eq (type-of ?z) 'character) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
925 (Assert-eq (type-of "42") 'string) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
926 (Assert-eq (type-of 'foo) 'symbol) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
927 (Assert-eq (type-of (selected-device)) 'device) |
| 428 | 928 |
| 929 ;;----------------------------------------------------- | |
| 930 ;; Test mapping functions | |
| 931 ;;----------------------------------------------------- | |
| 932 (Check-Error wrong-type-argument (mapcar #'identity (current-buffer))) | |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
933 (Assert-equal (mapcar #'identity load-path) load-path) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
934 (Assert-equal (mapcar #'identity '(1 2 3)) '(1 2 3)) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
935 (Assert-equal (mapcar #'identity "123") '(?1 ?2 ?3)) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
936 (Assert-equal (mapcar #'identity [1 2 3]) '(1 2 3)) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
937 (Assert-equal (mapcar #'identity #*010) '(0 1 0)) |
| 428 | 938 |
| 939 (let ((z 0) (list (make-list 1000 1))) | |
| 940 (mapc (lambda (x) (incf z x)) list) | |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
941 (Assert-eq 1000 z)) |
| 428 | 942 |
| 943 (Check-Error wrong-type-argument (mapvector #'identity (current-buffer))) | |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
944 (Assert-equal (mapvector #'identity '(1 2 3)) [1 2 3]) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
945 (Assert-equal (mapvector #'identity "123") [?1 ?2 ?3]) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
946 (Assert-equal (mapvector #'identity [1 2 3]) [1 2 3]) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
947 (Assert-equal (mapvector #'identity #*010) [0 1 0]) |
| 428 | 948 |
| 949 (Check-Error wrong-type-argument (mapconcat #'identity (current-buffer) "foo")) | |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
950 (Assert-equal (mapconcat #'identity '("1" "2" "3") "|") "1|2|3") |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
951 (Assert-equal (mapconcat #'identity ["1" "2" "3"] "|") "1|2|3") |
| 428 | 952 |
| 434 | 953 ;; The following 2 functions used to crash XEmacs via mapcar1(). |
| 954 ;; We don't test the actual values of the mapcar, since they're undefined. | |
| 446 | 955 (Assert |
| 434 | 956 (let ((x (list (cons 1 1) (cons 2 2) (cons 3 3)))) |
| 957 (mapcar | |
| 958 (lambda (y) | |
| 959 "Devious evil mapping function" | |
| 960 (when (eq (car y) 2) ; go out onto a limb | |
| 961 (setcdr x nil) ; cut it off behind us | |
| 962 (garbage-collect)) ; are we riding a magic broomstick? | |
| 963 (car y)) ; sorry, hard landing | |
| 964 x))) | |
| 965 | |
| 446 | 966 (Assert |
| 434 | 967 (let ((x (list (cons 1 1) (cons 2 2) (cons 3 3)))) |
| 968 (mapcar | |
| 969 (lambda (y) | |
| 970 "Devious evil mapping function" | |
| 971 (when (eq (car y) 1) | |
| 972 (setcdr (cdr x) 42)) ; drop a brick wall onto the freeway | |
| 973 (car y)) | |
| 974 x))) | |
| 975 | |
|
5034
1b96882bdf37
Fix a multiple-value bug, mapcarX; correct a comment and a label name.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4906
diff
changeset
|
976 (Assert-eql |
|
1b96882bdf37
Fix a multiple-value bug, mapcarX; correct a comment and a label name.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4906
diff
changeset
|
977 (length (multiple-value-list |
|
1b96882bdf37
Fix a multiple-value bug, mapcarX; correct a comment and a label name.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4906
diff
changeset
|
978 (car (mapcar #'(lambda (argument) (floor argument)) (list pi e))))) |
|
1b96882bdf37
Fix a multiple-value bug, mapcarX; correct a comment and a label name.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4906
diff
changeset
|
979 1 |
|
1b96882bdf37
Fix a multiple-value bug, mapcarX; correct a comment and a label name.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4906
diff
changeset
|
980 "checking multiple values are correctly discarded in mapcar") |
|
1b96882bdf37
Fix a multiple-value bug, mapcarX; correct a comment and a label name.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4906
diff
changeset
|
981 |
| 428 | 982 ;;----------------------------------------------------- |
| 983 ;; Test vector functions | |
| 984 ;;----------------------------------------------------- | |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
985 (Assert-equal [1 2 3] [1 2 3]) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
986 (Assert-equal [] []) |
| 428 | 987 (Assert (not (equal [1 2 3] []))) |
| 988 (Assert (not (equal [1 2 3] [1 2 4]))) | |
| 989 (Assert (not (equal [0 2 3] [1 2 3]))) | |
| 990 (Assert (not (equal [1 2 3] [1 2 3 4]))) | |
| 991 (Assert (not (equal [1 2 3 4] [1 2 3]))) | |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
992 (Assert-equal (vector 1 2 3) [1 2 3]) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
993 (Assert-equal (make-vector 3 1) [1 1 1]) |
| 428 | 994 |
| 995 ;;----------------------------------------------------- | |
| 996 ;; Test bit-vector functions | |
| 997 ;;----------------------------------------------------- | |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
998 (Assert-equal #*010 #*010) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
999 (Assert-equal #* #*) |
| 428 | 1000 (Assert (not (equal #*010 #*011))) |
| 1001 (Assert (not (equal #*010 #*))) | |
| 1002 (Assert (not (equal #*110 #*010))) | |
| 1003 (Assert (not (equal #*010 #*0100))) | |
| 1004 (Assert (not (equal #*0101 #*010))) | |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1005 (Assert-equal (bit-vector 0 1 0) #*010) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1006 (Assert-equal (make-bit-vector 3 1) #*111) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1007 (Assert-equal (make-bit-vector 3 0) #*000) |
| 428 | 1008 |
| 1009 ;;----------------------------------------------------- | |
| 1010 ;; Test buffer-local variables used as (ugh!) function parameters | |
| 1011 ;;----------------------------------------------------- | |
| 1012 (make-local-variable 'test-emacs-buffer-local-variable) | |
| 1013 (byte-compile | |
| 1014 (defun test-emacs-buffer-local-parameter (test-emacs-buffer-local-variable) | |
| 1015 (setq test-emacs-buffer-local-variable nil))) | |
| 1016 (test-emacs-buffer-local-parameter nil) | |
| 1017 | |
| 1018 ;;----------------------------------------------------- | |
| 1019 ;; Test split-string | |
| 1020 ;;----------------------------------------------------- | |
| 1425 | 1021 ;; Keep nulls, explicit SEPARATORS |
| 1022 ;; Hrvoje didn't like the next 3 tests so I'm disabling them for now. -sb | |
| 1023 ;; I assume Hrvoje worried about the possibility of infloops. -sjt | |
| 1024 (when test-harness-risk-infloops | |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1025 (Assert-equal (split-string "foo" "") '("" "f" "o" "o" "")) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1026 (Assert-equal (split-string "foo" "^") '("" "foo")) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1027 (Assert-equal (split-string "foo" "$") '("foo" ""))) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1028 (Assert-equal (split-string "foo,bar" ",") '("foo" "bar")) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1029 (Assert-equal (split-string ",foo,bar," ",") '("" "foo" "bar" "")) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1030 (Assert-equal (split-string ",foo,bar," "^,") '("" "foo,bar,")) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1031 (Assert-equal (split-string ",foo,bar," ",$") '(",foo,bar" "")) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1032 (Assert-equal (split-string ",foo,,bar," ",") '("" "foo" "" "bar" "")) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1033 (Assert-equal (split-string "foo,,,bar" ",") '("foo" "" "" "bar")) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1034 (Assert-equal (split-string "foo,,bar,," ",") '("foo" "" "bar" "" "")) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1035 (Assert-equal (split-string "foo,,bar" ",+") '("foo" "bar")) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1036 (Assert-equal (split-string ",foo,,bar," ",+") '("" "foo" "bar" "")) |
| 1425 | 1037 ;; Omit nulls, explicit SEPARATORS |
| 1038 (when test-harness-risk-infloops | |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1039 (Assert-equal (split-string "foo" "" t) '("f" "o" "o")) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1040 (Assert-equal (split-string "foo" "^" t) '("foo")) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1041 (Assert-equal (split-string "foo" "$" t) '("foo"))) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1042 (Assert-equal (split-string "foo,bar" "," t) '("foo" "bar")) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1043 (Assert-equal (split-string ",foo,bar," "," t) '("foo" "bar")) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1044 (Assert-equal (split-string ",foo,bar," "^," t) '("foo,bar,")) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1045 (Assert-equal (split-string ",foo,bar," ",$" t) '(",foo,bar")) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1046 (Assert-equal (split-string ",foo,,bar," "," t) '("foo" "bar")) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1047 (Assert-equal (split-string "foo,,,bar" "," t) '("foo" "bar")) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1048 (Assert-equal (split-string "foo,,bar,," "," t) '("foo" "bar")) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1049 (Assert-equal (split-string "foo,,bar" ",+" t) '("foo" "bar")) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1050 (Assert-equal (split-string ",foo,,bar," ",+" t) '("foo" "bar")) |
| 1425 | 1051 ;; "Double-default" case |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1052 (Assert-equal (split-string "foo bar") '("foo" "bar")) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1053 (Assert-equal (split-string " foo bar ") '("foo" "bar")) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1054 (Assert-equal (split-string " foo bar ") '("foo" "bar")) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1055 (Assert-equal (split-string "foo bar") '("foo" "bar")) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1056 (Assert-equal (split-string "foo bar ") '("foo" "bar")) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1057 (Assert-equal (split-string "foobar") '("foobar")) |
| 1425 | 1058 ;; Semantics are identical to "double-default" case! Fool ya? |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1059 (Assert-equal (split-string "foo bar" nil t) '("foo" "bar")) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1060 (Assert-equal (split-string " foo bar " nil t) '("foo" "bar")) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1061 (Assert-equal (split-string " foo bar " nil t) '("foo" "bar")) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1062 (Assert-equal (split-string "foo bar" nil t) '("foo" "bar")) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1063 (Assert-equal (split-string "foo bar " nil t) '("foo" "bar")) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1064 (Assert-equal (split-string "foobar" nil t) '("foobar")) |
| 1425 | 1065 ;; Perverse "anti-double-default" case |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1066 (Assert-equal (split-string "foo bar" split-string-default-separators) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1067 '("foo" "bar")) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1068 (Assert-equal (split-string " foo bar " split-string-default-separators) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1069 '("" "foo" "bar" "")) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1070 (Assert-equal (split-string " foo bar " split-string-default-separators) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1071 '("" "foo" "bar" "")) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1072 (Assert-equal (split-string "foo bar" split-string-default-separators) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1073 '("foo" "bar")) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1074 (Assert-equal (split-string "foo bar " split-string-default-separators) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1075 '("foo" "bar" "")) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1076 (Assert-equal (split-string "foobar" split-string-default-separators) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1077 '("foobar")) |
| 434 | 1078 |
| 1079 ;;----------------------------------------------------- | |
|
5035
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1080 ;; Test split-string-by-char |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1081 ;;----------------------------------------------------- |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1082 |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1083 (Assert |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1084 (equal |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1085 (split-string-by-char |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1086 #r"re\:ee:this\\is\\text\\\\:oo\ps: |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1087 Eine Sprache, die stagnirt, ist zu vergleichen mit einem See, dem der |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1088 bisherige Quellenzufluß versiegt oder abgeleitet wird. Aus dem Wasser, |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1089 worüber der Geist Gottes schwebte, wird Sumpf und Moder, worüber die |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1090 unreinen\: Geister brüten.\\ |
|
5036
9624523604c5
Use better types when ESCAPECHAR is specified, split_string_by_ichar_1
Aidan Kehoe <kehoea@parhasard.net>
parents:
5035
diff
changeset
|
1091 Serum concentrations of vitamin E: (alpha-tocopherol) depend on the liver, |
|
9624523604c5
Use better types when ESCAPECHAR is specified, split_string_by_ichar_1
Aidan Kehoe <kehoea@parhasard.net>
parents:
5035
diff
changeset
|
1092 which takes up the nutrient after the various forms are absorbed from the |
|
9624523604c5
Use better types when ESCAPECHAR is specified, split_string_by_ichar_1
Aidan Kehoe <kehoea@parhasard.net>
parents:
5035
diff
changeset
|
1093 small intestine. The liver preferentially resecretes only alpha-tocopherol |
|
9624523604c5
Use better types when ESCAPECHAR is specified, split_string_by_ichar_1
Aidan Kehoe <kehoea@parhasard.net>
parents:
5035
diff
changeset
|
1094 via the hepatic alpha-tocopherol transfer protein" |
|
5035
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1095 ?: ?\\) |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1096 '("re:ee" "this\\is\\text\\\\" "oops" " |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1097 Eine Sprache, die stagnirt, ist zu vergleichen mit einem See, dem der |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1098 bisherige Quellenzufluß versiegt oder abgeleitet wird. Aus dem Wasser, |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1099 worüber der Geist Gottes schwebte, wird Sumpf und Moder, worüber die |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1100 unreinen: Geister brüten.\\ |
|
5036
9624523604c5
Use better types when ESCAPECHAR is specified, split_string_by_ichar_1
Aidan Kehoe <kehoea@parhasard.net>
parents:
5035
diff
changeset
|
1101 Serum concentrations of vitamin E" " (alpha-tocopherol) depend on the liver, |
|
9624523604c5
Use better types when ESCAPECHAR is specified, split_string_by_ichar_1
Aidan Kehoe <kehoea@parhasard.net>
parents:
5035
diff
changeset
|
1102 which takes up the nutrient after the various forms are absorbed from the |
|
9624523604c5
Use better types when ESCAPECHAR is specified, split_string_by_ichar_1
Aidan Kehoe <kehoea@parhasard.net>
parents:
5035
diff
changeset
|
1103 small intestine. The liver preferentially resecretes only alpha-tocopherol |
|
9624523604c5
Use better types when ESCAPECHAR is specified, split_string_by_ichar_1
Aidan Kehoe <kehoea@parhasard.net>
parents:
5035
diff
changeset
|
1104 via the hepatic alpha-tocopherol transfer protein"))) |
|
5035
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1105 (Assert |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1106 (equal |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1107 (split-string-by-char |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1108 #r"re\:ee:this\\is\\text\\\\:oo\ps: |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1109 Eine Sprache, die stagnirt, ist zu vergleichen mit einem See, dem der |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1110 bisherige Quellenzufluß versiegt oder abgeleitet wird. Aus dem Wasser, |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1111 worüber der Geist Gottes schwebte, wird Sumpf und Moder, worüber die |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1112 unreinen\: Geister brüten.\\ |
|
5036
9624523604c5
Use better types when ESCAPECHAR is specified, split_string_by_ichar_1
Aidan Kehoe <kehoea@parhasard.net>
parents:
5035
diff
changeset
|
1113 Serum concentrations of vitamin E: (alpha-tocopherol) depend on the liver, |
|
9624523604c5
Use better types when ESCAPECHAR is specified, split_string_by_ichar_1
Aidan Kehoe <kehoea@parhasard.net>
parents:
5035
diff
changeset
|
1114 which takes up the nutrient after the various forms are absorbed from the |
|
9624523604c5
Use better types when ESCAPECHAR is specified, split_string_by_ichar_1
Aidan Kehoe <kehoea@parhasard.net>
parents:
5035
diff
changeset
|
1115 small intestine. The liver preferentially resecretes only alpha-tocopherol |
|
9624523604c5
Use better types when ESCAPECHAR is specified, split_string_by_ichar_1
Aidan Kehoe <kehoea@parhasard.net>
parents:
5035
diff
changeset
|
1116 via the hepatic alpha-tocopherol transfer protein" |
|
5035
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1117 ?: ?\x00) |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1118 '("re\\" "ee" "this\\\\is\\\\text\\\\\\\\" "oo\\ps" " |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1119 Eine Sprache, die stagnirt, ist zu vergleichen mit einem See, dem der |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1120 bisherige Quellenzufluß versiegt oder abgeleitet wird. Aus dem Wasser, |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1121 worüber der Geist Gottes schwebte, wird Sumpf und Moder, worüber die |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1122 unreinen\\" " Geister brüten.\\\\ |
|
5036
9624523604c5
Use better types when ESCAPECHAR is specified, split_string_by_ichar_1
Aidan Kehoe <kehoea@parhasard.net>
parents:
5035
diff
changeset
|
1123 Serum concentrations of vitamin E" " (alpha-tocopherol) depend on the liver, |
|
9624523604c5
Use better types when ESCAPECHAR is specified, split_string_by_ichar_1
Aidan Kehoe <kehoea@parhasard.net>
parents:
5035
diff
changeset
|
1124 which takes up the nutrient after the various forms are absorbed from the |
|
9624523604c5
Use better types when ESCAPECHAR is specified, split_string_by_ichar_1
Aidan Kehoe <kehoea@parhasard.net>
parents:
5035
diff
changeset
|
1125 small intestine. The liver preferentially resecretes only alpha-tocopherol |
|
9624523604c5
Use better types when ESCAPECHAR is specified, split_string_by_ichar_1
Aidan Kehoe <kehoea@parhasard.net>
parents:
5035
diff
changeset
|
1126 via the hepatic alpha-tocopherol transfer protein"))) |
|
5035
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1127 (Assert |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1128 (equal |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1129 (split-string-by-char |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1130 #r"re\:ee:this\\is\\text\\\\:oo\ps: |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1131 Eine Sprache, die stagnirt, ist zu vergleichen mit einem See, dem der |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1132 bisherige Quellenzufluß versiegt oder abgeleitet wird. Aus dem Wasser, |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1133 worüber der Geist Gottes schwebte, wird Sumpf und Moder, worüber die |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1134 unreinen\: Geister brüten.\\ |
|
5036
9624523604c5
Use better types when ESCAPECHAR is specified, split_string_by_ichar_1
Aidan Kehoe <kehoea@parhasard.net>
parents:
5035
diff
changeset
|
1135 Serum concentrations of vitamin E: (alpha-tocopherol) depend on the liver, |
|
9624523604c5
Use better types when ESCAPECHAR is specified, split_string_by_ichar_1
Aidan Kehoe <kehoea@parhasard.net>
parents:
5035
diff
changeset
|
1136 which takes up the nutrient after the various forms are absorbed from the |
|
9624523604c5
Use better types when ESCAPECHAR is specified, split_string_by_ichar_1
Aidan Kehoe <kehoea@parhasard.net>
parents:
5035
diff
changeset
|
1137 small intestine. The liver preferentially resecretes only alpha-tocopherol |
|
9624523604c5
Use better types when ESCAPECHAR is specified, split_string_by_ichar_1
Aidan Kehoe <kehoea@parhasard.net>
parents:
5035
diff
changeset
|
1138 via the hepatic alpha-tocopherol transfer protein" ?\\) |
|
5035
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1139 '("re" ":ee:this" "" "is" "" "text" "" "" "" ":oo" "ps: |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1140 Eine Sprache, die stagnirt, ist zu vergleichen mit einem See, dem der |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1141 bisherige Quellenzufluß versiegt oder abgeleitet wird. Aus dem Wasser, |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1142 worüber der Geist Gottes schwebte, wird Sumpf und Moder, worüber die |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1143 unreinen" ": Geister brüten." "" " |
|
5036
9624523604c5
Use better types when ESCAPECHAR is specified, split_string_by_ichar_1
Aidan Kehoe <kehoea@parhasard.net>
parents:
5035
diff
changeset
|
1144 Serum concentrations of vitamin E: (alpha-tocopherol) depend on the liver, |
|
9624523604c5
Use better types when ESCAPECHAR is specified, split_string_by_ichar_1
Aidan Kehoe <kehoea@parhasard.net>
parents:
5035
diff
changeset
|
1145 which takes up the nutrient after the various forms are absorbed from the |
|
9624523604c5
Use better types when ESCAPECHAR is specified, split_string_by_ichar_1
Aidan Kehoe <kehoea@parhasard.net>
parents:
5035
diff
changeset
|
1146 small intestine. The liver preferentially resecretes only alpha-tocopherol |
|
9624523604c5
Use better types when ESCAPECHAR is specified, split_string_by_ichar_1
Aidan Kehoe <kehoea@parhasard.net>
parents:
5035
diff
changeset
|
1147 via the hepatic alpha-tocopherol transfer protein"))) |
|
5035
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1148 |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1149 ;;----------------------------------------------------- |
| 434 | 1150 ;; Test near-text buffer functions. |
| 1151 ;;----------------------------------------------------- | |
| 1152 (with-temp-buffer | |
| 1153 (erase-buffer) | |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1154 (Assert-eq (char-before) nil) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1155 (Assert-eq (char-before (point)) nil) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1156 (Assert-eq (char-before (point-marker)) nil) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1157 (Assert-eq (char-before (point) (current-buffer)) nil) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1158 (Assert-eq (char-before (point-marker) (current-buffer)) nil) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1159 (Assert-eq (char-after) nil) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1160 (Assert-eq (char-after (point)) nil) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1161 (Assert-eq (char-after (point-marker)) nil) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1162 (Assert-eq (char-after (point) (current-buffer)) nil) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1163 (Assert-eq (char-after (point-marker) (current-buffer)) nil) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1164 (Assert-eq (preceding-char) 0) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1165 (Assert-eq (preceding-char (current-buffer)) 0) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1166 (Assert-eq (following-char) 0) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1167 (Assert-eq (following-char (current-buffer)) 0) |
| 434 | 1168 (insert "foobar") |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1169 (Assert-eq (char-before) ?r) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1170 (Assert-eq (char-after) nil) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1171 (Assert-eq (preceding-char) ?r) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1172 (Assert-eq (following-char) 0) |
| 434 | 1173 (goto-char (point-min)) |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1174 (Assert-eq (char-before) nil) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1175 (Assert-eq (char-after) ?f) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1176 (Assert-eq (preceding-char) 0) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1177 (Assert-eq (following-char) ?f) |
| 434 | 1178 ) |
| 440 | 1179 |
| 1180 ;;----------------------------------------------------- | |
| 1181 ;; Test plist manipulation functions. | |
| 1182 ;;----------------------------------------------------- | |
| 1183 (let ((sym (make-symbol "test-symbol"))) | |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1184 (Assert-eq t (get* sym t t)) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1185 (Assert-eq t (get sym t t)) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1186 (Assert-eq t (getf nil t t)) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1187 (Assert-eq t (plist-get nil t t)) |
| 440 | 1188 (put sym 'bar 'baz) |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1189 (Assert-eq 'baz (get sym 'bar)) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1190 (Assert-eq 'baz (getf '(bar baz) 'bar)) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1191 (Assert-eq 'baz (getf (symbol-plist sym) 'bar)) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1192 (Assert-eq 2 (getf '(1 2) 1)) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1193 (Assert-eq 4 (put sym 3 4)) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1194 (Assert-eq 4 (get sym 3)) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1195 (Assert-eq t (remprop sym 3)) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1196 (Assert-eq nil (remprop sym 3)) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1197 (Assert-eq 5 (get sym 3 5)) |
| 440 | 1198 ) |
| 442 | 1199 |
| 1200 (loop for obj in | |
| 1201 (list (make-symbol "test-symbol") | |
| 1202 "test-string" | |
| 1203 (make-extent nil nil nil) | |
| 1204 (make-face 'test-face)) | |
| 1205 do | |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1206 (Assert-eq 2 (get obj ?1 2) obj) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1207 (Assert-eq 4 (put obj ?3 4) obj) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1208 (Assert-eq 4 (get obj ?3) obj) |
| 442 | 1209 (when (or (stringp obj) (symbolp obj)) |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1210 (Assert-equal '(?3 4) (object-plist obj) obj)) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1211 (Assert-eq t (remprop obj ?3) obj) |
| 442 | 1212 (when (or (stringp obj) (symbolp obj)) |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1213 (Assert-eq '() (object-plist obj) obj)) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1214 (Assert-eq nil (remprop obj ?3) obj) |
| 442 | 1215 (when (or (stringp obj) (symbolp obj)) |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1216 (Assert-eq '() (object-plist obj) obj)) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1217 (Assert-eq 5 (get obj ?3 5) obj) |
| 442 | 1218 ) |
| 1219 | |
| 1220 (Check-Error-Message | |
| 1221 error "Object type has no properties" | |
| 1222 (get 2 'property)) | |
| 1223 | |
| 1224 (Check-Error-Message | |
| 1225 error "Object type has no settable properties" | |
| 1226 (put (current-buffer) 'property 'value)) | |
| 1227 | |
| 1228 (Check-Error-Message | |
| 1229 error "Object type has no removable properties" | |
| 1230 (remprop ?3 'property)) | |
| 1231 | |
| 1232 (Check-Error-Message | |
| 1233 error "Object type has no properties" | |
| 1234 (object-plist (symbol-function 'car))) | |
| 1235 | |
| 1236 (Check-Error-Message | |
| 1237 error "Can't remove property from object" | |
| 1238 (remprop (make-extent nil nil nil) 'detachable)) | |
| 1239 | |
| 1240 ;;----------------------------------------------------- | |
| 1241 ;; Test subseq | |
| 1242 ;;----------------------------------------------------- | |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1243 (Assert-equal (subseq nil 0) nil) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1244 (Assert-equal (subseq [1 2 3] 0) [1 2 3]) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1245 (Assert-equal (subseq [1 2 3] 1 -1) [2]) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1246 (Assert-equal (subseq "123" 0) "123") |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1247 (Assert-equal (subseq "1234" -3 -1) "23") |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1248 (Assert-equal (subseq #*0011 0) #*0011) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1249 (Assert-equal (subseq #*0011 -3 3) #*01) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1250 (Assert-equal (subseq '(1 2 3) 0) '(1 2 3)) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1251 (Assert-equal (subseq '(1 2 3 4) -3 nil) '(2 3 4)) |
| 442 | 1252 |
| 446 | 1253 (Check-Error wrong-type-argument (subseq 3 2)) |
| 1254 (Check-Error args-out-of-range (subseq [1 2 3] -42)) | |
| 1255 (Check-Error args-out-of-range (subseq [1 2 3] 0 42)) | |
| 442 | 1256 |
| 1257 ;;----------------------------------------------------- | |
| 1258 ;; Time-related tests | |
| 1259 ;;----------------------------------------------------- | |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1260 (Assert= (length (current-time-string)) 24) |
| 444 | 1261 |
| 1262 ;;----------------------------------------------------- | |
| 1263 ;; format test | |
| 1264 ;;----------------------------------------------------- | |
| 1265 (Assert (string= (format "%d" 10) "10")) | |
| 1266 (Assert (string= (format "%o" 8) "10")) | |
| 1267 (Assert (string= (format "%x" 31) "1f")) | |
| 1268 (Assert (string= (format "%X" 31) "1F")) | |
| 826 | 1269 ;; MS-Windows uses +002 in its floating-point numbers. #### We should |
| 1270 ;; perhaps fix this, but writing our own floating-point support in doprnt.c | |
| 1271 ;; is very hard. | |
| 1272 (Assert (or (string= (format "%e" 100) "1.000000e+02") | |
| 1273 (string= (format "%e" 100) "1.000000e+002"))) | |
| 1274 (Assert (or (string= (format "%E" 100) "1.000000E+02") | |
| 1275 (string= (format "%E" 100) "1.000000E+002"))) | |
| 1276 (Assert (or (string= (format "%E" 100) "1.000000E+02") | |
| 1277 (string= (format "%E" 100) "1.000000E+002"))) | |
| 444 | 1278 (Assert (string= (format "%f" 100) "100.000000")) |
| 448 | 1279 (Assert (string= (format "%7.3f" 12.12345) " 12.123")) |
| 1280 (Assert (string= (format "%07.3f" 12.12345) "012.123")) | |
| 1281 (Assert (string= (format "%-7.3f" 12.12345) "12.123 ")) | |
| 1282 (Assert (string= (format "%-07.3f" 12.12345) "12.123 ")) | |
| 444 | 1283 (Assert (string= (format "%g" 100.0) "100")) |
| 826 | 1284 (Assert (or (string= (format "%g" 0.000001) "1e-06") |
| 1285 (string= (format "%g" 0.000001) "1e-006"))) | |
| 444 | 1286 (Assert (string= (format "%g" 0.0001) "0.0001")) |
| 1287 (Assert (string= (format "%G" 100.0) "100")) | |
| 826 | 1288 (Assert (or (string= (format "%G" 0.000001) "1E-06") |
| 1289 (string= (format "%G" 0.000001) "1E-006"))) | |
| 444 | 1290 (Assert (string= (format "%G" 0.0001) "0.0001")) |
| 1291 | |
| 1292 (Assert (string= (format "%2$d%1$d" 10 20) "2010")) | |
| 1293 (Assert (string= (format "%-d" 10) "10")) | |
| 1294 (Assert (string= (format "%-4d" 10) "10 ")) | |
| 1295 (Assert (string= (format "%+d" 10) "+10")) | |
| 1296 (Assert (string= (format "%+d" -10) "-10")) | |
| 1297 (Assert (string= (format "%+4d" 10) " +10")) | |
| 1298 (Assert (string= (format "%+4d" -10) " -10")) | |
| 1299 (Assert (string= (format "% d" 10) " 10")) | |
| 1300 (Assert (string= (format "% d" -10) "-10")) | |
| 1301 (Assert (string= (format "% 4d" 10) " 10")) | |
| 1302 (Assert (string= (format "% 4d" -10) " -10")) | |
| 1303 (Assert (string= (format "%0d" 10) "10")) | |
| 1304 (Assert (string= (format "%0d" -10) "-10")) | |
| 1305 (Assert (string= (format "%04d" 10) "0010")) | |
| 1306 (Assert (string= (format "%04d" -10) "-010")) | |
| 1307 (Assert (string= (format "%*d" 4 10) " 10")) | |
| 1308 (Assert (string= (format "%*d" 4 -10) " -10")) | |
| 1309 (Assert (string= (format "%*d" -4 10) "10 ")) | |
| 1310 (Assert (string= (format "%*d" -4 -10) "-10 ")) | |
| 1311 (Assert (string= (format "%#d" 10) "10")) | |
| 1312 (Assert (string= (format "%#o" 8) "010")) | |
| 1313 (Assert (string= (format "%#x" 16) "0x10")) | |
| 826 | 1314 (Assert (or (string= (format "%#e" 100) "1.000000e+02") |
| 1315 (string= (format "%#e" 100) "1.000000e+002"))) | |
| 1316 (Assert (or (string= (format "%#E" 100) "1.000000E+02") | |
| 1317 (string= (format "%#E" 100) "1.000000E+002"))) | |
| 444 | 1318 (Assert (string= (format "%#f" 100) "100.000000")) |
| 1319 (Assert (string= (format "%#g" 100.0) "100.000")) | |
| 826 | 1320 (Assert (or (string= (format "%#g" 0.000001) "1.00000e-06") |
| 1321 (string= (format "%#g" 0.000001) "1.00000e-006"))) | |
| 444 | 1322 (Assert (string= (format "%#g" 0.0001) "0.000100000")) |
| 1323 (Assert (string= (format "%#G" 100.0) "100.000")) | |
| 826 | 1324 (Assert (or (string= (format "%#G" 0.000001) "1.00000E-06") |
| 1325 (string= (format "%#G" 0.000001) "1.00000E-006"))) | |
| 444 | 1326 (Assert (string= (format "%#G" 0.0001) "0.000100000")) |
| 1327 (Assert (string= (format "%.1d" 10) "10")) | |
| 1328 (Assert (string= (format "%.4d" 10) "0010")) | |
| 1329 ;; Combination of `-', `+', ` ', `0', `#', `.', `*' | |
| 448 | 1330 (Assert (string= (format "%-04d" 10) "10 ")) |
| 444 | 1331 (Assert (string= (format "%-*d" 4 10) "10 ")) |
| 1332 ;; #### Correctness of this behavior is questionable. | |
| 1333 ;; It might be better to signal error. | |
| 1334 (Assert (string= (format "%-*d" -4 10) "10 ")) | |
| 1335 ;; These behavior is not specified. | |
| 1336 ;; (format "%-+d" 10) | |
| 1337 ;; (format "%- d" 10) | |
| 1338 ;; (format "%-01d" 10) | |
| 1339 ;; (format "%-#4x" 10) | |
| 1340 ;; (format "%-.1d" 10) | |
| 1341 | |
| 1342 (Assert (string= (format "%01.1d" 10) "10")) | |
| 448 | 1343 (Assert (string= (format "%03.1d" 10) " 10")) |
| 1344 (Assert (string= (format "%01.3d" 10) "010")) | |
| 1345 (Assert (string= (format "%1.3d" 10) "010")) | |
| 444 | 1346 (Assert (string= (format "%3.1d" 10) " 10")) |
| 446 | 1347 |
| 448 | 1348 ;;; The following two tests used to use 1000 instead of 100, |
| 1349 ;;; but that merely found buffer overflow bugs in Solaris sprintf(). | |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1350 (Assert= 102 (length (format "%.100f" 3.14))) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1351 (Assert= 100 (length (format "%100f" 3.14))) |
| 448 | 1352 |
| 446 | 1353 ;;; Check for 64-bit cleanness on LP64 platforms. |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1354 (Assert= (read (format "%d" most-positive-fixnum)) most-positive-fixnum) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1355 (Assert= (read (format "%ld" most-positive-fixnum)) most-positive-fixnum) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1356 (Assert= (read (format "%u" most-positive-fixnum)) most-positive-fixnum) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1357 (Assert= (read (format "%lu" most-positive-fixnum)) most-positive-fixnum) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1358 (Assert= (read (format "%d" most-negative-fixnum)) most-negative-fixnum) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1359 (Assert= (read (format "%ld" most-negative-fixnum)) most-negative-fixnum) |
| 446 | 1360 |
| 4287 | 1361 ;; These used to crash. |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1362 (Assert-eql (read (format "%f" 1.2e+302)) 1.2e+302) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1363 (Assert-eql (read (format "%.1000d" 1)) 1) |
| 4287 | 1364 |
| 446 | 1365 ;;; "%u" is undocumented, and Emacs Lisp has no unsigned type. |
| 1366 ;;; What to do if "%u" is used with a negative number? | |
| 1983 | 1367 ;;; For non-bignum XEmacsen, the most reasonable thing seems to be to print an |
| 1368 ;;; un-read-able number. The printed value might be useful to a human, if not | |
| 1369 ;;; to Emacs Lisp. | |
| 1370 ;;; For bignum XEmacsen, we make %u with a negative value throw an error. | |
| 1371 (if (featurep 'bignum) | |
| 1372 (progn | |
| 1373 (Check-Error wrong-type-argument (format "%u" most-negative-fixnum)) | |
| 1374 (Check-Error wrong-type-argument (format "%u" -1))) | |
| 1375 (Check-Error invalid-read-syntax (read (format "%u" most-negative-fixnum))) | |
| 1376 (Check-Error invalid-read-syntax (read (format "%u" -1)))) | |
| 448 | 1377 |
| 1378 ;; Check all-completions ignore element start with space. | |
| 1379 (Assert (not (all-completions "" '((" hidden" . "object"))))) | |
| 1380 (Assert (all-completions " " '((" hidden" . "object")))) | |
|
4394
cacc942c0d0f
Avoid clearing print-gensym-alist inappropriately when printing hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4287
diff
changeset
|
1381 |
|
cacc942c0d0f
Avoid clearing print-gensym-alist inappropriately when printing hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4287
diff
changeset
|
1382 (let* ((literal-with-uninterned |
|
cacc942c0d0f
Avoid clearing print-gensym-alist inappropriately when printing hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4287
diff
changeset
|
1383 '(first-element |
|
cacc942c0d0f
Avoid clearing print-gensym-alist inappropriately when printing hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4287
diff
changeset
|
1384 [#1=#:G32976 #2=#:G32974 #3=#:G32971 #4=#:G32969 alias |
|
4396
e97f16fb2e25
Don't assume lisp-tests.el will be correctly read as UTF-8.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4394
diff
changeset
|
1385 #s(hash-table size 256 data (969 ?\xF9 55 ?7 166 ?\xA6)) |
|
4394
cacc942c0d0f
Avoid clearing print-gensym-alist inappropriately when printing hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4287
diff
changeset
|
1386 #5=#:G32970 #6=#:G32972])) |
|
cacc942c0d0f
Avoid clearing print-gensym-alist inappropriately when printing hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4287
diff
changeset
|
1387 (print-readably t) |
|
cacc942c0d0f
Avoid clearing print-gensym-alist inappropriately when printing hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4287
diff
changeset
|
1388 (print-gensym t) |
|
cacc942c0d0f
Avoid clearing print-gensym-alist inappropriately when printing hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4287
diff
changeset
|
1389 (printed-with-uninterned (prin1-to-string literal-with-uninterned)) |
|
cacc942c0d0f
Avoid clearing print-gensym-alist inappropriately when printing hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4287
diff
changeset
|
1390 (awkward-regexp "#1=#") |
|
cacc942c0d0f
Avoid clearing print-gensym-alist inappropriately when printing hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4287
diff
changeset
|
1391 (first-match-start (string-match awkward-regexp |
|
cacc942c0d0f
Avoid clearing print-gensym-alist inappropriately when printing hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4287
diff
changeset
|
1392 printed-with-uninterned))) |
|
cacc942c0d0f
Avoid clearing print-gensym-alist inappropriately when printing hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4287
diff
changeset
|
1393 (Assert (null (string-match awkward-regexp printed-with-uninterned |
|
cacc942c0d0f
Avoid clearing print-gensym-alist inappropriately when printing hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4287
diff
changeset
|
1394 (1+ first-match-start))))) |
|
4580
1d11ecca9cd0
Print char table values correctly.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4575
diff
changeset
|
1395 |
|
1d11ecca9cd0
Print char table values correctly.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4575
diff
changeset
|
1396 (let ((char-table-with-string #s(char-table data (?\x00 "text"))) |
|
1d11ecca9cd0
Print char table values correctly.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4575
diff
changeset
|
1397 (char-table-with-symbol #s(char-table data (?\x00 text)))) |
|
4582
00ed9903a988
Fix make check after my last change.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4580
diff
changeset
|
1398 (Assert (not (string-equal (prin1-to-string char-table-with-string) |
|
00ed9903a988
Fix make check after my last change.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4580
diff
changeset
|
1399 (prin1-to-string char-table-with-symbol))) |
|
4580
1d11ecca9cd0
Print char table values correctly.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4575
diff
changeset
|
1400 "Check that char table elements are quoted correctly when printing")) |
|
1d11ecca9cd0
Print char table values correctly.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4575
diff
changeset
|
1401 |
|
4608
1e3cf11fa27d
Make #$ truly read-only for Lisp; check this in the test suite.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4582
diff
changeset
|
1402 |
|
1e3cf11fa27d
Make #$ truly read-only for Lisp; check this in the test suite.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4582
diff
changeset
|
1403 (let ((test-file-name |
|
1e3cf11fa27d
Make #$ truly read-only for Lisp; check this in the test suite.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4582
diff
changeset
|
1404 (make-temp-file (expand-file-name "sR4KDwU" (temp-directory)) |
|
1e3cf11fa27d
Make #$ truly read-only for Lisp; check this in the test suite.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4582
diff
changeset
|
1405 nil ".el"))) |
|
1e3cf11fa27d
Make #$ truly read-only for Lisp; check this in the test suite.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4582
diff
changeset
|
1406 (find-file test-file-name) |
|
1e3cf11fa27d
Make #$ truly read-only for Lisp; check this in the test suite.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4582
diff
changeset
|
1407 (erase-buffer) |
|
1e3cf11fa27d
Make #$ truly read-only for Lisp; check this in the test suite.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4582
diff
changeset
|
1408 (insert |
|
1e3cf11fa27d
Make #$ truly read-only for Lisp; check this in the test suite.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4582
diff
changeset
|
1409 "\ |
|
1e3cf11fa27d
Make #$ truly read-only for Lisp; check this in the test suite.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4582
diff
changeset
|
1410 ;; Lisp should not be able to modify #$, which is |
|
1e3cf11fa27d
Make #$ truly read-only for Lisp; check this in the test suite.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4582
diff
changeset
|
1411 ;; Vload_file_name_internal of lread.c. |
|
1e3cf11fa27d
Make #$ truly read-only for Lisp; check this in the test suite.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4582
diff
changeset
|
1412 (Check-Error setting-constant (aset #$ 0 ?\\ )) |
|
1e3cf11fa27d
Make #$ truly read-only for Lisp; check this in the test suite.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4582
diff
changeset
|
1413 |
|
1e3cf11fa27d
Make #$ truly read-only for Lisp; check this in the test suite.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4582
diff
changeset
|
1414 ;; But modifying load-file-name should work: |
|
1e3cf11fa27d
Make #$ truly read-only for Lisp; check this in the test suite.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4582
diff
changeset
|
1415 (let ((new-char ?\\ ) |
|
1e3cf11fa27d
Make #$ truly read-only for Lisp; check this in the test suite.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4582
diff
changeset
|
1416 old-char) |
|
1e3cf11fa27d
Make #$ truly read-only for Lisp; check this in the test suite.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4582
diff
changeset
|
1417 (setq old-char (aref load-file-name 0)) |
|
1e3cf11fa27d
Make #$ truly read-only for Lisp; check this in the test suite.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4582
diff
changeset
|
1418 (if (= new-char old-char) |
|
1e3cf11fa27d
Make #$ truly read-only for Lisp; check this in the test suite.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4582
diff
changeset
|
1419 (setq new-char ?/)) |
|
1e3cf11fa27d
Make #$ truly read-only for Lisp; check this in the test suite.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4582
diff
changeset
|
1420 (aset load-file-name 0 new-char) |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1421 (Assert= new-char (aref load-file-name 0) |
|
4608
1e3cf11fa27d
Make #$ truly read-only for Lisp; check this in the test suite.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4582
diff
changeset
|
1422 \"Check that we can modify the string value of load-file-name\")) |
|
1e3cf11fa27d
Make #$ truly read-only for Lisp; check this in the test suite.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4582
diff
changeset
|
1423 |
|
1e3cf11fa27d
Make #$ truly read-only for Lisp; check this in the test suite.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4582
diff
changeset
|
1424 (let* ((new-load-file-name \"hi there\") |
|
1e3cf11fa27d
Make #$ truly read-only for Lisp; check this in the test suite.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4582
diff
changeset
|
1425 (load-file-name new-load-file-name)) |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1426 (Assert-eq new-load-file-name load-file-name |
|
4608
1e3cf11fa27d
Make #$ truly read-only for Lisp; check this in the test suite.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4582
diff
changeset
|
1427 \"Checking that we can bind load-file-name successfully.\")) |
|
1e3cf11fa27d
Make #$ truly read-only for Lisp; check this in the test suite.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4582
diff
changeset
|
1428 |
|
1e3cf11fa27d
Make #$ truly read-only for Lisp; check this in the test suite.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4582
diff
changeset
|
1429 ") |
|
1e3cf11fa27d
Make #$ truly read-only for Lisp; check this in the test suite.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4582
diff
changeset
|
1430 (write-region (point-min) (point-max) test-file-name nil 'quiet) |
|
1e3cf11fa27d
Make #$ truly read-only for Lisp; check this in the test suite.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4582
diff
changeset
|
1431 (set-buffer-modified-p nil) |
|
1e3cf11fa27d
Make #$ truly read-only for Lisp; check this in the test suite.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4582
diff
changeset
|
1432 (kill-buffer nil) |
|
1e3cf11fa27d
Make #$ truly read-only for Lisp; check this in the test suite.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4582
diff
changeset
|
1433 (load test-file-name nil t nil) |
|
1e3cf11fa27d
Make #$ truly read-only for Lisp; check this in the test suite.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4582
diff
changeset
|
1434 (delete-file test-file-name)) |
|
1e3cf11fa27d
Make #$ truly read-only for Lisp; check this in the test suite.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4582
diff
changeset
|
1435 |
|
4678
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1436 (flet ((cl-floor (x &optional y) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1437 (let ((q (floor x y))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1438 (list q (- x (if y (* y q) q))))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1439 (cl-ceiling (x &optional y) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1440 (let ((res (cl-floor x y))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1441 (if (= (car (cdr res)) 0) res |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1442 (list (1+ (car res)) (- (car (cdr res)) (or y 1)))))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1443 (cl-truncate (x &optional y) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1444 (if (eq (>= x 0) (or (null y) (>= y 0))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1445 (cl-floor x y) (cl-ceiling x y))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1446 (cl-round (x &optional y) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1447 (if y |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1448 (if (and (integerp x) (integerp y)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1449 (let* ((hy (/ y 2)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1450 (res (cl-floor (+ x hy) y))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1451 (if (and (= (car (cdr res)) 0) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1452 (= (+ hy hy) y) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1453 (/= (% (car res) 2) 0)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1454 (list (1- (car res)) hy) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1455 (list (car res) (- (car (cdr res)) hy)))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1456 (let ((q (round (/ x y)))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1457 (list q (- x (* q y))))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1458 (if (integerp x) (list x 0) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1459 (let ((q (round x))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1460 (list q (- x q)))))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1461 (Assert-rounding (first second &key |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1462 one-floor-result two-floor-result |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1463 one-ffloor-result two-ffloor-result |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1464 one-ceiling-result two-ceiling-result |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1465 one-fceiling-result two-fceiling-result |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1466 one-round-result two-round-result |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1467 one-fround-result two-fround-result |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1468 one-truncate-result two-truncate-result |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1469 one-ftruncate-result two-ftruncate-result) |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1470 (Assert-equal one-floor-result (multiple-value-list |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1471 (floor first)) |
|
4678
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1472 (format "checking (floor %S) gives %S" |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1473 first one-floor-result)) |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1474 (Assert-equal one-floor-result (multiple-value-list |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1475 (floor first 1)) |
|
4678
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1476 (format "checking (floor %S 1) gives %S" |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1477 first one-floor-result)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1478 (Check-Error arith-error (floor first 0)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1479 (Check-Error arith-error (floor first 0.0)) |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1480 (Assert-equal two-floor-result (multiple-value-list |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1481 (floor first second)) |
|
4678
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1482 (format |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1483 "checking (floor %S %S) gives %S" |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1484 first second two-floor-result)) |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1485 (Assert-equal (cl-floor first second) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1486 (multiple-value-list (floor first second)) |
|
4678
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1487 (format |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1488 "checking (floor %S %S) gives the same as the old code" |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1489 first second)) |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1490 (Assert-equal one-ffloor-result (multiple-value-list |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1491 (ffloor first)) |
|
4678
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1492 (format "checking (ffloor %S) gives %S" |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1493 first one-ffloor-result)) |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1494 (Assert-equal one-ffloor-result (multiple-value-list |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1495 (ffloor first 1)) |
|
4678
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1496 (format "checking (ffloor %S 1) gives %S" |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1497 first one-ffloor-result)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1498 (Check-Error arith-error (ffloor first 0)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1499 (Check-Error arith-error (ffloor first 0.0)) |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1500 (Assert-equal two-ffloor-result (multiple-value-list |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1501 (ffloor first second)) |
|
4678
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1502 (format "checking (ffloor %S %S) gives %S" |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1503 first second two-ffloor-result)) |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1504 (Assert-equal one-ceiling-result (multiple-value-list |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1505 (ceiling first)) |
|
4678
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1506 (format "checking (ceiling %S) gives %S" |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1507 first one-ceiling-result)) |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1508 (Assert-equal one-ceiling-result (multiple-value-list |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1509 (ceiling first 1)) |
|
4678
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1510 (format "checking (ceiling %S 1) gives %S" |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1511 first one-ceiling-result)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1512 (Check-Error arith-error (ceiling first 0)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1513 (Check-Error arith-error (ceiling first 0.0)) |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1514 (Assert-equal two-ceiling-result (multiple-value-list |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1515 (ceiling first second)) |
|
4678
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1516 (format "checking (ceiling %S %S) gives %S" |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1517 first second two-ceiling-result)) |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1518 (Assert-equal (cl-ceiling first second) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1519 (multiple-value-list (ceiling first second)) |
|
4678
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1520 (format |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1521 "checking (ceiling %S %S) gives the same as the old code" |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1522 first second)) |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1523 (Assert-equal one-fceiling-result (multiple-value-list |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1524 (fceiling first)) |
|
4678
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1525 (format "checking (fceiling %S) gives %S" |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1526 first one-fceiling-result)) |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1527 (Assert-equal one-fceiling-result (multiple-value-list |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1528 (fceiling first 1)) |
|
4678
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1529 (format "checking (fceiling %S 1) gives %S" |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1530 first one-fceiling-result)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1531 (Check-Error arith-error (fceiling first 0)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1532 (Check-Error arith-error (fceiling first 0.0)) |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1533 (Assert-equal two-fceiling-result (multiple-value-list |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1534 (fceiling first second)) |
|
4678
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1535 (format "checking (fceiling %S %S) gives %S" |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1536 first second two-fceiling-result)) |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1537 (Assert-equal one-round-result (multiple-value-list |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1538 (round first)) |
|
4678
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1539 (format "checking (round %S) gives %S" |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1540 first one-round-result)) |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1541 (Assert-equal one-round-result (multiple-value-list |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1542 (round first 1)) |
|
4686
cdabd56ce1b5
Fix various small issues with the multiple-value implementation.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4679
diff
changeset
|
1543 (format "checking (round %S 1) gives %S" |
|
cdabd56ce1b5
Fix various small issues with the multiple-value implementation.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4679
diff
changeset
|
1544 first one-round-result)) |
|
4678
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1545 (Check-Error arith-error (round first 0)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1546 (Check-Error arith-error (round first 0.0)) |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1547 (Assert-equal two-round-result (multiple-value-list |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1548 (round first second)) |
|
4678
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1549 (format "checking (round %S %S) gives %S" |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1550 first second two-round-result)) |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1551 (Assert-equal one-fround-result (multiple-value-list |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1552 (fround first)) |
|
4678
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1553 (format "checking (fround %S) gives %S" |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1554 first one-fround-result)) |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1555 (Assert-equal one-fround-result (multiple-value-list |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1556 (fround first 1)) |
|
4678
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1557 (format "checking (fround %S 1) gives %S" |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1558 first one-fround-result)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1559 (Check-Error arith-error (fround first 0)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1560 (Check-Error arith-error (fround first 0.0)) |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1561 (Assert-equal two-fround-result (multiple-value-list |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1562 (fround first second)) |
|
4678
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1563 (format "checking (fround %S %S) gives %S" |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1564 first second two-fround-result)) |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1565 (Assert-equal (cl-round first second) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1566 (multiple-value-list (round first second)) |
|
4678
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1567 (format |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1568 "checking (round %S %S) gives the same as the old code" |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1569 first second)) |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1570 (Assert-equal one-truncate-result (multiple-value-list |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1571 (truncate first)) |
|
4678
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1572 (format "checking (truncate %S) gives %S" |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1573 first one-truncate-result)) |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1574 (Assert-equal one-truncate-result (multiple-value-list |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1575 (truncate first 1)) |
|
4678
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1576 (format "checking (truncate %S 1) gives %S" |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1577 first one-truncate-result)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1578 (Check-Error arith-error (truncate first 0)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1579 (Check-Error arith-error (truncate first 0.0)) |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1580 (Assert-equal two-truncate-result (multiple-value-list |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1581 (truncate first second)) |
|
4678
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1582 (format "checking (truncate %S %S) gives %S" |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1583 first second two-truncate-result)) |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1584 (Assert-equal (cl-truncate first second) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1585 (multiple-value-list (truncate first second)) |
|
4678
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1586 (format |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1587 "checking (truncate %S %S) gives the same as the old code" |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1588 first second)) |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1589 (Assert-equal one-ftruncate-result (multiple-value-list |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1590 (ftruncate first)) |
|
4678
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1591 (format "checking (ftruncate %S) gives %S" |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1592 first one-ftruncate-result)) |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1593 (Assert-equal one-ftruncate-result (multiple-value-list |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1594 (ftruncate first 1)) |
|
4678
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1595 (format "checking (ftruncate %S 1) gives %S" |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1596 first one-ftruncate-result)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1597 (Check-Error arith-error (ftruncate first 0)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1598 (Check-Error arith-error (ftruncate first 0.0)) |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1599 (Assert-equal two-ftruncate-result (multiple-value-list |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1600 (ftruncate first second)) |
|
4678
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1601 (format "checking (ftruncate %S %S) gives %S" |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1602 first second two-ftruncate-result))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1603 (Assert-rounding-floating (pie ee) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1604 (let ((pie-type (type-of pie))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1605 (assert (eq pie-type (type-of ee)) t |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1606 "This code assumes the two arguments have the same type.") |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1607 (Assert-rounding pie ee |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1608 :one-floor-result (list 3 (- pie 3)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1609 :two-floor-result (list 1 (- pie (* 1 ee))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1610 :one-ffloor-result (list (coerce 3 pie-type) (- pie 3.0)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1611 :two-ffloor-result (list (coerce 1 pie-type) (- pie (* 1.0 ee))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1612 :one-ceiling-result (list 4 (- pie 4)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1613 :two-ceiling-result (list 2 (- pie (* 2 ee))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1614 :one-fceiling-result (list (coerce 4 pie-type) (- pie 4.0)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1615 :two-fceiling-result (list (coerce 2 pie-type) (- pie (* 2.0 ee))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1616 :one-round-result (list 3 (- pie 3)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1617 :two-round-result (list 1 (- pie (* 1 ee))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1618 :one-fround-result (list (coerce 3 pie-type) (- pie 3.0)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1619 :two-fround-result (list (coerce 1 pie-type) (- pie (* 1.0 ee))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1620 :one-truncate-result (list 3 (- pie 3)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1621 :two-truncate-result (list 1 (- pie (* 1 ee))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1622 :one-ftruncate-result (list (coerce 3 pie-type) (- pie 3.0)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1623 :two-ftruncate-result (list (coerce 1 pie-type) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1624 (- pie (* 1.0 ee)))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1625 (Assert-rounding pie (- ee) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1626 :one-floor-result (list 3 (- pie 3)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1627 :two-floor-result (list -2 (- pie (* -2 (- ee)))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1628 :one-ffloor-result (list (coerce 3 pie-type) (- pie 3.0)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1629 :two-ffloor-result (list (coerce -2 pie-type) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1630 (- pie (* -2.0 (- ee)))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1631 :one-ceiling-result (list 4 (- pie 4)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1632 :two-ceiling-result (list -1 (- pie (* -1 (- ee)))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1633 :one-fceiling-result (list (coerce 4 pie-type) (- pie 4.0)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1634 :two-fceiling-result (list (coerce -1 pie-type) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1635 (- pie (* -1.0 (- ee)))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1636 :one-round-result (list 3 (- pie 3)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1637 :two-round-result (list -1 (- pie (* -1 (- ee)))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1638 :one-fround-result (list (coerce 3 pie-type) (- pie 3.0)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1639 :two-fround-result (list (coerce -1 pie-type) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1640 (- pie (* -1.0 (- ee)))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1641 :one-truncate-result (list 3 (- pie 3)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1642 :two-truncate-result (list -1 (- pie (* -1 (- ee)))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1643 :one-ftruncate-result (list (coerce 3 pie-type) (- pie 3.0)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1644 :two-ftruncate-result (list (coerce -1 pie-type) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1645 (- pie (* -1.0 (- ee))))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1646 (Assert-rounding (- pie) ee |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1647 :one-floor-result (list -4 (- (- pie) -4)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1648 :two-floor-result (list -2 (- (- pie) (* -2 ee))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1649 :one-ffloor-result (list (coerce -4 pie-type) (- (- pie) -4.0)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1650 :two-ffloor-result (list (coerce -2 pie-type) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1651 (- (- pie) (* -2.0 ee))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1652 :one-ceiling-result (list -3 (- (- pie) -3)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1653 :two-ceiling-result (list -1 (- (- pie) (* -1 ee))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1654 :one-fceiling-result (list (coerce -3 pie-type) (- (- pie) -3.0)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1655 :two-fceiling-result (list (coerce -1 pie-type) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1656 (- (- pie) (* -1.0 ee))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1657 :one-round-result (list -3 (- (- pie) -3)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1658 :two-round-result (list -1 (- (- pie) (* -1 ee))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1659 :one-fround-result (list (coerce -3 pie-type) (- (- pie) -3.0)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1660 :two-fround-result (list (coerce -1 pie-type) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1661 (- (- pie) (* -1.0 ee))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1662 :one-truncate-result (list -3 (- (- pie) -3)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1663 :two-truncate-result (list -1 (- (- pie) (* -1 ee))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1664 :one-ftruncate-result (list (coerce -3 pie-type) (- (- pie) -3.0)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1665 :two-ftruncate-result (list (coerce -1 pie-type) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1666 (- (- pie) (* -1.0 ee)))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1667 (Assert-rounding (- pie) (- ee) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1668 :one-floor-result (list -4 (- (- pie) -4)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1669 :two-floor-result (list 1 (- (- pie) (* 1 (- ee)))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1670 :one-ffloor-result (list (coerce -4 pie-type) (- (- pie) -4.0)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1671 :two-ffloor-result (list (coerce 1 pie-type) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1672 (- (- pie) (* 1.0 (- ee)))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1673 :one-ceiling-result (list -3 (- (- pie) -3)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1674 :two-ceiling-result (list 2 (- (- pie) (* 2 (- ee)))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1675 :one-fceiling-result (list (coerce -3 pie-type) (- (- pie) -3.0)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1676 :two-fceiling-result (list (coerce 2 pie-type) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1677 (- (- pie) (* 2.0 (- ee)))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1678 :one-round-result (list -3 (- (- pie) -3)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1679 :two-round-result (list 1 (- (- pie) (* 1 (- ee)))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1680 :one-fround-result (list (coerce -3 pie-type) (- (- pie) -3.0)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1681 :two-fround-result (list (coerce 1 pie-type) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1682 (- (- pie) (* 1.0 (- ee)))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1683 :one-truncate-result (list -3 (- (- pie) -3)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1684 :two-truncate-result (list 1 (- (- pie) (* 1 (- ee)))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1685 :one-ftruncate-result (list (coerce -3 pie-type) (- (- pie) -3.0)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1686 :two-ftruncate-result (list (coerce 1 pie-type) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1687 (- (- pie) (* 1.0 (- ee))))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1688 (Assert-rounding ee pie |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1689 :one-floor-result (list 2 (- ee 2)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1690 :two-floor-result (list 0 ee) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1691 :one-ffloor-result (list (coerce 2 pie-type) (- ee 2.0)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1692 :two-ffloor-result (list (coerce 0 pie-type) ee) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1693 :one-ceiling-result (list 3 (- ee 3)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1694 :two-ceiling-result (list 1 (- ee pie)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1695 :one-fceiling-result (list (coerce 3 pie-type) (- ee 3.0)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1696 :two-fceiling-result (list (coerce 1 pie-type) (- ee pie)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1697 :one-round-result (list 3 (- ee 3)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1698 :two-round-result (list 1 (- ee (* 1 pie))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1699 :one-fround-result (list (coerce 3 pie-type) (- ee 3.0)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1700 :two-fround-result (list (coerce 1 pie-type) (- ee (* 1.0 pie))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1701 :one-truncate-result (list 2 (- ee 2)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1702 :two-truncate-result (list 0 ee) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1703 :one-ftruncate-result (list (coerce 2 pie-type) (- ee 2.0)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1704 :two-ftruncate-result (list (coerce 0 pie-type) ee)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1705 (Assert-rounding ee (- pie) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1706 :one-floor-result (list 2 (- ee 2)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1707 :two-floor-result (list -1 (- ee (* -1 (- pie)))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1708 :one-ffloor-result (list (coerce 2 pie-type) (- ee 2.0)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1709 :two-ffloor-result (list (coerce -1 pie-type) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1710 (- ee (* -1.0 (- pie)))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1711 :one-ceiling-result (list 3 (- ee 3)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1712 :two-ceiling-result (list 0 ee) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1713 :one-fceiling-result (list (coerce 3 pie-type) (- ee 3.0)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1714 :two-fceiling-result (list (coerce 0 pie-type) ee) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1715 :one-round-result (list 3 (- ee 3)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1716 :two-round-result (list -1 (- ee (* -1 (- pie)))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1717 :one-fround-result (list (coerce 3 pie-type) (- ee 3.0)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1718 :two-fround-result (list (coerce -1 pie-type) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1719 (- ee (* -1.0 (- pie)))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1720 :one-truncate-result (list 2 (- ee 2)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1721 :two-truncate-result (list 0 ee) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1722 :one-ftruncate-result (list (coerce 2 pie-type) (- ee 2.0)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1723 :two-ftruncate-result (list (coerce 0 pie-type) ee))))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1724 ;; First, two integers: |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1725 (Assert-rounding 27 8 :one-floor-result '(27 0) :two-floor-result '(3 3) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1726 :one-ffloor-result '(27.0 0) :two-ffloor-result '(3.0 3) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1727 :one-ceiling-result '(27 0) :two-ceiling-result '(4 -5) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1728 :one-fceiling-result '(27.0 0) :two-fceiling-result '(4.0 -5) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1729 :one-round-result '(27 0) :two-round-result '(3 3) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1730 :one-fround-result '(27.0 0) :two-fround-result '(3.0 3) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1731 :one-truncate-result '(27 0) :two-truncate-result '(3 3) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1732 :one-ftruncate-result '(27.0 0) :two-ftruncate-result '(3.0 3)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1733 (Assert-rounding 27 -8 :one-floor-result '(27 0) :two-floor-result '(-4 -5) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1734 :one-ffloor-result '(27.0 0) :two-ffloor-result '(-4.0 -5) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1735 :one-ceiling-result '(27 0) :two-ceiling-result '(-3 3) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1736 :one-fceiling-result '(27.0 0) :two-fceiling-result '(-3.0 3) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1737 :one-round-result '(27 0) :two-round-result '(-3 3) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1738 :one-fround-result '(27.0 0) :two-fround-result '(-3.0 3) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1739 :one-truncate-result '(27 0) :two-truncate-result '(-3 3) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1740 :one-ftruncate-result '(27.0 0) :two-ftruncate-result '(-3.0 3)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1741 (Assert-rounding -27 8 |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1742 :one-floor-result '(-27 0) :two-floor-result '(-4 5) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1743 :one-ffloor-result '(-27.0 0) :two-ffloor-result '(-4.0 5) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1744 :one-ceiling-result '(-27 0) :two-ceiling-result '(-3 -3) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1745 :one-fceiling-result '(-27.0 0) :two-fceiling-result '(-3.0 -3) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1746 :one-round-result '(-27 0) :two-round-result '(-3 -3) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1747 :one-fround-result '(-27.0 0) :two-fround-result '(-3.0 -3) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1748 :one-truncate-result '(-27 0) :two-truncate-result '(-3 -3) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1749 :one-ftruncate-result '(-27.0 0) :two-ftruncate-result '(-3.0 -3)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1750 (Assert-rounding -27 -8 |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1751 :one-floor-result '(-27 0) :two-floor-result '(3 -3) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1752 :one-ffloor-result '(-27.0 0) :two-ffloor-result '(3.0 -3) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1753 :one-ceiling-result '(-27 0) :two-ceiling-result '(4 5) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1754 :one-fceiling-result '(-27.0 0) :two-fceiling-result '(4.0 5) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1755 :one-round-result '(-27 0) :two-round-result '(3 -3) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1756 :one-fround-result '(-27.0 0) :two-fround-result '(3.0 -3) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1757 :one-truncate-result '(-27 0) :two-truncate-result '(3 -3) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1758 :one-ftruncate-result '(-27.0 0) :two-ftruncate-result '(3.0 -3)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1759 (Assert-rounding 8 27 |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1760 :one-floor-result '(8 0) :two-floor-result '(0 8) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1761 :one-ffloor-result '(8.0 0) :two-ffloor-result '(0.0 8) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1762 :one-ceiling-result '(8 0) :two-ceiling-result '(1 -19) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1763 :one-fceiling-result '(8.0 0) :two-fceiling-result '(1.0 -19) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1764 :one-round-result '(8 0) :two-round-result '(0 8) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1765 :one-fround-result '(8.0 0) :two-fround-result '(0.0 8) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1766 :one-truncate-result '(8 0) :two-truncate-result '(0 8) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1767 :one-ftruncate-result '(8.0 0) :two-ftruncate-result '(0.0 8)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1768 (Assert-rounding 8 -27 |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1769 :one-floor-result '(8 0) :two-floor-result '(-1 -19) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1770 :one-ffloor-result '(8.0 0) :two-ffloor-result '(-1.0 -19) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1771 :one-ceiling-result '(8 0) :two-ceiling-result '(0 8) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1772 :one-fceiling-result '(8.0 0) :two-fceiling-result '(0.0 8) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1773 :one-round-result '(8 0) :two-round-result '(0 8) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1774 :one-fround-result '(8.0 0) :two-fround-result '(0.0 8) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1775 :one-truncate-result '(8 0) :two-truncate-result '(0 8) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1776 :one-ftruncate-result '(8.0 0) :two-ftruncate-result '(0.0 8)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1777 (Assert-rounding -8 27 |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1778 :one-floor-result '(-8 0) :two-floor-result '(-1 19) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1779 :one-ffloor-result '(-8.0 0) :two-ffloor-result '(-1.0 19) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1780 :one-ceiling-result '(-8 0) :two-ceiling-result '(0 -8) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1781 :one-fceiling-result '(-8.0 0) :two-fceiling-result '(0.0 -8) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1782 :one-round-result '(-8 0) :two-round-result '(0 -8) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1783 :one-fround-result '(-8.0 0) :two-fround-result '(0.0 -8) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1784 :one-truncate-result '(-8 0) :two-truncate-result '(0 -8) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1785 :one-ftruncate-result '(-8.0 0) :two-ftruncate-result '(0.0 -8)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1786 (Assert-rounding -8 -27 |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1787 :one-floor-result '(-8 0) :two-floor-result '(0 -8) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1788 :one-ffloor-result '(-8.0 0) :two-ffloor-result '(0.0 -8) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1789 :one-ceiling-result '(-8 0) :two-ceiling-result '(1 19) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1790 :one-fceiling-result '(-8.0 0) :two-fceiling-result '(1.0 19) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1791 :one-round-result '(-8 0) :two-round-result '(0 -8) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1792 :one-fround-result '(-8.0 0) :two-fround-result '(0.0 -8) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1793 :one-truncate-result '(-8 0) :two-truncate-result '(0 -8) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1794 :one-ftruncate-result '(-8.0 0) :two-ftruncate-result '(0.0 -8)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1795 (Assert-rounding 32 4 |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1796 :one-floor-result '(32 0) :two-floor-result '(8 0) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1797 :one-ffloor-result '(32.0 0) :two-ffloor-result '(8.0 0) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1798 :one-ceiling-result '(32 0) :two-ceiling-result '(8 0) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1799 :one-fceiling-result '(32.0 0) :two-fceiling-result '(8.0 0) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1800 :one-round-result '(32 0) :two-round-result '(8 0) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1801 :one-fround-result '(32.0 0) :two-fround-result '(8.0 0) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1802 :one-truncate-result '(32 0) :two-truncate-result '(8 0) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1803 :one-ftruncate-result '(32.0 0) :two-ftruncate-result '(8.0 0)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1804 (Assert-rounding 32 -4 |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1805 :one-floor-result '(32 0) :two-floor-result '(-8 0) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1806 :one-ffloor-result '(32.0 0) :two-ffloor-result '(-8.0 0) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1807 :one-ceiling-result '(32 0) :two-ceiling-result '(-8 0) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1808 :one-fceiling-result '(32.0 0) :two-fceiling-result '(-8.0 0) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1809 :one-round-result '(32 0) :two-round-result '(-8 0) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1810 :one-fround-result '(32.0 0) :two-fround-result '(-8.0 0) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1811 :one-truncate-result '(32 0) :two-truncate-result '(-8 0) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1812 :one-ftruncate-result '(32.0 0) :two-ftruncate-result '(-8.0 0)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1813 (Assert-rounding 12 9 |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1814 :one-floor-result '(12 0) :two-floor-result '(1 3) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1815 :one-ffloor-result '(12.0 0) :two-ffloor-result '(1.0 3) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1816 :one-ceiling-result '(12 0) :two-ceiling-result '(2 -6) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1817 :one-fceiling-result '(12.0 0) :two-fceiling-result '(2.0 -6) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1818 :one-round-result '(12 0) :two-round-result '(1 3) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1819 :one-fround-result '(12.0 0) :two-fround-result '(1.0 3) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1820 :one-truncate-result '(12 0) :two-truncate-result '(1 3) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1821 :one-ftruncate-result '(12.0 0) :two-ftruncate-result '(1.0 3)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1822 (Assert-rounding 10 4 |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1823 :one-floor-result '(10 0) :two-floor-result '(2 2) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1824 :one-ffloor-result '(10.0 0) :two-ffloor-result '(2.0 2) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1825 :one-ceiling-result '(10 0) :two-ceiling-result '(3 -2) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1826 :one-fceiling-result '(10.0 0) :two-fceiling-result '(3.0 -2) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1827 :one-round-result '(10 0) :two-round-result '(2 2) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1828 :one-fround-result '(10.0 0) :two-fround-result '(2.0 2) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1829 :one-truncate-result '(10 0) :two-truncate-result '(2 2) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1830 :one-ftruncate-result '(10.0 0) :two-ftruncate-result '(2.0 2)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1831 (Assert-rounding 14 4 |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1832 :one-floor-result '(14 0) :two-floor-result '(3 2) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1833 :one-ffloor-result '(14.0 0) :two-ffloor-result '(3.0 2) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1834 :one-ceiling-result '(14 0) :two-ceiling-result '(4 -2) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1835 :one-fceiling-result '(14.0 0) :two-fceiling-result '(4.0 -2) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1836 :one-round-result '(14 0) :two-round-result '(4 -2) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1837 :one-fround-result '(14.0 0) :two-fround-result '(4.0 -2) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1838 :one-truncate-result '(14 0) :two-truncate-result '(3 2) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1839 :one-ftruncate-result '(14.0 0) :two-ftruncate-result '(3.0 2)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1840 ;; Now, two floats: |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1841 (Assert-rounding-floating pi e) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1842 (when (featurep 'bigfloat) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1843 (Assert-rounding-floating (coerce pi 'bigfloat) (coerce e 'bigfloat))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1844 (when (featurep 'bignum) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1845 (assert (not (evenp most-positive-fixnum)) t |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1846 "In the unlikely event that most-positive-fixnum is even, rewrite this.") |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1847 (Assert-rounding (1+ most-positive-fixnum) (* 2 most-positive-fixnum) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1848 :one-floor-result `(,(1+ most-positive-fixnum) 0) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1849 :two-floor-result `(0 ,(1+ most-positive-fixnum)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1850 :one-ffloor-result `(,(float (1+ most-positive-fixnum)) 0) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1851 :two-ffloor-result `(0.0 ,(1+ most-positive-fixnum)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1852 :one-ceiling-result `(,(1+ most-positive-fixnum) 0) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1853 :two-ceiling-result `(1 ,(1+ (- most-positive-fixnum))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1854 :one-fceiling-result `(,(float (1+ most-positive-fixnum)) 0) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1855 :two-fceiling-result `(1.0 ,(1+ (- most-positive-fixnum))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1856 :one-round-result `(,(1+ most-positive-fixnum) 0) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1857 :two-round-result `(1 ,(1+ (- most-positive-fixnum))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1858 :one-fround-result `(,(float (1+ most-positive-fixnum)) 0) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1859 :two-fround-result `(1.0 ,(1+ (- most-positive-fixnum))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1860 :one-truncate-result `(,(1+ most-positive-fixnum) 0) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1861 :two-truncate-result `(0 ,(1+ most-positive-fixnum)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1862 :one-ftruncate-result `(,(float (1+ most-positive-fixnum)) 0) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1863 :two-ftruncate-result `(0.0 ,(1+ most-positive-fixnum))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1864 (Assert-rounding (1+ most-positive-fixnum) (- (* 2 most-positive-fixnum)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1865 :one-floor-result `(,(1+ most-positive-fixnum) 0) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1866 :two-floor-result `(-1 ,(1+ (- most-positive-fixnum))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1867 :one-ffloor-result `(,(float (1+ most-positive-fixnum)) 0) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1868 :two-ffloor-result `(-1.0 ,(1+ (- most-positive-fixnum))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1869 :one-ceiling-result `(,(1+ most-positive-fixnum) 0) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1870 :two-ceiling-result `(0 ,(1+ most-positive-fixnum)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1871 :one-fceiling-result `(,(float (1+ most-positive-fixnum)) 0) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1872 :two-fceiling-result `(0.0 ,(1+ most-positive-fixnum)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1873 :one-round-result `(,(1+ most-positive-fixnum) 0) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1874 :two-round-result `(-1 ,(1+ (- most-positive-fixnum))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1875 :one-fround-result `(,(float (1+ most-positive-fixnum)) 0) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1876 :two-fround-result `(-1.0 ,(1+ (- most-positive-fixnum))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1877 :one-truncate-result `(,(1+ most-positive-fixnum) 0) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1878 :two-truncate-result `(0 ,(1+ most-positive-fixnum)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1879 :one-ftruncate-result `(,(float (1+ most-positive-fixnum)) 0) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1880 :two-ftruncate-result `(0.0 ,(1+ most-positive-fixnum))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1881 (Assert-rounding (- (1+ most-positive-fixnum)) (* 2 most-positive-fixnum) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1882 :one-floor-result `(,(- (1+ most-positive-fixnum)) 0) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1883 :two-floor-result `(-1 ,(1- most-positive-fixnum)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1884 :one-ffloor-result `(,(float (- (1+ most-positive-fixnum))) 0) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1885 :two-ffloor-result `(-1.0 ,(1- most-positive-fixnum)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1886 :one-ceiling-result `(,(- (1+ most-positive-fixnum)) 0) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1887 :two-ceiling-result `(0 ,(- (1+ most-positive-fixnum))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1888 :one-fceiling-result `(,(float (- (1+ most-positive-fixnum))) 0) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1889 :two-fceiling-result `(0.0 ,(- (1+ most-positive-fixnum))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1890 :one-round-result `(,(- (1+ most-positive-fixnum)) 0) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1891 :two-round-result `(-1 ,(1- most-positive-fixnum)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1892 :one-fround-result `(,(float (- (1+ most-positive-fixnum))) 0) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1893 :two-fround-result `(-1.0 ,(1- most-positive-fixnum)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1894 :one-truncate-result `(,(- (1+ most-positive-fixnum)) 0) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1895 :two-truncate-result `(0 ,(- (1+ most-positive-fixnum))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1896 :one-ftruncate-result `(,(float (- (1+ most-positive-fixnum))) 0) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1897 :two-ftruncate-result `(0.0 ,(- (1+ most-positive-fixnum)))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1898 ;; Test the handling of values with .5: |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1899 (Assert-rounding (1+ (* 2 most-positive-fixnum)) 2 |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1900 :one-floor-result `(,(1+ (* 2 most-positive-fixnum)) 0) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1901 :two-floor-result `(,most-positive-fixnum 1) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1902 :one-ffloor-result `(,(float (1+ (* 2 most-positive-fixnum))) 0) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1903 ;; We can't just call #'float here; we must use code that converts a |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1904 ;; bignum with value most-positive-fixnum (the creation of which is |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1905 ;; not directly possible in Lisp) to a float, not code that converts |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1906 ;; the fixnum with value most-positive-fixnum to a float. The eval is |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1907 ;; to avoid compile-time optimisation that can break this. |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1908 :two-ffloor-result `(,(eval '(- (1+ most-positive-fixnum) 1 0.0)) 1) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1909 :one-ceiling-result `(,(1+ (* 2 most-positive-fixnum)) 0) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1910 :two-ceiling-result `(,(1+ most-positive-fixnum) -1) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1911 :one-fceiling-result `(,(float (1+ (* 2 most-positive-fixnum))) 0) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1912 :two-fceiling-result `(,(float (1+ most-positive-fixnum)) -1) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1913 :one-round-result `(,(1+ (* 2 most-positive-fixnum)) 0) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1914 :two-round-result `(,(1+ most-positive-fixnum) -1) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1915 :one-fround-result `(,(float (1+ (* 2 most-positive-fixnum))) 0) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1916 :two-fround-result `(,(float (1+ most-positive-fixnum)) -1) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1917 :one-truncate-result `(,(1+ (* 2 most-positive-fixnum)) 0) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1918 :two-truncate-result `(,most-positive-fixnum 1) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1919 :one-ftruncate-result `(,(float (1+ (* 2 most-positive-fixnum))) 0) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1920 ;; See the comment above on :two-ffloor-result: |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1921 :two-ftruncate-result `(,(eval '(- (1+ most-positive-fixnum) 1 0.0)) 1)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1922 (Assert-rounding (1+ (* 2 (1- most-positive-fixnum))) 2 |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1923 :one-floor-result `(,(1+ (* 2 (1- most-positive-fixnum))) 0) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1924 :two-floor-result `(,(1- most-positive-fixnum) 1) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1925 :one-ffloor-result `(,(float (1+ (* 2 (1- most-positive-fixnum)))) 0) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1926 ;; See commentary above on float conversions. |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1927 :two-ffloor-result `(,(eval '(- (1+ most-positive-fixnum) 2 0.0)) 1) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1928 :one-ceiling-result `(,(1+ (* 2 (1- most-positive-fixnum))) 0) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1929 :two-ceiling-result `(,most-positive-fixnum -1) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1930 :one-fceiling-result `(,(float (1+ (* 2 (1- most-positive-fixnum)))) 0) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1931 :two-fceiling-result `(,(eval '(- (1+ most-positive-fixnum) 1 0.0)) -1) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1932 :one-round-result `(,(1+ (* 2 (1- most-positive-fixnum))) 0) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1933 :two-round-result `(,(1- most-positive-fixnum) 1) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1934 :one-fround-result `(,(float (1+ (* 2 (1- most-positive-fixnum)))) 0) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1935 :two-fround-result `(,(eval '(- (1+ most-positive-fixnum) 2 0.0)) 1) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1936 :one-truncate-result `(,(1+ (* 2 (1- most-positive-fixnum))) 0) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1937 :two-truncate-result `(,(1- most-positive-fixnum) 1) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1938 :one-ftruncate-result `(,(float (1+ (* 2 (1- most-positive-fixnum)))) 0) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1939 ;; See commentary above |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1940 :two-ftruncate-result `(,(eval '(- (1+ most-positive-fixnum) 2 0.0)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1941 1))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1942 (when (featurep 'ratio) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1943 (Assert-rounding (read "4/3") (read "8/7") |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1944 :one-floor-result '(1 1/3) :two-floor-result '(1 4/21) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1945 :one-ffloor-result '(1.0 1/3) :two-ffloor-result '(1.0 4/21) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1946 :one-ceiling-result '(2 -2/3) :two-ceiling-result '(2 -20/21) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1947 :one-fceiling-result '(2.0 -2/3) :two-fceiling-result '(2.0 -20/21) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1948 :one-round-result '(1 1/3) :two-round-result '(1 4/21) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1949 :one-fround-result '(1.0 1/3) :two-fround-result '(1.0 4/21) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1950 :one-truncate-result '(1 1/3) :two-truncate-result '(1 4/21) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1951 :one-ftruncate-result '(1.0 1/3) :two-ftruncate-result '(1.0 4/21)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1952 (Assert-rounding (read "-4/3") (read "8/7") |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1953 :one-floor-result '(-2 2/3) :two-floor-result '(-2 20/21) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1954 :one-ffloor-result '(-2.0 2/3) :two-ffloor-result '(-2.0 20/21) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1955 :one-ceiling-result '(-1 -1/3) :two-ceiling-result '(-1 -4/21) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1956 :one-fceiling-result '(-1.0 -1/3) :two-fceiling-result '(-1.0 -4/21) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1957 :one-round-result '(-1 -1/3) :two-round-result '(-1 -4/21) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1958 :one-fround-result '(-1.0 -1/3) :two-fround-result '(-1.0 -4/21) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1959 :one-truncate-result '(-1 -1/3) :two-truncate-result '(-1 -4/21) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1960 :one-ftruncate-result '(-1.0 -1/3) :two-ftruncate-result '(-1.0 -4/21)))) |
|
4608
1e3cf11fa27d
Make #$ truly read-only for Lisp; check this in the test suite.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4582
diff
changeset
|
1961 |
|
4678
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1962 ;; Run this function in a Common Lisp with two arguments to get results that |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1963 ;; we should compare against, above. Though note the dancing-around with the |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1964 ;; bigfloats and bignums above, too; you can't necessarily just use the |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1965 ;; output here. |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1966 |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1967 (defun generate-rounding-output (first second) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1968 (let ((print-readably t)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1969 (princ first) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1970 (princ " ") |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1971 (princ second) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1972 (princ " :one-floor-result ") |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1973 (princ (list 'quote (multiple-value-list (floor first)))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1974 (princ " :two-floor-result ") |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1975 (princ (list 'quote (multiple-value-list (floor first second)))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1976 (princ " :one-ffloor-result ") |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1977 (princ (list 'quote (multiple-value-list (ffloor first)))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1978 (princ " :two-ffloor-result ") |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1979 (princ (list 'quote (multiple-value-list (ffloor first second)))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1980 (princ " :one-ceiling-result ") |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1981 (princ (list 'quote (multiple-value-list (ceiling first)))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1982 (princ " :two-ceiling-result ") |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1983 (princ (list 'quote (multiple-value-list (ceiling first second)))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1984 (princ " :one-fceiling-result ") |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1985 (princ (list 'quote (multiple-value-list (fceiling first)))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1986 (princ " :two-fceiling-result ") |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1987 (princ (list 'quote (multiple-value-list (fceiling first second)))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1988 (princ " :one-round-result ") |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1989 (princ (list 'quote (multiple-value-list (round first)))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1990 (princ " :two-round-result ") |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1991 (princ (list 'quote (multiple-value-list (round first second)))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1992 (princ " :one-fround-result ") |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1993 (princ (list 'quote (multiple-value-list (fround first)))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1994 (princ " :two-fround-result ") |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1995 (princ (list 'quote (multiple-value-list (fround first second)))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1996 (princ " :one-truncate-result ") |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1997 (princ (list 'quote (multiple-value-list (truncate first)))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1998 (princ " :two-truncate-result ") |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1999 (princ (list 'quote (multiple-value-list (truncate first second)))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
2000 (princ " :one-ftruncate-result ") |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
2001 (princ (list 'quote (multiple-value-list (ftruncate first)))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
2002 (princ " :two-ftruncate-result ") |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
2003 (princ (list 'quote (multiple-value-list (ftruncate first second)))))) |
|
4679
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2004 |
|
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2005 ;; Multiple value tests. |
|
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2006 |
|
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2007 (flet ((foo (x y) |
|
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2008 (floor (+ x y) y)) |
|
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2009 (foo-zero (x y) |
|
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2010 (values (floor (+ x y) y))) |
|
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2011 (multiple-value-function-returning-t () |
|
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2012 (values t pi e degrees-to-radians radians-to-degrees)) |
|
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2013 (multiple-value-function-returning-nil () |
|
4686
cdabd56ce1b5
Fix various small issues with the multiple-value implementation.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4679
diff
changeset
|
2014 (values nil pi e radians-to-degrees degrees-to-radians)) |
|
4679
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2015 (function-throwing-multiple-values () |
|
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2016 (let* ((listing '(0 3 4 nil "string" symbol)) |
|
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2017 (tail listing) |
|
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2018 elt) |
|
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2019 (while t |
|
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2020 (setq tail (cdr listing) |
|
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2021 elt (car listing) |
|
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2022 listing tail) |
|
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2023 (when (null elt) |
|
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2024 (throw 'VoN61Lo4Y (multiple-value-function-returning-t))))))) |
|
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2025 (Assert |
|
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2026 (= (+ (floor 5 3) (floor 19 4)) (+ 1 4) 5) |
|
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2027 "Checking that multiple values are discarded correctly as func args") |
|
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2028 (Assert |
|
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2029 (= 2 (length (multiple-value-list (foo 400 (1+ most-positive-fixnum))))) |
|
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2030 "Checking multiple values are passed through correctly as return values") |
|
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2031 (Assert |
|
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2032 (= 1 (length (multiple-value-list |
|
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2033 (foo-zero 400 (1+ most-positive-fixnum))))) |
|
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2034 "Checking multiple values are discarded correctly when forced") |
|
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2035 (Check-Error setting-constant (setq multiple-values-limit 20)) |
|
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2036 (Assert-equal '(-1 1) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2037 (multiple-value-list (floor -3 4)) |
|
4679
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2038 "Checking #'multiple-value-list gives a sane result") |
|
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2039 (let ((ey 40000) |
|
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2040 (bee "this is a string") |
|
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2041 (cee #s(hash-table size 256 data (969 ?\xF9)))) |
|
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2042 (Assert-equal |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2043 (multiple-value-list (values ey bee cee)) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2044 (multiple-value-list (values-list (list ey bee cee))) |
|
4679
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2045 "Checking that #'values and #'values-list are correctly related") |
|
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2046 (Assert-equal |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2047 (multiple-value-list (values-list (list ey bee cee))) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2048 (multiple-value-list (apply #'values (list ey bee cee))) |
|
4679
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2049 "Checking #'values-list and #'apply with #values are correctly related")) |
|
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2050 (Assert= (multiple-value-call #'+ (floor 5 3) (floor 19 4)) 10 |
|
4679
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2051 "Checking #'multiple-value-call gives reasonable results.") |
|
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2052 (Assert= (multiple-value-call (values '+ '*) (floor 5 3) (floor 19 4)) 10 |
|
4679
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2053 "Checking #'multiple-value-call correct when first arg multiple.") |
|
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2054 (Assert= 1 (length (multiple-value-list (prog1 (floor pi) "hi there"))) |
|
4679
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2055 "Checking #'prog1 does not pass back multiple values") |
|
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2056 (Assert= 2 (length (multiple-value-list |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2057 (multiple-value-prog1 (floor pi) "hi there"))) |
|
4679
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2058 "Checking #'multiple-value-prog1 passes back multiple values") |
|
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2059 (multiple-value-bind (floored remainder this-is-nil) |
|
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2060 (floor pi 1.0) |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
2061 (Assert= floored 3 |
|
4679
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2062 "Checking floored bound correctly") |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
2063 (Assert-eql remainder (- pi 3.0) |
|
4679
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2064 "Checking remainder bound correctly") |
|
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2065 (Assert (null this-is-nil) |
|
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2066 "Checking trailing arg bound but nil")) |
|
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2067 (let ((ey 40000) |
|
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2068 (bee "this is a string") |
|
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2069 (cee #s(hash-table size 256 data (969 ?\xF9)))) |
|
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2070 (multiple-value-setq (ey bee cee) |
|
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2071 (ffloor e 1.0)) |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
2072 (Assert-eql 2.0 ey "Checking ey set correctly") |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
2073 (Assert-eql bee (- e 2.0) "Checking bee set correctly") |
|
4679
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2074 (Assert (null cee) "Checking cee set to nil correctly")) |
|
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2075 (Assert= 3 (length (multiple-value-list (eval '(values nil t pi)))) |
|
4679
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2076 "Checking #'eval passes back multiple values") |
|
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2077 (Assert= 2 (length (multiple-value-list (apply #'floor '(5 3)))) |
|
4679
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2078 "Checking #'apply passes back multiple values") |
|
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2079 (Assert= 2 (length (multiple-value-list (funcall #'floor 5 3))) |
|
4679
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2080 "Checking #'funcall passes back multiple values") |
|
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2081 (Assert-equal '(1 2) (multiple-value-list |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2082 (multiple-value-call #'floor (values 5 3))) |
|
4679
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2083 "Checking #'multiple-value-call passes back multiple values correctly") |
|
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2084 (Assert= 1 (length (multiple-value-list |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2085 (and (multiple-value-function-returning-nil) t))) |
|
4679
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2086 "Checking multiple values from non-trailing forms discarded by #'and") |
|
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2087 (Assert= 5 (length (multiple-value-list |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2088 (and t (multiple-value-function-returning-nil)))) |
|
4679
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2089 "Checking multiple values from final forms not discarded by #'and") |
|
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2090 (Assert= 1 (length (multiple-value-list |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2091 (or (multiple-value-function-returning-t) t))) |
|
4679
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2092 "Checking multiple values from non-trailing forms discarded by #'and") |
|
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2093 (Assert= 5 (length (multiple-value-list |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2094 (or nil (multiple-value-function-returning-t)))) |
|
4679
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2095 "Checking multiple values from final forms not discarded by #'and") |
|
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2096 (Assert= 1 (length (multiple-value-list |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2097 (cond ((multiple-value-function-returning-t))))) |
|
4679
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2098 "Checking cond doesn't pass back multiple values in tests.") |
|
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2099 (Assert-equal (list nil pi e radians-to-degrees degrees-to-radians) |
|
4679
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2100 (multiple-value-list |
|
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2101 (cond (t (multiple-value-function-returning-nil)))) |
|
4679
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2102 "Checking cond passes back multiple values in clauses.") |
|
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2103 (Assert= 1 (length (multiple-value-list |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2104 (prog1 (multiple-value-function-returning-nil)))) |
|
4679
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2105 "Checking prog1 discards multiple values correctly.") |
|
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2106 (Assert= 5 (length (multiple-value-list |
|
4679
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2107 (multiple-value-prog1 |
|
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2108 (multiple-value-function-returning-nil)))) |
|
4679
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2109 "Checking multiple-value-prog1 passes back multiple values correctly.") |
|
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2110 (Assert-equal (list t pi e degrees-to-radians radians-to-degrees) |
|
4679
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2111 (multiple-value-list |
|
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2112 (catch 'VoN61Lo4Y (function-throwing-multiple-values)))) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2113 (Assert-equal (list t pi e degrees-to-radians radians-to-degrees) |
|
4679
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2114 (multiple-value-list |
|
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2115 (loop |
|
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2116 for eye in `(a b c d ,e f g ,nil ,pi) |
|
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2117 do (when (null eye) |
|
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2118 (return (multiple-value-function-returning-t))))) |
|
4686
cdabd56ce1b5
Fix various small issues with the multiple-value implementation.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4679
diff
changeset
|
2119 "Checking #'loop passes back multiple values correctly.") |
|
cdabd56ce1b5
Fix various small issues with the multiple-value implementation.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4679
diff
changeset
|
2120 (Assert |
|
cdabd56ce1b5
Fix various small issues with the multiple-value implementation.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4679
diff
changeset
|
2121 (null (or)) |
|
cdabd56ce1b5
Fix various small issues with the multiple-value implementation.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4679
diff
changeset
|
2122 "Checking #'or behaves correctly with zero arguments.") |
|
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2123 (Assert-eq t (and) |
|
4686
cdabd56ce1b5
Fix various small issues with the multiple-value implementation.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4679
diff
changeset
|
2124 "Checking #'and behaves correctly with zero arguments.") |
|
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2125 (Assert= (* 3.0 (- pi 3.0)) |
|
4742
4cf435fcebbc
Make #'letf not error if handed a #'values form.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4732
diff
changeset
|
2126 (letf (((values three one-four-one-five-nine) (floor pi))) |
|
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2127 (* three one-four-one-five-nine)) |
|
4742
4cf435fcebbc
Make #'letf not error if handed a #'values form.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4732
diff
changeset
|
2128 "checking letf handles #'values in a basic sense")) |
|
4686
cdabd56ce1b5
Fix various small issues with the multiple-value implementation.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4679
diff
changeset
|
2129 |
|
4792
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4742
diff
changeset
|
2130 ;; #'equalp tests. |
|
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4742
diff
changeset
|
2131 (let ((string-variable "aBcDeeFgH\u00Edj") |
|
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4742
diff
changeset
|
2132 (eacute-character ?\u00E9) |
|
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4742
diff
changeset
|
2133 (Eacute-character ?\u00c9) |
|
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4742
diff
changeset
|
2134 (+base-chars+ (loop |
|
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2135 with res = (make-string 96 ?\x20) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2136 for int-char from #x20 to #x7f |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2137 for char being each element in-ref res |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2138 do (setf char (int-to-char int-char)) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2139 finally return res))) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2140 (let ((equal-lists |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2141 '((111111111111111111111111111111111111111111111111111 |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2142 111111111111111111111111111111111111111111111111111.0) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2143 (0 0.0 0.000 -0 -0.0 -0.000 #b0 0/5 -0/5) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2144 (21845 #b101010101010101 #x5555) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2145 (1.5 1.500000000000000000000000000000000000000000000000000000000 |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2146 3/2) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2147 (-55 -110/2) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2148 ;; Can't use this, these values aren't `='. |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2149 ;;(-12345678901234567890123457890123457890123457890123457890123457890 |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2150 ;; -12345678901234567890123457890123457890123457890123457890123457890.0) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2151 ))) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2152 (loop for li in equal-lists do |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2153 (loop for (x . tail) on li do |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2154 (loop for y in tail do |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2155 (Assert-equalp x y) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2156 (Assert-equalp y x))))) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2157 |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2158 (let ((diff-list |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2159 `(0 1 2 3 1000 5000000000 5555555555555555555555555555555555555 |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2160 -1 -2 -3 -1000 -5000000000 -5555555555555555555555555555555555555 |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2161 1/2 1/3 2/3 8/2 355/113 (/ 3/2 0.2) (/ 3/2 0.7) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2162 55555555555555555555555555555555555555555/2718281828459045 |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2163 0.111111111111111111111111111111111111111111111111111111111111111 |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2164 1e+300 1e+301 -1e+300 -1e+301))) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2165 (loop for (x . tail) on diff-list do |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2166 (loop for y in tail do |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2167 (Assert-not-equalp x y) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2168 (Assert-not-equalp y x)))) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2169 |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
2170 (Assert-equalp "hi there" "Hi There" |
|
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2171 "checking equalp isn't case-sensitive") |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
2172 (Assert-equalp 99 99.0 |
|
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2173 "checking equalp compares numerical values of different types") |
|
4792
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4742
diff
changeset
|
2174 (Assert (null (equalp 99 ?c)) |
|
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4742
diff
changeset
|
2175 "checking equalp does not convert characters to numbers") |
|
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4742
diff
changeset
|
2176 ;; Fixed in Hg d0ea57eb3de4. |
|
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4742
diff
changeset
|
2177 (Assert (null (equalp "hi there" [hi there])) |
|
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4742
diff
changeset
|
2178 "checking equalp doesn't error with string and non-string") |
|
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2179 (Assert-equalp "ABCDEEFGH\u00CDJ" string-variable |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2180 "checking #'equalp is case-insensitive with an upcased constant") |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2181 (Assert-equalp "abcdeefgh\xedj" string-variable |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2182 "checking #'equalp is case-insensitive with a downcased constant") |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2183 (Assert-equalp string-variable string-variable |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2184 "checking #'equalp works when handed the same string twice") |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2185 (Assert-equalp string-variable "aBcDeeFgH\u00Edj" |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2186 "check #'equalp is case-insensitive with a variable-cased constant") |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2187 (Assert-equalp "" (bit-vector) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2188 "check empty string and empty bit-vector are #'equalp.") |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2189 (Assert-equalp (string) (bit-vector) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2190 "check empty string and empty bit-vector are #'equalp, no constants") |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2191 (Assert-equalp "hi there" (vector ?h ?i ?\ ?t ?h ?e ?r ?e) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2192 "check string and vector with same contents #'equalp") |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2193 (Assert-equalp (string ?h ?i ?\ ?t ?h ?e ?r ?e) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2194 (vector ?h ?i ?\ ?t ?h ?e ?r ?e) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2195 "check string and vector with same contents #'equalp, no constants") |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2196 (Assert-equalp [?h ?i ?\ ?t ?h ?e ?r ?e] |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2197 (string ?h ?i ?\ ?t ?h ?e ?r ?e) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2198 "check string and vector with same contents #'equalp, vector constant") |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2199 (Assert-equalp [0 1.0 0.0 0 1] |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2200 (bit-vector 0 1 0 0 1) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2201 "check vector and bit-vector with same contents #'equalp,\ |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2202 vector constant") |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2203 (Assert-not-equalp [0 2 0.0 0 1] |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2204 (bit-vector 0 1 0 0 1) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2205 "check vector and bit-vector with different contents not #'equalp,\ |
|
4792
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4742
diff
changeset
|
2206 vector constant") |
|
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2207 (Assert-equalp #*01001 |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2208 (vector 0 1.0 0.0 0 1) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2209 "check vector and bit-vector with same contents #'equalp,\ |
|
4792
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4742
diff
changeset
|
2210 bit-vector constant") |
|
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2211 (Assert-equalp ?\u00E9 Eacute-character |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2212 "checking characters are case-insensitive, one constant") |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2213 (Assert-not-equalp ?\u00E9 (aref (format "%c" ?a) 0) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2214 "checking distinct characters are not equalp, one constant") |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2215 (Assert-equalp t (and) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2216 "checking symbols are correctly #'equalp") |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2217 (Assert-not-equalp t (or nil '#:t) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2218 "checking distinct symbols with the same name are not #'equalp") |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2219 (Assert-equalp #s(char-table type generic data (?\u0080 "hi-there")) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2220 (let ((aragh (make-char-table 'generic))) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2221 (put-char-table ?\u0080 "hi-there" aragh) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2222 aragh) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2223 "checking #'equalp succeeds correctly, char-tables") |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2224 (Assert-equalp #s(char-table type generic data (?\u0080 "hi-there")) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2225 (let ((aragh (make-char-table 'generic))) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2226 (put-char-table ?\u0080 "HI-THERE" aragh) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2227 aragh) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2228 "checking #'equalp succeeds correctly, char-tables") |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2229 (Assert-not-equalp #s(char-table type generic data (?\u0080 "hi-there")) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2230 (let ((aragh (make-char-table 'generic))) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2231 (put-char-table ?\u0080 "hi there" aragh) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2232 aragh) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2233 "checking #'equalp fails correctly, char-tables")) |
|
4792
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4742
diff
changeset
|
2234 |
|
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4742
diff
changeset
|
2235 ;; There are more tests available for equalp here: |
|
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4742
diff
changeset
|
2236 ;; |
|
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4742
diff
changeset
|
2237 ;; http://www.parhasard.net/xemacs/equalp-tests.el |
|
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4742
diff
changeset
|
2238 ;; |
|
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4742
diff
changeset
|
2239 ;; They are taken from Paul Dietz' GCL ANSI test suite, licensed under the |
|
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4742
diff
changeset
|
2240 ;; LGPL and part of GNU Common Lisp; the GCL people didn't respond to |
|
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4742
diff
changeset
|
2241 ;; several requests for information on who owned the copyright for the |
|
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4742
diff
changeset
|
2242 ;; files, so I haven't included the tests with XEmacs. Anyone doing XEmacs |
|
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4742
diff
changeset
|
2243 ;; development on equalp should still run them, though. Aidan Kehoe, Thu Dec |
|
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4742
diff
changeset
|
2244 ;; 31 14:53:52 GMT 2009. |
|
4732
2491a837112c
Fix typo in test of equalp and add more tests.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4728
diff
changeset
|
2245 |
|
4795
084056f46755
#'functionp gives nil for special forms, as in CL and GNU Emacs 23.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4792
diff
changeset
|
2246 (loop |
|
084056f46755
#'functionp gives nil for special forms, as in CL and GNU Emacs 23.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4792
diff
changeset
|
2247 for special-form in '(multiple-value-call setq-default quote throw |
|
084056f46755
#'functionp gives nil for special forms, as in CL and GNU Emacs 23.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4792
diff
changeset
|
2248 save-current-buffer and or) |
|
084056f46755
#'functionp gives nil for special forms, as in CL and GNU Emacs 23.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4792
diff
changeset
|
2249 with not-special-form = nil |
|
084056f46755
#'functionp gives nil for special forms, as in CL and GNU Emacs 23.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4792
diff
changeset
|
2250 do |
|
084056f46755
#'functionp gives nil for special forms, as in CL and GNU Emacs 23.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4792
diff
changeset
|
2251 (Assert (special-form-p special-form) |
|
084056f46755
#'functionp gives nil for special forms, as in CL and GNU Emacs 23.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4792
diff
changeset
|
2252 (format "checking %S is a special operator" special-form)) |
|
084056f46755
#'functionp gives nil for special forms, as in CL and GNU Emacs 23.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4792
diff
changeset
|
2253 (setq not-special-form |
|
084056f46755
#'functionp gives nil for special forms, as in CL and GNU Emacs 23.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4792
diff
changeset
|
2254 (intern (format "%s-gMAu" (symbol-name special-form)))) |
|
084056f46755
#'functionp gives nil for special forms, as in CL and GNU Emacs 23.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4792
diff
changeset
|
2255 (Assert (not (special-form-p not-special-form)) |
|
084056f46755
#'functionp gives nil for special forms, as in CL and GNU Emacs 23.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4792
diff
changeset
|
2256 (format "checking %S is a special operator" special-form)) |
|
084056f46755
#'functionp gives nil for special forms, as in CL and GNU Emacs 23.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4792
diff
changeset
|
2257 (Assert (not (functionp special-form)) |
|
084056f46755
#'functionp gives nil for special forms, as in CL and GNU Emacs 23.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4792
diff
changeset
|
2258 (format "checking %S is not a function" special-form))) |
|
084056f46755
#'functionp gives nil for special forms, as in CL and GNU Emacs 23.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4792
diff
changeset
|
2259 |
|
084056f46755
#'functionp gives nil for special forms, as in CL and GNU Emacs 23.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4792
diff
changeset
|
2260 (loop |
|
084056f46755
#'functionp gives nil for special forms, as in CL and GNU Emacs 23.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4792
diff
changeset
|
2261 for real-function in '(find-file quote-maybe + - find-file-read-only) |
|
084056f46755
#'functionp gives nil for special forms, as in CL and GNU Emacs 23.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4792
diff
changeset
|
2262 do (Assert (functionp real-function) |
|
084056f46755
#'functionp gives nil for special forms, as in CL and GNU Emacs 23.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4792
diff
changeset
|
2263 (format "checking %S is a function" real-function))) |
|
084056f46755
#'functionp gives nil for special forms, as in CL and GNU Emacs 23.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4792
diff
changeset
|
2264 |
|
4885
6772ce4d982b
Fix hash tables, #'member*, #'assoc*, #'eql compiler macros if bignums
Aidan Kehoe <kehoea@parhasard.net>
parents:
4855
diff
changeset
|
2265 ;; #'member, #'assoc tests. |
|
6772ce4d982b
Fix hash tables, #'member*, #'assoc*, #'eql compiler macros if bignums
Aidan Kehoe <kehoea@parhasard.net>
parents:
4855
diff
changeset
|
2266 |
|
6772ce4d982b
Fix hash tables, #'member*, #'assoc*, #'eql compiler macros if bignums
Aidan Kehoe <kehoea@parhasard.net>
parents:
4855
diff
changeset
|
2267 (when (featurep 'bignum) |
|
6772ce4d982b
Fix hash tables, #'member*, #'assoc*, #'eql compiler macros if bignums
Aidan Kehoe <kehoea@parhasard.net>
parents:
4855
diff
changeset
|
2268 (let* ((member*-list `(0 9 342 [hi there] ,(1+ most-positive-fixnum) 0 |
|
6772ce4d982b
Fix hash tables, #'member*, #'assoc*, #'eql compiler macros if bignums
Aidan Kehoe <kehoea@parhasard.net>
parents:
4855
diff
changeset
|
2269 0.0 ,(1- most-negative-fixnum) nil)) |
|
6772ce4d982b
Fix hash tables, #'member*, #'assoc*, #'eql compiler macros if bignums
Aidan Kehoe <kehoea@parhasard.net>
parents:
4855
diff
changeset
|
2270 (assoc*-list (loop |
|
6772ce4d982b
Fix hash tables, #'member*, #'assoc*, #'eql compiler macros if bignums
Aidan Kehoe <kehoea@parhasard.net>
parents:
4855
diff
changeset
|
2271 for elt in member*-list |
|
6772ce4d982b
Fix hash tables, #'member*, #'assoc*, #'eql compiler macros if bignums
Aidan Kehoe <kehoea@parhasard.net>
parents:
4855
diff
changeset
|
2272 collect (cons elt (random)))) |
|
6772ce4d982b
Fix hash tables, #'member*, #'assoc*, #'eql compiler macros if bignums
Aidan Kehoe <kehoea@parhasard.net>
parents:
4855
diff
changeset
|
2273 (hashing (make-hash-table :test 'eql)) |
|
6772ce4d982b
Fix hash tables, #'member*, #'assoc*, #'eql compiler macros if bignums
Aidan Kehoe <kehoea@parhasard.net>
parents:
4855
diff
changeset
|
2274 hashed-bignum) |
|
6772ce4d982b
Fix hash tables, #'member*, #'assoc*, #'eql compiler macros if bignums
Aidan Kehoe <kehoea@parhasard.net>
parents:
4855
diff
changeset
|
2275 (macrolet |
|
6772ce4d982b
Fix hash tables, #'member*, #'assoc*, #'eql compiler macros if bignums
Aidan Kehoe <kehoea@parhasard.net>
parents:
4855
diff
changeset
|
2276 ((1+most-positive-fixnum () |
|
6772ce4d982b
Fix hash tables, #'member*, #'assoc*, #'eql compiler macros if bignums
Aidan Kehoe <kehoea@parhasard.net>
parents:
4855
diff
changeset
|
2277 (1+ most-positive-fixnum)) |
|
6772ce4d982b
Fix hash tables, #'member*, #'assoc*, #'eql compiler macros if bignums
Aidan Kehoe <kehoea@parhasard.net>
parents:
4855
diff
changeset
|
2278 (1-most-negative-fixnum () |
|
6772ce4d982b
Fix hash tables, #'member*, #'assoc*, #'eql compiler macros if bignums
Aidan Kehoe <kehoea@parhasard.net>
parents:
4855
diff
changeset
|
2279 (1- most-negative-fixnum)) |
|
6772ce4d982b
Fix hash tables, #'member*, #'assoc*, #'eql compiler macros if bignums
Aidan Kehoe <kehoea@parhasard.net>
parents:
4855
diff
changeset
|
2280 (*-2-most-positive-fixnum () |
|
6772ce4d982b
Fix hash tables, #'member*, #'assoc*, #'eql compiler macros if bignums
Aidan Kehoe <kehoea@parhasard.net>
parents:
4855
diff
changeset
|
2281 (* 2 most-positive-fixnum))) |
|
6772ce4d982b
Fix hash tables, #'member*, #'assoc*, #'eql compiler macros if bignums
Aidan Kehoe <kehoea@parhasard.net>
parents:
4855
diff
changeset
|
2282 (Assert-eq |
|
6772ce4d982b
Fix hash tables, #'member*, #'assoc*, #'eql compiler macros if bignums
Aidan Kehoe <kehoea@parhasard.net>
parents:
4855
diff
changeset
|
2283 (member* (1+ most-positive-fixnum) member*-list) |
|
6772ce4d982b
Fix hash tables, #'member*, #'assoc*, #'eql compiler macros if bignums
Aidan Kehoe <kehoea@parhasard.net>
parents:
4855
diff
changeset
|
2284 (member* (1+ most-positive-fixnum) member*-list :test #'eql) |
|
6772ce4d982b
Fix hash tables, #'member*, #'assoc*, #'eql compiler macros if bignums
Aidan Kehoe <kehoea@parhasard.net>
parents:
4855
diff
changeset
|
2285 "checking #'member* correct if #'eql not explicitly specified") |
|
6772ce4d982b
Fix hash tables, #'member*, #'assoc*, #'eql compiler macros if bignums
Aidan Kehoe <kehoea@parhasard.net>
parents:
4855
diff
changeset
|
2286 (Assert-eq |
|
6772ce4d982b
Fix hash tables, #'member*, #'assoc*, #'eql compiler macros if bignums
Aidan Kehoe <kehoea@parhasard.net>
parents:
4855
diff
changeset
|
2287 (assoc* (1+ most-positive-fixnum) assoc*-list) |
|
6772ce4d982b
Fix hash tables, #'member*, #'assoc*, #'eql compiler macros if bignums
Aidan Kehoe <kehoea@parhasard.net>
parents:
4855
diff
changeset
|
2288 (assoc* (1+ most-positive-fixnum) assoc*-list :test #'eql) |
|
6772ce4d982b
Fix hash tables, #'member*, #'assoc*, #'eql compiler macros if bignums
Aidan Kehoe <kehoea@parhasard.net>
parents:
4855
diff
changeset
|
2289 "checking #'assoc* correct if #'eql not explicitly specified") |
|
6772ce4d982b
Fix hash tables, #'member*, #'assoc*, #'eql compiler macros if bignums
Aidan Kehoe <kehoea@parhasard.net>
parents:
4855
diff
changeset
|
2290 (Assert-eq |
|
6772ce4d982b
Fix hash tables, #'member*, #'assoc*, #'eql compiler macros if bignums
Aidan Kehoe <kehoea@parhasard.net>
parents:
4855
diff
changeset
|
2291 (rassoc* (1- most-negative-fixnum) assoc*-list) |
|
6772ce4d982b
Fix hash tables, #'member*, #'assoc*, #'eql compiler macros if bignums
Aidan Kehoe <kehoea@parhasard.net>
parents:
4855
diff
changeset
|
2292 (rassoc* (1- most-negative-fixnum) assoc*-list :test #'eql) |
|
6772ce4d982b
Fix hash tables, #'member*, #'assoc*, #'eql compiler macros if bignums
Aidan Kehoe <kehoea@parhasard.net>
parents:
4855
diff
changeset
|
2293 "checking #'rassoc* correct if #'eql not explicitly specified") |
|
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2294 (Assert-eql (1+most-positive-fixnum) (1+ most-positive-fixnum) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2295 "checking #'eql handles a bignum literal properly.") |
|
4885
6772ce4d982b
Fix hash tables, #'member*, #'assoc*, #'eql compiler macros if bignums
Aidan Kehoe <kehoea@parhasard.net>
parents:
4855
diff
changeset
|
2296 (Assert-eq |
|
6772ce4d982b
Fix hash tables, #'member*, #'assoc*, #'eql compiler macros if bignums
Aidan Kehoe <kehoea@parhasard.net>
parents:
4855
diff
changeset
|
2297 (member* (1+most-positive-fixnum) member*-list) |
|
6772ce4d982b
Fix hash tables, #'member*, #'assoc*, #'eql compiler macros if bignums
Aidan Kehoe <kehoea@parhasard.net>
parents:
4855
diff
changeset
|
2298 (member* (1+ most-positive-fixnum) member*-list :test #'equal) |
|
6772ce4d982b
Fix hash tables, #'member*, #'assoc*, #'eql compiler macros if bignums
Aidan Kehoe <kehoea@parhasard.net>
parents:
4855
diff
changeset
|
2299 "checking #'member* compiler macro correct with literal bignum") |
|
6772ce4d982b
Fix hash tables, #'member*, #'assoc*, #'eql compiler macros if bignums
Aidan Kehoe <kehoea@parhasard.net>
parents:
4855
diff
changeset
|
2300 (Assert-eq |
|
6772ce4d982b
Fix hash tables, #'member*, #'assoc*, #'eql compiler macros if bignums
Aidan Kehoe <kehoea@parhasard.net>
parents:
4855
diff
changeset
|
2301 (assoc* (1+most-positive-fixnum) assoc*-list) |
|
6772ce4d982b
Fix hash tables, #'member*, #'assoc*, #'eql compiler macros if bignums
Aidan Kehoe <kehoea@parhasard.net>
parents:
4855
diff
changeset
|
2302 (assoc* (1+ most-positive-fixnum) assoc*-list :test #'equal) |
|
6772ce4d982b
Fix hash tables, #'member*, #'assoc*, #'eql compiler macros if bignums
Aidan Kehoe <kehoea@parhasard.net>
parents:
4855
diff
changeset
|
2303 "checking #'assoc* compiler macro correct with literal bignum") |
|
6772ce4d982b
Fix hash tables, #'member*, #'assoc*, #'eql compiler macros if bignums
Aidan Kehoe <kehoea@parhasard.net>
parents:
4855
diff
changeset
|
2304 (puthash (setq hashed-bignum (*-2-most-positive-fixnum)) |
|
6772ce4d982b
Fix hash tables, #'member*, #'assoc*, #'eql compiler macros if bignums
Aidan Kehoe <kehoea@parhasard.net>
parents:
4855
diff
changeset
|
2305 (gensym) hashing) |
|
6772ce4d982b
Fix hash tables, #'member*, #'assoc*, #'eql compiler macros if bignums
Aidan Kehoe <kehoea@parhasard.net>
parents:
4855
diff
changeset
|
2306 (Assert-eq |
|
6772ce4d982b
Fix hash tables, #'member*, #'assoc*, #'eql compiler macros if bignums
Aidan Kehoe <kehoea@parhasard.net>
parents:
4855
diff
changeset
|
2307 (gethash (* 2 most-positive-fixnum) hashing) |
|
6772ce4d982b
Fix hash tables, #'member*, #'assoc*, #'eql compiler macros if bignums
Aidan Kehoe <kehoea@parhasard.net>
parents:
4855
diff
changeset
|
2308 (gethash hashed-bignum hashing) |
|
6772ce4d982b
Fix hash tables, #'member*, #'assoc*, #'eql compiler macros if bignums
Aidan Kehoe <kehoea@parhasard.net>
parents:
4855
diff
changeset
|
2309 "checking hashing works correctly with #'eql tests and bignums")))) |
|
6772ce4d982b
Fix hash tables, #'member*, #'assoc*, #'eql compiler macros if bignums
Aidan Kehoe <kehoea@parhasard.net>
parents:
4855
diff
changeset
|
2310 |
|
4732
2491a837112c
Fix typo in test of equalp and add more tests.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4728
diff
changeset
|
2311 ;;; end of lisp-tests.el |