Mercurial > hg > xemacs-beta
annotate tests/automated/lisp-tests.el @ 5035:b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
src/ChangeLog addition:
2010-02-07 Aidan Kehoe <kehoea@parhasard.net>
* fns.c (split_string_by_ichar_1): Extend this to take UNESCAPE
and ESCAPECHAR arguments.
(split_external_path, split_env_path, Fsplit_string_by_char)
(Fsplit_path):
Pass the new arguments to split_string_by_ichar_1(); take a new
optional argument, ESCAPE-CHAR, in #'split-string-by-char,
allowing SEPCHAR to be escaped.
tests/ChangeLog addition:
2010-02-07 Aidan Kehoe <kehoea@parhasard.net>
* automated/lisp-tests.el (split-string-by-char):
Test this function, and its new ESCAPE-CHAR argument.
| author | Aidan Kehoe <kehoea@parhasard.net> |
|---|---|
| date | Sun, 07 Feb 2010 12:24:03 +0000 |
| parents | 1b96882bdf37 |
| children | 9624523604c5 |
| 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.\\ |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1091 tocopherol |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1092 Vitamin E: any or all of a group of closely related fat-soluble compounds |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1093 that occur especially in plant oils and are anti-oxidants essential in the |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1094 diets of many animals and probably of man. " |
|
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.\\ |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1101 tocopherol |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1102 Vitamin E" " any or all of a group of closely related fat-soluble compounds |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1103 that occur especially in plant oils and are anti-oxidants essential in the |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1104 diets of many animals and probably of man. "))) |
|
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.\\ |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1113 tocopherol |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1114 Vitamin E: any or all of a group of closely related fat-soluble compounds |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1115 that occur especially in plant oils and are anti-oxidants essential in the |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1116 diets of many animals and probably of man. " |
|
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.\\\\ |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1123 tocopherol |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1124 Vitamin E" " any or all of a group of closely related fat-soluble compounds |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1125 that occur especially in plant oils and are anti-oxidants essential in the |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1126 diets of many animals and probably of man. "))) |
|
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.\\ |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1135 tocopherol |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1136 Vitamin E: any or all of a group of closely related fat-soluble compounds |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1137 that occur especially in plant oils and are anti-oxidants essential in the |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1138 diets of many animals and probably of man. " ?\\) |
|
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." "" " |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1144 tocopherol |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1145 Vitamin E: any or all of a group of closely related fat-soluble compounds |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1146 that occur especially in plant oils and are anti-oxidants essential in the |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1147 diets of many animals and probably of man. "))) |
|
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 |